Menu
▾
▴
[Sbcl-commits] master: Less constraint propagation when COMPILATION-SPEED > SPEED
|
From: Paul K. <pk...@us...> - 2011-06-19 01:16:31
|
The branch "master" has been updated in SBCL:
via fb24d88c8f97f1b344addab398fc54f62d8aa4ce (commit)
from e7100f143ac497232623ada89aa364b720faa345 (commit)
- Log -----------------------------------------------------------------
commit fb24d88c8f97f1b344addab398fc54f62d8aa4ce
Author: Paul Khuong <pv...@pv...>
Date: Sat Jun 18 16:36:02 2011 -0400
Less constraint propagation when COMPILATION-SPEED > SPEED
Propagate much fewer EQL constraints, and propagate fewer constraints
to EQL variables. Can results in a few orders of magnitude speed ups
in compilation times.
---
NEWS | 2 +
src/compiler/constraint.lisp | 65 ++++++++++++++++++++++++++++++-----------
tests/compiler.pure.lisp | 15 +++++----
3 files changed, 57 insertions(+), 25 deletions(-)
diff --git a/NEWS b/NEWS
index 48cc671..f73e8fb 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,8 @@ changes relative to sbcl-1.0.49:
and SB-EXT:*SYSINIT-PATHNAME-FUNCTION*.
* enhancement: SB-EXT:MAKE-THREAD accepts an argument list designator for
the thunk, as a keyword argument, :arguments.
+ * enhancement: constraint propagation is simplified (and sped up) when
+ COMPILATION-SPEED > SPEED.
* optimization: extracting bits of a single-float on x86-64 has been
optimized. (lp#555201)
* meta-optimization: improved compilation speed, especially for large
diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index d14a982..79f19c1 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -563,24 +563,48 @@
;;; Add the indicated test constraint to BLOCK. We don't add the
;;; constraint if the block has multiple predecessors, since it only
;;; holds on this particular path.
-(defun add-test-constraint (fun x y not-p constraints target)
- (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
- (add-eql-var-var-constraint x y constraints target))
+(defun precise-add-test-constraint (fun x y not-p constraints target)
+ (if (and (eq 'eql fun) (lambda-var-p y) (not not-p))
+ (add-eql-var-var-constraint x y constraints target)
+ (conset-add-constraint-to-eql constraints fun x y not-p target))
+ (values))
+
+(defun add-test-constraint (quick-p fun x y not-p constraints target)
+ (cond (quick-p
+ (conset-add-constraint target fun x y not-p))
(t
- (conset-add-constraint-to-eql constraints fun x y not-p target)))
- (values))
-
+ (precise-add-test-constraint fun x y not-p constraints target))))
;;; Add complementary constraints to the consequent and alternative
;;; blocks of IF. We do nothing if X is NIL.
-(defun add-complement-constraints (fun x y not-p constraints
+(declaim (inline precise-add-test-constraint quick-add-complement-constraints))
+(defun precise-add-complement-constraints (fun x y not-p constraints
+ consequent-constraints
+ alternative-constraints)
+ (when x
+ (precise-add-test-constraint fun x y not-p constraints
+ consequent-constraints)
+ (precise-add-test-constraint fun x y (not not-p) constraints
+ alternative-constraints))
+ (values))
+
+(defun quick-add-complement-constraints (fun x y not-p
+ consequent-constraints
+ alternative-constraints)
+ (when x
+ (conset-add-constraint consequent-constraints fun x y not-p)
+ (conset-add-constraint alternative-constraints fun x y (not not-p)))
+ (values))
+
+(defun add-complement-constraints (quick-p fun x y not-p constraints
consequent-constraints
alternative-constraints)
- (when x
- (add-test-constraint fun x y not-p constraints
- consequent-constraints)
- (add-test-constraint fun x y (not not-p) constraints
- alternative-constraints))
- (values))
+ (if quick-p
+ (quick-add-complement-constraints fun x y not-p
+ consequent-constraints
+ alternative-constraints)
+ (precise-add-complement-constraints fun x y not-p constraints
+ consequent-constraints
+ alternative-constraints)))
;;; Add test constraints to the consequent and alternative blocks of
;;; the test represented by USE.
@@ -592,9 +616,11 @@
;; need to avoid barfing on this case.
(unless (eq (if-consequent if) (if-alternative if))
(let ((consequent-constraints (make-conset))
- (alternative-constraints (make-conset)))
+ (alternative-constraints (make-conset))
+ (quick-p (policy if (> compilation-speed speed))))
(macrolet ((add (fun x y not-p)
- `(add-complement-constraints ,fun ,x ,y ,not-p
+ `(add-complement-constraints quick-p
+ ,fun ,x ,y ,not-p
constraints
consequent-constraints
alternative-constraints)))
@@ -634,7 +660,8 @@
;; unnatural asymmetry of the tests.
(cond ((not var1)
(when var2
- (add-test-constraint 'typep var2 (lvar-type arg1)
+ (add-test-constraint quick-p
+ 'typep var2 (lvar-type arg1)
nil constraints
consequent-constraints)))
(var2
@@ -647,7 +674,8 @@
(find-constant (lvar-value arg2))))
nil))
(t
- (add-test-constraint 'typep var1 (lvar-type arg2)
+ (add-test-constraint quick-p
+ 'typep var1 (lvar-type arg2)
nil constraints
consequent-constraints)))))
((< >)
@@ -917,7 +945,8 @@
(let ((type (single-value-type (node-derived-type node))))
(unless (eq type *universal-type*)
(conset-add-constraint gen 'typep var type nil)))
- (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
+ (unless (policy node (> compilation-speed speed))
+ (maybe-add-eql-var-var-constraint var (set-value node) gen))))))
gen)
(defun constraint-propagate-if (block gen)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 19f6c96..633efef 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2231,15 +2231,16 @@
(logand most-positive-fixnum (* x most-positive-fixnum))))
;;; bug 256.b
-(assert (let (warned-p)
+(with-test (:name :propagate-type-through-error-and-binding)
+ (assert (let (warned-p)
(handler-bind ((warning (lambda (w) (setf warned-p t))))
(compile nil
- '(lambda (x)
- (list (let ((y (the real x)))
- (unless (floatp y) (error ""))
- y)
- (integer-length x)))))
- warned-p))
+ '(lambda (x)
+ (list (let ((y (the real x)))
+ (unless (floatp y) (error ""))
+ y)
+ (integer-length x)))))
+ warned-p)))
;; Dead / in safe code
(with-test (:name :safe-dead-/)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
