Skip to content
Snippets Groups Projects
Commit fb6f5f57 authored by Raymond Toy's avatar Raymond Toy
Browse files

Implemeent more VOPS or make them not-implemented. Long-float support

ripped out.
parent c7a90762
No related branches found
No related tags found
No related merge requests found
......@@ -202,26 +202,26 @@
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) vm:word-bytes)))
(let ((value-tn (complex-double-double-reg-real-hi-tn y)))
(inst lddf value-tn nfp offset))
(inst vldr value-tn (make-ea nfp :offset offset)))
(let ((value-tn (complex-double-double-reg-real-lo-tn y)))
(inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes))))
(inst vldr value-tn (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))
(let ((value-tn (complex-double-double-reg-imag-hi-tn y)))
(inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes))))
(inst vldr value-tn (make-ea nfp :offset (+ offset (* 4 vm:word-bytes)))))
(let ((value-tn (complex-double-double-reg-imag-lo-tn y)))
(inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
(inst vldr value-tn (make-ea nfp :offset (+ offset (* 6 vm:word-bytes)))))))
(define-move-function (store-complex-double-double 4) (vop x y)
((complex-double-double-reg) (complex-double-double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) vm:word-bytes)))
(let ((value-tn (complex-double-double-reg-real-hi-tn x)))
(inst stdf value-tn nfp offset))
(inst vstr value-tn (make-ea nfp :offset offset)))
(let ((value-tn (complex-double-double-reg-real-lo-tn x)))
(inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes))))
(inst vstr value-tn (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))
(let ((value-tn (complex-double-double-reg-imag-hi-tn x)))
(inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes))))
(inst vstr value-tn (make-ea nfp :offset (+ offset (* 4 vm:word-bytes)))))
(let ((value-tn (complex-double-double-reg-imag-lo-tn x)))
(inst stdf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
(inst vstr value-tn (make-ea nfp :offset (+ offset (* 6 vm:word-bytes)))))))
)
......@@ -347,21 +347,25 @@
(with-fixed-allocation (y ndescr vm::complex-double-double-float-type
vm::complex-double-double-float-size))
(let ((real-tn (complex-double-double-reg-real-hi-tn x)))
(inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot
(inst vstr real-tn
(make-ea y :offset (- (* vm::complex-double-double-float-real-hi-slot
vm:word-bytes)
vm:other-pointer-type)))
vm:other-pointer-type))))
(let ((real-tn (complex-double-double-reg-real-lo-tn x)))
(inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot
(inst vstr real-tn
(make-ea y :offset (- (* vm::complex-double-double-float-real-lo-slot
vm:word-bytes)
vm:other-pointer-type)))
vm:other-pointer-type))))
(let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
(inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot
(inst vstr imag-tn
(make-ea y :offset (- (* vm::complex-double-double-float-imag-hi-slot
vm:word-bytes)
vm:other-pointer-type)))
vm:other-pointer-type))))
(let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
(inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot
(inst vstr imag-tn
(make-ea y :offset (- (* vm::complex-double-double-float-imag-lo-slot
vm:word-bytes)
vm:other-pointer-type)))))
vm:other-pointer-type))))))
;;;
#+double-double
(define-move-vop move-from-complex-double-double :move
......@@ -409,17 +413,21 @@
(:note _N"pointer to complex double-double float coercion")
(:generator 2
(let ((real-tn (complex-double-double-reg-real-hi-tn y)))
(inst lddf real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes)
other-pointer-type)))
(inst vldr real-tn
(make-ea x :offset (- (* complex-double-double-float-real-hi-slot word-bytes)
other-pointer-type))))
(let ((real-tn (complex-double-double-reg-real-lo-tn y)))
(inst lddf real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes)
other-pointer-type)))
(inst vldr real-tn
(make-ea x :offset (- (* complex-double-double-float-real-lo-slot word-bytes)
other-pointer-type))))
(let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
(inst lddf imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes)
other-pointer-type)))
(inst vldr imag-tn
(make-ea x :offset (- (* complex-double-double-float-imag-hi-slot word-bytes)
other-pointer-type))))
(let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
(inst lddf imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes)
other-pointer-type)))))
(inst vldr imag-tn
(make-ea x :offset (- (* complex-double-double-float-imag-lo-slot word-bytes)
other-pointer-type))))))
#+double-double
(define-move-vop move-to-complex-double-double :move
(descriptor-reg) (complex-double-double-reg))
......@@ -500,13 +508,13 @@
(complex-double-double-stack
(let ((offset (* (tn-offset y) word-bytes)))
(let ((real-tn (complex-double-double-reg-real-hi-tn x)))
(inst stdf real-tn nfp offset))
(inst vstr real-tn (make-ea nfp :offset offset)))
(let ((real-tn (complex-double-double-reg-real-lo-tn x)))
(inst stdf real-tn nfp (+ offset (* 2 word-bytes))))
(inst vstr real-tn (make-ea nfp :offset (+ offset (* 2 word-bytes)))))
(let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
(inst stdf imag-tn nfp (+ offset (* 4 word-bytes))))
(inst vstr imag-tn (make-ea nfp :offset (+ offset (* 4 word-bytes)))))
(let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
(inst stdf imag-tn nfp (+ offset (* 6 word-bytes)))))))))
(inst vstr imag-tn (make-ea nfp :offset (+ offset (* 6 word-bytes))))))))))
#+double-double
(define-move-vop move-complex-double-double-float-argument :move-argument
......@@ -619,16 +627,7 @@
(:save-p :compute-only)
(:generator 3
(note-this-location vop :internal-error)
(ecase format
(:single (inst fcmps x y))
(:double (inst fcmpd x y))
(:long (inst fcmpq x y)))
;; The SPARC V9 doesn't need an instruction between a
;; floating-point compare and a floating-point branch.
(unless (backend-featurep :sparc-v9)
(inst nop))
(inst fb (if not-p nope yep) target)
(inst nop)))
(not-implemented)))
(macrolet ((frob (name sc ptype)
`(define-vop (,name float-compare)
......@@ -636,33 +635,20 @@
(y :scs (,sc)))
(:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float)
#+long-float
(frob long-float-compare long-reg long-float))
(frob double-float-compare double-reg double-float))
(macrolet ((frob (translate yep nope sname dname #+long-float lname)
(macrolet ((frob (translate yep nope sname dname)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
(:variant :single ,yep ,nope))
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:variant :double ,yep ,nope))
#+long-float
(define-vop (,lname long-float-compare)
(:translate ,translate)
(:variant :long ,yep ,nope)))))
(:variant :double ,yep ,nope)))))
(frob < :l :ge </single-float </double-float #+long-float </long-float)
(frob > :g :le >/single-float >/double-float #+long-float >/long-float)
(frob = :eq :ne eql/single-float eql/double-float #+long-float eql/long-float))
#+long-float
(deftransform eql ((x y) (long-float long-float))
'(and (= (long-float-low-bits x) (long-float-low-bits y))
(= (long-float-mid-bits x) (long-float-mid-bits y))
(= (long-float-high-bits x) (long-float-high-bits y))
(= (long-float-exp-bits x) (long-float-exp-bits y))))
#+double-double
(deftransform eql ((x y) (double-double-float double-double-float))
'(and (eql (double-double-hi x) (double-double-hi y))
......@@ -684,45 +670,6 @@
(frob %%single-float single-float)
(frob %%double-float double-float))
;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces. Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together. The pieces are done in a way such that no
;; roundoff occurs. The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two. The final
;; sum will produce the correct rounded result. (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(macrolet ((frob (name vop-trans limit unit)
`(progn
(deftransform ,name ((n) ((unsigned-byte 32)))
;; Should this be extended to a (unsigned-byte 53)? We could. Just
;; take the low 31 bits, and the rest, and float them and combine
;; them as before.
(when (csubtypep (c::continuation-type n)
(c::specifier-type '(unsigned-byte 31)))
;; We want to give-up if we know the number can't have the
;; MSB set. The signed 32-bit vop can handle that.
(c::give-up))
`(+ (,',vop-trans (ldb (byte ,',limit 0) n))
(* (,',vop-trans (ldb (byte ,',(- 32 limit) ,',limit) n))
(scale-float ,',unit ,',limit))))
;; Always convert %foo to %%foo for 32-bit signed values.
(deftransform ,name ((n) ((signed-byte 32)))
`(,',vop-trans n)))))
;; If we break up the numbers into the low 12 bits and the high 20
;; bits, we can use a single AND instruction to get the low 12 bits.
;; This is a microoptimization for Sparc. Otherwise, the only
;; constraint is that the pieces must be small enough to fit in the
;; desired float format without rounding.
(frob %single-float %%single-float 12 1f0)
(frob %double-float %%double-float 12 1f0))
(macrolet ((frob (name translate inst to-sc to-type)
`(define-vop (,name)
(:args (x :scs (signed-reg) :target stack-temp
......@@ -738,58 +685,9 @@
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((stack-tn
(sc-case x
(signed-reg
(inst st x
(current-nfp-tn vop)
(* (tn-offset temp) vm:word-bytes))
stack-temp)
(signed-stack
x))))
(inst ldf temp
(current-nfp-tn vop)
(* (tn-offset stack-tn) vm:word-bytes))
(note-this-location vop :internal-error)
(inst ,inst y temp))))))
(not-implemented)))))
(frob %single-float/signed %%single-float fitos single-reg single-float)
(frob %double-float/signed %%double-float fitod double-reg double-float)
#+long-float
(frob %long-float/signed %long-float fitoq long-reg long-float))
;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces. Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together. The pieces are done in a way such that no
;; roundoff occurs. The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two. The final
;; sum will produce the correct rounded result. (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(macrolet ((frob (name limit unit)
`(deftransform ,name ((n) ((unsigned-byte 32)))
;; Should this be extended to a (unsigned-byte 53)? We could. Just
;; take the low 31 bits, and the rest, and float them and combine
;; them as before.
(when (csubtypep (c::continuation-type n)
(c::specifier-type '(unsigned-byte 31)))
;; We want to give-up if we know the number can't have the
;; MSB set. The signed 32-bit vop can handle that.
(c::give-up))
`(+ (,',name (ldb (byte ,',limit 0) n))
(* (,',name (ldb (byte ,',(- 32 limit) ,',limit) n))
(scale-float ,',unit ,',limit))))))
;; If we break up the numbers into the low 12 bits and the high 20
;; bits, we can use a single AND instruction to get the low 12 bits.
;; This is a microoptimization for Sparc. Otherwise, the only
;; constraint is that the pieces must be small enough to fit in the
;; desired float format without rounding.
(frob %single-float 12 1f0)
(frob %double-float 12 1f0))
(frob %double-float/signed %%double-float fitod double-reg double-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
......@@ -805,22 +703,10 @@
(:generator 2
(note-this-location vop :internal-error)
(inst ,inst y x)))))
(frob %single-float/double-float %single-float fdtos
(frob %single-float/double-float %single-float vcvt.f32.f64
double-reg double-float single-reg single-float)
#+long-float
(frob %single-float/long-float %single-float fqtos
long-reg long-float single-reg single-float)
(frob %double-float/single-float %double-float fstod
single-reg single-float double-reg double-float)
#+long-float
(frob %double-float/long-float %double-float fqtod
long-reg long-float double-reg double-float)
#+long-float
(frob %long-float/single-float %long-float fstoq
single-reg single-float long-reg long-float)
#+long-float
(frob %long-float/double-float %long-float fdtoq
double-reg double-float long-reg long-float))
(frob %double-float/single-float %double-float vcvt.f64.f32
single-reg single-float double-reg double-float))
(macrolet ((frob (trans from-sc from-type inst)
`(define-vop (,(symbolicate trans "/" from-type))
......@@ -838,24 +724,9 @@
(:save-p :compute-only)
(:generator 5
(note-this-location vop :internal-error)
(inst ,inst temp x)
(sc-case y
(signed-stack
(inst stf temp (current-nfp-tn vop)
(* (tn-offset y) vm:word-bytes)))
(signed-reg
(inst stf temp (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldsw y (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))))))))
(not-implemented)))))
(frob %unary-truncate single-reg single-float fstoi)
(frob %unary-truncate double-reg double-float fdtoi)
#+long-float
(frob %unary-truncate long-reg long-float fqtoi)
#-sun4
(frob %unary-round single-reg single-float fstoir)
#-sun4
(frob %unary-round double-reg double-float fdtoir))
(frob %unary-truncate double-reg double-float fdtoi))
(define-vop (fast-unary-ftruncate/single-float)
(:args (x :scs (single-reg)))
......@@ -867,8 +738,8 @@
(:guard (not (backend-featurep :sparc-v9)))
(:note _N"inline ftruncate")
(:generator 2
(inst fstoi r x)
(inst fitos r r)))
(inst vcvt.s32.f32 r x)
(inst vcvt.f32.s32 r r)))
(define-vop (fast-unary-ftruncate/double-float)
(:args (x :scs (double-reg) :target r))
......@@ -880,48 +751,8 @@
(:guard (not (backend-featurep :sparc-v9)))
(:note _N"inline ftruncate")
(:generator 2
(inst fdtoi r x)
(inst fitod r r)))
;; The V9 architecture can convert 64-bit integers.
(define-vop (v9-fast-unary-ftruncate/single-float)
(:args (x :scs (single-reg)))
(:arg-types single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(:temporary (:scs (double-reg)) temp)
(:policy :fast-safe)
(:translate c::fast-unary-ftruncate)
(:guard (backend-featurep :sparc-v9))
(:note _N"inline ftruncate")
(:generator 2
(inst fstox temp x)
(inst fxtos r temp)))
(define-vop (v9-fast-unary-ftruncate/double-float)
(:args (x :scs (double-reg) :target r))
(:arg-types double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(:policy :fast-safe)
(:translate c::fast-unary-ftruncate)
(:guard (backend-featurep :sparc-v9))
(:note _N"inline ftruncate")
(:generator 2
(inst fdtox r x)
(inst fxtod r r)))
#+sun4
(deftransform %unary-round ((x) (float) (signed-byte 32))
'(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
(extra (- x trunc))
(absx (abs extra))
(one-half (float 1/2 x)))
(if (if (oddp trunc)
(>= absx one-half)
(> absx one-half))
(truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
trunc)))
(inst vcvt.s32.f64 r x)
(inst vcvt.f64.s32 r r)))
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
......@@ -936,28 +767,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 4
(sc-case bits
(signed-reg
(sc-case res
(single-reg
(inst st bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldf res (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(single-stack
(inst st bits (current-nfp-tn vop)
(* (tn-offset res) vm:word-bytes)))))
(signed-stack
(sc-case res
(single-reg
(inst ldf res (current-nfp-tn vop)
(* (tn-offset bits) vm:word-bytes)))
(single-stack
(unless (location= bits res)
(inst ldsw temp (current-nfp-tn vop)
(* (tn-offset bits) vm:word-bytes))
(inst st temp (current-nfp-tn vop)
(* (tn-offset res) vm:word-bytes)))))))))
(not-implemented)))
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
......@@ -971,46 +781,8 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
(double-stack res)
(double-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
(* (tn-offset stack-tn) vm:word-bytes))
(inst st lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-tn)) vm:word-bytes)))
(when (sc-is res double-reg)
(inst lddf res (current-nfp-tn vop)
(* (tn-offset temp) vm:word-bytes)))))
#+long-float
(define-vop (make-long-float)
(:args (hi-bits :scs (signed-reg))
(lo1-bits :scs (unsigned-reg))
(lo2-bits :scs (unsigned-reg))
(lo3-bits :scs (unsigned-reg)))
(:results (res :scs (long-reg)
:load-if (not (sc-is res long-stack))))
(:temporary (:scs (long-stack)) temp)
(:arg-types signed-num unsigned-num unsigned-num unsigned-num)
(:result-types long-float)
(:translate make-long-float)
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
(long-stack res)
(long-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
(* (tn-offset stack-tn) vm:word-bytes))
(inst st lo1-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-tn)) vm:word-bytes))
(inst st lo2-bits (current-nfp-tn vop)
(* (+ 2 (tn-offset stack-tn)) vm:word-bytes))
(inst st lo3-bits (current-nfp-tn vop)
(* (+ 3 (tn-offset stack-tn)) vm:word-bytes)))
(when (sc-is res long-reg)
(load-long-reg res (current-nfp-tn vop)
(* (tn-offset temp) vm:word-bytes)))))
(not-implemented)))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
......@@ -1025,25 +797,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 4
(sc-case bits
(signed-reg
(sc-case float
(single-reg
(inst stf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldsw bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(single-stack
(inst ldsw bits (current-nfp-tn vop)
(* (tn-offset float) vm:word-bytes)))
(descriptor-reg
(loadw bits float vm:single-float-value-slot
vm:other-pointer-type))))
(signed-stack
(sc-case float
(single-reg
(inst stf float (current-nfp-tn vop)
(* (tn-offset bits) vm:word-bytes))))))))
(not-implemented)))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg descriptor-reg)
......@@ -1056,18 +810,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldsw hi-bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(double-stack
(inst ldsw hi-bits (current-nfp-tn vop)
(* (tn-offset float) vm:word-bytes)))
(descriptor-reg
(loadw hi-bits float vm:double-float-value-slot
vm:other-pointer-type)))))
(not-implemented)))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
......@@ -1080,18 +823,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldsw lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-temp)) vm:word-bytes)))
(double-stack
(inst ldsw lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset float)) vm:word-bytes)))
(descriptor-reg
(loadw lo-bits float (1+ vm:double-float-value-slot)
vm:other-pointer-type)))))
(not-implemented)))
(define-vop (double-float-bits)
(:args (float :scs (double-reg descriptor-reg)
......@@ -1105,136 +837,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ldsw hi-bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes))
(inst ld lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-temp)) vm:word-bytes)))
(double-stack
(inst ldsw hi-bits (current-nfp-tn vop)
(* (tn-offset float) vm:word-bytes))
(inst ld lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset float)) vm:word-bytes)))
(descriptor-reg
(loadw hi-bits float vm:double-float-value-slot
vm:other-pointer-type)
(loadw lo-bits float (1+ vm:double-float-value-slot)
vm:other-pointer-type)))))
#+long-float
(define-vop (long-float-exp-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
(:results (exp-bits :scs (signed-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(:result-types signed-num)
(:translate long-float-exp-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg *backend*)
:offset (tn-offset float))))
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(inst ld exp-bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(long-stack
(inst ld exp-bits (current-nfp-tn vop)
(* (tn-offset float) vm:word-bytes)))
(descriptor-reg
(loadw exp-bits float vm:long-float-value-slot
vm:other-pointer-type)))))
#+long-float
(define-vop (long-float-high-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
(:results (high-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(:result-types unsigned-num)
(:translate long-float-high-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg *backend*)
:offset (tn-offset float))))
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(inst ld high-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-temp)) vm:word-bytes)))
(long-stack
(inst ld high-bits (current-nfp-tn vop)
(* (1+ (tn-offset float)) vm:word-bytes)))
(descriptor-reg
(loadw high-bits float (1+ vm:long-float-value-slot)
vm:other-pointer-type)))))
#+long-float
(define-vop (long-float-mid-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
(:results (mid-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(:result-types unsigned-num)
(:translate long-float-mid-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg *backend*)
:offset (+ 2 (tn-offset float)))))
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(inst ld mid-bits (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(long-stack
(inst ld mid-bits (current-nfp-tn vop)
(* (+ 2 (tn-offset float)) vm:word-bytes)))
(descriptor-reg
(loadw mid-bits float (+ 2 vm:long-float-value-slot)
vm:other-pointer-type)))))
#+long-float
(define-vop (long-float-low-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(:result-types unsigned-num)
(:translate long-float-low-bits)
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg *backend*)
:offset (+ 2 (tn-offset float)))))
(inst stdf float (current-nfp-tn vop)
(* (tn-offset stack-temp) vm:word-bytes)))
(inst ld lo-bits (current-nfp-tn vop)
(* (1+ (tn-offset stack-temp)) vm:word-bytes)))
(long-stack
(inst ld lo-bits (current-nfp-tn vop)
(* (+ 3 (tn-offset float)) vm:word-bytes)))
(descriptor-reg
(loadw lo-bits float (+ 3 vm:long-float-value-slot)
vm:other-pointer-type)))))
(not-implemented)))
;;;; Float mode hackery:
......@@ -1252,28 +855,7 @@
(:vop-var vop)
(:temporary (:sc unsigned-stack) temp)
(:generator 3
(let ((nfp (current-nfp-tn vop)))
(inst stfsr nfp (* word-bytes (tn-offset temp)))
(loadw res nfp (tn-offset temp))
(inst nop))))
#+nil
(define-vop (floating-point-modes)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate floating-point-modes)
(:policy :fast-safe)
(:vop-var vop)
(:temporary (:sc double-stack) temp)
(:generator 3
(let* ((nfp (current-nfp-tn vop))
(offset (* 4 (tn-offset temp))))
(inst stxfsr nfp offset)
;; The desired FP mode data is in the least significant 32
;; bits, which is stored at the next higher word in memory.
(loadw res nfp (+ offset 4))
;; Is this nop needed? (toy@rtp.ericsson.se)
(inst nop))))
(not-implemented)))
(define-vop (set-floating-point-modes)
(:args (new :scs (unsigned-reg) :target res))
......@@ -1285,61 +867,8 @@
(:temporary (:sc unsigned-stack) temp)
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop)))
(storew new nfp (tn-offset temp))
(inst ldfsr nfp (* word-bytes (tn-offset temp)))
(move res new))))
(not-implemented)))
#+nil
(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)
(:temporary (:sc double-stack) temp)
(:temporary (:sc unsigned-reg) my-fsr)
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
(offset (* word-bytes (tn-offset temp))))
(pseudo-atomic ()
;; Get the current FSR, so we can get the new %fcc's
(inst stxfsr nfp offset)
(inst ldx my-fsr nfp offset)
;; Carefully merge in the new mode bits with the rest of the
;; FSR. This is only needed if we care about preserving the
;; high 32 bits of the FSR, which contain the additional
;; %fcc's on the sparc V9. If not, we don't need this, but we
;; do need to make sure that the unused bits are written as
;; zeroes, according the the V9 architecture manual.
(inst signx new)
(inst srlx my-fsr 32)
(inst sllx my-fsr 32)
(inst or my-fsr new)
;; Save it back and load it into the fsr register
(inst stx my-fsr nfp offset)
(inst ldxfsr nfp offset)
(move res new)))))
#+nil
(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)
(:temporary (:sc double-stack) temp)
(:temporary (:sc unsigned-reg) my-fsr)
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
(offset (* word-bytes (tn-offset temp))))
(inst stx new nfp offset)
(inst ldxfsr nfp offset)
(move res new))))
;;;; Special functions.
......@@ -1360,22 +889,7 @@
(:save-p :compute-only)
(:generator 1
(note-this-location vop :internal-error)
(inst fsqrtd y x)))
#+long-float
(define-vop (fsqrt-long)
(:args (x :scs (long-reg)))
(:results (y :scs (long-reg)))
(:translate %sqrt)
(:policy :fast-safe)
(:arg-types long-float)
(:result-types long-float)
(:note _N"inline float arithmetic")
(:vop-var vop)
(:save-p :compute-only)
(:generator 1
(note-this-location vop :internal-error)
(inst fsqrtq y x)))
(inst vsqrt y x)))
;;;; Complex float VOPs
......@@ -1393,20 +907,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case r
(complex-single-reg
(let ((r-real (complex-single-reg-real-tn r)))
(unless (location= real r-real)
(inst fmovs r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
(unless (location= imag r-imag)
(inst fmovs r-imag imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) vm:word-bytes)))
(unless (location= real r)
(inst stf real nfp offset))
(inst stf imag nfp (+ offset vm:word-bytes)))))))
(not-implemented)))
(define-vop (make-complex-double-float)
(:translate complex)
......@@ -1421,49 +922,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case r
(complex-double-reg
(let ((r-real (complex-double-reg-real-tn r)))
(unless (location= real r-real)
(move-double-reg r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
(unless (location= imag r-imag)
(move-double-reg r-imag imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) vm:word-bytes)))
(unless (location= real r)
(inst stdf real nfp offset))
(inst stdf imag nfp (+ offset (* 2 vm:word-bytes))))))))
#+long-float
(define-vop (make-complex-long-float)
(:translate complex)
(:args (real :scs (long-reg) :target r
:load-if (not (location= real r)))
(imag :scs (long-reg) :to :save))
(:arg-types long-float long-float)
(:results (r :scs (complex-long-reg) :from (:argument 0)
:load-if (not (sc-is r complex-long-stack))))
(:result-types complex-long-float)
(:note _N"inline complex long-float creation")
(:policy :fast-safe)
(:vop-var vop)
(:generator 5
(sc-case r
(complex-long-reg
(let ((r-real (complex-long-reg-real-tn r)))
(unless (location= real r-real)
(move-long-reg r-real real)))
(let ((r-imag (complex-long-reg-imag-tn r)))
(unless (location= imag r-imag)
(move-long-reg r-imag imag))))
(complex-long-stack
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) vm:word-bytes)))
(unless (location= real r)
(store-long-reg real nfp offset))
(store-long-reg imag nfp (+ offset (* 4 vm:word-bytes))))))))
(not-implemented)))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg descriptor-reg) :target r
......@@ -1475,23 +934,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
(:real (complex-single-reg-real-tn x))
(:imag (complex-single-reg-imag-tn x)))))
(unless (location= value-tn r)
(inst fmovs r value-tn))))
(complex-single-stack
(inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
(tn-offset x))
vm:word-bytes)))
(descriptor-reg
(inst ldf r x (- (* (ecase slot
(:real vm::complex-single-float-real-slot)
(:imag vm::complex-single-float-imag-slot))
vm:word-bytes)
vm:other-pointer-type))))))
(not-implemented)))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
......@@ -1513,23 +956,7 @@
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
(:real (complex-double-reg-real-tn x))
(:imag (complex-double-reg-imag-tn x)))))
(unless (location= value-tn r)
(move-double-reg r value-tn))))
(complex-double-stack
(inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
(tn-offset x))
vm:word-bytes)))
(descriptor-reg
(inst lddf r x (- (* (ecase slot
(:real vm::complex-double-float-real-slot)
(:imag vm::complex-double-float-imag-slot))
vm:word-bytes)
vm:other-pointer-type))))))
(not-implemented)))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
......@@ -1541,41 +968,6 @@
(:note _N"complex double float imagpart")
(:variant :imag))
#+long-float
(define-vop (complex-long-float-value)
(:args (x :scs (complex-long-reg) :target r
:load-if (not (sc-is x complex-long-stack))))
(:arg-types complex-long-float)
(:results (r :scs (long-reg)))
(:result-types long-float)
(:variant-vars slot)
(:policy :fast-safe)
(:vop-var vop)
(:generator 4
(sc-case x
(complex-long-reg
(let ((value-tn (ecase slot
(:real (complex-long-reg-real-tn x))
(:imag (complex-long-reg-imag-tn x)))))
(unless (location= value-tn r)
(move-long-reg r value-tn))))
(complex-long-stack
(load-long-reg r (current-nfp-tn vop)
(* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
vm:word-bytes))))))
#+long-float
(define-vop (realpart/complex-long-float complex-long-float-value)
(:translate realpart)
(:note _N"complex long float realpart")
(:variant :real))
#+long-float
(define-vop (imagpart/complex-long-float complex-long-float-value)
(:translate imagpart)
(:note _N"complex long float imagpart")
(:variant :imag))
;;;; Complex float arithmetic
......@@ -1616,7 +1008,7 @@
(ri (,imag-tn r)))
(,@fneg rr xr)
(,@fneg ri xi)))))))
(frob single (inst fnegs) 4)
(frob single (inst vneg) 4)
(frob double (negate-double-reg) 4))
;; Add and subtract for two complex arguments
......@@ -1644,10 +1036,10 @@
(ri (,imag-part r)))
(inst ,inst rr xr yr)
(inst ,inst ri xi yi)))))))
(frob + fadds single 4)
(frob + faddd double 4)
(frob - fsubs single 4)
(frob - fsubd double 4))
(frob + vadd single 4)
(frob + vadd double 4)
(frob - vsub single 4)
(frob - vsub double 4))
;; Add and subtract a complex and a float
......@@ -1698,10 +1090,10 @@
(inst ,fop rr xr y)
(inst ,fop ri xi zero)))))))
(frob single + fadds 2)
(frob single - fsubs 2)
(frob double + faddd 4)
(frob double - fsubd 4))
(frob single + vadd 2)
(frob single - vsub 2)
(frob double + vadd 4)
(frob double - vsub 4))
;; Add a float and a complex
(macrolet
......@@ -1744,8 +1136,8 @@
vm:other-pointer-type))
(inst ,fop rr xr y)
(inst ,fop ri xi zero)))))))
(frob single fadds 1)
(frob double faddd 2))
(frob single vadd 1)
(frob double vadd 2))
;; Subtract a complex from a float.
;;
......@@ -1839,8 +1231,8 @@
(inst ,fmul ri xi yr)
(inst ,fadd ri ri p1)))))))))
(frob single fmuls fadds fsubs 6)
(frob double fmuld faddd fsubd 6))
(frob single fmuls vadd fsubs 6)
(frob double fmuld vadd fsubd 6))
;; Multiply a complex by a float. The case of float * complex is
;; handled by a deftransform to convert it to the complex*float case.
......@@ -2114,7 +1506,7 @@
(,@fneg ri ri)))))))
(frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
(frob single fcmps fadds fmuls fdivs (inst vneg) (inst vabs) 10)
(frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
;; Conjugate of a complex number
......@@ -2143,7 +1535,7 @@
(unless (location= rr xr)
(,@fmov rr xr))))))))
(frob single (inst fnegs) (inst fmovs) 4)
(frob single (inst vneg) (inst vmov) 4)
(frob double (negate-double-reg) (move-double-reg) 4))
;; Compare a float with a complex or a complex with a float
......@@ -2265,57 +1657,7 @@
(:guard (not (backend-featurep :sparc-v9)))
(:generator 6
(note-this-location vop :internal-error)
(let ((xr (,real-part x))
(xi (,imag-part x))
(yr (,real-part y))
(yi (,imag-part y)))
(inst ,fcmp xr yr)
(inst nop)
(inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
(inst ,fcmp xi yi)
(inst nop)
(inst fb (if not-p :ne :eq) target #+sparc-v9 :fcc0 #+sparc-v9 :pn)
(inst nop)))))))
(frob single fcmps)
(frob double fcmpd))
;; Compare a complex with a complex, for V9
(macrolet
((frob (float-type fcmp)
(let ((vop-name
(symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
(complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
(c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
(real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
(imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
`(define-vop (,vop-name)
(:args (x :scs (,complex-reg))
(y :scs (,complex-reg)))
(:arg-types ,c-type ,c-type)
(:translate =)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:note _N"inline complex float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:sc descriptor-reg) true)
(:guard (backend-featurep :sparc-v9))
(:generator 6
(note-this-location vop :internal-error)
(let ((xr (,real-part x))
(xi (,imag-part x))
(yr (,real-part y))
(yi (,imag-part y)))
;; Assume comparison is true
(load-symbol true t)
(inst ,fcmp xr yr)
(inst cmove (if not-p :eq :ne) true null-tn :fcc0)
(inst ,fcmp xi yi)
(inst cmove (if not-p :eq :ne) true null-tn :fcc0)
(inst cmp true null-tn)
(inst b (if not-p :eq :ne) target :pt)
(inst nop)))))))
(not-implemented))))))
(frob single fcmps)
(frob double fcmpd))
......@@ -2337,240 +1679,6 @@
) ; end progn complex-fp-vops
#+sparc-v9
(progn
;; Vops to take advantage of the conditional move instruction
;; available on the Sparc V9
(defknown (%%max %%min) ((or (unsigned-byte #.vm:word-bits)
(signed-byte #.vm:word-bits)
single-float double-float)
(or (unsigned-byte #.vm:word-bits)
(signed-byte #.vm:word-bits)
single-float double-float))
(or (unsigned-byte #.vm:word-bits)
(signed-byte #.vm:word-bits)
single-float double-float)
(movable foldable flushable))
;; We need these definitions for byte-compiled code
(defun %%min (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
single-float double-float) x y))
(if (<= x y)
x y))
(defun %%max (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
single-float double-float) x y))
(if (>= x y)
x y))
(macrolet
((frob (name sc-type type compare cmov cost cc max min note)
(let ((vop-name (symbolicate name "-" type "=>" type))
(trans-name (symbolicate "%%" name)))
`(define-vop (,vop-name)
(:args (x :scs (,sc-type))
(y :scs (,sc-type)))
(:results (r :scs (,sc-type)))
(:arg-types ,type ,type)
(:result-types ,type)
(:policy :fast-safe)
(:note ,note)
(:translate ,trans-name)
(:guard (backend-featurep :sparc-v9))
(:generator ,cost
(inst ,compare x y)
(cond ((location= r x)
;; If x < y, need to move y to r, otherwise r already has
;; the max.
(inst ,cmov ,min r y ,cc))
((location= r y)
;; If x > y, need to move x to r, otherwise r already has
;; the max.
(inst ,cmov ,max r x ,cc))
(t
;; It doesn't matter what R is, just copy the min to R.
(inst ,cmov ,max r x ,cc)
(inst ,cmov ,min r y ,cc))))))))
(frob max single-reg single-float fcmps cfmovs 3
:fcc0 :ge :l _N"inline float max")
(frob max double-reg double-float fcmpd cfmovd 3
:fcc0 :ge :l _N"inline float max")
(frob min single-reg single-float fcmps cfmovs 3
:fcc0 :l :ge _N"inline float min")
(frob min double-reg double-float fcmpd cfmovd 3
:fcc0 :l :ge _N"inline float min")
;; Strictly speaking these aren't float ops, but it's convenient to
;; do them here.
;;
;; The cost is here is the worst case number of instructions. For
;; 32-bit integer operands, we add 2 more to account for the
;; untagging of fixnums, if necessary.
(frob max signed-reg signed-num cmp cmove 5
:icc :ge :lt _N"inline (signed-byte 32) max")
(frob max unsigned-reg unsigned-num cmp cmove 5
:icc :ge :lt _N"inline (unsigned-byte 32) max")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob max any-reg tagged-num cmp cmove 3
:icc :ge :lt _N"inline fixnum max")
(frob min signed-reg signed-num cmp cmove 5
:icc :lt :ge _N"inline (signed-byte 32) min")
(frob min unsigned-reg unsigned-num cmp cmove 5
:icc :lt :ge _N"inline (unsigned-byte 32) min")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob min any-reg tagged-num cmp cmove 3
:icc :lt :ge _N"inline fixnum min"))
#+nil
(define-vop (max-boxed-double-float=>boxed-double-float)
(:args (x :scs (descriptor-reg))
(y :scs (descriptor-reg)))
(:results (r :scs (descriptor-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(:policy :fast-safe)
(:note _N"inline float max/min")
(:translate %max-double-float)
(:temporary (:scs (double-reg)) xval)
(:temporary (:scs (double-reg)) yval)
(:guard (backend-featurep :sparc-v9))
(:vop-var vop)
(:generator 3
(let ((offset (- (* vm:double-float-value-slot vm:word-bytes)
vm:other-pointer-type)))
(inst lddf xval x offset)
(inst lddf yval y offset)
(inst fcmpd xval yval)
(cond ((location= r x)
;; If x < y, need to move y to r, otherwise r already has
;; the max.
(inst cmove :l r y :fcc0))
((location= r y)
;; If x > y, need to move x to r, otherwise r already has
;; the max.
(inst cmove :ge r x :fcc0))
(t
;; It doesn't matter what R is, just copy the min to R.
(inst cmove :ge r x :fcc0)
(inst cmove :l r y :fcc0))))))
)
(in-package "C")
#+sparc-v9
(progn
;;; The sparc-v9 architecture has conditional move instructions that
;;; can be used. This should be faster than using the obvious if
;;; expression since we don't have to do branches.
(def-source-transform min (&rest args)
(case (length args)
((0 2) (values nil t))
(1 `(values (the real ,(first args))))
(t (c::associate-arguments 'min (first args) (rest args)))))
(def-source-transform max (&rest args)
(case (length args)
((0 2) (values nil t))
(1 `(values (the real ,(first args))))
(t (c::associate-arguments 'max (first args) (rest args)))))
;; Derive the types of max and min
(defoptimizer (max derive-type) ((x y))
;; It's Y < X instead of X < Y because that's how the
;; source-transform, the deftransform and the max function do the
;; comparisons. This is important if the types of X and Y are
;; different types, like integer vs double-float because CMUCL
;; returns the actual arg, instead of applying float-contagion to
;; the result.
(multiple-value-bind (definitely-< definitely->=)
(ir1-transform-<-helper y x)
(cond (definitely-<
(continuation-type x))
(definitely->=
(continuation-type y))
(t
(make-canonical-union-type (list (continuation-type x)
(continuation-type y)))))))
(defoptimizer (min derive-type) ((x y))
(multiple-value-bind (definitely-> definitely-<=)
(ir1-transform-<-helper y x)
(cond (definitely-<=
(continuation-type x))
(definitely->
(continuation-type y))
(t
(make-canonical-union-type (list (continuation-type x)
(continuation-type y)))))))
(deftransform max ((x y) (number number) * :when :both)
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(signed (specifier-type '(signed-byte #.vm:word-bits)))
(unsigned (specifier-type '(unsigned-byte #.vm:word-bits)))
(d-float (specifier-type 'double-float))
(s-float (specifier-type 'single-float)))
;; Use %%max if both args are good types of the same type. As a
;; last resort, use the obvious comparison to select the desired
;; element.
(cond ((and (csubtypep x-type signed)
(csubtypep y-type signed))
`(sparc::%%max x y))
((and (csubtypep x-type unsigned)
(csubtypep y-type unsigned))
`(sparc::%%max x y))
((and (csubtypep x-type d-float)
(csubtypep y-type d-float))
`(sparc::%%max x y))
((and (csubtypep x-type s-float)
(csubtypep y-type s-float))
`(sparc::%%max x y))
(t
(let ((arg1 (gensym))
(arg2 (gensym)))
`(let ((,arg1 x)
(,arg2 y))
(if (> ,arg1 ,arg2)
,arg1 ,arg2)))))))
(deftransform min ((x y) (real real) * :when :both)
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(signed (specifier-type '(signed-byte #.vm:word-bits)))
(unsigned (specifier-type '(unsigned-byte #.vm:word-bits)))
(d-float (specifier-type 'double-float))
(s-float (specifier-type 'single-float)))
(cond ((and (csubtypep x-type signed)
(csubtypep y-type signed))
`(sparc::%%min x y))
((and (csubtypep x-type unsigned)
(csubtypep y-type unsigned))
`(sparc::%%min x y))
((and (csubtypep x-type d-float)
(csubtypep y-type d-float))
`(sparc::%%min x y))
((and (csubtypep x-type s-float)
(csubtypep y-type s-float))
`(sparc::%%min x y))
(t
(let ((arg1 (gensym))
(arg2 (gensym)))
`(let ((,arg1 x)
(,arg2 y))
(if (< ,arg1 ,arg2)
,arg1 ,arg2)))))))
)
(in-package "SPARC")
;;; Support for double-double floats
......@@ -2592,18 +1700,18 @@
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset x) vm:word-bytes)))
(let ((hi-tn (double-double-reg-hi-tn y)))
(inst lddf hi-tn nfp offset))
(inst vldr hi-tn (make-ea nfp :offset offset)))
(let ((lo-tn (double-double-reg-lo-tn y)))
(inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
(inst vldr lo-tn (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))))
(define-move-function (store-double-double 4) (vop x y)
((double-double-reg) (double-double-stack))
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset y) vm:word-bytes)))
(let ((hi-tn (double-double-reg-hi-tn x)))
(inst stdf hi-tn nfp offset))
(inst vstr hi-tn (make-ea nfp :offset offset)))
(let ((lo-tn (double-double-reg-lo-tn x)))
(inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
(inst vstr lo-tn (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))))
;;; Double-double float register to register moves
......@@ -2638,13 +1746,15 @@
(with-fixed-allocation (y ndescr vm::double-double-float-type
vm::double-double-float-size))
(let ((hi-tn (double-double-reg-hi-tn x)))
(inst stdf hi-tn y (- (* vm::double-double-float-hi-slot
(inst vstr hi-tn
(make-ea y :offset (- (* vm::double-double-float-hi-slot
vm:word-bytes)
vm:other-pointer-type)))
vm:other-pointer-type))))
(let ((lo-tn (double-double-reg-lo-tn x)))
(inst stdf lo-tn y (- (* vm::double-double-float-lo-slot
(inst vstr lo-tn
(make-ea y :offset (- (* vm::double-double-float-lo-slot
vm:word-bytes)
vm:other-pointer-type)))))
vm:other-pointer-type))))))
;;;
(define-move-vop move-from-double-double :move
(double-double-reg) (descriptor-reg))
......@@ -2657,11 +1767,13 @@
(:note _N"pointer to double-double float coercion")
(:generator 2
(let ((hi-tn (double-double-reg-hi-tn y)))
(inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes)
other-pointer-type)))
(inst vldr hi-tn
(make-ea x :offset (- (* double-double-float-hi-slot word-bytes)
other-pointer-type))))
(let ((lo-tn (double-double-reg-lo-tn y)))
(inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes)
other-pointer-type)))))
(inst vldr lo-tn
(make-ea x :offset (- (* double-double-float-lo-slot word-bytes)
other-pointer-type))))))
(define-move-vop move-to-double-double :move
(descriptor-reg) (double-double-reg))
......@@ -2686,9 +1798,9 @@
(double-double-stack
(let ((offset (* (tn-offset y) word-bytes)))
(let ((hi-tn (double-double-reg-hi-tn x)))
(inst stdf hi-tn nfp offset))
(inst vstr hi-tn (make-ea nfp :offset offset)))
(let ((lo-tn (double-double-reg-lo-tn x)))
(inst stdf lo-tn nfp (+ offset (* 2 word-bytes)))))))))
(inst vstr lo-tn (make-ea nfp :offset (+ offset (* 2 word-bytes))))))))))
(define-move-vop move-double-double-float-argument :move-argument
(double-double-reg descriptor-reg) (double-double-reg))
......@@ -2719,8 +1831,8 @@
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset res) vm:word-bytes)))
(unless (location= hi res)
(inst stdf hi nfp offset))
(inst stdf lo nfp (+ offset (* 2 vm:word-bytes))))))))
(inst vstr hi (make-ea nfp :offset offset)))
(inst vstr lo (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))))))
(define-vop (double-double-float-value)
(:args (x :scs (double-double-reg descriptor-reg) :target r
......@@ -2740,15 +1852,17 @@
(unless (location= value-tn r)
(move-double-reg r value-tn))))
(double-double-stack
(inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2))
(inst vldr r
(make-ea (current-nfp-tn vop) :offset (* (+ (ecase slot (:hi 0) (:lo 2))
(tn-offset x))
vm:word-bytes)))
vm:word-bytes))))
(descriptor-reg
(inst lddf r x (- (* vm:word-bytes
(inst vldr r
(make-ea x :offste (- (* vm:word-bytes
(ecase slot
(:hi vm:double-double-float-hi-slot)
(:lo vm:double-double-float-lo-slot)))
vm:other-pointer-type))))))
vm:other-pointer-type)))))))
(define-vop (hi/double-double-value double-double-float-value)
(:translate kernel::double-double-hi)
......@@ -2792,13 +1906,13 @@
(let ((nfp (current-nfp-tn vop))
(offset (* (tn-offset r) vm:word-bytes)))
(let ((r-real (double-double-reg-hi-tn real)))
(inst stdf r-real nfp offset))
(inst vstr r-real (make-ea nfp :offset offset)))
(let ((r-real (double-double-reg-lo-tn real)))
(inst stdf r-real nfp (+ offset (* 2 vm:word-bytes))))
(inst vstr r-real (make-ea nfp :offset (+ offset (* 2 vm:word-bytes)))))
(let ((r-imag (double-double-reg-hi-tn imag)))
(inst stdf r-imag nfp (+ offset (* 4 vm:word-bytes))))
(inst vstr r-imag (make-ea nfp :offset (+ offset (* 4 vm:word-bytes)))))
(let ((r-imag (double-double-reg-lo-tn imag)))
(inst stdf r-imag nfp (+ offset (* 6 vm:word-bytes)))))))))
(inst vstr r-imag (make-ea nfp :offset (+ offset (* 6 vm:word-bytes))))))))))
(define-vop (complex-double-double-float-value)
(:args (x :scs (complex-double-double-reg descriptor-reg)
......@@ -2826,26 +1940,34 @@
(move-double-reg r-lo value-tn))))
(complex-double-double-stack
(let ((r-hi (double-double-reg-hi-tn r)))
(inst lddf r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4))
(inst vldr r-hi
(make-ea (current-nfp-tn vop)
:offset (* (+ (ecase slot (:real 0) (:imag 4))
(tn-offset x))
vm:word-bytes)))
vm:word-bytes))))
(let ((r-lo (double-double-reg-lo-tn r)))
(inst lddf r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6))
(inst vldr r-lo
(make-ea (current-nfp-tn vop)
:offset (* (+ (ecase slot (:real 2) (:imag 6))
(tn-offset x))
vm:word-bytes))))
vm:word-bytes)))))
(descriptor-reg
(let ((r-hi (double-double-reg-hi-tn r)))
(inst lddf r-hi x (- (* (ecase slot
(inst vldr r-hi
(make-ea x
:offset (- (* (ecase slot
(:real vm::complex-double-double-float-real-hi-slot)
(:imag vm::complex-double-double-float-imag-hi-slot))
vm:word-bytes)
vm:other-pointer-type))
vm:other-pointer-type))))
(let ((r-lo (double-double-reg-lo-tn r)))
(inst lddf r-lo x (- (* (ecase slot
(inst vldr r-lo
(make-ea x
:offset (- (* (ecase slot
(:real vm::complex-double-double-float-real-lo-slot)
(:imag vm::complex-double-double-float-imag-lo-slot))
vm:word-bytes)
vm:other-pointer-type))))))))
vm:other-pointer-type)))))))))
(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
(:translate realpart)
......
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please to comment