|
From: Paul K. <pk...@us...> - 2011-06-20 01:08:24
|
The branch "master" has been updated in SBCL:
via 74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7 (commit)
from fb24d88c8f97f1b344addab398fc54f62d8aa4ce (commit)
- Log -----------------------------------------------------------------
commit 74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7
Author: Paul Khuong <pv...@pv...>
Date: Sun Jun 19 21:04:20 2011 -0400
More constraint propagation in the presence of assignment
When SPEED = 3 > COMPILATION-SPEED, propagate type in code
like (cond ((eql (the fixnum x) y) (setf x 42) y) ...).
---
src/compiler/constraint.lisp | 6 ++++++
1 files changed, 6 insertions(+), 0 deletions(-)
diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 79f19c1..88a8252 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -941,6 +941,12 @@
(binding* ((var (set-var node))
(nil (lambda-var-p var) :exit-if-null)
(nil (lambda-var-constraints var) :exit-if-null))
+ (when (policy node (and (= speed 3) (> speed compilation-speed)))
+ (let ((type (lambda-var-type var)))
+ (unless (eql *universal-type* type)
+ (do-eql-vars (other (var gen))
+ (unless (eql other var)
+ (conset-add-constraint gen 'typep other type nil))))))
(conset-clear-lambda-var gen var)
(let ((type (single-value-type (node-derived-type node))))
(unless (eq type *universal-type*)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|