0.9.1.32:

[sbcl.git] / src / compiler / ppc / float.lisp

diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp
index 21750f9..d06334b 100644 (file)
--- a/src/compiler/ppc/float.lisp
+++ b/src/compiler/ppc/float.lisp
@@ -478,6 +478,36 @@
   (frob %single-float/signed %single-float fsubs single-reg single-float)
   (frob %double-float/signed %double-float fsub double-reg double-float))
 
+(macrolet ((frob (name translate inst to-sc to-type)
+            `(define-vop (,name)
+               (:args (x :scs (unsigned-reg)))
+               (:temporary (:scs (double-stack)) temp)
+              (:temporary (:scs (double-reg)) fmagic)
+              (:temporary (:scs (signed-reg)) rtemp)
+               (:results (y :scs (,to-sc)))
+               (:arg-types unsigned-num)
+               (:result-types ,to-type)
+               (:policy :fast-safe)
+               (:note "inline float coercion")
+               (:translate ,translate)
+               (:vop-var vop)
+               (:save-p :compute-only)
+               (:generator 5
+                 (let* ((stack-offset (* (tn-offset temp) n-word-bytes))
+                         (nfp-tn (current-nfp-tn vop))
+                         (temp-offset-high (* stack-offset n-word-bytes))
+                         (temp-offset-low (* (1+ stack-offset) n-word-bytes)))
+                    (inst lis rtemp #x4330)   ; High word of magic constant
+                    (inst stw rtemp nfp-tn temp-offset-high)
+                    (inst stw zero-tn nfp-tn temp-offset-low)
+                    (inst lfd fmagic nfp-tn temp-offset-high)
+                    (inst stw x nfp-tn temp-offset-low)
+                    (inst lfd y nfp-tn temp-offset-high)
+                   (note-this-location vop :internal-error)
+                   (inst ,inst y y fmagic))))))
+  (frob %single-float/unsigned %single-float fsubs single-reg single-float)
+  (frob %double-float/unsigned %double-float fsub double-reg double-float))
+
 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (,from-sc)))