X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=5e61da0c24bde2938a6e49a392435b4c72a0d102;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=823a16324d2edcc3d22fe133b0a18d05cad21c4c;hpb=bf4aee82dd12d132a82fa39355d66f2ac67c8fc5;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 823a163..5e61da0 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)) @@ -86,15 +120,17 @@ (lambda-var-constraints leaf)) leaf))) -;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, +;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, ;;; otherwise NIL. -#!-sb-fluid (declaim (inline ok-cont-lambda-var)) -(defun ok-cont-lambda-var (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) +#!-sb-fluid (declaim (inline ok-lvar-lambda-var)) +(defun ok-lvar-lambda-var (lvar) + (declare (type lvar lvar)) + (let ((use (lvar-uses lvar))) (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 @@ -133,49 +169,49 @@ (combination (unless (eq (combination-kind use) :error) - (let ((name (continuation-fun-name + (let ((name (lvar-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))) + (when (constant-lvar-p type) + (let ((val (lvar-value type))) (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) (if (ctype-p val) val (specifier-type val)) nil))))) ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) + (let* ((var1 (ok-lvar-lambda-var (first args))) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (cond ((not var1)) (var2 (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) + ((constant-lvar-p arg2) (add-complement-constraints if 'eql var1 (ref-leaf - (continuation-use arg2)) + (lvar-uses arg2)) nil))))) ((< >) (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) + (var1 (ok-lvar-lambda-var arg1)) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) + (add-complement-constraints if name var1 (lvar-type arg2) nil)) (when var2 (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) + var2 (lvar-type arg1) nil)))) (t (let ((ptype (gethash name *backend-predicate-types*))) (when ptype (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) ptype nil))))))))) (values)) @@ -185,49 +221,14 @@ (declare (type cblock block)) (let ((last (block-last block))) (when (if-p last) - (let ((use (continuation-use (if-test last)))) - (when use + (let ((use (lvar-uses (if-test last)))) + (when (node-p use) (add-test-constraints use last))))) (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-list 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) @@ -274,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.) @@ -353,7 +354,8 @@ (setq not-res (type-union not-res other-type))) (let ((leaf-type (leaf-type leaf))) (when (or (constant-p other) - (and (csubtypep other-type leaf-type) + (and (leaf-refs other) ; protect from deleted vars + (csubtypep other-type leaf-type) (not (type= other-type leaf-type)))) (change-ref-leaf ref other) (when (constant-p other) (return))))))) @@ -370,64 +372,167 @@ (constrain-float-type res y greater not-p))))) ))))) - (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*)) - (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))))))) + (cond ((and (if-p (node-dest ref)) + (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 + (make-single-value-type + (or (type-difference res not-res) + res))) + (maybe-terminate-block ref nil))))) (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 lvar block) + (typecase node + (bind + (let ((fun (bind-lambda node))) + (when (eq (functional-kind fun) :let) + (loop with call = (lvar-dest (node-lvar (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 (lvar-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 (and lvar (lvar-dest lvar)))) + (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 @@ -446,48 +551,6 @@ (dolist (let (lambda-lets fun)) (frob let))))) -;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. -;;; Our OUT is: -;;; out U (in - kill) -;;; -;;; 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 -;;; 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 - (let ((*compiler-error-context* (block-last block))) - (compiler-warn - "unreachable code in constraint ~ - propagation -- apparent compiler bug")) - (make-sset)))) - (kill-list (block-kill-list block)) - (out (block-out block))) - - (setf (block-in block) in) - (cond ((null kill-list) - (sset-union (block-out block) in)) - ((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-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)) @@ -496,7 +559,7 @@ (incf result)) result)) -(defun constraint-propagate (component) +(defun constraint-propagate (component &aux (loop-p nil)) (declare (type component component)) (init-var-constraints component) @@ -504,29 +567,29 @@ (when (block-test-modified block) (find-test-constraints block))) + (unless (block-out (component-head component)) + (setf (block-out (component-head component)) (make-sset))) + (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)) - - (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))))) + (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)) + (unless (block-delete-p block) + (use-result-constraints block))) (values))