From 52b1041d3a14eaa4e45f6d8edfbdc0dec4292239 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 5 Apr 2012 19:55:05 +0100 Subject: [PATCH] Fix bug in unsigned modular arithmetic using a signed implementation If we aim to be clever by implementing an unsigned modular arithmetic computation using signed arithmetic, we need to make sure that we don't accidentally contaminate the computation with any extraneous high bits. This means that we must be sure to cut constants to the appropriate width, as well as computations, so do so; this fixes bug #974406 from Paul Dietz. (In addition the change from cutting to the requested width to the implementation width fixes #903821, so Go Team!) Test cases. Minimally horrible test case for #903821; far worse suggestions were made on #sbcl IRC... --- NEWS | 4 ++++ src/compiler/srctran.lisp | 38 +++++++++++++++++++++++++++++++++----- tests/compiler.impure.lisp | 12 ++++++++++++ tests/compiler.pure.lisp | 27 +++++++++++++++++++++++++++ 4 files changed, 76 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 509ca7c..328934f 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,8 @@ changes relative to sbcl-1.0.56: * enhancement: GENCGC reclaims space more aggressively when objects being allocated are a large fraction of the total available heap space. (lp#936304) + * optimization: fewer uses of full calls to signed modular functions. + (lp#903821) * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in OPEN. (lp#969352, thanks to Kambiz Darabi) * bug fix: CASE normal-clauses do not allow T and OTHERWISE as keys. @@ -18,6 +20,8 @@ changes relative to sbcl-1.0.56: * bug fix: run-program with existent or non-existent files for :output or :input when :if-output-exists or :if-input-does-not-exist are NIL properly returns NIL instead of signalling an obscure error. + * bug fix: fix miscompilation of some logand forms with large constant + arguments. (lp#974406) * documentation: ** improved docstrings: REPLACE (lp#965592) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 16accff..09842e9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3043,6 +3043,19 @@ (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)) + (setf (lvar-%derived-type (node-lvar node)) (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))) @@ -3117,9 +3130,23 @@ (best-modular-version width nil) (when w ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). - (cut-to-width x kind width signedp) - (cut-to-width y kind width signedp) - nil ; After fixing above, replace with T. + ;; + ;; FIXME: I think the FIXME (which is from APD) above + ;; implies that CUT-TO-WIDTH should do /everything/ + ;; that's required, including reoptimizing things + ;; itself that it knows are necessary. At the moment, + ;; CUT-TO-WIDTH sets up some new calls with + ;; combination-type :FULL, which later get noticed as + ;; known functions and properly converted. + ;; + ;; We cut to W not WIDTH if SIGNEDP is true, because + ;; signed constant replacement needs to know which bit + ;; in the field is the signed bit. + (let ((xact (cut-to-width x kind (if signedp w width) signedp)) + (yact (cut-to-width y kind (if signedp w width) signedp))) + (declare (ignore xact yact)) + nil) ; After fixing above, replace with T, meaning + ; "don't reoptimize this (LOGAND) node any more". )))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) @@ -3132,8 +3159,9 @@ (multiple-value-bind (w kind) (best-modular-version width t) (when w - ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). - (cut-to-width x kind width t) + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T). + ;; [ see comment above in LOGAND optimizer ] + (cut-to-width x kind w t) nil ; After fixing above, replace with T. )))))))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index d437d1c..b3970e6 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -2246,4 +2246,16 @@ ;; ...but the compiler should not break. (assert (and warn fail)))) +(test-util:with-test (:name :bug-903821) + (let* ((fun (compile nil '(lambda (x n) + (declare (sb-ext:word x) + (type (integer 0 #.(1- sb-vm:n-word-bits)) n) + (optimize speed)) + (logandc2 x (ash -1 n))))) + (trace-output + (with-output-to-string (*trace-output*) + (eval `(trace ,(intern (format nil "ASH-LEFT-MOD~D" sb-vm::n-word-bits) "SB-VM"))) + (assert (= 7 (funcall fun 15 3)))))) + (assert (string= "" trace-output)))) + ;;; success diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index bcdfe32..fe4bd64 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -4209,3 +4209,30 @@ :c)))) (style-warning () :style-warning))))) + +(with-test (:name :bug-974406) + (let ((fun32 (compile nil `(lambda (x) + (declare (optimize speed (safety 0))) + (declare (type (integer 53 86) x)) + (logand (+ x 1032791128) 11007078467)))) + (fun64 (compile nil `(lambda (x) + (declare (optimize speed (safety 0))) + (declare (type (integer 53 86) x)) + (logand (+ x 1152921504606846975) + 38046409652025950207))))) + (assert (= (funcall fun32 61) 268574721)) + (assert (= (funcall fun64 61) 60))) + (let (result) + (do ((width 5 (1+ width))) + ((= width 130)) + (dotimes (extra 4) + (let ((fun (compile nil `(lambda (x) + (declare (optimize speed (safety 0))) + (declare (type (integer 1 16) x)) + (logand + (+ x ,(1- (ash 1 width))) + ,(logior (ash 1 (+ width 1 extra)) + (1- (ash 1 width)))))))) + (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width)))) + (push (cons width extra) result))))) + (assert (null result)))) -- 1.7.10.4