diff --git a/compiler/rt/afpa.lisp b/compiler/rt/afpa.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e53d3c711a276db6367e11d9d8001ef1542feb85 --- /dev/null +++ b/compiler/rt/afpa.lisp @@ -0,0 +1,499 @@ +;;; -*- Package: RT -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/afpa.lisp,v 1.1 1991/07/23 12:14:16 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; The following code is to support the AFPA on the EAPC card and the +;;; accessory AFPA for the APC card. There isn't heavy use of AFPA features; +;;; other than the size of the register set, and the DMA use, this would work +;;; on the FPA (supposing anyone still has one of those.) This is adapted from +;;; the 68881 support, and from the MIPS support. +;;; +;;; See section 4 in Vol 1 of the RT technical manual. In particular DMA is +;;; described on 4-96 to 4-98. +;;; +(in-package "RT") + + +;;;; Status register formats. + +(defconstant afpa-rounding-mode-byte (byte 2 (- 31 24))) +(defconstant afpa-compare-result-byte (byte 2 (- 31 22))) + +;;; The condition code bits. +;;; +(defconstant afpa-compare-lss #b00) +(defconstant afpa-compare-eql #b01) +(defconstant afpa-compare-gtr #b10) +(defconstant afpa-compare-unordered #b11) + + +;;;; Move functions: +;;; +;;; Since moving between memory and a FP register reqires *two* temporaries, +;;; we need a special temporary to form the magic address we store to do a +;;; floating point operation. We get this temp by always spilling NL0 on the +;;; number stack. See WITH-FP-TEMP in the 68881 support. +;;; +;;; We also use LIP to form the address of the data location that we are +;;; reading or writing. + + +(define-move-function (load-afpa-single 7) (vop x y) + ((single-stack) (afpa-single-reg)) + (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)) + (with-fp-temp (temp) + (inst afpa-load y lip-tn :single temp) + (inst afpa-noop temp))) + +(define-move-function (store-single 8) (vop x y) + ((afpa-single-reg) (single-stack)) + (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) + (with-fp-temp (temp) + (inst afpa-store x lip-tn :single temp) + (inst afpa-noop temp))) + +(define-move-function (load-double 7) (vop x y) + ((double-stack) (afpa-double-reg)) + (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)) + (with-fp-temp (temp) + (inst afpa-load y lip-tn :double temp) + (inst afpa-noop temp))) + +(define-move-function (store-double 8) (vop x y) + ((afpa-double-reg) (double-stack)) + (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) + (with-fp-temp (temp) + (inst afpa-store x lip-tn :double temp) + (inst afpa-noop temp))) + + +;;;; Move VOPs: + + +(macrolet ((frob (vop sc inst) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note "float move") + (:temporary (:sc sap-reg) temp) + (:generator 0 + (unless (location= y x) + (inst afpa-unop y x ,inst temp)))) + (define-move-vop ,vop :move (,sc) (,sc))))) + (frob afpa-single-move afpa-single-reg :cops) + (frob afpa-double-move afpa-double-reg :copl)) + + + +(macrolet ((frob (name format data sc) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:temporary (:sc sap-reg) temp) + (:generator 7 + (inst cal lip-tn x (- (* ,data vm:word-bytes) + vm:other-pointer-type)) + (inst afpa-load y lip-tn ,format temp) + (inst afpa-noop temp))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-afpa-single :single vm:single-float-value-slot + afpa-single-reg) + (frob move-to-afpa-double :double vm:double-float-value-slot + afpa-double-reg)) + + + +(macrolet ((frob (name sc format size type data) + `(progn + (define-vop (,name) + (:args (x :scs (afpa-single-reg afpa-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:scs (sap-reg)) ndescr) + (:temporary (:scs (word-pointer-reg)) alloc) + (:generator 20 + (with-fixed-allocation (y ndescr alloc ,type ,size) + (inst cal lip-tn y (- (* ,data vm:word-bytes) + vm:other-pointer-type)) + (inst afpa-store x lip-tn ,format ndescr) + (inst afpa-noop ndescr)))) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) + (frob move-from-afpa-single afpa-single-reg + :single vm:single-float-size vm:single-float-type + vm:single-float-value-slot) + (frob move-from-afpa-double afpa-double-reg + :double vm:double-float-size vm:double-float-type + vm:double-float-value-slot)) + +(define-vop (move-to-afpa-argument) + (:args (x :scs (afpa-single-reg afpa-double-reg)) + (nfp :scs (word-pointer-reg) + :load-if (not (sc-is y afpa-single-reg afpa-double-reg)))) + (:results (y)) + (:temporary (:sc sap-reg) temp) + (:variant-vars format) + (:vop-var vop) + (:generator 7 + (sc-case y + ((afpa-single-reg afpa-double-reg) + (unless (location= y x) + (inst afpa-move y x format temp))) + ((single-stack double-stack) + (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)) + (inst afpa-store y lip-tn format temp) + (inst afpa-noop temp))))) + +(macrolet ((frob (name format sc) + `(progn + (define-vop (,name move-to-afpa-argument) + (:variant ,format)) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-afpa-single-float-argument :single afpa-single-reg) + (frob move-afpa-double-float-argument :double afpa-double-reg)) + +(define-move-vop move-argument :move-argument + (afpa-single-reg afpa-double-reg) (descriptor-reg)) + + +;;;; Arithmetic VOPs: + +(define-vop (afpa-op) + (:args (x) (y)) + (:results (r)) + (:temporary (:sc sap-reg) temp) + (:policy :fast-safe) + (:guard (eq *target-float-hardware* :afpa)) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only)) + +(macrolet ((frob (name sc ptype format) + `(define-vop (,name afpa-op) + (:args (x :scs (,sc) :target r) + (y :scs (,sc))) + (:results (r :scs (,sc) :from (:argument 0))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype) + (:variant-vars op) + (:generator 20 + (unless (location= x r) + (inst afpa-move r x ,format temp)) + (note-this-location vop :internal-error) + (inst afpa-binop r y op temp))))) + (frob afpa-single-float-op afpa-single-reg afpa-single-float :single) + (frob afpa-double-float-op afpa-double-reg afpa-double-float :double)) + +(macrolet ((frob (op sinst sname dinst dname) + `(progn + (define-vop (,sname afpa-single-float-op) + (:translate ,op) + (:variant ,sinst)) + (define-vop (,dname afpa-double-float-op) + (:translate ,op) + (:variant ,dinst))))) + (frob + :adds +/single-float :addl +/double-float) + (frob - :subs -/single-float :subl -/double-float) + (frob * :muls */single-float :mull */double-float) + (frob / :divs //single-float :divl //double-float)) + +(define-vop (afpa-unop afpa-op) + (:args (x))) + +(macrolet ((frob (name sc ptype) + `(define-vop (,name afpa-unop) + (:args (x :scs (,sc))) + (:results (r :scs (,sc))) + (:arg-types ,ptype) + (:result-types ,ptype) + (:variant-vars op) + (:generator 20 + (inst afpa-unop r x op temp))))) + (frob afpa-single-float-unop afpa-single-reg afpa-single-float) + (frob afpa-double-float-unop afpa-double-reg afpa-double-float)) + + +(macrolet ((frob (op sinst sname dinst dname) + `(progn + (define-vop (,sname afpa-single-float-unop) + (:translate ,op) + (:variant ,sinst)) + (define-vop (,dname afpa-double-float-unop) + (:translate ,op) + (:variant ,dinst))))) + (frob abs :abss abs/single-float :absl abs/double-float) + (frob %negate :negs %negate/single-float :negl %negate/double-float)) + + +;;;; Comparison: + +(define-vop (afpa-compare) + (:args (x) (y)) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:guard (eq *target-float-hardware* :afpa)) + (:temporary (:sc sap-reg) temp) + (:variant-vars condition format) + (:note "inline float comparison") + (:vop-var vop) + (:save-p :compute-only) + (:generator 15 + (note-this-location vop :internal-error) + (inst afpa-compare x y + (ecase format + (:single :comts) + (:double :comtl)) + temp) + (inst afpa-get-status temp temp) + (inst nilz temp temp (mask-field afpa-compare-result-byte -1)) + (inst c temp (dpb condition afpa-compare-result-byte 0)) + (if not-p + (inst bnc :eq target) + (inst bc :eq target)))) + + +(macrolet ((frob (name sc ptype) + `(define-vop (,name afpa-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) + (frob afpa-single-float-compare afpa-single-reg afpa-single-float) + (frob afpa-double-float-compare afpa-double-reg afpa-double-float)) + +(macrolet ((frob (translate sname dname condition) + `(progn + (define-vop (,sname afpa-single-float-compare) + (:translate ,translate) + (:variant ,condition :single)) + (define-vop (,dname afpa-double-float-compare) + (:translate ,translate) + (:variant ,condition :double))))) + (frob < afpa-</single-float afpa-</double-float afpa-compare-lss) + (frob > afpa->/single-float afpa->/double-float afpa-compare-gtr) + (frob eql afpa-eql/single-float afpa-eql/double-float afpa-compare-eql)) + + +;;;; Conversion: + +(macrolet ((frob (name translate + from-sc from-type + to-sc to-type + word-p op) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:temporary (:sc sap-reg) temp) + (:policy :fast-safe) + (:guard (eq *target-float-hardware* :afpa)) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (note-this-location vop :internal-error) + ,@(if word-p + `((inst afpa-put-float-inst y x temp + (do-afpa-inst ,op temp :fr2 y :data x + :ds :fr1-immediate))) + `((inst afpa-unop y x ,op temp))))))) + (frob %afpa-single-float/signed %single-float + signed-reg signed-num + afpa-single-reg afpa-single-float + t :cws) + (frob %afpa-double-float/signed %double-float + signed-reg signed-num + afpa-double-reg afpa-double-float + t :cwl) + (frob %afpa-single-float/double-float %single-float + afpa-double-reg afpa-double-float + afpa-single-reg afpa-single-float + nil :cls) + (frob %afpa-double-float/single-float %double-float + afpa-single-reg afpa-single-float + afpa-double-reg afpa-double-float + nil :csl)) + +(macrolet ((frob (translate name from-sc from-type op) + `(define-vop (,name) + (:args (x :scs (,from-sc))) + (:results (y :scs (signed-reg))) + (:temporary (:from (:argument 0) :sc ,from-sc) fp-temp) + (:temporary (:sc sap-reg) temp) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,translate) + (:policy :fast-safe) + (:guard (eq *target-float-hardware* :afpa)) + (:note "inline float round/truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (note-this-location vop :internal-error) + (inst afpa-unop fp-temp x ,op temp) + (inst afpa-get-float y temp fp-temp))))) + + (frob %unary-round %unary-round/afpa-single-float + afpa-single-reg afpa-single-float :rsw) + (frob %unary-round %unary-round/afpa-double-float + afpa-double-reg afpa-double-float :rlw) + (frob %unary-truncate %unary-truncate/afpa-single-float + afpa-single-reg afpa-single-float :tsw) + (frob %unary-truncate %unary-truncate/afpa-double-float + afpa-double-reg afpa-double-float :tlw)) + + +(define-vop (make-afpa-single-float) + (:args (bits :scs (signed-reg))) + (:results (res :scs (afpa-single-reg))) + (:arg-types signed-num) + (:temporary (:sc sap-reg) temp) + (:guard (eq *target-float-hardware* :afpa)) + (:result-types afpa-single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:generator 5 + (inst afpa-put-float res bits temp))) + +(define-vop (make-afpa-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (afpa-double-reg))) + (:temporary (:sc sap-reg) temp) + (:guard (eq *target-float-hardware* :afpa)) + (:arg-types signed-num unsigned-num) + (:result-types afpa-double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:generator 10 + (inst afpa-put-float-odd res lo-bits temp) + (inst afpa-put-float res hi-bits temp))) + +(define-vop (afpa-single-float-bits) + (:args (float :scs (afpa-single-reg))) + (:results (bits :scs (signed-reg))) + (:temporary (:sc sap-reg) temp) + (:guard (eq *target-float-hardware* :afpa)) + (:arg-types afpa-single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:generator 5 + (inst afpa-get-float bits float temp))) + +(define-vop (afpa-double-float-high-bits) + (:args (float :scs (afpa-double-reg))) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:sc sap-reg) temp) + (:guard (eq *target-float-hardware* :afpa)) + (:arg-types afpa-double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:generator 5 + (inst afpa-get-float hi-bits float temp))) + +(define-vop (afpa-double-float-low-bits) + (:args (float :scs (afpa-double-reg))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc sap-reg) temp) + (:guard (eq *target-float-hardware* :afpa)) + (:arg-types afpa-double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:generator 5 + (inst afpa-get-float-odd lo-bits float temp))) + + +;;;; SAP accessors/setters + +#| +(define-vop (sap-ref-afpa-single sap-ref) + (:translate sap-ref-single) + (:results (result :scs (afpa-single-reg))) + (:result-types afpa-single-float) + (:variant :afpa-single nil)) + +(define-vop (sap-set-afpa-single sap-set) + (:translate %set-sap-ref-single) + (:args (sap :scs (sap-reg)) + (offset :scs (any-reg signed-reg zero immediate)) + (value :scs (afpa-single-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum afpa-single-float) + (:results (result :scs (afpa-single-reg))) + (:result-types afpa-single-float) + (:variant :afpa-single)) + +(define-vop (sap-ref-afpa-double sap-ref) + (:translate sap-ref-double) + (:results (result :scs (afpa-double-reg))) + (:result-types afpa-double-float) + (:variant :afpa-double nil)) + +(define-vop (sap-set-afpa-double sap-set) + (:translate %set-sap-ref-double) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg any-reg zero immediate)) + (value :scs (afpa-double-reg) :target result)) + (:arg-types system-area-pointer positive-fixnum afpa-double-float) + (:results (result :scs (afpa-double-reg))) + (:result-types afpa-double-float) + (:variant :afpa-double)) + +|# + + +;;;; Float mode hackery: + +(deftype float-modes () '(unsigned-byte 32)) +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + #+nil (:vop-var vop) + #+nil (:temporary (:sc unsigned-stack) temp) + (:generator 3 + #+nil + (let ((nfp (current-nfp-tn vop))) + (inst stfsr nfp (* word-bytes (tn-offset temp))) + (loadw res nfp (tn-offset temp)) + (inst nop)) + (inst li res 0))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + #+nil (:temporary (:sc unsigned-stack) temp) + #+nil (:vop-var vop) + (:generator 3 + #+nil + (let ((nfp (current-nfp-tn vop))) + (storew new nfp (tn-offset temp)) + (inst ldfsr nfp (* word-bytes (tn-offset temp))) + (move res new)) + (move res new)))