0.8.4.4:

	Fix bignum/bignum ASH bug (PFD sbcl-devel 2003-09-22)
	... one-liner fix, yum yum
	Add SIGNUM derive-type optimizer
	... not strictly necessary any more as we now ignore errors when
		deriving types, but since I wrote it, why not?

diff --git a/NEWS b/NEWS
index 729dd09..9ab2e1f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2117,12 +2117,16 @@ changes in sbcl-0.8.5 relative to sbcl-0.8.4:
   * fix bug 214: algorithm for noting rejected templates is now more
     similar to that of template seletion. (also reported by rydis on
     #lisp)
+  * compiler enhancement: SIGNUM is now better able to derive the type
+    of its result.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** incorrect optimization of TRUNCATE for a positive first
        argument and negative second.
     ** compiler failure in let-convertion during flushing dead code.
     ** compiler failure while deriving type of TRUNCATE on an
        interval, containing 0.
+    ** ASH of a negative bignum by a negative bignum count now returns
+       -1, not 0.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp
index 03f2337..c0606e6 100644 (file)
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -749,7 +749,7 @@
                                       (%normalize-bignum res res-len))
                                      res)))))
          ((> count bignum-len)
-          0)
+          (if (%bignum-0-or-plusp bignum bignum-len) 0 -1))
           ;; Since a FIXNUM should be big enough to address anything in
           ;; memory, including arrays of bits, and since arrays of bits
           ;; take up about the same space as corresponding fixnums, there

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index e43395a..fe7f950 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1022,10 +1022,9 @@
                  (if member-fun
                      (with-float-traps-masked
                          (:underflow :overflow :divide-by-zero)
-                       (make-member-type
-                        :members (list
-                                  (funcall member-fun
-                                           (first (member-type-members x))))))
+                       (specifier-type
+                        `(eql ,(funcall member-fun
+                                        (first (member-type-members x))))))
                      ;; Otherwise convert to a numeric type.
                      (let ((result-type-list
                             (funcall derive-fun (convert-member-type x))))
@@ -1075,7 +1074,7 @@
                                              :format (type-of result)
                                              :complexp :real))
                          (t
-                          (make-member-type :members (list result))))))
+                          (specifier-type `(eql ,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))
@@ -2301,6 +2300,45 @@
 
 (defoptimizer (values derive-type) ((&rest values))
   (make-values-type :required (mapcar #'lvar-type values)))
+
+(defun signum-derive-type-aux (type)
+  (if (eq (numeric-type-complexp type) :complex)
+      (let* ((format (case (numeric-type-class type)
+                         ((integer rational) 'single-float)
+                         (t (numeric-type-format type))))
+               (bound-format (or format 'float)))
+          (make-numeric-type :class 'float
+                             :format format
+                             :complexp :complex
+                             :low (coerce -1 bound-format)
+                             :high (coerce 1 bound-format)))
+      (let* ((interval (numeric-type->interval type))
+            (range-info (interval-range-info interval))
+            (contains-0-p (interval-contains-p 0 interval))
+            (class (numeric-type-class type))
+            (format (numeric-type-format type))
+            (one (coerce 1 (or format class 'real)))
+            (zero (coerce 0 (or format class 'real)))
+            (minus-one (coerce -1 (or format class 'real)))
+            (plus (make-numeric-type :class class :format format
+                                     :low one :high one))
+            (minus (make-numeric-type :class class :format format
+                                      :low minus-one :high minus-one))
+            ;; KLUDGE: here we have a fairly horrible hack to deal
+            ;; with the schizophrenia in the type derivation engine.
+            ;; The problem is that the type derivers reinterpret
+            ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
+            ;; 0d0) within the derivation mechanism doesn't include
+            ;; -0d0.  Ugh.  So force it in here, instead.
+            (zero (make-numeric-type :class class :format format
+                                     :low (- zero) :high zero)))
+       (case range-info
+         (+ (if contains-0-p (type-union plus zero) plus))
+         (- (if contains-0-p (type-union minus zero) minus))
+         (t (type-union minus zero plus))))))
+
+(defoptimizer (signum derive-type) ((num))
+  (one-arg-derive-type num #'signum-derive-type-aux nil))
 \f
 ;;;; byte operations
 ;;;;

diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 6e13aea..959e2c1 100644 (file)
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -199,3 +199,7 @@
             ((89 125 16) (ASH A (MIN 18 -706)))
             (T (DPB -3 (BYTE 30 30) -1)))))))
   (assert (= (funcall fn 1227072 -529823 -18 -792831) -2147483649)))
+
+;;; ASH of a negative bignum by a bignum count would erroneously
+;;; return 0 prior to sbcl-0.8.4.4
+(assert (= (ash (1- most-negative-fixnum) (1- most-negative-fixnum)) -1))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6c8ea3c..c029261 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.4.3"
+"0.8.4.4"