0.8.2.26:

        * Fix bug in the portable implementation of SB-MD5::I;
        * add support for modular functions with argument number
          different from 2;
        * SB!C::CUT-TO-WIDTH: derive node type from the type
          declaration;
        * on x86 reimplement LOGNOT as a modular function and
          implement 32BIT-LOGICAL-NOT in terms of LOGNOT;
        ... remove optimization of LOGNOT with LOGAND dest.

diff --git a/BUGS b/BUGS
index 9e5139a..98ea647 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1061,6 +1061,22 @@ WORKAROUND:
 269:
   SCALE-FLOAT should accept any integer for its second argument.
 
+270:
+  In the following function constraint propagator optimizes nothing:
+
+    (defun foo (x)
+      (declare (integer x))
+      (declare (optimize speed))
+      (typecase x
+        (fixnum "hala")
+        (fixnum "buba")
+        (bignum "hip")
+        (t "zuz")))
+
+271:
+  Cross-compiler cannot perform constant folding of some internal
+  functions, such as %NEGATE.
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp
index 9eee945..e362f74 100644 (file)
--- a/contrib/sb-md5/md5.lisp
+++ b/contrib/sb-md5/md5.lisp
@@ -117,7 +117,7 @@ where a is the intended low-order byte and d the high-order byte."
   #+sbcl
   (sb-kernel:32bit-logical-xor y (sb-kernel:32bit-logical-orc2 x z))  
   #-(or cmu sbcl)
-  (logxor y (logorc2 x z)))
+  (ldb (byte 32 0) (logxor y (logorc2 x z))))
 
 (declaim (inline mod32+)
         (ftype (function (ub32 ub32) ub32) mod32+))

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 7a17b29..0539b31 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1340,10 +1340,10 @@
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name width pattern)
+  (flet ((definition (name lambda-list width pattern)
            ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
            ;;                      'BIGNUM-ELEMENT-TYPE)
-           `(defun ,name (x y)
+           `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
                        (etypecase x
@@ -1351,10 +1351,14 @@
                          (bignum-element-type (logand x ,pattern))
                          (fixnum (logand x ,pattern))
                          (bignum (logand (%bignum-ref x 0) ,pattern)))))
-                (,name (prepare-argument x) (prepare-argument y))))))
-    (loop for info being each hash-value of sb!c::*modular-funs*
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of sb!c::*modular-funs*
           ;; FIXME: We need to process only "toplevel" functions
-          do (loop for (width . name) in info
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
                    for pattern = (1- (ash 1 width))
-                   do (forms (definition name width pattern)))))
+                   do (forms (definition name lambda-list width pattern)))))
   `(progn ,@(forms)))

diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index 94e8b39..2984db4 100644 (file)
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -158,32 +158,51 @@
 
 ;;; List of increasing widths
 (defvar *modular-funs-widths* nil)
+(defstruct modular-fun-info
+  (name (missing-arg) :type symbol)
+  (width (missing-arg) :type (integer 0))
+  (lambda-list (missing-arg) :type list)
+  (prototype (missing-arg) :type symbol))
 
 (defun find-modular-version (fun-name width)
-  (let ((info (gethash fun-name *modular-funs*)))
-    (cdr (find-if (lambda (item-width) (>= item-width width))
-                  info
-                  :key #'car))))
-
-(defun %define-modular-fun (name prototype width)
-  (let* ((list (gethash prototype *modular-funs*))
-         (entry (assoc width list)))
-    (if entry
-        (unless (eq name (cdr entry))
-          (setf (cdr entry) name)
+  (let ((infos (gethash fun-name *modular-funs*)))
+    (find-if (lambda (item-width) (>= item-width width))
+             infos
+             :key #'modular-fun-info-width)))
+
+(defun %define-modular-fun (name lambda-list prototype width)
+  (let* ((infos (the list (gethash prototype *modular-funs*)))
+         (info (find-if (lambda (item-width) (= item-width width))
+                        infos
+                        :key #'modular-fun-info-width)))
+    (if info
+        (unless (and (eq name (modular-fun-info-name info))
+                     (= (length lambda-list)
+                        (length (modular-fun-info-lambda-list info))))
+          (setf (modular-fun-info-name info) name)
           (style-warn "Redefining modular version ~S of ~S for width ~S."
                       name prototype width))
         (setf (gethash prototype *modular-funs*)
-              (merge 'list (list (cons width name)) list #'<))))
+              (merge 'list
+                     (list (make-modular-fun-info :name name
+                                                  :width width
+                                                  :lambda-list lambda-list
+                                                  :prototype prototype))
+                     infos
+                     #'< :key #'modular-fun-info-width))))
   (setq *modular-funs-widths*
         (merge 'list (list width) *modular-funs-widths* #'<)))
 
-(defmacro define-modular-fun (name prototype width)
+(defmacro define-modular-fun (name lambda-list prototype width)
   (check-type name symbol)
   (check-type prototype symbol)
   (check-type width unsigned-byte)
+  (dolist (arg lambda-list)
+    (when (member arg lambda-list-keywords)
+      (error "Lambda list keyword ~S is not supported for ~
+              modular function lambda lists." arg)))
   `(progn
-     (%define-modular-fun ',name ',prototype ,width)
-     (defknown ,name (integer integer) (unsigned-byte ,width)
-               (foldable flushable movable))
-     ))
+     (%define-modular-fun ',name ',lambda-list ',prototype ,width)
+     (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
+               (unsigned-byte ,width)
+               (foldable flushable movable))))

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 8e82df7..d5937ba 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -391,6 +391,7 @@
 
 \f
 ;;;; 32-bit operations
