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

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index f6c1427..f4f65bf 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -18,35 +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)
 
-;;; not strictly float functions, but primarily useful on floats:
-(macrolet ((frob (fun ufun)
-	     `(progn
-		(defknown ,ufun (real) integer (movable foldable flushable))
-		(deftransform ,fun ((x &optional by)
-				    (* &optional
-				       (constant-argument (member 1))))
-		  '(let ((res (,ufun x)))
-		     (values res (- x res)))))))
-  (frob truncate %unary-truncate)
-  (frob round %unary-round))
-
 ;;; 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)
@@ -63,7 +50,7 @@
   ;; 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"
+  "use inline (UNSIGNED-BYTE 32) operations"
   (let ((num-high (numeric-type-high (continuation-type num))))
     (when (null num-high)
       (give-up-ir1-transform))
@@ -151,39 +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)))
 
-;;; toy@rtp.ericsson.se:
+;;; 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.
-
-#!+propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 (defun scale-float-derive-type-aux (f ex same-arg)
@@ -194,7 +211,7 @@
 	   ;; zeros.
 	   (set-bound
 	    (handler-case
-	     (scale-float (bound-value x) n)
+	     (scale-float (type-bound-number x) n)
 	     (floating-point-overflow ()
 		nil))
 	    (consp x))))
@@ -225,7 +242,6 @@
 ;;; 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.
-
 (macrolet
     ((frob (fun type)
        (let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
@@ -233,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 '*)))))
 
@@ -251,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 '(+ * / -))
@@ -275,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
@@ -294,7 +310,7 @@
 
 ;;; Derive the result to be float for argument types in the
 ;;; appropriate domain.
-#!-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))
@@ -302,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
@@ -310,7 +326,7 @@
 			       type)
 		(specifier-type 'float)))))))
 
-#!-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)))
@@ -330,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)
@@ -358,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)
@@ -373,74 +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
-    (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.
@@ -449,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)
@@ -457,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)
@@ -465,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)))
@@ -487,9 +506,7 @@
 	(list (coerce (car bound) type))
 	(coerce bound type))))
 
-) ; PROGN
-
-#!+propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 ;;;; optimizers for elementary functions
@@ -507,7 +524,7 @@
 	 (float-type (or format 'float)))
     (specifier-type `(complex ,float-type))))
 
-;;; Compute a specifier like '(or float (complex float)), except float
+;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
 ;;; should be the right kind of float. Allow bounds for the float
 ;;; part too.
 (defun float-or-complex-float-type (arg &optional lo hi)
@@ -521,27 +538,41 @@
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
 			 (complex ,float-type)))))
 
