X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ffloat-tran.lisp;h=f6c14279ebd64d5402f58ec5e217b6c98cf69669;hb=c8af15e61b030c8d4b0e950bc9b7618530044618;hp=69faaae7404bece4f2d11653ab92e7d5322a1c4a;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 69faaae..f6c1427 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -12,9 +12,6 @@
 ;;;; files for more information.
 
 (in-package "SB!C")
-
-(file-comment
-  "$Header$")
 
 ;;;; coercions
 
@@ -183,11 +180,9 @@
 
 ;;; toy@rtp.ericsson.se:
 ;;;
-;;; Optimizers for scale-float. If the float has bounds, new bounds
+;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
 ;;; are computed for the result, if possible.
 
-#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
-(progn
 #!+propagate-float-type
 (progn
 
@@ -226,9 +221,7 @@
   (two-arg-derive-type f ex #'scale-float-derive-type-aux
 		       #'scale-double-float t))
 
-;;; toy@rtp.ericsson.se:
-;;;
-;;; Defoptimizers for %single-float and %double-float. This makes the
+;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
 ;;; FLOAT function return the correct ranges if the input has some
 ;;; defined range. Quite useful if we want to convert some type of
 ;;; bounded integer into a float.
@@ -252,7 +245,7 @@
 	     (one-arg-derive-type num #',aux-name #',fun))))))
   (frob %single-float single-float)
   (frob %double-float double-float))
-)) ; PROGN PROGN
+) ; PROGN 
 
 ;;;; float contagion
 
