X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=e2be0938884ce119eebd89a76d83cb03487cb74a;hb=94ac5b7c3ff37850210b6fc9a7593cf1c5752993;hp=328056a70e08f3b33eb3412c06a3d9b79c8bb627;hpb=872175cd9cb5b4966a36d4bd92421cc407a0355b;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 328056a..e2be093 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -126,50 +126,52 @@ (add-complement-constraints if 'typep (ok-ref-lambda-var use) (specifier-type 'null) t)) (combination - (let ((name (continuation-function-name - (basic-combination-fun use))) - (args (basic-combination-args use))) - (case name - ((%typep %instance-typep) - (let ((type (second args))) - (when (constant-continuation-p type) - (let ((val (continuation-value type))) - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - (if (ctype-p val) - val - (specifier-type val)) - nil))))) - ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (cond ((not var1)) - (var2 - (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) - (add-complement-constraints if 'eql var1 - (ref-leaf - (continuation-use arg2)) - nil))))) - ((< >) - (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) - nil)) - (when var2 - (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) - nil)))) - (t - (let ((ptype (gethash name *backend-predicate-types*))) - (when ptype - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - ptype nil)))))))) + (unless (eq (combination-kind use) + :error) + (let ((name (continuation-fun-name + (basic-combination-fun use))) + (args (basic-combination-args use))) + (case name + ((%typep %instance-typep) + (let ((type (second args))) + (when (constant-continuation-p type) + (let ((val (continuation-value type))) + (add-complement-constraints if 'typep + (ok-cont-lambda-var (first args)) + (if (ctype-p val) + val + (specifier-type val)) + nil))))) + ((eq eql) + (let* ((var1 (ok-cont-lambda-var (first args))) + (arg2 (second args)) + (var2 (ok-cont-lambda-var arg2))) + (cond ((not var1)) + (var2 + (add-complement-constraints if 'eql var1 var2 nil)) + ((constant-continuation-p arg2) + (add-complement-constraints if 'eql var1 + (ref-leaf + (continuation-use arg2)) + nil))))) + ((< >) + (let* ((arg1 (first args)) + (var1 (ok-cont-lambda-var arg1)) + (arg2 (second args)) + (var2 (ok-cont-lambda-var arg2))) + (when var1 + (add-complement-constraints if name var1 (continuation-type arg2) + nil)) + (when var2 + (add-complement-constraints if (if (eq name '<) '> '<) + var2 (continuation-type arg1) + nil)))) + (t + (let ((ptype (gethash name *backend-predicate-types*))) + (when ptype + (add-complement-constraints if 'typep + (ok-cont-lambda-var (first args)) + ptype nil))))))))) (values)) ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to @@ -187,7 +189,7 @@ ;;; Compute the initial flow analysis sets for BLOCK: ;;; -- For any lambda-var ref with a type check, add that constraint. -;;; -- For any lambda-var set, delete all constraints on that var, and add +;;; -- For any LAMBDA-VAR set, delete all constraints on that var, and add ;;; those constraints to the set nuked by this block. (defun find-block-type-constraints (block) (declare (type cblock block)) @@ -217,7 +219,7 @@ (setf (block-in block) nil) (setf (block-gen block) gen) - (setf (block-kill block) (kill)) + (setf (block-kill-list block) (kill)) (setf (block-out block) (copy-sset gen)) (setf (block-type-asserted block) nil) (values)))) @@ -439,11 +441,11 @@ (dolist (let (lambda-lets fun)) (frob let))))) -;;; BLOCK-IN becomes the intersection of the OUT of the prececessors. +;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. ;;; Our OUT is: ;;; out U (in - kill) ;;; -;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must +;;; BLOCK-KILL-LIST is just a list of the LAMBDA-VARs killed, so we must ;;; compute the kill set when there are any vars killed. We bum this a ;;; bit by special-casing when only one var is killed, and just using ;;; that var's constraints as the kill set. This set could possibly be @@ -457,31 +459,38 @@ (sset-intersection res (block-out b))) res)) (t - (when *check-consistency* - (let ((*compiler-error-context* (block-last block))) - (compiler-warning - "*** Unreachable code in constraint ~ - propagation... Bug?"))) + (let ((*compiler-error-context* (block-last block))) + (compiler-warn + "unreachable code in constraint ~ + propagation -- apparent compiler bug")) (make-sset)))) - (kill (block-kill block)) + (kill-list (block-kill-list block)) (out (block-out block))) (setf (block-in block) in) - (cond ((null kill) + (cond ((null kill-list) (sset-union (block-out block) in)) - ((null (rest kill)) - (let ((con (lambda-var-constraints (first kill)))) + ((null (rest kill-list)) + (let ((con (lambda-var-constraints (first kill-list)))) (if con (sset-union-of-difference out in con) (sset-union out in)))) (t (let ((kill-set (make-sset))) - (dolist (var kill) + (dolist (var kill-list) (let ((con (lambda-var-constraints var))) (when con (sset-union kill-set con)))) (sset-union-of-difference (block-out block) in kill-set)))))) +;;; How many blocks does COMPONENT have? +(defun component-n-blocks (component) + (let ((result 0)) + (declare (type index result)) + (do-blocks (block component :both) + (incf result)) + result)) + (defun constraint-propagate (component) (declare (type component component)) (init-var-constraints component) @@ -499,14 +508,18 @@ (setf (block-out (component-head component)) (make-sset)) - (let ((did-something nil)) - (loop - (do-blocks (block component) - (when (flow-propagate-constraints block) - (setq did-something t))) - - (unless did-something (return)) - (setq did-something nil))) + (let (;; If we have to propagate changes more than this many times, + ;; something is wrong. + (max-n-changes-remaining (component-n-blocks component))) + (declare (type fixnum max-n-changes-remaining)) + (loop (aver (plusp max-n-changes-remaining)) + (decf max-n-changes-remaining) + (let ((did-something nil)) + (do-blocks (block component) + (when (flow-propagate-constraints block) + (setq did-something t))) + (unless did-something + (return))))) (do-blocks (block component) (use-result-constraints block))