From: Paul Khuong Date: Sat, 18 May 2013 00:22:44 +0000 (-0400) Subject: Complete cut-to-width X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b111015a7111501231c7b61990c61c046392796b;p=sbcl.git 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 --- 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 --- 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 --- 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)))