@@ -283,9 +276,10 @@
 ;;; float (such as 0).
 (macrolet ((frob (op)
 	     `(deftransform ,op ((x y) (float rational) * :when :both)
+		"open-code FLOAT to RATIONAL comparison"
 		(unless (constant-continuation-p y)
 		  (give-up-ir1-transform
-		   "can't open-code float to rational comparison"))
+		   "The RATIONAL value isn't known at compile time."))
 		(let ((val (continuation-value y)))
 		  (unless (eql (rational (float val)) val)
 		    (give-up-ir1-transform
@@ -309,12 +303,12 @@
   (destructuring-bind (name type) stuff
     (let ((type (specifier-type type)))
       (setf (function-info-derive-type (function-info-or-lose name))
-	    #'(lambda (call)
-		(declare (type combination call))
-		(when (csubtypep (continuation-type
-				  (first (combination-args call)))
-				 type)
-		  (specifier-type 'float)))))))
+	    (lambda (call)
+	      (declare (type combination call))
+	      (when (csubtypep (continuation-type
+				(first (combination-args call)))
+			       type)
+		(specifier-type 'float)))))))
 
 #!-propagate-fun-type
 (defoptimizer (log derive-type) ((x &optional y))
@@ -332,52 +326,52 @@
   (movable foldable flushable))
 
 (defknown (%sin %cos %tanh %sin-quick %cos-quick)
-    (double-float) (double-float -1.0d0 1.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float -1.0d0 1.0d0)
+  (movable foldable flushable))
 
 (defknown (%asin %atan)
-    (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
-    (movable foldable flushable))
+  (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+  (movable foldable flushable))
 
 (defknown (%acos)
-    (double-float) (double-float 0.0d0 #.pi)
-    (movable foldable flushable))
+  (double-float) (double-float 0.0d0 #.pi)
+  (movable foldable flushable))
 
 (defknown (%cosh)
-    (double-float) (double-float 1.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float 1.0d0)
+  (movable foldable flushable))
 
 (defknown (%acosh %exp %sqrt)
-    (double-float) (double-float 0.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float 0.0d0)
+  (movable foldable flushable))
 
 (defknown %expm1
-    (double-float) (double-float -1d0)
-    (movable foldable flushable))
+  (double-float) (double-float -1d0)
+  (movable foldable flushable))
 
 (defknown (%hypot)
-    (double-float double-float) (double-float 0d0)
+  (double-float double-float) (double-float 0d0)
   (movable foldable flushable))
 
 (defknown (%pow)
-    (double-float double-float) double-float
+  (double-float double-float) double-float
   (movable foldable flushable))
 
 (defknown (%atan2)
-    (double-float double-float) (double-float #.(- pi) #.pi)
+  (double-float double-float) (double-float #.(- pi) #.pi)
   (movable foldable flushable))
 
 (defknown (%scalb)
-    (double-float double-float) double-float
+  (double-float double-float) double-float
   (movable foldable flushable))
 
 (defknown (%scalbn)
-    (double-float (signed-byte 32)) double-float
-    (movable foldable flushable))
+  (double-float (signed-byte 32)) double-float
+  (movable foldable flushable))
 
 (defknown (%log1p)
-    (double-float) double-float
-    (movable foldable flushable))
+  (double-float) double-float
+  (movable foldable flushable))
 
 (dolist (stuff '((exp %exp *)
 		 (log %log float)
@@ -565,8 +559,6 @@
 				(minusp (float-sign arg-hi-val))
 				(plusp (float-sign arg-hi-val))))))))))
 
-;;; Elfun-Derive-Type-Simple
-;;;
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the
 ;;; function, and DOMAIN is a specifier that gives the (real) domain
@@ -747,7 +739,6 @@
 	     (interval-expt-< pos y))))))
 
 ;;; Compute bounds for (expt x y).
-
 (defun interval-expt (x y)
   (case (interval-range-info x 1)
     ('+
@@ -872,8 +863,8 @@
 (defun merged-interval-expt (x y)
   (let* ((x-int (numeric-type->interval x))
 	 (y-int (numeric-type->interval y)))
-    (mapcar #'(lambda (type)
-		(fixup-interval-expt type x-int y-int x y))
+    (mapcar (lambda (type)
+	      (fixup-interval-expt type x-int y-int x y))
 	    (flatten-list (interval-expt x-int y-int)))))
 
 (defun expt-derive-type-aux (x y same-arg)
@@ -893,7 +884,7 @@
 		;; 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
+		;; a real to some power. The result could be a real
 		;; or a complex.
 		(float-or-complex-float-type (numeric-contagion x y)))))))
 
@@ -908,16 +899,13 @@
 (defun log-derive-type-aux-2 (x y same-arg)
   (let ((log-x (log-derive-type-aux-1 x))
 	(log-y (log-derive-type-aux-1 y))
-	(result '()))
-    ;; log-x or log-y might be union types. We need to run through
-    ;; the union types ourselves because /-derive-type-aux doesn't.
+	(accumulated-list nil))
+    ;; LOG-X or LOG-Y might be union types. We need to run through
+    ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
     (dolist (x-type (prepare-arg-for-derive-type log-x))
       (dolist (y-type (prepare-arg-for-derive-type log-y))
-	(push (/-derive-type-aux x-type y-type same-arg) result)))
-    (setf result (flatten-list result))
-    (if (rest result)
-	(make-union-type result)
-	(first result))))
+	(push (/-derive-type-aux x-type y-type same-arg) accumulated-list)))
+    (apply #'type-union (flatten-list accumulated-list))))
 
 (defoptimizer (log derive-type) ((x &optional y))
   (if y
@@ -1018,7 +1006,6 @@
 
 ;;; Make REALPART and IMAGPART return the appropriate types. This
 ;;; should help a lot in optimized code.
-
 (defun realpart-derive-type-aux (type)
   (let ((class (numeric-type-class type))
 	(format (numeric-type-format type)))
@@ -1039,11 +1026,9 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-
 #!+(or propagate-fun-type propagate-float-type)
 (defoptimizer (realpart derive-type) ((num))
   (one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
-
 (defun imagpart-derive-type-aux (type)
   (let ((class (numeric-type-class type))
 	(format (numeric-type-format type)))
@@ -1065,7 +1050,6 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-
 #!+(or propagate-fun-type propagate-float-type)
 (defoptimizer (imagpart derive-type) ((num))
   (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
@@ -1098,10 +1082,9 @@
 	     (rat-result-p (csubtypep element-type
 				      (specifier-type 'rational))))
 	(if rat-result-p
-	    (make-union-type
-	     (list element-type
-		   (specifier-type
-		    `(complex ,(numeric-type-class element-type)))))
+	    (type-union element-type
+			(specifier-type
+			 `(complex ,(numeric-type-class element-type))))
 	    (make-numeric-type :class (numeric-type-class element-type)
 			       :format (numeric-type-format element-type)
 			       :complexp (if rat-result-p
@@ -1187,12 +1170,11 @@
   (frob single-float)
   (frob double-float))
 
-;;; Here are simple optimizers for sin, cos, and tan. They do not
+;;; Here are simple optimizers for SIN, COS, and TAN. They do not
 ;;; produce a minimal range for the result; the result is the widest
 ;;; possible answer. This gets around the problem of doing range
 ;;; reduction correctly but still provides useful results when the
 ;;; inputs are union types.
-
 #!+propagate-fun-type
 (progn
 (defun trig-derive-type-aux (arg domain fcn
@@ -1236,39 +1218,42 @@
 (defoptimizer (sin derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [-pi/2, pi/2].
-       (trig-derive-type-aux
-	arg
-	(specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
-	#'sin
-	-1 1))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+     (trig-derive-type-aux
+      arg
+      (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+      #'sin
+      -1 1))
    #'sin))
 
 (defoptimizer (cos derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [0, pi].
-       (trig-derive-type-aux arg
-			     (specifier-type `(float 0d0 ,pi))
-			     #'cos
-			     -1 1
-			     nil))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [0, pi].
+     (trig-derive-type-aux arg
+			   (specifier-type `(float 0d0 ,pi))
+			   #'cos
+			   -1 1
+			   nil))
    #'cos))
 
 (defoptimizer (tan derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [-pi/2, pi/2].
-       (trig-derive-type-aux arg
-			     (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
-			     #'tan
-			     nil nil))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+     (trig-derive-type-aux arg
+			   (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+			   #'tan
+			   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))