X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=b0e652a88cfa0363574a6b68c87f1175fa760396;hb=369029d73f198b59135c6c005b7a70ae5a753650;hp=ba12b8e4448984ed705e9ebf1d21f008f43cd3c1;hpb=0dea4acb4216f9ee1182a6dc49483ec8d42babc5;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index ba12b8e..b0e652a 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -18,23 +18,22 @@
 (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) * :when :both)
+(deftransform float ((n &optional f) (* &optional single-float) *)
   '(%single-float n))
 
-(deftransform float ((n f) (* double-float) * :when :both)
+(deftransform float ((n f) (* double-float) *)
   '(%double-float n))
 
-(deftransform %single-float ((n) (single-float) * :when :both)
+(deftransform %single-float ((n) (single-float) *)
   'n)
 
-(deftransform %double-float ((n) (double-float) * :when :both)
+(deftransform %double-float ((n) (double-float) *)
   'n)
 
 ;;; RANDOM
 (macrolet ((frob (fun type)
 	     `(deftransform random ((num &optional state)
-				    (,type &optional *) *
-				    :when :both)
+				    (,type &optional *) *)
 		"Use inline float operations."
 		'(,fun num (or state *random-state*)))))
   (frob %random-single-float single-float)
@@ -139,36 +138,69 @@
 (defknown scale-double-float (double-float fixnum) double-float
   (movable foldable flushable))
 
-(deftransform decode-float ((x) (single-float) * :when :both)
+(deftransform decode-float ((x) (single-float) *)
   '(decode-single-float x))
 
-(deftransform decode-float ((x) (double-float) * :when :both)
+(deftransform decode-float ((x) (double-float) *)
   '(decode-double-float x))
 
-(deftransform integer-decode-float ((x) (single-float) * :when :both)
+(deftransform integer-decode-float ((x) (single-float) *)
   '(integer-decode-single-float x))
 
-(deftransform integer-decode-float ((x) (double-float) * :when :both)
+(deftransform integer-decode-float ((x) (double-float) *)
   '(integer-decode-double-float x))
 
-(deftransform scale-float ((f ex) (single-float *) * :when :both)
+(deftransform scale-float ((f ex) (single-float *) *)
   (if (and #!+x86 t #!-x86 nil
 	   (csubtypep (continuation-type ex)
-		      (specifier-type '(signed-byte 32)))
-	   (not (byte-compiling)))
+		      (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 *) * :when :both)
+(deftransform scale-float ((f ex) (double-float *) *)
   (if (and #!+x86 t #!-x86 nil
 	   (csubtypep (continuation-type ex)
 		      (specifier-type '(signed-byte 32))))
       '(%scalbn f ex)
       '(scale-double-float f ex)))
 
+;;; What is the CROSS-FLOAT-INFINITY-KLUDGE?
+;;;
+;;; SBCL's own implementation of floating point supports floating
+;;; point infinities. Some of the old CMU CL :PROPAGATE-FLOAT-TYPE and
+;;; :PROPAGATE-FUN-TYPE code, like the DEFOPTIMIZERs below, uses this
+;;; floating point support. Thus, we have to avoid running it on the
+;;; cross-compilation host, since we're not guaranteed that the
+;;; cross-compilation host will support floating point infinities.
+;;;
+;;; If we wanted to live dangerously, we could conditionalize the code
+;;; with #+(OR SBCL SB-XC) instead. That way, if the cross-compilation
+;;; host happened to be SBCL, we'd be able to run the infinity-using
+;;; code. Pro:
+;;;   * SBCL itself gets built with more complete optimization.
+;;; Con:
+;;;   * You get a different SBCL depending on what your cross-compilation
+;;;     host is.
+;;; So far the pros and cons seem seem to be mostly academic, since
+;;; AFAIK (WHN 2001-08-28) the propagate-foo-type optimizations aren't
+;;; actually important in compiling SBCL itself. If this changes, then
+;;; we have to decide:
+;;;   * Go for simplicity, leaving things as they are.
+;;;   * Go for performance at the expense of conceptual clarity,
+;;;     using #+(OR SBCL SB-XC) and otherwise leaving the build
+;;;     process as is.
+;;;   * Go for performance at the expense of build time, using
+;;;     #+(OR SBCL SB-XC) and also making SBCL do not just
+;;;     make-host-1.sh and make-host-2.sh, but a third step
+;;;     make-host-3.sh where it builds itself under itself. (Such a
+;;;     3-step build process could also help with other things, e.g.
+;;;     using specialized arrays to represent debug information.)
+;;;   * Rewrite the code so that it doesn't depend on unportable
+;;;     floating point infinities.
+
 ;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
 ;;; are computed for the result, if possible.
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 (defun scale-float-derive-type-aux (f ex same-arg)
@@ -217,11 +249,11 @@
 	   (defun ,aux-name (num)
 	     ;; When converting a number to a float, the limits are
 	     ;; the same.
-	     (let* ((lo (bound-func #'(lambda (x)
-					(coerce x ',type))
+	     (let* ((lo (bound-func (lambda (x)
+				      (coerce x ',type))
 				    (numeric-type-low num)))
-		    (hi (bound-func #'(lambda (x)
-					(coerce x ',type))
+		    (hi (bound-func (lambda (x)
+				      (coerce x ',type))
 				    (numeric-type-high num))))
 	       (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
 
@@ -235,12 +267,12 @@
 
 ;;; Do some stuff to recognize when the loser is doing mixed float and
 ;;; rational arithmetic, or different float types, and fix it up. If
-;;; we don't, he won't even get so much as an efficency note.
+;;; 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-function-name (basic-combination-fun node))
+  `(,(continuation-fun-name (basic-combination-fun node))
     (float x y) y))
 (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
-  `(,(continuation-function-name (basic-combination-fun node))
+  `(,(continuation-fun-name (basic-combination-fun node))
     x (float y x)))
 
 (dolist (x '(+ * / -))
@@ -259,7 +291,7 @@
 ;;; do it for any rational that has a precise representation as a
 ;;; float (such as 0).
 (macrolet ((frob (op)
-	     `(deftransform ,op ((x y) (float rational) * :when :both)
+	     `(deftransform ,op ((x y) (float rational) *)
 		"open-code FLOAT to RATIONAL comparison"
 		(unless (constant-continuation-p y)
 		  (give-up-ir1-transform
@@ -278,7 +310,7 @@
 
 ;;; Derive the result to be float for argument types in the
 ;;; appropriate domain.
-#!-sb-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (dolist (stuff '((asin (real -1.0 1.0))
 		 (acos (real -1.0 1.0))
 		 (acosh (real 1.0))
@@ -286,7 +318,7 @@
 		 (sqrt (real 0.0))))
   (destructuring-bind (name type) stuff
     (let ((type (specifier-type type)))
-      (setf (function-info-derive-type (function-info-or-lose name))
+      (setf (fun-info-derive-type (fun-info-or-lose name))
 	    (lambda (call)
 	      (declare (type combination call))
 	      (when (csubtypep (continuation-type
@@ -294,7 +326,7 @@
 			       type)
 		(specifier-type 'float)))))))
 
-#!-sb-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (log derive-type) ((x &optional y))
   (when (and (csubtypep (continuation-type x)
 			(specifier-type '(real 0.0)))
@@ -314,11 +346,13 @@
   (movable foldable flushable))
 
 (defknown (%asin %atan)
-  (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+  (double-float)
+  (double-float #.(coerce (- (/ pi 2)) 'double-float)
+		#.(coerce (/ pi 2) 'double-float))
   (movable foldable flushable))
 
 (defknown (%acos)
-  (double-float) (double-float 0.0d0 #.pi)
+  (double-float) (double-float 0.0d0 #.(coerce pi 'double-float))
   (movable foldable flushable))
 
 (defknown (%cosh)
@@ -342,7 +376,9 @@
   (movable foldable flushable))
 
 (defknown (%atan2)
-  (double-float double-float) (double-float #.(- pi) #.pi)
+  (double-float double-float)
+  (double-float #.(coerce (- pi) 'double-float)
+		#.(coerce pi 'double-float))
   (movable foldable flushable))
 
 (defknown (%scalb)
@@ -357,75 +393,77 @@
   (double-float) double-float
   (movable foldable flushable))
 
-(dolist (stuff '((exp %exp *)
-		 (log %log float)
-		 (sqrt %sqrt float)
-		 (asin %asin float)
-		 (acos %acos float)
-		 (atan %atan *)
-		 (sinh %sinh *)
-		 (cosh %cosh *)
-		 (tanh %tanh *)
-		 (asinh %asinh *)
-		 (acosh %acosh float)
-		 (atanh %atanh float)))
-  (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x) '(single-float) rtype :eval-name t)
-      `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
-      `(,prim x))))
+(macrolet ((def (name prim rtype)
+             `(progn
+               (deftransform ,name ((x) (single-float) ,rtype)
+                 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+               (deftransform ,name ((x) (double-float) ,rtype)
+                 `(,',prim x)))))
+  (def exp %exp *)
+  (def log %log float)
+  (def sqrt %sqrt float)
+  (def asin %asin float)
+  (def acos %acos float)
+  (def atan %atan *)
+  (def sinh %sinh *)
+  (def cosh %cosh *)
+  (def tanh %tanh *)
+  (def asinh %asinh *)
+  (def acosh %acosh float)
+  (def atanh %atanh float))
 
 ;;; The argument range is limited on the x86 FP trig. functions. A
 ;;; post-test can detect a failure (and load a suitable result), but
 ;;; this test is avoided if possible.
-(dolist (stuff '((sin %sin %sin-quick)
-		 (cos %cos %cos-quick)
-		 (tan %tan %tan-quick)))
-  (destructuring-bind (name prim prim-quick) stuff
-    (declare (ignorable prim-quick))
-    (deftransform name ((x) '(single-float) '* :eval-name t)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(single-float
-						 (#.(- (expt 2f0 64)))
-						 (#.(expt 2f0 64)))))
-		    `(coerce (,prim-quick (coerce x 'double-float))
-		    'single-float))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		      because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(coerce (,prim (coerce x 'double-float)) 'single-float)))
-      #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(double-float
-						 (#.(- (expt 2d0 64)))
-						 (#.(expt 2d0 64)))))
-		    `(,prim-quick x))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		   because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(,prim x)))
-      #!-x86 `(,prim x))))
+(macrolet ((def (name prim prim-quick)
+             (declare (ignorable prim-quick))
+             `(progn
+                (deftransform ,name ((x) (single-float) *)
+                  #!+x86 (cond ((csubtypep (continuation-type x)
+                                           (specifier-type '(single-float
+                                                             (#.(- (expt 2f0 64)))
+                                                             (#.(expt 2f0 64)))))
+                                `(coerce (,',prim-quick (coerce x 'double-float))
+                                  'single-float))
+                               (t
+                                (compiler-note
+                                 "unable to avoid inline argument range check~@
+                                  because the argument range (~S) was not within 2^64"
+                                 (type-specifier (continuation-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)
+                                          (specifier-type '(double-float
+                                                            (#.(- (expt 2d0 64)))
+                                                            (#.(expt 2d0 64)))))
+                               `(,',prim-quick x))
+                              (t
+                               (compiler-note
+                                "unable to avoid inline argument range check~@
+                                 because the argument range (~S) was not within 2^64"
+                                (type-specifier (continuation-type x)))
+                               `(,',prim x)))
+                 #!-x86 `(,',prim x)))))
+  (def sin %sin %sin-quick)
+  (def cos %cos %cos-quick)
+  (def tan %tan %tan-quick))
 
 (deftransform atan ((x y) (single-float single-float) *)
   `(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform atan ((x y) (double-float double-float) * :when :both)
+(deftransform atan ((x y) (double-float double-float) *)
   `(%atan2 x y))
 
 (deftransform expt ((x y) ((single-float 0f0) single-float) *)
   `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform expt ((x y) ((double-float 0d0) double-float) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) double-float) *)
   `(%pow x y))
 (deftransform expt ((x y) ((single-float 0f0) (signed-byte 32)) *)
   `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) *)
   `(%pow x (coerce y 'double-float)))
 
 ;;; ANSI says log with base zero returns zero.
@@ -434,7 +472,7 @@
 
 ;;; Handle some simple transformations.
 
-(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+(deftransform abs ((x) ((complex double-float)) double-float)
   '(%hypot (realpart x) (imagpart x)))
 
 (deftransform abs ((x) ((complex single-float)) single-float)
@@ -442,7 +480,7 @@
 		   (coerce (imagpart x) 'double-float))
 	  'single-float))
 
-(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+(deftransform phase ((x) ((complex double-float)) double-float)
   '(%atan2 (imagpart x) (realpart x)))
 
 (deftransform phase ((x) ((complex single-float)) single-float)
@@ -450,16 +488,12 @@
 		   (coerce (realpart x) 'double-float))
 	  'single-float))
 
-(deftransform phase ((x) ((float)) float :when :both)
+(deftransform phase ((x) ((float)) float)
   '(if (minusp (float-sign x))
        (float pi x)
        (float 0 x)))
 
-;; #!+(or propagate-float-type propagate-fun-type)
-(progn
-
 ;;; The number is of type REAL.
-#!-sb-fluid (declaim (inline numeric-type-real-p))
 (defun numeric-type-real-p (type)
   (and (numeric-type-p type)
        (eq (numeric-type-complexp type) :real)))
@@ -472,9 +506,7 @@
 	(list (coerce (car bound) type))
 	(coerce bound type))))
 
-) ; PROGN
-
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 ;;;; optimizers for elementary functions
@@ -620,11 +652,11 @@
 	 `(defoptimizer (,name derive-type) ((,num))
 	   (one-arg-derive-type
 	    ,num
-	    #'(lambda (arg)
-		(elfun-derive-type-simple arg #',name
-					  ,domain-low ,domain-high
-					  ,def-low-bnd ,def-high-bnd
-					  ,increasingp))
+	    (lambda (arg)
+	      (elfun-derive-type-simple arg #',name
+					,domain-low ,domain-high
+					,def-low-bnd ,def-high-bnd
+					,increasingp))
 	    #',name)))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
@@ -1009,7 +1041,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or sb-propagate-fun-type sb-propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (realpart derive-type) ((num))
   (one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
 (defun imagpart-derive-type-aux (type)
@@ -1033,7 +1065,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or sb-propagate-fun-type sb-propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (imagpart derive-type) ((num))
   (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
 
@@ -1075,7 +1107,7 @@
 					     :complex))))
       (specifier-type 'complex)))
 
-#!+(or sb-propagate-fun-type sb-propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (complex derive-type) ((re &optional im))
   (if im
       (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
@@ -1158,7 +1190,7 @@
 ;;; possible answer. This gets around the problem of doing range
 ;;; reduction correctly but still provides useful results when the
 ;;; inputs are union types.
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 (defun trig-derive-type-aux (arg domain fcn
 				 &optional def-lo def-hi (increasingp t))
@@ -1242,9 +1274,9 @@
 
 (defoptimizer (cis derive-type) ((num))
   (one-arg-derive-type num
-     #'(lambda (arg)
-	 (sb!c::specifier-type
-	  `(complex ,(or (numeric-type-format arg) 'float))))
+     (lambda (arg)
+       (sb!c::specifier-type
+	`(complex ,(or (numeric-type-format arg) 'float))))
      #'cis))
 
 ) ; PROGN
@@ -1256,7 +1288,7 @@
 		(defknown ,ufun (real) integer (movable foldable flushable))
 		(deftransform ,fun ((x &optional by)
 				    (* &optional
-				       (constant-argument (member 1))))
+				       (constant-arg (member 1))))
 		  '(let ((res (,ufun x)))
 		     (values res (- x res)))))))
   (define-frobs truncate %unary-truncate)