[Sbcl-commits] CVS: sbcl/src/compiler float-tran.lisp,1.35,1.36 srctran.lisp,1.116,1.117

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29059/src/compiler

Modified Files:
	float-tran.lisp srctran.lisp 
Log Message:
0.8.21.2:
	Merge mainly MISC fixes held over from pre-freeze


Index: float-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/float-tran.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- float-tran.lisp	7 Mar 2005 06:53:17 -0000	1.35
+++ float-tran.lisp	27 Mar 2005 18:34:45 -0000	1.36
@@ -238,10 +238,18 @@
 	    (ex-hi (numeric-type-high ex))
 	    (new-lo nil)
 	    (new-hi nil))
-	(when (and f-hi ex-hi)
-	  (setf new-hi (scale-bound f-hi ex-hi)))
-	(when (and f-lo ex-lo)
-	  (setf new-lo (scale-bound f-lo ex-lo)))
+	(when f-hi
+	  (if (< (float-sign (type-bound-number f-hi)) 0.0)
+	      (when ex-lo
+		(setf new-hi (scale-bound f-hi ex-lo)))
+	      (when ex-hi
+		(setf new-hi (scale-bound f-hi ex-hi)))))
+	(when f-lo
+	  (if (< (float-sign (type-bound-number f-lo)) 0.0)
+	      (when ex-hi
+		(setf new-lo (scale-bound f-lo ex-hi)))
+	      (when ex-lo
+		(setf new-lo (scale-bound f-lo ex-lo)))))
 	(make-numeric-type :class (numeric-type-class f)
 			   :format (numeric-type-format f)
 			   :complexp :real
@@ -624,9 +632,7 @@
   (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))
+	    (complex-float-type arg))
 	   ((numeric-type-real-p arg)
 	    ;; The argument is real, so let's find the intersection
 	    ;; between the argument and the domain of the function.
@@ -1297,20 +1303,34 @@
 			   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))?
-;;; Or (EQL #C(1 2))?
 (defoptimizer (conjugate derive-type) ((num))
-  (lvar-type num))
+  (one-arg-derive-type num
+    (lambda (arg)
+      (flet ((most-negative-bound (l h)
+	       (and l h
+		    (if (< (type-bound-number l) (- (type-bound-number h)))
+			l
+			(set-bound (- (type-bound-number h)) (consp h)))))
+	     (most-positive-bound (l h)
+	       (and l h
+		    (if (> (type-bound-number h) (- (type-bound-number l)))
+			h
+			(set-bound (- (type-bound-number l)) (consp l))))))
+	(if (numeric-type-real-p arg)
+	    (lvar-type num)
+	    (let ((low (numeric-type-low arg))
+		  (high (numeric-type-high arg)))
+	      (let ((new-low (most-negative-bound low high))
+		    (new-high (most-positive-bound low high)))
+	      (modified-numeric-type arg :low new-low :high new-high))))))
+    #'conjugate))
 
 (defoptimizer (cis derive-type) ((num))
   (one-arg-derive-type num
-     (lambda (arg)
-       (sb!c::specifier-type
-	`(complex ,(or (numeric-type-format arg) 'float))))
-     #'cis))
+    (lambda (arg)
+      (sb!c::specifier-type
+       `(complex ,(or (numeric-type-format arg) 'float))))
+    #'cis))
 
 ) ; PROGN
 

Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.116
retrieving revision 1.117
diff -u -d -r1.116 -r1.117
--- srctran.lisp	19 Dec 2004 07:01:08 -0000	1.116
+++ srctran.lisp	27 Mar 2005 18:34:46 -0000	1.117
@@ -3105,19 +3105,27 @@
 
 ;;; similarly to the EQL transform above, we attempt to constant-fold
 ;;; or convert to a simpler predicate: mostly we have to be careful
-;;; with strings.
+;;; with strings and bit-vectors.
 (deftransform equal ((x y) * *)
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
 	(y-type (lvar-type y))
-	(string-type (specifier-type 'string)))
+	(string-type (specifier-type 'string))
+	(bit-vector-type (specifier-type 'bit-vector)))
     (cond
       ((same-leaf-ref-p x y) t)
       ((and (csubtypep x-type string-type)
 	    (csubtypep y-type string-type))
        '(string= x y))
-      ((and (or (not (types-equal-or-intersect x-type string-type))
-		(not (types-equal-or-intersect y-type string-type)))
+      ((and (csubtypep x-type bit-vector-type)
+	    (csubtypep y-type bit-vector-type))
+       '(bit-vector-= x y))
+      ;; if at least one is not a string, and at least one is not a
+      ;; bit-vector, then we can reason from types.
+      ((and (not (and (types-equal-or-intersect x-type string-type)
+		      (types-equal-or-intersect y-type string-type)))
+	    (not (and (types-equal-or-intersect x-type bit-vector-type)
+		      (types-equal-or-intersect y-type bit-vector-type)))
 	    (not (types-equal-or-intersect x-type y-type)))
        nil)
       (t (give-up-ir1-transform)))))