Forked from
cmucl / cmucl
9815 commits behind the upstream repository.
mc68881.lisp 19.08 KiB
;;; -*- 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/mc68881.lisp,v 1.11 1992/03/09 20:37:46 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; The following code is to support the MC68881 floating point chip on the APC
;;; card. Adapted by Rob MacLachlan from the Sparc support, written by Rob
;;; MacLachlan and William Lott, with some stuff from Dave McDonald's original
;;; RT miscops.
;;;
(in-package "RT")
(eval-when (compile eval load)
;;; The actual positions of the info in the mc68881 FPCR and FPSR.
;;;
(defconstant mc68881-fpcr-rounding-mode-byte (byte 2 4))
(defconstant mc68881-fpcr-rounding-precision-byte (byte 2 6))
(defconstant mc68881-fpcr-traps-byte (byte 8 8))
(defconstant mc68881-fpsr-accrued-exceptions-byte (byte 5 3))
(defconstant mc68881-fpsr-current-exceptions-byte (byte 8 8))
(defconstant mc68881-fpsr-condition-code-byte (byte 4 24))
;;; Amount to shift by the get the condition code, - 16.
;;;
(defconstant mc68881-fpsr-condition-code-shift-16 8)
;;; The condition code bits.
;;;
(defconstant mc68881-nan-condition (ash 1 0))
(defconstant mc68881-infinity-condition (ash 1 1))
(defconstant mc68881-zero-condition (ash 1 2))
(defconstant mc68881-negative-condition (ash 1 3))
;;; Masks that map the extended set of exceptions implemented by the 68881 to
;;; the IEEE exceptions. This extended format is used for the enabled traps
;;; and the current exceptions.
;;;
(defconstant mc68881-invalid-exception (ash #b111 5))
(defconstant mc68881-overflow-exception (ash 1 4))
(defconstant mc68881-underflow-exception (ash 1 3))
(defconstant mc68881-divide-zero-exception (ash 1 2))
(defconstant mc68881-inexact-exception (ash #b11 0))
;;; Encoding of float exceptions in the FLOATING-POINT-MODES result. This is
;;; also the encoding used in the mc68881 accrued exceptions.
;;;
(defconstant float-inexact-trap-bit (ash 1 0))
(defconstant float-divide-by-zero-trap-bit (ash 1 1))
(defconstant float-underflow-trap-bit (ash 1 2))
(defconstant float-overflow-trap-bit (ash 1 3))
(defconstant float-invalid-trap-bit (ash 1 4))
(defconstant float-round-to-nearest 0)
(defconstant float-round-to-zero 1)
(defconstant float-round-to-negative 2)
(defconstant float-round-to-positive 3)
;;; Positions of bits in the FLOATING-POINT-MODES result.
;;;
(defconstant float-rounding-mode (byte 2 0))
(defconstant float-sticky-bits (byte 5 2))
(defconstant float-traps-byte (byte 5 7))
(defconstant float-exceptions-byte (byte 5 12))
(defconstant float-fast-bit 0)
); eval-when
;;; When compared to the 68881 documentation, the RT only uses the low 16 bits
;;; of the instruction. Memory access is controlled in an RT specific way.
;;; See the AFPA coprocessor hardware assist operation (page B34 in volume 1.)
;;;; Move functions:
;;;
;;; See With-FP-Temp comment...
(define-move-function (load-single 7) (vop x y)
((single-stack) (mc68881-single-reg))
(inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
(with-fp-temp (temp)
(inst mc68881-load y lip-tn :single temp)))
(define-move-function (store-single 8) (vop x y)
((mc68881-single-reg) (single-stack))
(inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
(with-fp-temp (temp)
(inst mc68881-store x lip-tn :single temp)))
(define-move-function (load-double 7) (vop x y)
((double-stack) (mc68881-double-reg))
(inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
(with-fp-temp (temp)
(inst mc68881-load y lip-tn :double temp)))
(define-move-function (store-double 8) (vop x y)
((mc68881-double-reg) (double-stack))
(inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
(with-fp-temp (temp)
(inst mc68881-store x lip-tn :double temp)))
;;;; Move VOPs:
(define-vop (mc68881-move)
(:args (x :scs (mc68881-single-reg mc68881-double-reg)
:target y
:load-if (not (location= x y))))
(:results (y :scs (mc68881-single-reg mc68881-double-reg)
:load-if (not (location= x y))))
(:temporary (:sc sap-reg) temp)
(:generator 0
(unless (location= y x)
(inst mc68881-move y x temp))))
(define-move-vop mc68881-move :move
(mc68881-single-reg) (mc68881-single-reg)
(mc68881-double-reg) (mc68881-double-reg))
(define-vop (move-to-mc68881)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (mc68881-single-reg mc68881-double-reg)))
(:temporary (:sc sap-reg) temp)
(:variant-vars format data)
(:generator 7
(inst cal lip-tn x (- (* data vm:word-bytes) vm:other-pointer-type))
(inst mc68881-load y lip-tn format temp)))
(macrolet ((frob (name format data sc)
`(progn
(define-vop (,name move-to-mc68881)
(:variant ,format ,data))
(define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-mc68881-single :single vm:single-float-value-slot
mc68881-single-reg)
(frob move-to-mc68881-double :double vm:double-float-value-slot
mc68881-double-reg))
(define-vop (move-from-mc68881)
(:args (x :scs (mc68881-single-reg mc68881-double-reg) :to :save))
(:results (y :scs (descriptor-reg)))
(:temporary (:scs (sap-reg)) ndescr)
(:temporary (:scs (word-pointer-reg)) alloc)
(:variant-vars format size type data)
(:generator 20
(with-fixed-allocation (y ndescr alloc type size)
(inst cal lip-tn y (- (* data vm:word-bytes) vm:other-pointer-type))
(inst mc68881-store x lip-tn format ndescr))))
(macrolet ((frob (name sc &rest args)
`(progn
(define-vop (,name move-from-mc68881)
(:variant ,@args))
(define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-mc68881-single mc68881-single-reg
:single vm:single-float-size vm:single-float-type
vm:single-float-value-slot)
(frob move-from-mc68881-double mc68881-double-reg
:double vm:double-float-size vm:double-float-type
vm:double-float-value-slot))
(define-vop (move-to-mc68881-argument)
(:args (x :scs (mc68881-single-reg mc68881-double-reg) :target y)
(nfp :scs (word-pointer-reg)
:load-if (not (sc-is y mc68881-single-reg mc68881-double-reg))))
(:results (y))
(:temporary (:sc sap-reg) temp)
(:variant-vars format)
(:vop-var vop)
(:generator 7
(sc-case y
((mc68881-single-reg mc68881-double-reg)
(unless (location= y x)
(inst mc68881-move y x temp)))
((single-stack double-stack)
(inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
(inst mc68881-store y lip-tn format temp)))))
(macrolet ((frob (name format sc)
`(progn
(define-vop (,name move-to-mc68881-argument)
(:variant ,format))
(define-move-vop ,name :move-argument
(,sc descriptor-reg) (,sc)))))
(frob move-mc68881-single-float-argument :single mc68881-single-reg)
(frob move-mc68881-double-float-argument :double mc68881-double-reg))
(define-move-vop move-argument :move-argument
(mc68881-single-reg mc68881-double-reg) (descriptor-reg))
;;;; Arithmetic VOPs:
(define-vop (mc68881-op)
(:args (x) (y))
(:results (r))
(:temporary (:sc sap-reg) temp)
(:policy :fast-safe)
(:note "inline float arithmetic")
(:vop-var vop)
(:save-p :compute-only))
(macrolet ((frob (name sc ptype)
`(define-vop (,name mc68881-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 mc68881-move r x temp))
(note-this-location vop :internal-error)
(inst mc68881-binop r y op temp)))))
(frob mc68881-single-float-op mc68881-single-reg mc68881-single-float)
(frob mc68881-double-float-op mc68881-double-reg mc68881-double-float))
(macrolet ((frob (op sinst sname dinst dname)
`(progn
(define-vop (,sname mc68881-single-float-op)
(:translate ,op)
(:variant ,sinst))
(define-vop (,dname mc68881-double-float-op)
(:translate ,op)
(:variant ,dinst)))))
(frob + :add +/single-float :add +/double-float)
(frob - :sub -/single-float :sub -/double-float)
(frob * :sglmul */single-float :mul */double-float)
(frob / :sgldiv //single-float :div //double-float))
(define-vop (mc68881-unop mc68881-op)
(:args (x)))
(macrolet ((frob (name sc ptype)
`(define-vop (,name mc68881-unop)
(:args (x :scs (,sc)))
(:results (r :scs (,sc)))
(:arg-types ,ptype)
(:result-types ,ptype)
(:variant-vars op)
(:generator 20
(inst mc68881-unop r x op temp)))))
(frob mc68881-single-float-unop mc68881-single-reg mc68881-single-float)
(frob mc68881-double-float-unop mc68881-double-reg mc68881-double-float))
(macrolet ((frob (op sinst sname dinst dname)
`(progn
(define-vop (,sname mc68881-single-float-unop)
(:translate ,op)
(:variant ,sinst))
(define-vop (,dname mc68881-double-float-unop)
(:translate ,op)
(:variant ,dinst)))))
(frob abs :abs abs/single-float :abs abs/double-float)
(frob %negate :neg %negate/single-float :neg %negate/double-float))
;;;; Comparison:
(define-vop (mc68881-compare)
(:args (x) (y))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:temporary (:sc sap-reg) temp)
(:temporary (:sc descriptor-reg) loc)
(:temporary (:sc unsigned-stack) loc-tn)
(:variant-vars condition)
(:note "inline float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:generator 20
(let ((drop-thru (gen-label)))
(note-this-location vop :internal-error)
(if (eq condition '<)
(inst mc68881-compare y x :cmp temp)
(inst mc68881-compare x y :cmp temp))
(let ((nfp (current-nfp-tn vop)))
(inst cal loc nfp (* (tn-offset loc-tn) word-bytes)))
(inst mc68881-store-status :fpsr loc temp)
(loadw temp loc)
(ecase condition
((< >)
(inst niuz temp temp
(ash (logior mc68881-zero-condition
mc68881-negative-condition
mc68881-nan-condition)
mc68881-fpsr-condition-code-shift-16)))
(eql
(inst niuz temp temp
(ash mc68881-zero-condition
mc68881-fpsr-condition-code-shift-16))
(setq not-p (not not-p))))
(if not-p
(inst bnc :eq target)
(inst bc :eq target))
(emit-label drop-thru))))
(macrolet ((frob (name sc ptype)
`(define-vop (,name mc68881-compare)
(:args (x :scs (,sc))
(y :scs (,sc)))
(:arg-types ,ptype ,ptype))))
(frob mc68881-single-float-compare mc68881-single-reg mc68881-single-float)
(frob mc68881-double-float-compare mc68881-double-reg mc68881-double-float))
(macrolet ((frob (translate sname dname)
`(progn
(define-vop (,sname mc68881-single-float-compare)
(:translate ,translate)
(:variant ',translate))
(define-vop (,dname mc68881-double-float-compare)
(:translate ,translate)
(:variant ',translate)))))
(frob < mc68881-</single-float mc68881-</double-float)
(frob > mc68881->/single-float mc68881->/double-float)
(frob eql mc68881-eql/single-float mc68881-eql/double-float))
;;;; Conversion:
(macrolet ((frob (name translate to-sc to-type)
`(define-vop (,name)
(:args (x :scs (signed-reg) :target temp
:load-if (not (sc-is x signed-stack))))
(:temporary (:scs (single-stack)) temp)
(:temporary (:sc word-pointer-reg) addr)
(:temporary (:sc sap-reg) scratch)
(:results (y :scs (,to-sc)))
(:arg-types signed-num)
(:result-types ,to-type)
(:policy :fast-safe)
(:note "inline float coercion")
(:translate ,translate)
(:vop-var vop)
(:save-p :compute-only)
(:generator 20
(let ((stack-tn
(sc-case x
(signed-reg
(storew x
(current-nfp-tn vop)
(* (tn-offset temp) vm:word-bytes))
temp)
(signed-stack
x))))
(inst cal addr (current-nfp-tn vop)
(* (tn-offset stack-tn) vm:word-bytes))
(note-this-location vop :internal-error)
(inst mc68881-load y addr :integer scratch))))))
(frob mc68881-%single-float/signed %single-float
mc68881-single-reg mc68881-single-float)
(frob mc68881-%double-float/signed %double-float
mc68881-double-reg mc68881-double-float))
;;; Everything is represented as extended precision, so these operations don't
;;; really do anything. (Or, rather, whatever semantics there is, is
;;; automatically handled by the load functions.)
;;;
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
`(define-vop (,name mc68881-move)
(:args (x :scs (,from-sc) :target y))
(:results (y :scs (,to-sc)))
(:arg-types ,from-type)
(:result-types ,to-type)
(:policy :fast-safe)
(:note "inline float coercion")
(:translate ,translate))))
(frob mc68881-%single-float/double-float %single-float
mc68881-double-reg mc68881-double-float
mc68881-single-reg mc68881-single-float)
(frob mc68881-%double-float/single-float %double-float
mc68881-single-reg mc68881-single-float
mc68881-double-reg mc68881-double-float))
(macrolet ((frob (trans from-sc from-type inst)
`(define-vop (,(symbolicate trans "/" from-type))
(:args (x :scs (,from-sc) :target temp))
(:temporary (:from (:argument 0) :sc mc68881-single-reg) temp)
(:temporary (:sc sap-reg) scratch)
(:temporary (:scs (signed-stack)) stack-temp)
(:temporary (:sc word-pointer-reg) addr)
(:results (y :scs (signed-reg)
:load-if (not (sc-is y signed-stack))))
(:arg-types ,from-type)
(:result-types signed-num)
(:translate ,trans)
(:policy :fast-safe)
(:note "inline float truncate")
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(note-this-location vop :internal-error)
(inst mc68881-unop temp x ,inst scratch)
(sc-case y
(signed-stack
(inst cal addr (current-nfp-tn vop)
(* (tn-offset y) vm:word-bytes))
(inst mc68881-store temp addr :integer scratch))
(signed-reg
(inst cal addr (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst mc68881-store temp addr :integer scratch)
(loadw y (current-nfp-tn vop)
(tn-offset stack-temp))))))))
(frob %unary-truncate mc68881-single-reg mc68881-single-float :intrz)
(frob %unary-truncate mc68881-double-reg mc68881-double-float :intrz)
(frob %unary-round mc68881-single-reg mc68881-single-float :int)
(frob %unary-round mc68881-double-reg mc68881-double-float :int))
(define-vop (make-mc68881-single-float)
(:args (bits :scs (signed-reg) :target res
:load-if (not (sc-is bits signed-stack))))
(:results (res :scs (mc68881-single-reg)
:load-if (not (sc-is res single-stack))))
(:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
(:temporary (:scs (signed-stack)) stack-temp)
(:temporary (:sc sap-reg) scratch)
(:temporary (:sc word-pointer-reg) addr)
(:arg-types signed-num)
(:result-types mc68881-single-float)
(:translate make-single-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 20
(sc-case bits
(signed-reg
(sc-case res
(mc68881-single-reg
(storew bits (current-nfp-tn vop) (tn-offset stack-temp))
(inst cal addr (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst mc68881-load res addr :single scratch))
(single-stack
(storew bits (current-nfp-tn vop) (tn-offset res)))))
(signed-stack
(sc-case res
(mc68881-single-reg
(inst cal addr (current-nfp-tn vop)
(* (tn-offset bits) vm:word-bytes))
(inst mc68881-load res addr :single scratch))
(single-stack
(unless (location= bits res)
(loadw temp (current-nfp-tn vop) (tn-offset bits))
(storew temp (current-nfp-tn vop) (tn-offset res)))))))))
(define-vop (make-mc68881-double-float)
(:args (hi-bits :scs (signed-reg))
(lo-bits :scs (unsigned-reg)))
(:arg-types signed-num unsigned-num)
(:results (res :scs (mc68881-double-reg)
:load-if (not (sc-is res double-stack))))
(:result-types mc68881-double-float)
(:temporary (:scs (double-stack)) temp)
(:temporary (:sc sap-reg :from (:eval 0)) scratch)
(:temporary (:sc word-pointer-reg :from (:eval 0)) addr)
(:translate make-double-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 25
(let ((stack-tn (sc-case res
(double-stack res)
(mc68881-double-reg temp))))
(storew hi-bits (current-nfp-tn vop) (tn-offset stack-tn))
(storew lo-bits (current-nfp-tn vop) (1+ (tn-offset stack-tn))))
(when (sc-is res mc68881-double-reg)
(inst cal addr (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes))
(inst mc68881-load res addr :double scratch))))
(define-vop (mc68881-single-float-bits)
(:args (float :scs (mc68881-single-reg)))
(:results (bits :scs (signed-reg)))
(:temporary (:scs (signed-stack)) stack-temp)
(:temporary (:sc sap-reg) scratch)
(:temporary (:sc word-pointer-reg) addr)
(:arg-types mc68881-single-float)
(:result-types signed-num)
(:translate single-float-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 20
(inst cal addr (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst mc68881-store float addr :single scratch)
(loadw bits (current-nfp-tn vop) (tn-offset stack-temp))))
(define-vop (mc68881-double-float-high-bits)
(:args (float :scs (mc68881-double-reg)))
(:results (bits :scs (signed-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:temporary (:sc sap-reg) scratch)
(:temporary (:sc word-pointer-reg) addr)
(:arg-types mc68881-double-float)
(:result-types signed-num)
(:translate double-float-high-bits)
(:policy :fast-safe)
(:vop-var vop)
(:variant-vars offset)
(:variant 0)
(:generator 20
(inst cal addr (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst mc68881-store float addr :double scratch)
(loadw bits (current-nfp-tn vop) (+ (tn-offset stack-temp) offset))))
(define-vop (mc68881-double-float-low-bits mc68881-double-float-high-bits)
(:results (bits :scs (unsigned-reg)))
(:result-types unsigned-num)
(:variant 1)
(:translate double-float-low-bits))
;;;; 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)))