Declare types of END and TEST in N{LIST,VECTOR}-SUBSTITUTE-IF[-NOT]*

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

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index bde111a..0d20e7f 100644 (file)
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -1732,10 +1732,10 @@
                       (inst mov y stack-temp)))
                    ,@(unless round-p
                       '((inst fldcw scw)))))))))
-  (frob %unary-truncate single-reg single-float nil)
-  (frob %unary-truncate double-reg double-float nil)
+  (frob %unary-truncate/single-float single-reg single-float nil)
+  (frob %unary-truncate/double-float double-reg double-float nil)
   #!+long-float
-  (frob %unary-truncate long-reg long-float nil)
+  (frob %unary-truncate/long-float long-reg long-float nil)
   (frob %unary-round single-reg single-float t)
   (frob %unary-round double-reg double-float t)
   #!+long-float
@@ -1779,10 +1779,10 @@
                 (inst add esp-tn 4)
                 ,@(unless round-p
                    '((inst fldcw scw)))))))
-  (frob %unary-truncate single-reg single-float nil)
-  (frob %unary-truncate double-reg double-float nil)
+  (frob %unary-truncate/single-float single-reg single-float nil)
+  (frob %unary-truncate/double-float double-reg double-float nil)
   #!+long-float
-  (frob %unary-truncate long-reg long-float nil)
+  (frob %unary-truncate/long-float long-reg long-float nil)
   (frob %unary-round single-reg single-float t)
   (frob %unary-round double-reg double-float t)
   #!+long-float
@@ -1821,6 +1821,22 @@
            (with-empty-tn@fp-top(res)
               (inst fld bits))))))))
 
+(define-vop (make-single-float-c)
+  (:results (res :scs (single-reg single-stack)))
+  (:arg-types (:constant (signed-byte 32)))
+  (:result-types single-float)
+  (:info bits)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (sc-case res
+      (single-stack
+       (inst mov res bits))
+      (single-reg
+       (with-empty-tn@fp-top (res)
+         (inst fld (register-inline-constant :dword bits)))))))
+
 (define-vop (make-double-float)
   (:args (hi-bits :scs (signed-reg))
          (lo-bits :scs (unsigned-reg)))
@@ -1839,6 +1855,19 @@
         (inst fldd (make-ea :dword :base ebp-tn
                             :disp (frame-byte-offset (1+ offset))))))))
 
+(define-vop (make-double-float-c)
+  (:results (res :scs (double-reg)))
+  (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32)))
+  (:result-types double-float)
+  (:info hi lo)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 1
+    (with-empty-tn@fp-top(res)
+      (inst fldd (register-inline-constant
+                  :double-float-bits (logior (ash hi 32) lo))))))
+
 #!+long-float
 (define-vop (make-long-float)
   (:args (exp-bits :scs (signed-reg))
@@ -2160,6 +2189,10 @@
                 (:args (x :scs (double-reg) :target fr0))
                 (:temporary (:sc double-reg :offset fr0-offset
                                  :from :argument :to :result) fr0)
+                ;; FIXME: make that an arbitrary location and
+                ;; FXCH only when range reduction needed
+                (:temporary (:sc double-reg :offset fr1-offset
+                                 :from :argument :to :result) fr1)
                 (:temporary (:sc unsigned-reg :offset eax-offset
                              :from :argument :to :result) eax)
                 (:results (y :scs (double-reg)))
@@ -2171,21 +2204,34 @@
                 (:save-p :compute-only)
                 (:ignore eax)
                 (:generator 5
-                  (note-this-location vop :internal-error)
-                  (unless (zerop (tn-offset x))
-                          (inst fxch x)          ; x to top of stack
-                          (unless (location= x y)
-                                  (inst fst x))) ; maybe save it
-                  (inst ,op)
-                  (inst fnstsw)                  ; status word to ax
-                  (inst and ah-tn #x04)          ; C2
-                  (inst jmp :z DONE)
-                  ;; Else x was out of range so reduce it; ST0 is unchanged.
-                  (inst fstp fr0)               ; Load 0.0
-                  (inst fldz)
-                  DONE
-                  (unless (zerop (tn-offset y))
-                          (inst fstd y))))))
+                  (let ((DONE (gen-label))
+                        (REDUCE (gen-label))
+                        (REDUCE-LOOP (gen-label)))
+                    (note-this-location vop :internal-error)
+                    (unless (zerop (tn-offset x))
+                      (inst fxch x)          ; x to top of stack
+                      (unless (location= x y)
+                        (inst fst x))) ; maybe save it
+                    (inst ,op)
+                    (inst fnstsw)                  ; status word to ax
+                    (inst and ah-tn #x04)          ; C2
+                    (inst jmp :nz REDUCE)
+                    (emit-label DONE)
+                    (unless (zerop (tn-offset y))
+                      (inst fstd y))
+                    (assemble (*elsewhere*)
+                      (emit-label REDUCE)
+                      ;; Else x was out of range so reduce it; ST0 is unchanged.
+                      (with-empty-tn@fp-top (fr1)
+                        (inst fldpi)
+                        (inst fadd fr0))
+                      (emit-label REDUCE-LOOP)
+                      (inst fprem1)
+                      (inst fnstsw)
+                      (inst and ah-tn #x04)
+                      (inst jmp :nz REDUCE-LOOP)
+                      (inst ,op)
+                      (inst jmp DONE)))))))
           (frob fsin  %sin fsin)
           (frob fcos  %cos fcos))
 
@@ -2221,11 +2267,24 @@
                                    :sc (sc-or-lose 'double-reg)
                                    :offset (- (tn-offset x) 2)))))
     (inst fptan)
-    (inst fnstsw)                        ; status word to ax
-    (inst and ah-tn #x04)                ; C2
-    (inst jmp :z DONE)
-    ;; Else x was out of range so load 0.0
-    (inst fxch fr1)
+    (let ((REDUCE (gen-label))
+          (REDUCE-LOOP (gen-label)))
+      (inst fnstsw)                        ; status word to ax
+      (inst and ah-tn #x04)                ; C2
+      (inst jmp :nz REDUCE)
+      (assemble (*elsewhere*)
+        (emit-label REDUCE)
+        ;; Else x was out of range so reduce it; ST0 is unchanged.
+        (with-empty-tn@fp-top (fr1)
+          (inst fldpi)
+          (inst fadd fr0))
+        (emit-label REDUCE-LOOP)
+        (inst fprem1)
+        (inst fnstsw)
+        (inst and ah-tn #x04)
+        (inst jmp :nz REDUCE-LOOP)
+        (inst fptan)
+        (inst jmp DONE)))
     DONE
     ;; Result is in fr1
     (case (tn-offset y)