Complete cut-to-width for modular arithmetic

 For each modular argument, go through the nodes that provide its
 value and try to narrow down their bitwidth. If we fail on any and
 the result might be too wide, splice in an explicit call to LOGAND
 or MASK-SIGNED-FIELD. Skip that last step if the value is an argument
 to an equivalent LOGAND or MASK-SIGNED-FIELD.

 Test case by Eric Marsden.

diff --git a/NEWS b/NEWS
index 443728d..4e08aee 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,8 @@ changes relative to sbcl-1.1.8:
     prefixes as used on x86 and x86-64 no longer sometimes print incorrectly.
     (lp#1085729)
   * bug fix: Specialised SIMD-PACK types can be negated.
+  * bug fix: Modular arithmetic is more robust. (incidentally fixes another bug
+    reported by Eric Marsden)
   
 changes in sbcl-1.1.8 relative to sbcl-1.1.7:
   * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 38e851a..728e741 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2910,9 +2910,47 @@
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe))
+             (insert-lvar-cut (lvar)
+               "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+                to the required bit width. Returns T if any change was made.
+
+                When the destination of LVAR will definitely cut LVAR's value
+                to width (i.e. it's a logand or mask-signed-field with constant
+                other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+               (binding* ((dest (lvar-dest lvar) :exit-if-null)
+                          (nil  (combination-p dest) :exit-if-null)
+                          (name (lvar-fun-name (combination-fun dest) t))
+                          (args (combination-args dest)))
+                 (case name
+                   (logand
+                    (when (= 2 (length args))
+                      (let ((other (if (eql (first args) lvar)
+                                       (second args)
+                                       (first args))))
+                        (when (and (constant-lvar-p other)
+                                   (ctypep (lvar-value other) type)
+                                   (not signedp))
+                          (return-from insert-lvar-cut)))))
+                   (mask-signed-field
+                    (when (and signedp
+                               (eql lvar (second args))
+                               (constant-lvar-p (first args))
+                               (<= (lvar-value (first args)) width))
+                      (return-from insert-lvar-cut)))))
+               (filter-lvar lvar
+                            (if signedp
+                                `(mask-signed-field ,width 'dummy)
+                                `(logand 'dummy ,(ldb (byte width 0) -1))))
+               (do-uses (node lvar)
+                 (setf (block-reoptimize (node-block node)) t)
+                 (reoptimize-component (node-component node) :maybe))
+               t)
              (cut-node (node &aux did-something)
+               "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."
                (when (block-delete-p (node-block node))
-                 (return-from cut-node))
+                 (return-from cut-node (values t nil)))
                (typecase node
                  (ref
                   (typecase (ref-leaf node)
@@ -2921,39 +2959,18 @@
                             (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)
-                                          :recklessly t)
-                         (let ((lvar (node-lvar node)))
-                           (setf (lvar-%derived-type lvar)
-                                 (and (lvar-has-single-use-p lvar)
-                                      (make-values-type :required (list (ctype-of new-value))))))
-                         (setf (block-reoptimize (node-block node)) t)
-                         (reoptimize-component (node-component node) :maybe)
-                         t)))
-                    (lambda-var
-                     (binding* ((dest (lvar-dest lvar) :exit-if-null)
-                                (nil  (combination-p dest) :exit-if-null)
-                                (name (lvar-fun-name (combination-fun dest))))
-                       ;; we're about to insert an m-s-f/logand between a ref to
-                       ;; a variable and another m-s-f/logand. No point in doing
-                       ;; that; the parent m-s-f/logand was already cut to width
-                       ;; anyway.
-                       (unless (or (cond (signedp
-                                          (and (eql name 'mask-signed-field)
-                                               (eql lvar (second
-                                                          (combination-args
-                                                           dest)))))
-                                         (t
-                                          (eql name 'logand)))
-                                   (csubtypep (lvar-type lvar) type))
-                         (filter-lvar lvar
-                                      (if signedp
-                                          `(mask-signed-field ,width 'dummy)
-                                          `(logand 'dummy ,(ldb (byte width 0) -1))))
-                         (setf (block-reoptimize (node-block node)) t)
-                         (reoptimize-component (node-component node) :maybe)
-                         t)))))
+                       (cond ((= constant-value new-value)
+                              (values t nil)) ; we knew what to do and did nothing
+                             (t
+                              (change-ref-leaf node (make-constant new-value)
+                                               :recklessly t)
+                              (let ((lvar (node-lvar node)))
+                                (setf (lvar-%derived-type lvar)
+                                      (and (lvar-has-single-use-p lvar)
+                                           (make-values-type :required (list (ctype-of new-value))))))
+                              (setf (block-reoptimize (node-block node)) t)
+                              (reoptimize-component (node-component node) :maybe)
+                              (values t t)))))))
                  (combination
                   (when (eq (basic-combination-kind node) :known)
                     (let* ((fun-ref (lvar-use (combination-fun node)))
@@ -2984,11 +3001,30 @@
                                 (setq did-something t))))
                           (when did-something
                             (reoptimize-node node name))
-                          did-something)))))))
-             (cut-lvar (lvar &aux did-something)
+                          (values t did-something))))))))
+             (cut-lvar (lvar &aux did-something must-insert)
+               "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
+                MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
+                The narrowing operation might not be inserted if the LVAR's
+                destination is already such an operation, to avoid endless
+                recursion.
+
+                (*) 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)
-                 (when (cut-node node)
-                   (setq did-something t)))
+                 (multiple-value-bind (handled any-change)
+                     (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))))
 

diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 3b1b86c..8281d7e 100644 (file)
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -598,3 +598,13 @@
                             (logand 8459622733968096971 x)))
                 12417237222845306758)
                2612793697039849090)))
+
+;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
+(with-test (:name :more-recursive-cut-to-width)
+  (assert (eql (funcall
+                (compile nil `(lambda (a b)
+                                (declare (optimize (speed 2) (safety 0)))
+                                (logand (the (eql 16779072918521075607) a)
+                                        (the (integer 21371810342718833225 21371810343571293860) b))))
+                16779072918521075607 21371810342718833263)
+               2923729245085762055)))