+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+  ;; So the problem with this hack is that it's actually broken.  If
+  ;; the host does not have long floats, then setting *R-D-F-F* to
+  ;; LONG-FLOAT doesn't actually buy us anything.  FIXME.
+  (setf *read-default-float-format*
+	#!+long-float 'long-float #!-long-float 'double-float))
 ;;; Test whether the numeric-type ARG is within in domain specified by
 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
-;;; be distinct as for the :negative-zero-is-not-zero feature. With
-;;; the :negative-zero-is-not-zero feature this could be handled by
-;;; the numeric subtype code in type.lisp.
+;;; be distinct.
+#-sb-xc-host  ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun domain-subtypep (arg domain-low domain-high)
   (declare (type numeric-type arg)
 	   (type (or real null) domain-low domain-high))
   (let* ((arg-lo (numeric-type-low arg))
-	 (arg-lo-val (bound-value arg-lo))
+	 (arg-lo-val (type-bound-number arg-lo))
 	 (arg-hi (numeric-type-high arg))
-	 (arg-hi-val (bound-value arg-hi)))
+	 (arg-hi-val (type-bound-number arg-hi)))
     ;; Check that the ARG bounds are correctly canonicalized.
     (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
 	       (minusp (float-sign arg-lo-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
-      (setq arg-lo '(0l0) arg-lo-val 0l0))
+      (setq arg-lo '(0e0) arg-lo-val 0e0))
     (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
 	       (plusp (float-sign arg-hi-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
-      (setq arg-hi '(-0l0) arg-hi-val -0l0))
+      (setq arg-hi `(,(ecase *read-default-float-format*
+			(double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+			#!+long-float
+			(long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
+	    arg-hi-val (ecase *read-default-float-format*
+			 (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+			 #!+long-float
+			 (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))
     (and (or (null domain-low)
 	     (and arg-lo (>= arg-lo-val domain-low)
 		  (not (and (zerop domain-low) (floatp domain-low)
@@ -558,6 +589,11 @@
 			    (if (consp arg-hi)
 				(minusp (float-sign arg-hi-val))
 				(plusp (float-sign arg-hi-val))))))))))
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn
 
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the
@@ -568,8 +604,7 @@
 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
 ;;;
 ;;; Negative and positive zero are considered distinct within
-;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
-;;; feature.
+;;; DOMAIN-LOW and DOMAIN-HIGH.
 ;;;
 ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
 ;;; can't compute the bounds using FCN.
@@ -603,7 +638,6 @@
 				    default-low))
 			(res-hi (or (bound-func fcn (if increasingp high low))
 				    default-high))
-			;; Result specifier type.
 			(format (case (numeric-type-class arg)
 				  ((integer rational) 'single-float)
 				  (t (numeric-type-format arg))))
@@ -636,11 +670,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.
@@ -659,7 +693,7 @@
   (frob atanh -1d0 1d0 -1 1)
   ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
   ;; includes -0.0.
-  (frob sqrt -0d0 nil 0 nil))
+  (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))
 
 ;;; Compute bounds for (expt x y). This should be easy since (expt x
 ;;; y) = (exp (* y (log x))). However, computations done this way
@@ -677,19 +711,19 @@
      ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
      ;; obviously non-negative. We just have to be careful for
      ;; infinite bounds (given by nil).
-     (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			  (sb!c::bound-value (sb!c::interval-low y))))
-	   (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			  (sb!c::bound-value (sb!c::interval-high y)))))
+     (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+			  (type-bound-number (sb!c::interval-low y))))
+	   (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+			  (type-bound-number (sb!c::interval-high y)))))
        (list (sb!c::make-interval :low (or lo 1) :high hi))))
     ('-
      ;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
      ;; obviously [0, 1]. However, underflow (nil) means 0 is the
      ;; result.
-     (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			  (sb!c::bound-value (sb!c::interval-low y))))
-	   (hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			  (sb!c::bound-value (sb!c::interval-high y)))))
+     (let ((lo (safe-expt (type-bound-number (sb!c::interval-high x))
+			  (type-bound-number (sb!c::interval-low y))))
+	   (hi (safe-expt (type-bound-number (sb!c::interval-low x))
+			  (type-bound-number (sb!c::interval-high y)))))
        (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
     (t
      ;; Split the interval in half.
@@ -708,18 +742,18 @@
 	;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
 	;; obviously [0, 1]. We just have to be careful for infinite bounds
 	;; (given by nil).
-	(let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			     (sb!c::bound-value (sb!c::interval-high y))))
-	      (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			     (sb!c::bound-value (sb!c::interval-low y)))))
+	(let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+			     (type-bound-number (sb!c::interval-high y))))
+	      (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+			     (type-bound-number (sb!c::interval-low y)))))
 	  (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
        ('-
 	;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
 	;; obviously [1, inf].
-	(let ((hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			     (sb!c::bound-value (sb!c::interval-low y))))
-	      (lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			     (sb!c::bound-value (sb!c::interval-high y)))))
+	(let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
+			     (type-bound-number (sb!c::interval-low y))))
+	      (lo (safe-expt (type-bound-number (sb!c::interval-high x))
+			     (type-bound-number (sb!c::interval-high y)))))
 	  (list (sb!c::make-interval :low (or lo 1) :high hi))))
        (t
 	;; Split the interval in half
@@ -758,7 +792,7 @@
   ;; Figure out what the return type should be, given the argument
   ;; types and bounds and the result type and bounds.
   (cond ((csubtypep x-type (specifier-type 'integer))
-	 ;; An integer to some power. Cases to consider:
+	 ;; an integer to some power
 	 (case (numeric-type-class y-type)
 	   (integer
 	    ;; Positive integer to an integer power is either an
@@ -766,7 +800,7 @@
 	    (let ((lo (or (interval-low bnd) '*))
 		  (hi (or (interval-high bnd) '*)))
 	      (if (and (interval-low y-int)
-		       (>= (bound-value (interval-low y-int)) 0))
+		       (>= (type-bound-number (interval-low y-int)) 0))
 		  (specifier-type `(integer ,lo ,hi))
 		  (specifier-type `(rational ,lo ,hi)))))
 	   (rational
@@ -775,10 +809,10 @@
 	    (let* ((lo (interval-low bnd))
 		   (hi (interval-high bnd))
 		   (int-lo (if lo
-			       (floor (bound-value lo))
+			       (floor (type-bound-number lo))
 			       '*))
 		   (int-hi (if hi
-			       (ceiling (bound-value hi))
+			       (ceiling (type-bound-number hi))
 			       '*))
 		   (f-lo (if lo
 			     (bound-func #'float lo)
@@ -789,32 +823,30 @@
 	      (specifier-type `(or (rational ,int-lo ,int-hi)
 				(single-float ,f-lo, f-hi)))))
 	   (float
-	    ;; Positive integer to a float power is a float.
-	    (let ((res (copy-numeric-type y-type)))
-	      (setf (numeric-type-low res) (interval-low bnd))
-	      (setf (numeric-type-high res) (interval-high bnd))
-	      res))
+	    ;; A positive integer to a float power is a float.
+	    (modified-numeric-type y-type
+				   :low (interval-low bnd)
+				   :high (interval-high bnd)))
 	   (t
-	    ;; Positive integer to a number is a number (for now).
-	    (specifier-type 'number)))
-	 )
+	    ;; A positive integer to a number is a number (for now).
+	    (specifier-type 'number))))
 	((csubtypep x-type (specifier-type 'rational))
 	 ;; a rational to some power
 	 (case (numeric-type-class y-type)
 	   (integer
-	    ;; Positive rational to an integer power is always a rational.
+	    ;; A positive rational to an integer power is always a rational.
 	    (specifier-type `(rational ,(or (interval-low bnd) '*)
 				       ,(or (interval-high bnd) '*))))
 	   (rational
-	    ;; Positive rational to rational power is either a rational
+	    ;; A positive rational to rational power is either a rational
 	    ;; or a single-float.
 	    (let* ((lo (interval-low bnd))
 		   (hi (interval-high bnd))
 		   (int-lo (if lo
-			       (floor (bound-value lo))
+			       (floor (type-bound-number lo))
 			       '*))
 		   (int-hi (if hi
-			       (ceiling (bound-value hi))
+			       (ceiling (type-bound-number hi))
 			       '*))
 		   (f-lo (if lo
 			     (bound-func #'float lo)
@@ -825,20 +857,18 @@
 	      (specifier-type `(or (rational ,int-lo ,int-hi)
 				(single-float ,f-lo, f-hi)))))
 	   (float
-	    ;; Positive rational to a float power is a float.
-	    (let ((res (copy-numeric-type y-type)))
-	      (setf (numeric-type-low res) (interval-low bnd))
-	      (setf (numeric-type-high res) (interval-high bnd))
-	      res))
+	    ;; A positive rational to a float power is a float.
+	    (modified-numeric-type y-type
+				   :low (interval-low bnd)
+				   :high (interval-high bnd)))
 	   (t
-	    ;; Positive rational to a number is a number (for now).
-	    (specifier-type 'number)))
-	 )
+	    ;; A positive rational to a number is a number (for now).
+	    (specifier-type 'number))))
 	((csubtypep x-type (specifier-type 'float))
 	 ;; a float to some power
 	 (case (numeric-type-class y-type)
 	   ((or integer rational)
-	    ;; Positive float to an integer or rational power is
+	    ;; A positive float to an integer or rational power is
 	    ;; always a float.
 	    (make-numeric-type
 	     :class 'float
@@ -846,7 +876,8 @@
 	     :low (interval-low bnd)
 	     :high (interval-high bnd)))
 	   (float
-	    ;; Positive float to a float power is a float of the higher type.
+	    ;; A positive float to a float power is a float of the
+	    ;; higher type.
 	    (make-numeric-type
 	     :class 'float
 	     :format (float-format-max (numeric-type-format x-type)
@@ -854,7 +885,7 @@
 	     :low (interval-low bnd)
 	     :high (interval-high bnd)))
 	   (t
-	    ;; Positive float to a number is a number (for now)
+	    ;; A positive float to a number is a number (for now)
 	    (specifier-type 'number))))
 	(t
 	 ;; A number to some power is a number.
@@ -921,7 +952,9 @@
   (let ((result-type (numeric-contagion y x)))
     (cond ((and (numeric-type-real-p x)
 		(numeric-type-real-p y))
-	   (let* ((format (case (numeric-type-class result-type)
+	   (let* (;; FIXME: This expression for FORMAT seems to
+		  ;; appear multiple times, and should be factored out.
+		  (format (case (numeric-type-class result-type)
 			    ((integer rational) 'single-float)
 			    (t (numeric-type-format result-type))))
 		  (bound-format (or format 'float)))
@@ -1026,7 +1059,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or propagate-fun-type 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)
@@ -1050,7 +1083,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or propagate-fun-type 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))
 
@@ -1092,7 +1125,7 @@
 					     :complex))))
       (specifier-type 'complex)))
 
-#!+(or propagate-fun-type 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)
@@ -1175,7 +1208,7 @@
 ;;; 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
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 (defun trig-derive-type-aux (arg domain fcn
 				 &optional def-lo def-hi (increasingp t))
@@ -1259,9 +1292,54 @@
 
 (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
+
+;;;; TRUNCATE, FLOOR, CEILING, and ROUND
+
+(macrolet ((define-frobs (fun ufun)
+	     `(progn
+		(defknown ,ufun (real) integer (movable foldable flushable))
+		(deftransform ,fun ((x &optional by)
+				    (* &optional
+				       (constant-arg (member 1))))
+		  '(let ((res (,ufun x)))
+		     (values res (- x res)))))))
+  (define-frobs truncate %unary-truncate)
+  (define-frobs round %unary-round))
+
+;;; Convert (TRUNCATE x y) to the obvious implementation.  We only want
+;;; this when under certain conditions and let the generic TRUNCATE
+;;; handle the rest.  (Note: if Y = 1, the divide and multiply by Y
+;;; should be removed by other DEFTRANSFORMs.)
+(deftransform truncate ((x &optional y)
+                        (float &optional (or float integer)))
+  (let ((defaulted-y (if y 'y 1)))
+    `(let ((res (%unary-truncate (/ x ,defaulted-y))))
+       (values res (- x (* ,defaulted-y res))))))
+
+(deftransform floor ((number &optional divisor)
+                     (float &optional (or integer float)))
+  (let ((defaulted-divisor (if divisor 'divisor 1)))
+    `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+       (if (and (not (zerop rem))
+		(if (minusp ,defaulted-divisor)
+		    (plusp number)
+		    (minusp number)))
+	   (values (1- tru) (+ rem ,defaulted-divisor))
+	   (values tru rem)))))
+
+(deftransform ceiling ((number &optional divisor)
+                       (float &optional (or integer float)))
+  (let ((defaulted-divisor (if divisor 'divisor 1)))
+    `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+       (if (and (not (zerop rem))
+		(if (minusp ,defaulted-divisor)
+		    (minusp number)
+		    (plusp number)))
+	   (values (1+ tru) (- rem ,defaulted-divisor))
+	   (values tru rem)))))