From df2d632ead05d542d3cdd2d8d162060ee586c151 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Thu, 18 Jul 2013 15:03:21 -0400 Subject: [PATCH] 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. --- NEWS | 2 ++ src/compiler/srctran.lisp | 38 +++++++++++++++++++++++++------------- tests/compiler.pure.lisp | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 64 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index e4dc0a9..684a691 100644 --- 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 --- 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 --- 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)))))) -- 1.7.10.4