From cea76a8f9a567404019c42eab4930e3ece9a893e Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 5 Jan 1998 05:54:58 +0000
Subject: [PATCH] Enhancement of the arithmetic function derive type optimizers
 to better handle float zeros, by Raymond Toy and Douglas Crosher:

* The arithmetic function derive type optimisers now accept intervals
for which -0.0 and 0.0 are recognisably different. This will fix
naturally into a proposal by Raymond Toy which is conditional upon
:negative-zero-is-not-zero. Without this feature the functions
{one,two}-arg-derive-type convert the type intervals appropriately
before and after these optimisers so that the user visible type
specifiers behave the same.

* Update interval-range-info to recognise the difference between -0.0
and 0.0. This in turn helps fix the phase derive type optimizer.

* Elfun-derive-type-simple now uses a type specifier to giving the
applicable range rather then a function; updates to the various uses
of this function.

* The sqrt and log derive type optimizers have been re-written and now
use elfun-derive-type-simple.

* Remove the unused function numeric-real-union-type-p.

* Extend the expt trnasform to transform powers of 1/2 to sqrt.
---
 compiler/float-tran.lisp | 156 ++++++++-----------------
 compiler/srctran.lisp    | 241 ++++++++++++++++++++++++++++++++++-----
 2 files changed, 264 insertions(+), 133 deletions(-)

diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 0ee63b13a..163465a19 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.58 1998/01/02 05:08:52 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.59 1998/01/05 05:54:55 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -280,9 +280,11 @@
 			   :high new-hi)))))
 ;;;
 (defoptimizer (scale-single-float derive-type) ((f ex))
-  (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-single-float))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux
+		       #'scale-single-float t))
 (defoptimizer (scale-double-float derive-type) ((f ex))
-  (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-double-float))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux
+		       #'scale-double-float t))
 	     
 ;;; toy@rtp.ericsson.se:
 ;;;
@@ -593,10 +595,16 @@
 ;;;; function, based on the domain of the input.
 ;;;;
 
-;;; Handle these monotonic increasing functions whose domain is
-;;; possibly part of the real line
-
-(defun elfun-derive-type-simple (arg fcn cond default-lo default-hi)
+;;; ELFUN-DERIVE-TYPE-SIMPLE
+;;; 
+;;; Handle monotonic increasing functions of a single variable whose
+;;; domain is possibly part of the real line.  ARG is the variable,
+;;; FCN is the function, and CSPEC is a specifier that gives the
+;;; (real) domain of the function.  If ARG is not a subtype of CSPEC,
+;;; then the function is assumed to return either a float or a complex
+;;; number.  DEFAULT-LO and DEFAULT-HI are the lower and upper bounds
+;;; if we can't compute the bounds using FCN.
+(defun elfun-derive-type-simple (arg fcn cspec default-lo default-hi)
   (etypecase arg
     (numeric-type
      (cond ((eq (numeric-type-complexp arg) :complex)
@@ -606,7 +614,7 @@
 	   ((numeric-type-real-p arg)
 	    (let ((lo (numeric-type-low arg))
 		  (hi (numeric-type-high arg)))
-	      (if (funcall cond lo hi)
+	      (if (csubtypep arg cspec)
 		  (let ((f-type (or (numeric-type-format arg) 'single-float)))
 		    (make-numeric-type
 		     :class 'float
@@ -620,82 +628,40 @@
 	    (float-or-complex-type arg default-lo default-hi))))))
 
 (macrolet
-    ((frob (name cond def-lo-bnd def-hi-bnd)
+    ((frob (name cspec def-lo-bnd def-hi-bnd)
        (let ((num (gensym)))
 	 `(defoptimizer (,name derive-type) ((,num))
 	   (one-arg-derive-type
 	    ,num
 	    #'(lambda (arg)
 		(elfun-derive-type-simple arg #',name
-					  ,cond
+					  ,cspec
 					  ,def-lo-bnd ,def-hi-bnd))
 	    #',name)))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
-  (frob exp (constantly t)
+  (frob exp (specifier-type 'real)
 	0 nil)
-  (frob sinh (constantly t)
+  (frob sinh (specifier-type 'real)
 	nil nil)
-  (frob tanh (constantly t)
+  (frob tanh (specifier-type 'real)
 	-1 1)
-  (frob asinh (constantly t)
+  (frob asinh (specifier-type 'real)
 	nil nil)
 
   ;; These functions are only defined for part of the real line.  The
-  ;; condition selects the desired part of the line.  The default
-  ;; return value of (OR FLOAT (COMPLEX FLOAT)) is ok as the default.
-  (frob asin #'(lambda (lo hi)
-		 (and lo hi
-		      (>= (bound-value lo) -1)
-		      (<= (bound-value hi) 1)))
+  ;; condition selects the desired part of the line.  
+  (frob asin (specifier-type '(real -1d0 1d0))
 	#.(- (/ pi 2)) #.(/ pi 2))
-  (frob acosh #'(lambda (lo hi)
-		  (declare (ignore hi))
-		  (and lo (>= (bound-value lo) 1)))
+  (frob acosh (specifier-type '(real 1d0))
 	nil nil)
-  (frob atanh #'(lambda (lo hi)
-		  (and lo hi
-		       (>= (bound-value lo) -1)
-		       (<= (bound-value hi) 1)))
-	-1 1))
-
-
-;;; Note must assume that a type including 0.0 may also include -0.0
-;;; and thus the result may be complex.
-;;;
-(defun sqrt-derive-type-aux (arg)
-  (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))
-	   ((numeric-type-real-p arg)
-	    (let* ((lo (numeric-type-low arg))
-		   (lo-val (and lo (bound-value lo)))
-		   (hi (numeric-type-high arg)))
-	      (if (typecase lo-val
-		    (rational
-		     (>= lo-val 0))
-		    (float
-		     (if (consp lo)
-			 (>= lo-val 0)
-			 (> lo-val 0))))
-		  (let ((f-type (or (numeric-type-format arg) 'single-float)))
-		    (make-numeric-type
-		     :class 'float
-		     :format f-type
-		     :low (cond ((> lo-val 0) (bound-func #'sqrt lo))
-				((consp lo) (list (coerce 0 f-type)))
-				(t (coerce 0 f-type)))
-		     :high (bound-func #'sqrt hi)))
-		  (float-or-complex-type arg 0))))
-	   (t
-	    (float-or-complex-type arg 0))))))
-;;;
-(defoptimizer (sqrt derive-type) ((num))
-  (one-arg-derive-type num #'sqrt-derive-type-aux #'sqrt))
-
+  (frob atanh (specifier-type '(real -1d0 1d0))
+	-1 1)
+  (frob sqrt (specifier-type
+	      #-negative-zero-is-not-zero '(or (member 0f0 0d0) (real (0d0)))
+	      #+negative-zero-is-not-zero '(real 0d0))
+	0 nil))
+ 
 
 ;;; Acos is monotonic decreasing, so we need to swap the function
 ;;; values at the lower and upper bounds of the input domain.
@@ -741,7 +707,7 @@
 
 ;;; Handle the case when x >= 1
 (defun interval-expt-> (x y)
-  (case (c::interval-range-info y)
+  (case (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
@@ -769,7 +735,7 @@
 
 ;;; Handle the case when x <= 1
 (defun interval-expt-< (x y)
-  (case (c::interval-range-info x 0)
+  (case (c::interval-range-info x 0d0)
     ('+
      ;; The case of 0 <= x <= 1 is easy
      (case (c::interval-range-info y)
@@ -874,7 +840,7 @@
 	   (integer
 	    ;; Positive rational to an integer power is always a rational
 	    (specifier-type `(rational ,(or (interval-low bnd) '*)
-			      ,(or (interval-high bnd) '*))))
+				       ,(or (interval-high bnd) '*))))
 	   (rational
 	    ;; Positive rational to rational power is either a rational
 	    ;; or a single-float.
@@ -964,33 +930,13 @@
 ;;; Note must assume that a type including 0.0 may also include -0.0
 ;;; and thus the result may be complex -infinity + i*pi.
 ;;;
-(defun log-derive-type-aux-1 (arg)
-  (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))
-	   ((numeric-type-real-p arg)
-	    (let* ((lo (numeric-type-low arg))
-		   (lo-val (and lo (bound-value lo)))
-		   (hi (numeric-type-high arg)))
-	      (if (typecase lo-val
-		    (rational
-		     (>= lo-val 0))
-		    (float
-		     (if (consp lo)
-			 (>= lo-val 0)
-			 (> lo-val 0))))
-		  (let ((f-type (or (numeric-type-format arg) 'single-float)))
-		    (make-numeric-type
-		     :class 'float
-		     :format f-type
-		     :low (and (> lo-val 0) (bound-func #'log lo))
-		     :high (bound-func #'log hi)))
-		  (float-or-complex-type arg))))
-	   (t
-	    (float-or-complex-type arg))))))
+(defun log-derive-type-aux-1 (x)
+  (elfun-derive-type-simple
+   x #'log
+   (specifier-type
+    #-negative-zero-is-not-zero '(or (member 0f0 0d0) (real (0d0)))
+    #+negative-zero-is-not-zero '(real 0d0))
+   nil nil))
 
 (defun log-derive-type-aux-2 (x y same-arg)
   (let ((log-x (log-derive-type-aux-1 x))
@@ -1014,7 +960,7 @@
 
 (defun atan-derive-type-aux-1 (y)
   (elfun-derive-type-simple
-   y #'atan (constantly t) #.(- (/ pi 2)) #.(/ pi 2)))
+   y #'atan (specifier-type 'real) #.(- (/ pi 2)) #.(/ pi 2)))
 
 (defun atan-derive-type-aux-2 (y x same-arg)
   (declare (ignore same-arg))
@@ -1034,28 +980,26 @@
 	 (float-or-complex-type (numeric-contagion x y)))))
 
 (defoptimizer (atan derive-type) ((y &optional x))
-  (cond ((null x)
-	 (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan))
-	(t
-	 (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan))))
+  (if x
+      (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan)
+      (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan)))
 
 
 (defun cosh-derive-type-aux (x)
+  ;; We note that cosh x = cosh |x| for all real x.
   (elfun-derive-type-simple
    (if (numeric-type-real-p x)
        (abs-derive-type-aux x)
        x)
-   #'cosh (constantly t) 0 nil))
+   #'cosh (specifier-type 'real) 0 nil))
 
 (defoptimizer (cosh derive-type) ((num))
   (one-arg-derive-type num #'cosh-derive-type-aux #'cosh))
 
 
 (defun phase-derive-type-aux (type)
-  ;; Warning: This optimizer doesn't yet handle the case of -0.0.
-  ;; It returns 0 for this case instead of pi.  Need to fix this.
   (cond ((numeric-type-real-p type)
-	 (case (interval-range-info (numeric-type->interval type))
+	 (case (interval-range-info (numeric-type->interval type) 0.0)
 	   ('+
 	    ;; The number is positive, so the phase is 0.
 	    (make-numeric-type :class 'float
@@ -1256,7 +1200,7 @@
 	       ;; Divide a complex by a float
 	       (deftransform / ((w z) ((complex ,type) ,type) *)
 		 '(complex (/ (realpart w) z) (/ (imagpart w) z)))
-	       ;; Conjugate of a float or complex number
+	       ;; Conjugate of complex number
 	       (deftransform conjugate ((z) ((complex ,type)) *)
 		 '(complex (realpart z) (- (imagpart z))))
 	       ;; Cis.
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index ef931bfb3..aaa53c2f8 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.68 1997/12/21 00:14:51 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.69 1998/01/05 05:54:58 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -384,14 +384,18 @@
 ;;;
 (defun interval-range-info (x &optional (point 0))
   (declare (type interval x))
-  (let ((lo (interval-low x))
-	(hi (interval-high x)))
-  (cond ((and lo (>= (bound-value lo) point))
-	 '+)
-	((and hi (<= (bound-value hi) point))
-	 '-)
-	(t
-	 nil))))
+  (labels ((signed->= (x y)
+	     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+		 (>= (float-sign x) (float-sign y))
+		 (>= x y))))
+    (let ((lo (interval-low x))
+	  (hi (interval-high x)))
+      (cond ((and lo (signed->= (bound-value lo) point))
+	     '+)
+	    ((and hi (signed->= point (bound-value hi)))
+	     '-)
+	    (t
+	     nil)))))
 
 ;;; INTERVAL-BOUNDED-P
 ;;;
@@ -833,6 +837,149 @@
 	  nil
 	  new-args))))
 
+;;; Convert from the standard type convention for which -0.0 and 0.0
+;;; and equal to an intermediate convention for which they are
+;;; considered different which is more natural for some of the
+;;; optimisers.
+;;;
+#-negative-zero-is-not-zero
+(defun convert-numeric-type (type)
+  (declare (type numeric-type type))
+  ;;; Only convert real float interval delimiters types.
+  (if (eq (numeric-type-complexp type) :real)
+      (let* ((lo (numeric-type-low type))
+	     (lo-val (bound-value lo))
+	     (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
+	     (hi (numeric-type-high type))
+	     (hi-val (bound-value hi))
+	     (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
+	(if (or lo-float-zero-p hi-float-zero-p)
+	    (make-numeric-type
+	     :class (numeric-type-class type)
+	     :format (numeric-type-format type)
+	     :complexp :real
+	     :low (if lo-float-zero-p
+		      (if (consp lo)
+			  (list (float 0.0 lo-val))
+			  (float -0.0 lo-val))
+		      lo)
+	     :high (if hi-float-zero-p
+		       (if (consp hi)
+			   (list (float -0.0 hi-val))
+			   (float 0.0 hi-val))
+		       hi))
+	    type))
+      ;; Not real float.
+      type))
+
+;;; Convert from the standard type convention for which -0.0 and 0.0
+;;; and equal to an intermediate convention for which they are
+;;; considered different which is more natural for some of the
+;;; optimisers.
+;;;
+#-negative-zero-is-not-zero
+(defun convert-back-numeric-type (type)
+  (declare (type numeric-type type))
+  ;;; Only convert real float interval delimiters types.
+  (if (eq (numeric-type-complexp type) :real)
+      (let* ((lo (numeric-type-low type))
+	     (lo-val (bound-value lo))
+	     (lo-float-zero-p
+	      (and lo (floatp lo-val) (= lo-val 0.0)
+		   (float-sign lo-val)))
+	     (hi (numeric-type-high type))
+	     (hi-val (bound-value hi))
+	     (hi-float-zero-p
+	      (and hi (floatp hi-val) (= hi-val 0.0)
+		   (float-sign hi-val))))
+	(cond
+	  ;; (float +0.0 +0.0) => (member 0.0)
+	  ;; (float -0.0 -0.0) => (member -0.0)
+	  ((and lo-float-zero-p hi-float-zero-p)
+	   ;; Shouldn't have exclusive bounds here.
+	   (assert (and (not (consp lo)) (not (consp hi))))
+	   (if (= lo-float-zero-p hi-float-zero-p)
+	       ;; (float +0.0 +0.0) => (member 0.0)
+	       ;; (float -0.0 -0.0) => (member -0.0)
+	       (specifier-type `(member ,lo-val))
+	       ;; (float -0.0 +0.0) => (float 0.0 0.0)
+	       ;; (float +0.0 -0.0) => (float 0.0 0.0)
+	       (make-numeric-type :class (numeric-type-class type)
+				  :format (numeric-type-format type)
+				  :complexp :real
+				  :low hi-val
+				  :high hi-val)))
+	  (lo-float-zero-p
+	   (cond
+	     ;; (float -0.0 x) => (float 0.0 x)
+	     ((and (not (consp lo)) (minusp lo-float-zero-p))
+	      (make-numeric-type :class (numeric-type-class type)
+				 :format (numeric-type-format type)
+				 :complexp :real
+				 :low (float 0.0 lo-val)
+				 :high hi))
+	     ;; (float (+0.0) x) => (float (0.0) x)
+	     ((and (consp lo) (plusp lo-float-zero-p))
+	      (make-numeric-type :class (numeric-type-class type)
+				 :format (numeric-type-format type)
+				 :complexp :real
+				 :low (list (float 0.0 lo-val))
+				 :high hi))
+	     (t
+	      ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
+	      ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
+	      (list (specifier-type `(member ,(float 0.0 lo-val)))
+		    (make-numeric-type :class (numeric-type-class type)
+				       :format (numeric-type-format type)
+				       :complexp :real
+				       :low (list (float 0.0 lo-val))
+				       :high hi)))))
+	  (hi-float-zero-p
+	   (cond
+	     ;; (float x +0.0) => (float x 0.0)
+	     ((and (not (consp hi)) (plusp hi-float-zero-p))
+	      (make-numeric-type :class (numeric-type-class type)
+				 :format (numeric-type-format type)
+				 :complexp :real
+				 :low lo
+				 :high (float 0.0 hi-val)))
+	     ;; (float x (-0.0)) => (float x (0.0))
+	     ((and (consp hi) (minusp hi-float-zero-p))
+	      (make-numeric-type :class (numeric-type-class type)
+				 :format (numeric-type-format type)
+				 :complexp :real
+				 :low lo
+				 :high (list (float 0.0 hi-val))))
+	     (t
+	      ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
+	      ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
+	      (list (specifier-type `(member ,(float -0.0 hi-val)))
+		    (make-numeric-type :class (numeric-type-class type)
+				       :format (numeric-type-format type)
+				       :complexp :real
+				       :low lo
+				       :high (list (float 0.0 hi-val)))))))
+	  (t
+	   type)))
+      ;; Not real float.
+      type))
+
+;;; Convert back a possible list of numeric types.
+;;;
+#-negative-zero-is-not-zero
+(defun convert-back-numeric-type-list (type-list)
+  (declare (type (or list numeric-type) type-list))
+  (cond ((listp type-list)
+	 (collect ((results))
+		  (dolist (type type-list)
+		    (results (if (numeric-type-p type)
+				 (convert-back-numeric-type type)
+				 type)))
+		  (results)))
+	((numeric-type-p type-list)
+	 (convert-back-numeric-type type-list))
+	(t
+	 type-list)))
 
 ;;; ONE-ARG-DERIVE-TYPE
 ;;;
@@ -848,7 +995,7 @@
 ;;; For the case of member types, we call FCN on the element of the
 ;;; member type to get the resulting member type result.
 ;;;
-(defun one-arg-derive-type (arg derive-fcn fcn)
+(defun one-arg-derive-type (arg derive-fcn fcn &optional (convert-type t))
   (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
     (when arg-list
       (flet ((deriver (x)
@@ -860,6 +1007,12 @@
 		     `(member
 		       ,(funcall fcn (first (member-type-members x)))))))
 		 (numeric-type
+		  #-negative-zero-is-not-zero
+		  (if convert-type
+		      (convert-back-numeric-type-list
+		       (funcall derive-fcn (convert-numeric-type x)))
+		      (funcall derive-fcn x))
+		  #+negative-zero-is-not-zero
 		  (funcall derive-fcn x))
 		 (t
 		  *universal-type*))))
@@ -879,7 +1032,8 @@
 ;;; deriving the type of things like (* x x), which should always be
 ;;; positive.  If we didn't do this, we wouldn't be able to tell.
 ;;;
-(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn)
+(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
+				 &optional (convert-type t))
   (labels ((convert-member-type (arg)
 	     (let* ((val (first (member-type-members arg)))
 		    (val-type (type-of val)))
@@ -887,6 +1041,41 @@
 				      'integer
 				      val-type)
 				 ,val ,val))))
+	   ;;
+	   #-negative-zero-is-not-zero
+	   (deriver (x y same-arg)
+	     (cond ((and (member-type-p x) (member-type-p y))
+		    (let* ((x (first (member-type-members x)))
+			   (y (first (member-type-members y)))
+			   (result (with-float-traps-masked
+				       (:underflow :overflow :divide-by-zero)
+				     (funcall fcn x y))))
+		      (if result
+			  (specifier-type `(member ,result)))))
+		   ((and (member-type-p x) (numeric-type-p y))
+		    (let* ((x (convert-member-type x))
+			   (y (if convert-type (convert-numeric-type y) y))
+			   (result (funcall derive-fcn x y same-arg)))
+		      (if convert-type
+			  (convert-back-numeric-type-list result)
+			  result)))
+		   ((and (numeric-type-p x) (member-type-p y))
+		    (let* ((x (if convert-type (convert-numeric-type x) x))
+			   (y (convert-member-type y))
+			   (result (funcall derive-fcn x y same-arg)))
+		      (if convert-type
+			  (convert-back-numeric-type-list result)
+			  result)))
+		   ((and (numeric-type-p x) (numeric-type-p y))
+		    (let* ((x (if convert-type (convert-numeric-type x) x))
+			   (y (if convert-type (convert-numeric-type y) y))
+			   (result (funcall derive-fcn x y same-arg)))
+		      (if convert-type
+			  (convert-back-numeric-type-list result)
+			  result)))
+		   (t
+		    *universal-type*)))
+	   #+negative-zero-is-not-zero
 	   (deriver (x y same-arg)
 	     (cond ((and (member-type-p x) (member-type-p y))
 		    (let* ((x (first (member-type-members x)))
@@ -1260,16 +1449,6 @@
 #+propagate-float-type
 (progn
 
-;;; Check to see that the type is either a real numeric-type or is a
-;;; union of real numeric-types.
-(defun numeric-real-union-type-p (type)
-  (cond ((csubtypep type (specifier-type 'real))
-	 t)
-	((union-type-p type)
-	 (every #'(lambda (x)
-		    (csubtypep x (specifier-type 'real)))
-		(union-type-types type)))))
-
 (defun rem-result-type (number-type divisor-type)
   ;; Figure out what the remainder type is.  The remainder is an
   ;; integer if both args are integers; a rational if both args are
@@ -1379,8 +1558,10 @@
   (make-values-type
    :required
    (list
-    (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux #'truncate)
-    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem))))
+    (two-arg-derive-type number divisor
+			 #'truncate-derive-type-quot-aux #'truncate)
+    (two-arg-derive-type number divisor
+			 #'truncate-derive-type-rem-aux #'rem))))
 
 (defun ftruncate-derive-type-quot (number-type divisor-type)
   ;; The bounds are the same as for truncate.  However, the first
@@ -1404,8 +1585,10 @@
   (make-values-type
    :required
    (list
-    (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux #'ftruncate)
-    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem))))
+    (two-arg-derive-type number divisor
+			 #'ftruncate-derive-type-quot-aux #'ftruncate)
+    (two-arg-derive-type number divisor
+			 #'truncate-derive-type-rem-aux #'rem))))
 
 
 (defun %unary-truncate-derive-type-aux (number)
@@ -2550,9 +2733,11 @@
 	  (give-up))
 	(if (minusp val) minus-result result)))))
 
-;;; Fold (expt x n) into multiplications for small integral values of N.
+;;; Fold (expt x n) into multiplications for small integral values of
+;;; N; convert (expt x 1/2) to sqrt.
+;;;
 (deftransform expt ((x y) (t (constant-argument real)) *)
-  "recode as multiplication"
+  "recode as multiplication or sqrt"
   (let ((val (continuation-value y)))
     ;; If Y would cause the result to be promoted to the same type as
     ;; Y, we give up.  If not, then the result will be the same type
@@ -2565,6 +2750,8 @@
 	  ((= val -2) '(/ (* x x)))
 	  ((= val 3) '(* x x x))
 	  ((= val -3) '(/ (* x x x)))
+	  ((= val 1/2) '(sqrt x))
+	  ((= val -1/2) '(/ (sqrt x)))
 	  (t (give-up)))))
 
 (dolist (name '(ash /))
-- 
GitLab