X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=fea3f166033acf0687bc44af0d326b9b0c3c2907;hb=17794352c2ef078a1fc3cdd306f17f7328edf40b;hp=328056a70e08f3b33eb3412c06a3d9b79c8bb627;hpb=872175cd9cb5b4966a36d4bd92421cc407a0355b;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 328056a..fea3f16 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -11,6 +11,40 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. +;;; TODO: +;;; +;;; -- documentation +;;; +;;; -- MV-BIND, :ASSIGNMENT + +;;; Problems: +;;; +;;; -- Constraint propagation badly interacts with bottom-up type +;;; inference. Consider +;;; +;;; (defun foo (n &aux (i 42)) +;;; (declare (optimize speed)) +;;; (declare (fixnum n) +;;; #+nil (type (integer 0) i)) +;;; (tagbody +;;; (setq i 0) +;;; :loop +;;; (when (>= i n) (go :exit)) +;;; (setq i (1+ i)) +;;; (go :loop) +;;; :exit)) +;;; +;;; In this case CP cannot even infer that I is of class INTEGER. +;;; +;;; -- In the above example if we place the check after SETQ, CP will +;;; fail to infer (< I FIXNUM): is does not understand that this +;;; constraint follows from (TYPEP I (INTEGER 0 0)). + +;;; BUGS: +;;; +;;; -- this code does not check whether SET appears between REF and a +;;; test (bug 233b) + (in-package "SB!C") (defstruct (constraint @@ -20,11 +54,11 @@ ;; the kind of constraint we have: ;; ;; TYPEP - ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is + ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is ;; constrained to be of type Y. ;; ;; > or < - ;; X is a lambda-var and Y is a CTYPE. The relation holds + ;; X is a lambda-var and Y is a CTYPE. The relation holds ;; between X and some object of type Y. ;; ;; EQL @@ -34,7 +68,7 @@ ;; The operands to the relation. (x nil :type lambda-var) (y nil :type (or ctype lambda-var constant)) - ;; If true, negates the sense of the constraint, so the relation + ;; If true, negates the sense of the constraint, so the relation ;; does *not* hold. (not-p nil :type boolean)) @@ -95,6 +129,8 @@ (when (ref-p use) (ok-ref-lambda-var use)))) +;;;; Searching constraints + ;;; Add the indicated test constraint to BLOCK, marking the block as ;;; having a new assertion when the constriant was not already ;;; present. We don't add the constraint if the block has multiple @@ -110,9 +146,14 @@ ;;; Add complementary constraints to the consequent and alternative ;;; blocks of IF. We do nothing if X is NIL. -#!-sb-fluid (declaim (inline add-complement-constraints)) (defun add-complement-constraints (if fun x y not-p) - (when x + (when (and x + ;; Note: Even if we do (IF test exp exp) => (PROGN test exp) + ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means + ;; that we can't guarantee that the optimization will be + ;; done, so we still need to avoid barfing on this case. + (not (eq (if-consequent if) + (if-alternative if)))) (add-test-constraint (if-consequent if) fun x y not-p) (add-test-constraint (if-alternative if) fun x y (not not-p))) (values)) @@ -126,50 +167,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 @@ -185,42 +228,7 @@ (setf (block-test-modified block) nil) (values)) -;;; 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 -;;; those constraints to the set nuked by this block. -(defun find-block-type-constraints (block) - (declare (type cblock block)) - (let ((gen (make-sset))) - (collect ((kill nil adjoin)) - - (let ((test (block-test-constraint block))) - (when test - (sset-union gen test))) - - (do-nodes (node cont block) - (typecase node - (ref - (when (continuation-type-check cont) - (let ((var (ok-ref-lambda-var node))) - (when var - (let* ((atype (continuation-derived-type cont)) - (con (find-constraint 'typep var atype nil))) - (sset-adjoin con gen)))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (kill var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference gen cons)))))))) - - (setf (block-in block) nil) - (setf (block-gen block) gen) - (setf (block-kill block) (kill)) - (setf (block-out block) (copy-sset gen)) - (setf (block-type-asserted block) nil) - (values)))) +;;;; Applying constraints ;;; Return true if X is an integer NUMERIC-TYPE. (defun integer-type-p (x) @@ -267,7 +275,7 @@ (defun constrain-float-type (x y greater or-equal) (declare (type numeric-type x y)) (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE - + (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -366,61 +374,166 @@ (let* ((cont (node-cont ref)) (dest (continuation-dest cont))) (cond ((and (if-p dest) - (csubtypep (specifier-type 'null) not-res) - (eq (continuation-asserted-type cont) *wild-type*)) + (csubtypep (specifier-type 'null) not-res)) (setf (node-derived-type ref) *wild-type*) (change-ref-leaf ref (find-constant t))) (t - (derive-node-type ref (or (type-difference res not-res) - res))))))) + (derive-node-type ref + (make-single-value-type + (or (type-difference res not-res) + res)))))))) (values)) +;;;; Flow analysis + +;;; Local propagation +;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that +;;; constraint.] +;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add +;;; a type constraint based on the new value type. +(declaim (ftype (function (cblock sset + &key (:ref-preprocessor function) + (:set-preprocessor function)) + sset) + constraint-propagate-in-block)) +(defun constraint-propagate-in-block + (block gen &key ref-preprocessor set-preprocessor) + + (let ((test (block-test-constraint block))) + (when test + (sset-union gen test))) + + (do-nodes (node cont block) + (typecase node + (bind + (let ((fun (bind-lambda node))) + (when (eq (functional-kind fun) :let) + (loop with call = (continuation-dest + (node-cont (first (lambda-refs fun)))) + for var in (lambda-vars fun) + and val in (combination-args call) + when (and val + (lambda-var-constraints var) + ;; if VAR has no SETs, type inference is + ;; fully performed by IR1 optimizer + (lambda-var-sets var)) + do (let* ((type (continuation-type val)) + (con (find-constraint 'typep var type nil))) + (sset-adjoin con gen)))))) + (ref + (let ((var (ok-ref-lambda-var node))) + (when var + (when ref-preprocessor + (funcall ref-preprocessor node gen)) + (let ((dest (continuation-dest cont))) + (when (cast-p dest) + (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME + (con (find-constraint 'typep var atype nil))) + (sset-adjoin con gen))))))) + (cset + (binding* ((var (set-var node)) + (nil (lambda-var-p var) :exit-if-null) + (cons (lambda-var-constraints var) :exit-if-null)) + (when set-preprocessor + (funcall set-preprocessor var)) + (sset-difference gen cons) + (let* ((type (single-value-type (node-derived-type node))) + (con (find-constraint 'typep var type nil))) + (sset-adjoin con gen)))))) + + gen) + +;;; BLOCK-KILL 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 +;;; precomputed, but it would have to be invalidated whenever any +;;; constraint is added, which would be a pain. +(defun compute-block-out (block) + (declare (type cblock block)) + (let ((in (block-in block)) + (kill (block-kill block)) + (out (copy-sset (block-gen block)))) + (cond ((null kill) + (sset-union out in)) + ((null (rest kill)) + (let ((con (lambda-var-constraints (first kill)))) + (if con + (sset-union-of-difference out in con) + (sset-union out in)))) + (t + (let ((kill-set (make-sset))) + (dolist (var kill) + (let ((con (lambda-var-constraints var))) + (when con + (sset-union kill-set con)))) + (sset-union-of-difference out in kill-set)))) + out)) + +;;; Compute the initial flow analysis sets for BLOCK: +;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet +;;; computed, assume it to be a universal set (this is only +;;; possible in a loop) +;;; +;;; Return T if we have found a loop. +(defun find-block-type-constraints (block) + (declare (type cblock block)) + (collect ((kill nil adjoin)) + (let ((gen (constraint-propagate-in-block + block (make-sset) + :set-preprocessor (lambda (var) + (kill var))))) + (setf (block-gen block) gen) + (setf (block-kill block) (kill)) + (setf (block-type-asserted block) nil) + (let* ((n (block-number block)) + (pred (block-pred block)) + (in nil) + (loop-p nil)) + (dolist (b pred) + (cond ((> (block-number b) n) + (if in + (sset-intersection in (block-out b)) + (setq in (copy-sset (block-out b))))) + (t (setq loop-p t)))) + (unless in + (bug "Unreachable code is found or flow graph is not ~ + properly depth-first ordered.")) + (setf (block-in block) in) + (setf (block-out block) (compute-block-out block)) + loop-p)))) + +;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. +;;; Our OUT is: +;;; gen U (in - kill) +;;; +;;; Return True if we have done something. +(defun flow-propagate-constraints (block) + (let* ((pred (block-pred block)) + (in (progn (aver pred) + (let ((res (copy-sset (block-out (first pred))))) + (dolist (b (rest pred)) + (sset-intersection res (block-out b))) + res)))) + (setf (block-in block) in) + (let ((out (compute-block-out block))) + (if (sset= out (block-out block)) + nil + (setf (block-out block) out))))) + ;;; Deliver the results of constraint propagation to REFs in BLOCK. ;;; During this pass, we also do local constraint propagation by ;;; adding in constraints as we seem them during the pass through the ;;; block. (defun use-result-constraints (block) (declare (type cblock block)) - (let ((in (block-in block))) - - (let ((test (block-test-constraint block))) - (when test - (sset-union in test))) - - (do-nodes (node cont block) - (typecase node - (ref - (let ((var (ref-leaf node))) - (when (lambda-var-p var) - (let ((con (lambda-var-constraints var))) - (when con - (constrain-ref-type node con in) - (when (continuation-type-check cont) - (sset-adjoin - (find-constraint 'typep var - (continuation-asserted-type cont) - nil) - in))))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference in cons)))))))))) - -;;; Return true if VAR would have to be closed over if environment -;;; analysis ran now (i.e. if there are any uses that have a different -;;; home lambda than VAR's home.) -(defun closure-var-p (var) - (declare (type lambda-var var)) - (let ((home (lambda-home (lambda-var-home var)))) - (flet ((frob (l) - (dolist (node l nil) - (unless (eq (node-home-lambda node) home) - (return t))))) - (or (frob (leaf-refs var)) - (frob (basic-var-sets var)))))) + (constraint-propagate-in-block + block (block-in block) + :ref-preprocessor (lambda (node cons) + (let* ((var (ref-leaf node)) + (con (lambda-var-constraints var))) + (constrain-ref-type node con cons))))) ;;; Give an empty constraints set to any var that doesn't have one and ;;; isn't a set closure var. Since a var that we previously rejected @@ -439,50 +552,15 @@ (dolist (let (lambda-lets fun)) (frob let))))) -;;; BLOCK-IN becomes the intersection of the OUT of the prececessors. -;;; Our OUT is: -;;; out U (in - kill) -;;; -;;; BLOCK-KILL 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 -;;; precomputed, but it would have to be invalidated whenever any -;;; constraint is added, which would be a pain. -(defun flow-propagate-constraints (block) - (let* ((pred (block-pred block)) - (in (cond (pred - (let ((res (copy-sset (block-out (first pred))))) - (dolist (b (rest pred)) - (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?"))) - (make-sset)))) - (kill (block-kill block)) - (out (block-out block))) +;;; 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)) - (setf (block-in block) in) - (cond ((null kill) - (sset-union (block-out block) in)) - ((null (rest kill)) - (let ((con (lambda-var-constraints (first kill)))) - (if con - (sset-union-of-difference out in con) - (sset-union out in)))) - (t - (let ((kill-set (make-sset))) - (dolist (var kill) - (let ((con (lambda-var-constraints var))) - (when con - (sset-union kill-set con)))) - (sset-union-of-difference (block-out block) in kill-set)))))) - -(defun constraint-propagate (component) +(defun constraint-propagate (component &aux (loop-p nil)) (declare (type component component)) (init-var-constraints component) @@ -490,23 +568,26 @@ (when (block-test-modified block) (find-test-constraints block))) - (do-blocks (block component) - (cond ((block-type-asserted block) - (find-block-type-constraints block)) - (t - (setf (block-in block) nil) - (setf (block-out block) (copy-sset (block-gen block)))))) - - (setf (block-out (component-head component)) (make-sset)) + (unless (block-out (component-head component)) + (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))) + (do-blocks (block component) + (when (find-block-type-constraints block) + (setq loop-p t))) + + (when loop-p + (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 (>= max-n-changes-remaining 0)) + (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))