X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=9e6033c1e9680b200480280b45707b8ecd7df917;hb=0302ff8f5d8557453b4b3c2032c224d95ddd4813;hp=f2880dedbc95847c575b691c87fe949169e6fd61;hpb=cf42b486323a8c50ee1d937ba3eee33777575905;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index f2880de..9e6033c 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -18,12 +18,17 @@
 (defknown %single-float (real) single-float (movable foldable flushable))
 (defknown %double-float (real) double-float (movable foldable flushable))
 
-(deftransform float ((n &optional f) (* &optional single-float) *)
+(deftransform float ((n f) (* single-float) *)
   '(%single-float n))
 
 (deftransform float ((n f) (* double-float) *)
   '(%double-float n))
 
+(deftransform float ((n) *)
+  '(if (floatp n)
+       n
+       (%single-float n)))
+
 (deftransform %single-float ((n) (single-float) *)
   'n)
 
@@ -45,41 +50,52 @@
 ;;; through the code this way. It would be nice to move this into the
 ;;; same file as the other RANDOM definitions.
 (deftransform random ((num &optional state)
-		      ((integer 1 #.(expt 2 32)) &optional *))
+		      ((integer 1 #.(expt 2 sb!vm::n-word-bits)) &optional *))
   ;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way
   ;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
   ;; to let me scan for places that I made this mistake and didn't
   ;; catch myself.
   "use inline (UNSIGNED-BYTE 32) operations"
-  (let ((num-high (numeric-type-high (continuation-type num))))
-    (when (null num-high)
-      (give-up-ir1-transform))
-    (cond ((constant-continuation-p num)
-	   ;; Check the worst case sum absolute error for the random number
-	   ;; expectations.
-	   (let ((rem (rem (expt 2 32) num-high)))
-	     (unless (< (/ (* 2 rem (- num-high rem)) num-high (expt 2 32))
-			(expt 2 (- sb!kernel::random-integer-extra-bits)))
-	       (give-up-ir1-transform
-		"The random number expectations are inaccurate."))
-	     (if (= num-high (expt 2 32))
-		 '(random-chunk (or state *random-state*))
-		 #!-x86 '(rem (random-chunk (or state *random-state*)) num)
-		 #!+x86
-		 ;; Use multiplication, which is faster.
-		 '(values (sb!bignum::%multiply
-			   (random-chunk (or state *random-state*))
-			   num)))))
-	  ((> num-high random-fixnum-max)
-	   (give-up-ir1-transform
-	    "The range is too large to ensure an accurate result."))
-	  #!+x86
-	  ((< num-high (expt 2 32))
-	   '(values (sb!bignum::%multiply (random-chunk (or state
-							    *random-state*))
-		     num)))
-	  (t
-	   '(rem (random-chunk (or state *random-state*)) num)))))
+  (let ((type (lvar-type num))
+	(limit (expt 2 sb!vm::n-word-bits))
+	(random-chunk (ecase sb!vm::n-word-bits
+			(32 'random-chunk)
+			(64 'sb!kernel::big-random-chunk))))
+    (if (numeric-type-p type)
+        (let ((num-high (numeric-type-high (lvar-type num))))
+          (aver num-high)
+          (cond ((constant-lvar-p num)
+                 ;; Check the worst case sum absolute error for the
+                 ;; random number expectations.
+                 (let ((rem (rem limit num-high)))
+                   (unless (< (/ (* 2 rem (- num-high rem))
+                                 num-high limit)
+                              (expt 2 (- sb!kernel::random-integer-extra-bits)))
+                     (give-up-ir1-transform
+                      "The random number expectations are inaccurate."))
+                   (if (= num-high limit)
+                       `(,random-chunk (or state *random-state*))
+                       #!-(or x86 x86-64)
+		       `(rem (,random-chunk (or state *random-state*)) num)
+                       #!+(or x86 x86-64)
+                       ;; Use multiplication, which is faster.
+                       `(values (sb!bignum::%multiply
+                                 (,random-chunk (or state *random-state*))
+                                 num)))))
+                ((> num-high random-fixnum-max)
+                 (give-up-ir1-transform
+                  "The range is too large to ensure an accurate result."))
+		#!+(or x86 x86-64)
+                ((< num-high limit)
+                 `(values (sb!bignum::%multiply
+                           (,random-chunk (or state *random-state*))
+                           num)))
+                (t
+                 `(rem (,random-chunk (or state *random-state*)) num))))
+        ;; KLUDGE: a relatively conservative treatment, but better
+        ;; than a bug (reported by PFD sbcl-devel towards the end of
+        ;; 2004-11.
+        '(rem (random-chunk (or state *random-state*)) num))))
 
 ;;;; float accessors
 
@@ -132,10 +148,10 @@
   (values double-float-significand double-float-int-exponent (integer -1 1))
   (movable foldable flushable))
 
-(defknown scale-single-float (single-float fixnum) single-float
+(defknown scale-single-float (single-float integer) single-float
   (movable foldable flushable))
 
-(defknown scale-double-float (double-float fixnum) double-float
+(defknown scale-double-float (double-float integer) double-float
   (movable foldable flushable))
 
 (deftransform decode-float ((x) (single-float) *)
@@ -152,14 +168,14 @@
 
 (deftransform scale-float ((f ex) (single-float *) *)
   (if (and #!+x86 t #!-x86 nil
-	   (csubtypep (continuation-type ex)
+	   (csubtypep (lvar-type ex)
 		      (specifier-type '(signed-byte 32))))
       '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
       '(scale-single-float f ex)))
 
 (deftransform scale-float ((f ex) (double-float *) *)
   (if (and #!+x86 t #!-x86 nil
-	   (csubtypep (continuation-type ex)
+	   (csubtypep (lvar-type ex)
 		      (specifier-type '(signed-byte 32))))
       '(%scalbn f ex)
       '(scale-double-float f ex)))
@@ -222,10 +238,18 @@
 	    (ex-hi (numeric-type-high ex))
 	    (new-lo nil)
 	    (new-hi nil))
-	(when (and f-hi ex-hi)
-	  (setf new-hi (scale-bound f-hi ex-hi)))
-	(when (and f-lo ex-lo)
-	  (setf new-lo (scale-bound f-lo ex-lo)))
+	(when f-hi
+	  (if (< (float-sign (type-bound-number f-hi)) 0.0)
+	      (when ex-lo
+		(setf new-hi (scale-bound f-hi ex-lo)))
+	      (when ex-hi
+		(setf new-hi (scale-bound f-hi ex-hi)))))
+	(when f-lo
+	  (if (< (float-sign (type-bound-number f-lo)) 0.0)
+	      (when ex-hi
+		(setf new-lo (scale-bound f-lo ex-hi)))
+	      (when ex-lo
+		(setf new-lo (scale-bound f-lo ex-lo)))))
 	(make-numeric-type :class (numeric-type-class f)
 			   :format (numeric-type-format f)
 			   :complexp :real
@@ -269,10 +293,10 @@
 ;;; rational arithmetic, or different float types, and fix it up. If
 ;;; we don't, he won't even get so much as an efficiency note.
 (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
-  `(,(continuation-fun-name (basic-combination-fun node))
+  `(,(lvar-fun-name (basic-combination-fun node))
     (float x y) y))
 (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
-  `(,(continuation-fun-name (basic-combination-fun node))
+  `(,(lvar-fun-name (basic-combination-fun node))
     x (float y x)))
 
 (dolist (x '(+ * / -))
@@ -293,10 +317,10 @@
 (macrolet ((frob (op)
 	     `(deftransform ,op ((x y) (float rational) *)
 		"open-code FLOAT to RATIONAL comparison"
-		(unless (constant-continuation-p y)
+		(unless (constant-lvar-p y)
 		  (give-up-ir1-transform
 		   "The RATIONAL value isn't known at compile time."))
-		(let ((val (continuation-value y)))
+		(let ((val (lvar-value y)))
 		  (unless (eql (rational (float val)) val)
 		    (give-up-ir1-transform
 		     "~S doesn't have a precise float representation."
@@ -321,17 +345,17 @@
       (setf (fun-info-derive-type (fun-info-or-lose name))
 	    (lambda (call)
 	      (declare (type combination call))
-	      (when (csubtypep (continuation-type
+	      (when (csubtypep (lvar-type
 				(first (combination-args call)))
 			       type)
 		(specifier-type 'float)))))))
 
 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (log derive-type) ((x &optional y))
-  (when (and (csubtypep (continuation-type x)
+  (when (and (csubtypep (lvar-type x)
 			(specifier-type '(real 0.0)))
 	     (or (null y)
-		 (csubtypep (continuation-type y)
+		 (csubtypep (lvar-type y)
 			    (specifier-type '(real 0.0)))))
     (specifier-type 'float)))
 
@@ -419,7 +443,7 @@
              (declare (ignorable prim-quick))
              `(progn
                 (deftransform ,name ((x) (single-float) *)
-                  #!+x86 (cond ((csubtypep (continuation-type x)
+                  #!+x86 (cond ((csubtypep (lvar-type x)
                                            (specifier-type '(single-float
                                                              (#.(- (expt 2f0 64)))
                                                              (#.(expt 2f0 64)))))
@@ -429,11 +453,11 @@
                                 (compiler-notify
                                  "unable to avoid inline argument range check~@
                                   because the argument range (~S) was not within 2^64"
-                                 (type-specifier (continuation-type x)))
+                                 (type-specifier (lvar-type x)))
                                 `(coerce (,',prim (coerce x 'double-float)) 'single-float)))
                   #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
                (deftransform ,name ((x) (double-float) *)
-                 #!+x86 (cond ((csubtypep (continuation-type x)
+                 #!+x86 (cond ((csubtypep (lvar-type x)
                                           (specifier-type '(double-float
                                                             (#.(- (expt 2d0 64)))
                                                             (#.(expt 2d0 64)))))
@@ -442,7 +466,7 @@
                                (compiler-notify
                                 "unable to avoid inline argument range check~@
                                  because the argument range (~S) was not within 2^64"
-                                (type-specifier (continuation-type x)))
+                                (type-specifier (lvar-type x)))
                                `(,',prim x)))
                  #!-x86 `(,',prim x)))))
   (def sin %sin %sin-quick)
@@ -608,9 +632,7 @@
   (etypecase arg
     (numeric-type
      (cond ((eq (numeric-type-complexp arg) :complex)
-	    (make-numeric-type :class (numeric-type-class arg)
-			       :format (numeric-type-format arg)
-			       :complexp :complex))
+	    (complex-float-type arg))
 	   ((numeric-type-real-p arg)
 	    ;; The argument is real, so let's find the intersection
 	    ;; between the argument and the domain of the function.
@@ -901,17 +923,21 @@
 	((csubtypep y (specifier-type 'integer))
 	 ;; A real raised to an integer power is well-defined.
 	 (merged-interval-expt x y))
+	;; A real raised to a non-integral power can be a float or a
+	;; complex number.
+	((or (csubtypep x (specifier-type '(rational 0)))
+	     (csubtypep x (specifier-type '(float (0d0)))))
+	 ;; But a positive real to any power is well-defined.
+	 (merged-interval-expt x y))
+	((and (csubtypep x (specifier-type 'rational))
+	      (csubtypep x (specifier-type 'rational)))
+	 ;; A rational to the power of a rational could be a rational
+	 ;; or a possibly-complex single float
+	 (specifier-type '(or rational single-float (complex single-float))))
 	(t
-	 ;; A real raised to a non-integral power can be a float or a
-	 ;; complex number.
-	 (cond ((or (csubtypep x (specifier-type '(rational 0)))
-		    (csubtypep x (specifier-type '(float (0d0)))))
-		;; But a positive real to any power is well-defined.
-		(merged-interval-expt x y))
-	       (t
-		;; a real to some power. The result could be a real
-		;; or a complex.
-		(float-or-complex-float-type (numeric-contagion x y)))))))
+	 ;; a real to some power. The result could be a real or a
+	 ;; complex.
+	 (float-or-complex-float-type (numeric-contagion x y)))))
 
 (defoptimizer (expt derive-type) ((x y))
   (two-arg-derive-type x y #'expt-derive-type-aux #'expt))
@@ -1277,19 +1303,34 @@
 			   nil nil))
    #'tan))
 
-;;; CONJUGATE always returns the same type as the input type.
-;;;
-;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
-;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
 (defoptimizer (conjugate derive-type) ((num))
-  (continuation-type num))
+  (one-arg-derive-type num
+    (lambda (arg)
+      (flet ((most-negative-bound (l h)
+	       (and l h
+		    (if (< (type-bound-number l) (- (type-bound-number h)))
+			l
+			(set-bound (- (type-bound-number h)) (consp h)))))
+	     (most-positive-bound (l h)
+	       (and l h
+		    (if (> (type-bound-number h) (- (type-bound-number l)))
+			h
+			(set-bound (- (type-bound-number l)) (consp l))))))
+	(if (numeric-type-real-p arg)
+	    (lvar-type num)
+	    (let ((low (numeric-type-low arg))
+		  (high (numeric-type-high arg)))
+	      (let ((new-low (most-negative-bound low high))
+		    (new-high (most-positive-bound low high)))
+	      (modified-numeric-type arg :low new-low :high new-high))))))
+    #'conjugate))
 
 (defoptimizer (cis derive-type) ((num))
   (one-arg-derive-type num
-     (lambda (arg)
-       (sb!c::specifier-type
-	`(complex ,(or (numeric-type-format arg) 'float))))
-     #'cis))
+    (lambda (arg)
+      (sb!c::specifier-type
+       `(complex ,(or (numeric-type-format arg) 'float))))
+    #'cis))
 
 ) ; PROGN
 
@@ -1337,3 +1378,56 @@
 		    (plusp number)))
 	   (values (1+ tru) (- rem ,defaulted-divisor))
 	   (values tru rem)))))
+
+(defknown %unary-ftruncate (real) float (movable foldable flushable))
+(defknown %unary-ftruncate/single (single-float) single-float
+  (movable foldable flushable))
+(defknown %unary-ftruncate/double (double-float) double-float
+  (movable foldable flushable))
+
+(defun %unary-ftruncate/single (x)
+  (declare (type single-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((bits (single-float-bits x))
+	 (exp (ldb sb!vm:single-float-exponent-byte bits))
+	 (biased (the single-float-exponent
+		   (- exp sb!vm:single-float-bias))))
+    (declare (type (signed-byte 32) bits))
+    (cond
+      ((= exp sb!vm:single-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0f0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
+	 (make-single-float bits))))))
+
+(defun %unary-ftruncate/double (x)
+  (declare (type double-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((high (double-float-high-bits x))
+	 (low (double-float-low-bits x))
+	 (exp (ldb sb!vm:double-float-exponent-byte high))
+	 (biased (the double-float-exponent
+		   (- exp sb!vm:double-float-bias))))
+    (declare (type (signed-byte 32) high)
+	     (type (unsigned-byte 32) low))
+    (cond
+      ((= exp sb!vm:double-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0d0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (cond ((< frac-bits 32)
+		(setf low (logandc2 low (- (ash 1 frac-bits) 1))))
+	       (t
+		(setf low 0)
+		(setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1)))))
+	 (make-double-float high low))))))
+
+(macrolet
+    ((def (float-type fun)
+	 `(deftransform %unary-ftruncate ((x) (,float-type))
+	    '(,fun x))))
+  (def single-float %unary-ftruncate/single)
+  (def double-float %unary-ftruncate/double))