From: Stas Boukarev Date: Sat, 7 Dec 2013 09:04:14 +0000 (+0400) Subject: Fix cut-to-width in the presence of bad constants in dead code. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;p=sbcl.git Fix cut-to-width in the presence of bad constants in dead code. Unreachable branches may have mismatching types and constant values, and when cut-to-width is run before such nodes are deleted, it gets confused. Reported by Douglas Katzman. --- diff --git a/NEWS b/NEWS index 303ebc0..364d1e9 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,8 @@ changes relative to sbcl-1.1.14: having GUI applications without an automatically appearing console window. * bug fix: Windows applications without the console window no longer misbehave. (patch by Wilfredo Velazquez, lp#1256034). + * bug fix: modular arithmetic optimizations do not stumble on dead branches + with bad constants. (reported by Douglas Katzman) changes in sbcl-1.1.14 relative to sbcl-1.1.13: * optimization: complicated TYPEP tests are less opaque to the type diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index c808988..fa780c9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2955,7 +2955,7 @@ (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe)) t) - (cut-node (node &aux did-something over-wide) + (cut-node (node) "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. The third return value tells whether @@ -2967,9 +2967,13 @@ (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)))) + (new-value + (cond ((not (integerp constant-value)) + (return-from cut-node (values t nil))) + (signedp + (mask-signed-field width constant-value)) + (t + (ldb (byte width 0) constant-value))))) (cond ((= constant-value new-value) (values t nil)) ; we knew what to do and did nothing (t @@ -3014,7 +3018,9 @@ (modular-fun-info-name modular-fun)) (function (funcall modular-fun node width))) - :exit-if-null)) + :exit-if-null) + (did-something nil) + (over-wide nil)) (unless (eql modular-fun :good) (setq did-something t over-wide t) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 2fe23b1..e63e2d6 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1443,6 +1443,20 @@ (assert (equal (compile '(setf compile-setf)) '(setf compile-setf)))) +(declaim (inline cut-test)) +(defun cut-test (b) + (cond ((integerp b) b) + (b 469) + (t 2))) + +(with-test (:name :cut-to-width-bad-constant) + (assert (= (funcall (compile nil + `(lambda () + (multiple-value-bind (a b) (values t t) + (declare (ignore b)) + (mask-field (byte 10 0) (cut-test a)))))) + 469))) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself