X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=4679da2fcc239721a2f2349032e78a5a24bd547a;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=bdcbec7e5ffce891722a3dd38bdfaee4ede8052c;hpb=fcde5281a74cb29e21550f4f979ad6356f149ab9;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index bdcbec7..4679da2 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -29,12 +29,14 @@
 (define-source-transform identity (x) `(prog1 ,x))
 (define-source-transform values (x) `(prog1 ,x))
 
-;;; Bind the values and make a closure that returns them.
+;;; Bind the value and make a closure that returns it.
 (define-source-transform constantly (value)
-  (let ((rest (gensym "CONSTANTLY-REST-")))
-    `(lambda (&rest ,rest)
-       (declare (ignore ,rest))
-       ,value)))
+  (let ((rest (gensym "CONSTANTLY-REST-"))
+	(n-value (gensym "CONSTANTLY-VALUE-")))
+    `(let ((,n-value ,value))
+      (lambda (&rest ,rest)
+	(declare (ignore ,rest))
+	,n-value))))
 
 ;;; If the function has a known number of arguments, then return a
 ;;; lambda with the appropriate fixed number of args. If the
@@ -815,7 +817,6 @@
 ;;; are 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.
@@ -848,7 +849,6 @@
 ;;; Convert back from the intermediate convention for which -0.0 and
 ;;; 0.0 are considered different to the standard type convention for
 ;;; which and equal.
-#!-negative-zero-is-not-zero
 (defun convert-back-numeric-type (type)
   (declare (type numeric-type type))
   ;;; Only convert real float interval delimiters types.
@@ -936,7 +936,6 @@
       type))
 
 ;;; Convert back a possible list of numeric types.