+#!-x86 ; on X86 it is a modular function
 (deftransform lognot ((x) ((unsigned-byte 32)) *
                       :node node
                       :result result)

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 79e0c45..e79babe 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -445,6 +445,7 @@
          (multiple-value-bind (code-length trace-table fixups)
              (generate-code component)
 
+            #-sb-xc-host
            (when *compiler-trace-output*
              (format *compiler-trace-output*
                      "~|~%disassembly of code for ~S~2%" component)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 943e291..89747f7 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2441,8 +2441,12 @@
             (logand int (lognot mask)))))
 \f
 ;;; modular functions
+;;;
+;;; -- lower N bits of a result depend only on lower N bits of
+;;; arguments.
 
-;;; Try to cut all uses of the continuation CONT to WIDTH bits.
+;;; Try to recursively cut all uses of the continuation CONT to WIDTH
+;;; bits.
 (defun cut-to-width (cont width)
   (declare (type continuation cont) (type (integer 0) width))
   (labels ((cut-node (node)
@@ -2450,15 +2454,16 @@
                         (fun-info-p (basic-combination-kind node)))
                (let* ((fun-ref (continuation-use (combination-fun node)))
                       (fun-name (leaf-source-name (ref-leaf fun-ref)))
-                      (modular-fun-name (find-modular-version fun-name width)))
-                 (when modular-fun-name
+                      (modular-fun (find-modular-version fun-name width))
+                      (name (and modular-fun
+                                 (modular-fun-info-name modular-fun))))
+                 (when modular-fun
                    (change-ref-leaf fun-ref
-                                    (find-free-fun modular-fun-name
-                                                   "in a strange place"))
+                                    (find-free-fun name "in a strange place"))
                    (setf (combination-kind node) :full)
                    (setf (node-derived-type node)
-                         (values-specifier-type `(values (unsigned-byte ,width)
-                                                         &optional)))
+                         (fun-type-returns
+                          (info :function :type name)))
                    (setf (continuation-%derived-type (node-cont node)) nil)
                    (setf (node-reoptimize node) t)
                    (setf (block-reoptimize (node-block node)) t)

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index fa50482..c4444e0 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -997,22 +997,8 @@
   (:result-types unsigned-num)
   (:policy :fast-safe))
 
-(define-vop (32bit-logical-not)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg) :target r
-           :load-if (not (and (sc-is x unsigned-stack)
-                              (sc-is r unsigned-stack)
-                              (location= x r)))))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)
-              :load-if (not (and (sc-is x unsigned-stack)
-                                 (sc-is r unsigned-stack)
-                                 (location= x r)))))
-  (:result-types unsigned-num)
-  (:policy :fast-safe)
-  (:generator 1
-    (move r x)
-    (inst not r)))
+(define-source-transform 32bit-logical-not (x)
+  `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
 
 (define-vop (32bit-logical-and 32bit-logical)
   (:translate 32bit-logical-and)
@@ -1390,8 +1376,8 @@
     (inst shr tmp 18)
     (inst xor y tmp)))
 \f
-;;; Modular functions
-(define-modular-fun +-mod32 + 32)
+;;;; Modular functions
+(define-modular-fun +-mod32 (x y) + 32)
 
 (define-vop (fast-+-mod32/unsigned=>unsigned fast-safe-arith-op)
   (:translate +-mod32)
@@ -1415,3 +1401,23 @@
          (t
           (move r x)
           (inst add r y)))))
+
+;;; logical operations
+(define-modular-fun lognot-mod32 (x) lognot 32)
+
+(define-vop (lognot-mod32/unsigned=>unsigned)
+  (:translate lognot-mod32)
+  (:args (x :scs (unsigned-reg) :target r
+           :load-if (not (and (sc-is x unsigned-stack)
+                              (sc-is r unsigned-stack)
+                              (location= x r)))))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)
+              :load-if (not (and (sc-is x unsigned-stack)
+                                 (sc-is r unsigned-stack)
+                                 (location= x r)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (move r x)
+    (inst not r)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 46443a5..cb7b15c 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.2.25"
+"0.8.2.26"