Insert explicit cut to width when needed

 When modular arithmetic operations are replaced with specialised
 modular variants, the result's bitwidth is determined by the variant,
 and might be wider than expected. If necessary, insert an explicit
 cut to the exact bitwidth before returning a value in a non-modular
 context.

 Spotted by pfdietz's random tester.

 Fixes lp#1199428.

diff --git a/NEWS b/NEWS
index e4dc0a9..684a691 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes relative to sbcl-1.1.9:
   * enhancement: ASDF has been updated to 3.0.2.
   * bug fix: Compiling potential modularic arithmetic forms does not cause type
     errors when some integer types lack lower or upper bounds. (lp#1199127)
+  * bug fix: Non-trivial modular arithmetic forms are always cut to the right
+    bitwidth before being used in a non-modular context. (lp#1199428)
 
 changes in sbcl-1.1.9 relative to sbcl-1.1.8:
   * new feature: the contrib SB-GMP links with libgmp at runtime to speed

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 0ffbf42..69275ff 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2955,10 +2955,11 @@
                  (setf (block-reoptimize (node-block node)) t)
                  (reoptimize-component (node-component node) :maybe))
                t)
-             (cut-node (node &aux did-something)
+             (cut-node (node &aux did-something over-wide)
                "Try to cut a node to width. The primary return value is
                 whether we managed to cut (cleverly), and the second whether
-                anything was changed."
+                anything was changed.  The third return value tells whether
+                the cut value might be wider than expected."
                (when (block-delete-p (node-block node))
                  (return-from cut-node (values t nil)))
                (typecase node
@@ -3015,19 +3016,23 @@
                                                  (funcall modular-fun node width)))
                                               :exit-if-null))
                                (unless (eql modular-fun :good)
-                                 (setq did-something t)
+                                 (setq did-something t
+                                       over-wide t)
                                  (change-ref-leaf
                                   fun-ref
                                   (find-free-fun name "in a strange place"))
                                  (setf (combination-kind node) :full))
                                (unless (functionp modular-fun)
                                  (dolist (arg (basic-combination-args node))
-                                   (when (cut-lvar arg)
-                                     (setq did-something t))))
+                                   (multiple-value-bind (change wide)
+                                       (cut-lvar arg)
+                                     (setf did-something (or did-something change)
+                                           over-wide (or over-wide wide)))))
                                (when did-something
                                  (reoptimize-node node name))
-                               (values t did-something)))))))))
-             (cut-lvar (lvar &aux did-something must-insert)
+                               (values t did-something over-wide)))))))))
+             (cut-lvar (lvar &key head
+                        &aux did-something must-insert over-wide)
                "Cut all the LVAR's use nodes. If any of them wasn't handled
                 and its type is too wide for the operation we wish to perform
                 insert an explicit bit-width narrowing operation (LOGAND or
@@ -3036,22 +3041,29 @@
                 destination is already such an operation, to avoid endless
                 recursion.
 
+                If we're at the head, forcibly insert a cut operation if the
+                result might be too wide.
+
                 (*) We can't easily do that for each node, and doing so might
                 result in code bloat, anyway. (I'm also not sure it would be
                 correct for complicated C/D FG)"
                (do-uses (node lvar)
-                 (multiple-value-bind (handled any-change)
+                 (multiple-value-bind (handled any-change wide)
                      (cut-node node)
                    (setf did-something (or did-something any-change)
                          must-insert (or must-insert
                                          (not (or handled
                                                   (csubtypep (single-value-type
                                                               (node-derived-type node))
-                                                             type)))))))
-               (when must-insert
-                 (setf did-something (or (insert-lvar-cut lvar) did-something)))
-               did-something))
-      (cut-lvar lvar))))
+                                                             type))))
+                         over-wide (or over-wide wide))))
+               (when (or must-insert
+                         (and head over-wide))
+                 (setf did-something (or (insert-lvar-cut lvar) did-something)
+                       ;; we're just the right width after an explicit cut.
+                       over-wide nil))
+               (values did-something over-wide)))
+      (cut-lvar lvar :head t))))
 
 (defun best-modular-version (width signedp)
   ;; 1. exact width-matched :untagged

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index d3588af..9e955c1 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4682,3 +4682,40 @@
                                  (ash b (min 25 lv1))
                                  0)
                              -2)))))
+
+;; non-trivial modular arithmetic operations would evaluate to wider results
+;; than expected, and never be cut to the right final bitwidth.
+(with-test (:name :bug-1199428-1)
+  (let ((f1 (compile nil `(lambda (a c)
+                            (declare (type (integer -2 1217810089) a))
+                            (declare (type (integer -6895591104928 -561736648588) c))
+                            (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
+                                               (compilation-speed 3)))
+                            (logandc1 (gcd c)
+                                      (+ (- a c)
+                                         (loop for lv2 below 1 count t))))))
+        (f2 (compile nil `(lambda (a c)
+                            (declare (notinline - + gcd logandc1))
+                            (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
+                                               (compilation-speed 3)))
+                            (logandc1 (gcd c)
+                                      (+ (- a c)
+                                         (loop for lv2 below 1 count t)))))))
+    (let ((a 530436387)
+          (c -4890629672277))
+      (assert (eql (funcall f1 a c)
+                   (funcall f2 a c))))))
+
+(with-test (:name :bug-1199428-2)
+  (let ((f1 (compile nil `(lambda (a b)
+                            (declare (type (integer -1869232508 -6939151) a))
+                            (declare (type (integer -11466348357 -2645644006) b))
+                            (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
+                                               (compilation-speed 2)))
+                            (logand (lognand a -6) (* b -502823994)))))
+        (f2 (compile nil `(lambda (a b)
+                            (logand (lognand a -6) (* b -502823994))))))
+    (let ((a -1491588365)
+          (b -3745511761))
+      (assert (eql (funcall f1 a b)
+                   (funcall f2 a b))))))