Menu
▾
▴
[Sbcl-commits] master: Complete cut-to-width for modular arithmetic
|
From: Paul K. <pk...@us...> - 2013-06-08 06:51:16
|
The branch "master" has been updated in SBCL:
via a8419eb994f3b59b70cfa12e1004711a830a43fa (commit)
from 4f0bd9304dfa5010e2c7f17d7cecde0bba6c578e (commit)
- Log -----------------------------------------------------------------
commit a8419eb994f3b59b70cfa12e1004711a830a43fa
Author: Paul Khuong <pv...@pv...>
Date: Fri Jun 7 18:46:25 2013 -0400
Complete cut-to-width for modular arithmetic
For each modular argument, go through the nodes that provide its
value and try to narrow down their bitwidth. If we fail on any and
the result might be too wide, splice in an explicit call to LOGAND
or MASK-SIGNED-FIELD. Skip that last step if the value is an argument
to an equivalent LOGAND or MASK-SIGNED-FIELD.
Test case by Eric Marsden.
---
NEWS | 2 +
src/compiler/srctran.lisp | 112 +++++++++++++++++++++++++++++---------------
tests/arith.pure.lisp | 10 ++++
3 files changed, 86 insertions(+), 38 deletions(-)
diff --git a/NEWS b/NEWS
index 443728d..4e08aee 100644
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,8 @@ changes relative to sbcl-1.1.8:
prefixes as used on x86 and x86-64 no longer sometimes print incorrectly.
(lp#1085729)
* bug fix: Specialised SIMD-PACK types can be negated.
+ * bug fix: Modular arithmetic is more robust. (incidentally fixes another bug
+ reported by Eric Marsden)
changes in sbcl-1.1.8 relative to sbcl-1.1.7:
* notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 38e851a..728e741 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2910,9 +2910,47 @@
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
+ (insert-lvar-cut (lvar)
+ "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+ to the required bit width. Returns T if any change was made.
+
+ When the destination of LVAR will definitely cut LVAR's value
+ to width (i.e. it's a logand or mask-signed-field with constant
+ other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (nil (combination-p dest) :exit-if-null)
+ (name (lvar-fun-name (combination-fun dest) t))
+ (args (combination-args dest)))
+ (case name
+ (logand
+ (when (= 2 (length args))
+ (let ((other (if (eql (first args) lvar)
+ (second args)
+ (first args))))
+ (when (and (constant-lvar-p other)
+ (ctypep (lvar-value other) type)
+ (not signedp))
+ (return-from insert-lvar-cut)))))
+ (mask-signed-field
+ (when (and signedp
+ (eql lvar (second args))
+ (constant-lvar-p (first args))
+ (<= (lvar-value (first args)) width))
+ (return-from insert-lvar-cut)))))
+ (filter-lvar lvar
+ (if signedp
+ `(mask-signed-field ,width 'dummy)
+ `(logand 'dummy ,(ldb (byte width 0) -1))))
+ (do-uses (node lvar)
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe))
+ t)
(cut-node (node &aux did-something)
+ "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."
(when (block-delete-p (node-block node))
- (return-from cut-node))
+ (return-from cut-node (values t nil)))
(typecase node
(ref
(typecase (ref-leaf node)
@@ -2921,39 +2959,18 @@
(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)
- :recklessly t)
- (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)
- (name (lvar-fun-name (combination-fun dest))))
- ;; 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
- `(mask-signed-field ,width 'dummy)
- `(logand 'dummy ,(ldb (byte width 0) -1))))
- (setf (block-reoptimize (node-block node)) t)
- (reoptimize-component (node-component node) :maybe)
- t)))))
+ (cond ((= constant-value new-value)
+ (values t nil)) ; we knew what to do and did nothing
+ (t
+ (change-ref-leaf node (make-constant new-value)
+ :recklessly t)
+ (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)
+ (values t t)))))))
(combination
(when (eq (basic-combination-kind node) :known)
(let* ((fun-ref (lvar-use (combination-fun node)))
@@ -2984,11 +3001,30 @@
(setq did-something t))))
(when did-something
(reoptimize-node node name))
- did-something)))))))
- (cut-lvar (lvar &aux did-something)
+ (values t did-something))))))))
+ (cut-lvar (lvar &aux did-something must-insert)
+ "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
+ MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
+ The narrowing operation might not be inserted if the LVAR's
+ destination is already such an operation, to avoid endless
+ recursion.
+
+ (*) 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)
- (when (cut-node node)
- (setq did-something t)))
+ (multiple-value-bind (handled any-change)
+ (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))))
diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 3b1b86c..8281d7e 100644
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -598,3 +598,13 @@
(logand 8459622733968096971 x)))
12417237222845306758)
2612793697039849090)))
+
+;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
+(with-test (:name :more-recursive-cut-to-width)
+ (assert (eql (funcall
+ (compile nil `(lambda (a b)
+ (declare (optimize (speed 2) (safety 0)))
+ (logand (the (eql 16779072918521075607) a)
+ (the (integer 21371810342718833225 21371810343571293860) b))))
+ 16779072918521075607 21371810342718833263)
+ 2923729245085762055)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|