-#!-negative-zero-is-not-zero
 (defun convert-back-numeric-type-list (type-list)
   (typecase type-list
     (list
@@ -974,22 +973,13 @@
 	  (push type misc-types)))
     #!+long-float
     (when (null (set-difference '(-0l0 0l0) members))
-      #!-negative-zero-is-not-zero
       (push (specifier-type '(long-float 0l0 0l0)) misc-types)
-      #!+negative-zero-is-not-zero
-      (push (specifier-type '(long-float -0l0 0l0)) misc-types)
       (setf members (set-difference members '(-0l0 0l0))))
     (when (null (set-difference '(-0d0 0d0) members))
-      #!-negative-zero-is-not-zero
       (push (specifier-type '(double-float 0d0 0d0)) misc-types)
-      #!+negative-zero-is-not-zero
-      (push (specifier-type '(double-float -0d0 0d0)) misc-types)
       (setf members (set-difference members '(-0d0 0d0))))
     (when (null (set-difference '(-0f0 0f0) members))
-      #!-negative-zero-is-not-zero
       (push (specifier-type '(single-float 0f0 0f0)) misc-types)
-      #!+negative-zero-is-not-zero
-      (push (specifier-type '(single-float -0f0 0f0)) misc-types)
       (setf members (set-difference members '(-0f0 0f0))))
     (if members
 	(apply #'type-union (make-member-type :members members) misc-types)
@@ -1021,8 +1011,7 @@
 (defun one-arg-derive-type (arg derive-fcn member-fcn
 				&optional (convert-type t))
   (declare (type function derive-fcn)
-	   (type (or null function) member-fcn)
-	   #!+negative-zero-is-not-zero (ignore convert-type))
+	   (type (or null function) member-fcn))
   (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
     (when arg-list
       (flet ((deriver (x)
@@ -1038,20 +1027,14 @@
 		      ;; Otherwise convert to a numeric type.
 		      (let ((result-type-list
 			     (funcall derive-fcn (convert-member-type x))))
-			#!-negative-zero-is-not-zero
 			(if convert-type
 			    (convert-back-numeric-type-list result-type-list)
-			    result-type-list)
-			#!+negative-zero-is-not-zero
-			result-type-list)))
+			    result-type-list))))
 		 (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))
+		      (funcall derive-fcn x)))
 		 (t
 		  *universal-type*))))
 	;; Run down the list of args and derive the type of each one,
@@ -1075,10 +1058,7 @@
 (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
 				 &optional (convert-type t))
   (declare (type function derive-fcn fcn))
-  #!+negative-zero-is-not-zero
-  (declare (ignore convert-type))
-  (flet (#!-negative-zero-is-not-zero
-	 (deriver (x y same-arg)
+  (flet ((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)))
@@ -1115,26 +1095,6 @@
 			(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)))
-			 (y (first (member-type-members y)))
-			 (result (with-float-traps-masked
-				     (:underflow :overflow :divide-by-zero)
-				   (funcall fcn x y))))
-		    (if result
-			(make-member-type :members (list result)))))
-		 ((and (member-type-p x) (numeric-type-p y))
-		  (let ((x (convert-member-type x)))
-		    (funcall derive-fcn x y same-arg)))
-		 ((and (numeric-type-p x) (member-type-p y))
-		  (let ((y (convert-member-type y)))
-		    (funcall derive-fcn x y same-arg)))
-		 ((and (numeric-type-p x) (numeric-type-p y))
-		  (funcall derive-fcn x y same-arg))
-		 (t
 		  *universal-type*))))
     (let ((same-arg (same-leaf-ref-p arg1 arg2))
 	  (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
@@ -1345,16 +1305,19 @@
 
 ) ; PROGN
 
-
-;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
-;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
-;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
-;;; and it's hard to avoid that calculation in here.
-#-(and cmu sb-xc-host)
-(progn
-
 (defun ash-derive-type-aux (n-type shift same-arg)
   (declare (ignore same-arg))
+  ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
+  ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
+  ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
+  ;; two bignums yielding zero) and it's hard to avoid that
+  ;; calculation in here.
+  #+(and cmu sb-xc-host)
+  (when (and (or (typep (numeric-type-low n-type) 'bignum)
+		 (typep (numeric-type-high n-type) 'bignum))
+	     (or (typep (numeric-type-low shift) 'bignum)
+		 (typep (numeric-type-high shift) 'bignum)))
+    (return-from ash-derive-type-aux *universal-type*))
   (flet ((ash-outer (n s)
 	   (when (and (fixnump s)
 		      (<= s 64)
@@ -1387,7 +1350,6 @@
 
 (defoptimizer (ash derive-type) ((n shift))
   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
-) ; PROGN
 
 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (macrolet ((frob (fun)
@@ -2587,7 +2549,8 @@
     (or result 0)))
 
 ;;; If arg is a constant power of two, turn FLOOR into a shift and
-;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR.
+;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
+;;; remainder.
 (flet ((frob (y ceil-p)
 	 (unless (constant-continuation-p y)
 	   (give-up-ir1-transform))
@@ -2597,13 +2560,14 @@
 	   (unless (= y-abs (ash 1 len))
 	     (give-up-ir1-transform))
 	   (let ((shift (- len))
-		 (mask (1- y-abs)))
-	     `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+		 (mask (1- y-abs))
+                 (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
+	     `(let ((x (+ x ,delta)))
 		,(if (minusp y)
 		     `(values (ash (- x) ,shift)
-			      (- (logand (- x) ,mask)))
+			      (- (- (logand (- x) ,mask)) ,delta))
 		     `(values (ash x ,shift)
-			      (logand x ,mask))))))))
+			      (- (logand x ,mask) ,delta))))))))
   (deftransform floor ((x y) (integer integer) *)
     "convert division by 2^k to shift"
     (frob y nil))
@@ -3245,6 +3209,7 @@
      (let* ((specifier (continuation-value type))
 	    (result-typeoid (careful-specifier-type specifier)))
        (cond
+	 ((null result-typeoid) nil)
 	 ((csubtypep result-typeoid (specifier-type 'number))
 	  ;; the difficult case: we have to cope with ANSI 12.1.5.3
 	  ;; Rule of Canonical Representation for Complex Rationals,
@@ -3383,7 +3348,7 @@
 (defoptimizer (compile derive-type) ((nameoid function))
   (when (csubtypep (continuation-type nameoid)
 		   (specifier-type 'null))
-    (specifier-type 'function)))
+    (values-specifier-type '(values function boolean boolean))))
 
 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE