Complete cut-to-width

 * Insert logand/mask-signed-field even around references to variables
   in modular arithmetic: avoid recursive rewriting by disabling the
   transform when the destination is a direct logand/mask-signed-field
   combination.

 * Fixes lp#1026634 (reported by Anton Marsden on sbcl-devel).

diff --git a/NEWS b/NEWS
index 0c1eb2d..590b909 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -43,6 +43,8 @@ changes relative to sbcl-1.1.7:
     emitting or dumping code. (lp#504121)
   * bug fix: Multiply-inlined structure constructor don't cause IR2-time
     codegen errors: type checks are inserted as necessary. (lp#1177703)
+  * bug fix: Unsigned modular arithmetic is correctly converted into signed
+    modular arithemtic (mostly to exploit fixnum-width VOPs). (lp#1026634)
   * optimization: faster ISQRT on fixnums and small bignums
   * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64.
   * optimization: On x86-64, the number of multi-byte NOP instructions used

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 282c34f..a976fa5 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2826,53 +2826,84 @@
                (setf (block-reoptimize (node-block node)) t)
                (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))
-                     (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)
-                     (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)))
-                        (fun-name (leaf-source-name (ref-leaf fun-ref)))
-                        (modular-fun (find-modular-version fun-name kind signedp width)))
-                   (when (and modular-fun
-                              (not (and (eq fun-name 'logand)
-                                        (csubtypep
-                                         (single-value-type (node-derived-type node))
-                                         type))))
-                     (binding* ((name (etypecase modular-fun
-                                        ((eql :good) fun-name)
-                                        (modular-fun-info
-                                         (modular-fun-info-name modular-fun))
-                                        (function
-                                         (funcall modular-fun node width)))
-                                      :exit-if-null))
-                               (unless (eql modular-fun :good)
-                                 (setq did-something 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))))
-                               (when did-something
-                                 (reoptimize-node node name))
-                               did-something)))))
+               (when (block-delete-p (node-block node))
+                 (return-from cut-node))
+               (typecase node
+                 (ref
+                  (typecase (ref-leaf node)
+                    (constant
+                     (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))
+                         (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)
+                                (fun-ref (lvar-use (combination-fun dest)))
+                                (leaf (ref-leaf fun-ref))
+                                (name (and (leaf-has-source-name-p leaf)
+                                           (leaf-source-name leaf))))
+                       ;; 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
+                                          `((lambda (x)
+                                              (mask-signed-field ,width x))
+                                            'dummy)
+                                          `(logand 'dummy ,(ldb (byte width 0) -1))))
+                         (setf (block-reoptimize (node-block node)) t)
+                         (reoptimize-component (node-component node) :maybe)
+                         t)))))
+                 (combination
+                  (when (eq (basic-combination-kind node) :known)
+                    (let* ((fun-ref (lvar-use (combination-fun node)))
+                           (fun-name (leaf-source-name (ref-leaf fun-ref)))
+                           (modular-fun (find-modular-version fun-name kind
+                                                              signedp width)))
+                      (when (and modular-fun
+                                 (not (and (eq fun-name 'logand)
+                                           (csubtypep
+                                            (single-value-type (node-derived-type node))
+                                            type))))
+                        (binding* ((name (etypecase modular-fun
+                                           ((eql :good) fun-name)
+                                           (modular-fun-info
+                                            (modular-fun-info-name modular-fun))
+                                           (function
+                                            (funcall modular-fun node width)))
+                                         :exit-if-null))
+                          (unless (eql modular-fun :good)
+                            (setq did-something 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))))
+                          (when did-something
+                            (reoptimize-node node name))
+                          did-something)))))))
              (cut-lvar (lvar &aux did-something)
                (do-uses (node lvar)
                  (when (cut-node node)

diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index c78b328..3b1b86c 100644 (file)
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -586,3 +586,15 @@
           (tests j))
     (dotimes (i 10)
       (tests (random (expt 2 (+ 1000 (random 10000))))))))
+
+;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
+(with-test (:name :recursive-cut-to-width)
+  (assert (eql (funcall
+                (compile nil
+                         `(lambda (x)
+                            (declare (optimize (space 3))
+                                     (type (integer 12417236377505266230
+                                                    12417274239874990070) x))
+                            (logand 8459622733968096971 x)))
+                12417237222845306758)
+               2612793697039849090)))