X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=ec1fabfe9f8aac8c71fc6c06d3f1e3756fdcb41f;hb=bffa99d35c7d50ac46b9eb7dbe25d1ab1a0e6145;hp=3d82e9fc9137b3c7f842ed729f8790fe283a7061;hpb=4a0ab5193096ca70dbbf43bb21418544f6d018b7;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 3d82e9f..ec1fabf 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -18,23 +18,27 @@
 (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 f) (* 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 float ((n) *)
+  '(if (floatp n)
+       n
+       (%single-float n)))
+
+(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)
@@ -52,10 +56,10 @@
   ;; 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))))
+  (let ((num-high (numeric-type-high (lvar-type num))))
     (when (null num-high)
       (give-up-ir1-transform))
-    (cond ((constant-continuation-p num)
+    (cond ((constant-lvar-p num)
 	   ;; Check the worst case sum absolute error for the random number
 	   ;; expectations.
 	   (let ((rem (rem (expt 2 32) num-high)))
@@ -133,35 +137,34 @@
   (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) * :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)))
+	   (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 *) * :when :both)
+(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)))
@@ -251,11 +254,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 '*)))))
 
@@ -269,12 +272,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))
+  `(,(lvar-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))
+  `(,(lvar-fun-name (basic-combination-fun node))
     x (float y x)))
 
 (dolist (x '(+ * / -))
@@ -293,12 +296,12 @@
 ;;; 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)
+		(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."
@@ -320,20 +323,20 @@
 		 (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
+	      (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)))
 
@@ -348,11 +351,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)
@@ -376,7 +381,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)
@@ -391,75 +398,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 (lvar-type x)
+                                           (specifier-type '(single-float
+                                                             (#.(- (expt 2f0 64)))
+                                                             (#.(expt 2f0 64)))))
+                                `(coerce (,',prim-quick (coerce x 'double-float))
+                                  'single-float))
+                               (t
+                                (compiler-notify
+                                 "unable to avoid inline argument range check~@
+                                  because the argument range (~S) was not within 2^64"
+                                 (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 (lvar-type x)
+                                          (specifier-type '(double-float
+                                                            (#.(- (expt 2d0 64)))
+                                                            (#.(expt 2d0 64)))))
+                               `(,',prim-quick x))
+                              (t
+                               (compiler-notify
+                                "unable to avoid inline argument range check~@
+                                 because the argument range (~S) was not within 2^64"
+                                (type-specifier (lvar-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.
@@ -468,7 +477,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)
@@ -476,7 +485,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)
@@ -484,7 +493,7 @@
 		   (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)))
@@ -534,11 +543,18 @@
     (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))
@@ -549,28 +565,33 @@
     ;; 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))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
+      (setq arg-lo 0e0 arg-lo-val arg-lo))
     (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))
-    (and (or (null domain-low)
-	     (and arg-lo (>= arg-lo-val domain-low)
-		  (not (and (zerop domain-low) (floatp domain-low)
-			    (plusp (float-sign domain-low))
-			    (zerop arg-lo-val) (floatp arg-lo-val)
-			    (if (consp arg-lo)
-				(plusp (float-sign arg-lo-val))
-				(minusp (float-sign arg-lo-val)))))))
-	 (or (null domain-high)
-	     (and arg-hi (<= arg-hi-val domain-high)
-		  (not (and (zerop domain-high) (floatp domain-high)
-			    (minusp (float-sign domain-high))
-			    (zerop arg-hi-val) (floatp arg-hi-val)
-			    (if (consp arg-hi)
-				(minusp (float-sign arg-hi-val))
-				(plusp (float-sign arg-hi-val))))))))))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
+      (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 arg-hi))
+    (flet ((fp-neg-zero-p (f)           ; Is F -0.0?
+	     (and (floatp f) (zerop f) (minusp (float-sign f))))
+	   (fp-pos-zero-p (f)           ; Is F +0.0?
+	     (and (floatp f) (zerop f) (plusp (float-sign f)))))
+      (and (or (null domain-low)
+               (and arg-lo (>= arg-lo-val domain-low)
+                    (not (and (fp-pos-zero-p domain-low)
+			      (fp-neg-zero-p arg-lo)))))
+           (or (null domain-high)
+               (and arg-hi (<= arg-hi-val domain-high)
+                    (not (and (fp-neg-zero-p domain-high)
+			      (fp-pos-zero-p arg-hi)))))))))
+(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
@@ -581,8 +602,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.
@@ -648,11 +668,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.
@@ -671,21 +691,22 @@
   (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
 ;;; have too much roundoff. Thus we have to do it the hard way.
 (defun safe-expt (x y)
   (handler-case
-      (expt x y)
+      (when (< (abs y) 10000)
+        (expt x y))
     (error ()
       nil)))
 
 ;;; Handle the case when x >= 1.
 (defun interval-expt-> (x y)
   (case (sb!c::interval-range-info y 0d0)
-    ('+
+    (+
      ;; 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).
@@ -694,7 +715,7 @@
 	   (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.
@@ -713,10 +734,10 @@
 ;;; Handle the case when x <= 1
 (defun interval-expt-< (x y)
   (case (sb!c::interval-range-info x 0d0)
-    ('+
+    (+
      ;; The case of 0 <= x <= 1 is easy
      (case (sb!c::interval-range-info y)
-       ('+
+       (+
 	;; 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).
@@ -725,7 +746,7 @@
 	      (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 (type-bound-number (sb!c::interval-low x))
@@ -739,7 +760,7 @@
 	    (sb!c::interval-split 0 y t)
 	  (list (interval-expt-< x y-)
 		(interval-expt-< x y+))))))
-    ('-
+    (-
      ;; The case where x <= 0. Y MUST be an INTEGER for this to work!
      ;; The calling function must insure this! For now we'll just
      ;; return the appropriate unbounded float type.
@@ -753,10 +774,10 @@
 ;;; Compute bounds for (expt x y).
 (defun interval-expt (x y)
   (case (interval-range-info x 1)
-    ('+
+    (+
      ;; X >= 1
 	 (interval-expt-> x y))
-    ('-
+    (-
      ;; X <= 1
      (interval-expt-< x y))
     (t
@@ -885,17 +906,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))
@@ -968,14 +993,14 @@
 	 (bound-type (or format 'float)))
     (cond ((numeric-type-real-p arg)
 	   (case (interval-range-info (numeric-type->interval arg) 0.0)
-	     ('+
+	     (+
 	      ;; The number is positive, so the phase is 0.
 	      (make-numeric-type :class 'float
 				 :format format
 				 :complexp :real
 				 :low (coerce 0 bound-type)
 				 :high (coerce 0 bound-type)))
-	     ('-
+	     (-
 	      ;; The number is always negative, so the phase is pi.
 	      (make-numeric-type :class 'float
 				 :format format
@@ -1266,13 +1291,13 @@
 ;;; 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))
+  (lvar-type num))
 
 (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
@@ -1284,7 +1309,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)
@@ -1321,3 +1346,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))