Fix bug in unsigned modular arithmetic using a signed implementation

If we aim to be clever by implementing an unsigned modular arithmetic
computation using signed arithmetic, we need to make sure that we
don't accidentally contaminate the computation with any extraneous
high bits.  This means that we must be sure to cut constants to the
appropriate width, as well as computations, so do so; this fixes
bug #974406 from Paul Dietz.  (In addition the change from cutting
to the requested width to the implementation width fixes #903821,
so Go Team!)

Test cases.  Minimally horrible test case for #903821; far worse
suggestions were made on #sbcl IRC...

diff --git a/NEWS b/NEWS
index 509ca7c..328934f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes relative to sbcl-1.0.56:
   * enhancement: GENCGC reclaims space more aggressively when objects being
     allocated are a large fraction of the total available heap space.
     (lp#936304)
+  * optimization: fewer uses of full calls to signed modular functions.
+    (lp#903821)
   * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in
     OPEN. (lp#969352, thanks to Kambiz Darabi)
   * bug fix: CASE normal-clauses do not allow T and OTHERWISE as keys.
@@ -18,6 +20,8 @@ changes relative to sbcl-1.0.56:
   * bug fix: run-program with existent or non-existent files for :output or
     :input when :if-output-exists or :if-input-does-not-exist are NIL properly
     returns NIL instead of signalling an obscure error.
+  * bug fix: fix miscompilation of some logand forms with large constant
+    arguments.  (lp#974406)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 16accff..09842e9 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3043,6 +3043,19 @@
                (reoptimize-component (node-component node) :maybe))
              (cut-node (node &aux did-something)
                (when (and (not (block-delete-p (node-block node)))
+                          (ref-p node)
+                          (constant-p (ref-leaf node)))
+                 (let* ((constant-value (constant-value (ref-leaf node)))
+                        (new-value (if signedp
+                                       (mask-signed-field width constant-value)
+                                       (ldb (byte width 0) constant-value))))
+                   (unless (= constant-value new-value)
+                     (change-ref-leaf node (make-constant new-value))
+                     (setf (lvar-%derived-type (node-lvar node)) (make-values-type :required (list (ctype-of new-value))))
+                     (setf (block-reoptimize (node-block node)) t)
+                     (reoptimize-component (node-component node) :maybe)
+                     (return-from cut-node t))))
+               (when (and (not (block-delete-p (node-block node)))
                           (combination-p node)
                           (eq (basic-combination-kind node) :known))
                  (let* ((fun-ref (lvar-use (combination-fun node)))
@@ -3117,9 +3130,23 @@
                 (best-modular-version width nil)
               (when w
                 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
-                (cut-to-width x kind width signedp)
-                (cut-to-width y kind width signedp)
-                nil ; After fixing above, replace with T.
+                ;;
+                ;; FIXME: I think the FIXME (which is from APD) above
+                ;; implies that CUT-TO-WIDTH should do /everything/
+                ;; that's required, including reoptimizing things
+                ;; itself that it knows are necessary.  At the moment,
+                ;; CUT-TO-WIDTH sets up some new calls with
+                ;; combination-type :FULL, which later get noticed as
+                ;; known functions and properly converted.
+                ;;
+                ;; We cut to W not WIDTH if SIGNEDP is true, because
+                ;; signed constant replacement needs to know which bit
+                ;; in the field is the signed bit.
+                (let ((xact (cut-to-width x kind (if signedp w width) signedp))
+                      (yact (cut-to-width y kind (if signedp w width) signedp)))
+                  (declare (ignore xact yact))
+                  nil) ; After fixing above, replace with T, meaning
+                       ; "don't reoptimize this (LOGAND) node any more".
                 ))))))))
 
 (defoptimizer (mask-signed-field optimizer) ((width x) node)
@@ -3132,8 +3159,9 @@
             (multiple-value-bind (w kind)
                 (best-modular-version width t)
               (when w
-                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
-                (cut-to-width x kind width t)
+                ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
+                ;; [ see comment above in LOGAND optimizer ]
+                (cut-to-width x kind w t)
                 nil ; After fixing above, replace with T.
                 ))))))))
 \f

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d437d1c..b3970e6 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2246,4 +2246,16 @@
     ;; ...but the compiler should not break.
     (assert (and warn fail))))
 
+(test-util:with-test (:name :bug-903821)
+  (let* ((fun (compile nil '(lambda (x n)
+                             (declare (sb-ext:word x)
+                              (type (integer 0 #.(1- sb-vm:n-word-bits)) n)
+                              (optimize speed))
+                             (logandc2 x (ash -1 n)))))
+         (trace-output
+          (with-output-to-string (*trace-output*)
+            (eval `(trace ,(intern (format nil "ASH-LEFT-MOD~D" sb-vm::n-word-bits) "SB-VM")))
+            (assert (= 7 (funcall fun 15 3))))))
+    (assert (string= "" trace-output))))
+
 ;;; success

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index bcdfe32..fe4bd64 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4209,3 +4209,30 @@
                                             :c))))
                 (style-warning ()
                   :style-warning)))))
+
+(with-test (:name :bug-974406)
+  (let ((fun32 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1032791128) 11007078467))))
+        (fun64 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1152921504606846975)
+                                       38046409652025950207)))))
+    (assert (= (funcall fun32 61) 268574721))
+    (assert (= (funcall fun64 61) 60)))
+  (let (result)
+    (do ((width 5 (1+ width)))
+        ((= width 130))
+      (dotimes (extra 4)
+        (let ((fun (compile nil `(lambda (x)
+                                   (declare (optimize speed (safety 0)))
+                                   (declare (type (integer 1 16) x))
+                                   (logand
+                                    (+ x ,(1- (ash 1 width)))
+                                    ,(logior (ash 1 (+ width 1 extra))
+                                             (1- (ash 1 width))))))))
+          (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
+            (push (cons width extra) result)))))
+    (assert (null result))))