1 ;;;; This file implements the constraint propagation phase of the
2 ;;;; compiler, which uses global flow analysis to obtain dynamic type
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
18 ;;; -- MV-BIND, :ASSIGNMENT
20 ;;; Note: The functions in this file that accept constraint sets are
21 ;;; actually receiving the constraint sets associated with nodes,
22 ;;; blocks, and lambda-vars. It might be make CP easier to understand
23 ;;; and work on if these functions traded in nodes, blocks, and
24 ;;; lambda-vars directly.
28 ;;; -- Constraint propagation badly interacts with bottom-up type
29 ;;; inference. Consider
31 ;;; (defun foo (n &aux (i 42))
32 ;;; (declare (optimize speed))
33 ;;; (declare (fixnum n)
34 ;;; #+nil (type (integer 0) i))
38 ;;; (when (>= i n) (go :exit))
43 ;;; In this case CP cannot even infer that I is of class INTEGER.
45 ;;; -- In the above example if we place the check after SETQ, CP will
46 ;;; fail to infer (< I FIXNUM): it does not understand that this
47 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
51 (deftype constraint-y () '(or ctype lvar lambda-var constant))
53 (defstruct (constraint
54 (:include sset-element)
55 (:constructor make-constraint (number kind x y not-p))
57 ;; the kind of constraint we have:
60 ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
61 ;; constrained to be of type Y.
64 ;; X is a lambda-var and Y is a CTYPE. The relation holds
65 ;; between X and some object of type Y.
68 ;; X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
69 ;; The relation is asserted to hold.
70 (kind nil :type (member typep < > eql))
71 ;; The operands to the relation.
72 (x nil :type lambda-var)
73 (y nil :type constraint-y)
74 ;; If true, negates the sense of the constraint, so the relation
76 (not-p nil :type boolean))
78 (defvar *constraint-number*)
79 (declaim (type (integer 0) *constraint-number*))
81 (defun find-constraint (kind x y not-p)
82 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
85 (do-sset-elements (con (lambda-var-constraints x) nil)
86 (when (and (eq (constraint-kind con) kind)
87 (eq (constraint-not-p con) not-p)
88 (type= (constraint-y con) y))
91 (do-sset-elements (con (lambda-var-constraints x) nil)
92 (when (and (eq (constraint-kind con) kind)
93 (eq (constraint-not-p con) not-p)
94 (eq (constraint-y con) y))
97 (do-sset-elements (con (lambda-var-constraints x) nil)
98 (when (and (eq (constraint-kind con) kind)
99 (eq (constraint-not-p con) not-p)
100 (let ((cx (constraint-x con)))
107 ;;; Return a constraint for the specified arguments. We only create a
108 ;;; new constraint if there isn't already an equivalent old one,
109 ;;; guaranteeing that all equivalent constraints are EQ. This
110 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
111 (defun find-or-create-constraint (kind x y not-p)
112 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
113 (or (find-constraint kind x y not-p)
114 (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
115 (sset-adjoin new (lambda-var-constraints x))
116 (when (lambda-var-p y)
117 (sset-adjoin new (lambda-var-constraints y)))
120 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
121 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
122 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
123 (defun ok-ref-lambda-var (ref)
124 (declare (type ref ref))
125 (let ((leaf (ref-leaf ref)))
126 (when (and (lambda-var-p leaf)
127 (lambda-var-constraints leaf))
130 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
131 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
132 (defun ok-lvar-lambda-var (lvar constraints)
133 (declare (type lvar lvar))
134 (let ((use (lvar-uses lvar)))
136 (let ((lambda-var (ok-ref-lambda-var use)))
138 (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
139 (when (and constraint (sset-member constraint constraints))
142 (ok-lvar-lambda-var (cast-value use) constraints)))))
144 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
145 (once-only ((var var))
146 `(let ((,symbol ,var))
150 (do-sset-elements (con ,constraints ,result)
151 (let ((other (and (eq (constraint-kind con) 'eql)
152 (eq (constraint-not-p con) nil)
153 (cond ((eq ,var (constraint-x con))
155 ((eq ,var (constraint-y con))
161 (when (lambda-var-p ,symbol)
164 ;;;; Searching constraints
166 ;;; Add the indicated test constraint to BLOCK. We don't add the
167 ;;; constraint if the block has multiple predecessors, since it only
168 ;;; holds on this particular path.
169 (defun add-test-constraint (fun x y not-p constraints target)
170 (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
171 (add-eql-var-var-constraint x y constraints target))
173 (do-eql-vars (x (x constraints))
174 (let ((con (find-or-create-constraint fun x y not-p)))
175 (sset-adjoin con target)))))
178 ;;; Add complementary constraints to the consequent and alternative
179 ;;; blocks of IF. We do nothing if X is NIL.
180 (defun add-complement-constraints (fun x y not-p constraints
181 consequent-constraints
182 alternative-constraints)
184 (add-test-constraint fun x y not-p constraints
185 consequent-constraints)
186 (add-test-constraint fun x y (not not-p) constraints
187 alternative-constraints))
190 ;;; Add test constraints to the consequent and alternative blocks of
191 ;;; the test represented by USE.
192 (defun add-test-constraints (use if constraints)
193 (declare (type node use) (type cif if))
194 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
195 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
196 ;; can't guarantee that the optimization will be done, so we still
197 ;; need to avoid barfing on this case.
198 (unless (eq (if-consequent if) (if-alternative if))
199 (let ((consequent-constraints (make-sset))
200 (alternative-constraints (make-sset)))
201 (macrolet ((add (fun x y not-p)
202 `(add-complement-constraints ,fun ,x ,y ,not-p
204 consequent-constraints
205 alternative-constraints)))
208 (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
209 (specifier-type 'null) t))
211 (unless (eq (combination-kind use)
213 (let ((name (lvar-fun-name
214 (basic-combination-fun use)))
215 (args (basic-combination-args use)))
217 ((%typep %instance-typep)
218 (let ((type (second args)))
219 (when (constant-lvar-p type)
220 (let ((val (lvar-value type)))
222 (ok-lvar-lambda-var (first args) constraints)
225 (specifier-type val))
228 (let* ((arg1 (first args))
229 (var1 (ok-lvar-lambda-var arg1 constraints))
231 (var2 (ok-lvar-lambda-var arg2 constraints)))
232 ;; The code below assumes that the constant is the
233 ;; second argument in case of variable to constant
234 ;; comparision which is sometimes true (see source
235 ;; transformations for EQ, EQL and CHAR=). Fixing
236 ;; that would result in more constant substitutions
237 ;; which is not a universally good thing, thus the
238 ;; unnatural asymmetry of the tests.
241 (add-test-constraint 'typep var2 (lvar-type arg1)
243 consequent-constraints)))
245 (add 'eql var1 var2 nil))
246 ((constant-lvar-p arg2)
247 (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
250 (add-test-constraint 'typep var1 (lvar-type arg2)
252 consequent-constraints)))))
254 (let* ((arg1 (first args))
255 (var1 (ok-lvar-lambda-var arg1 constraints))
257 (var2 (ok-lvar-lambda-var arg2 constraints)))
259 (add name var1 (lvar-type arg2) nil))
261 (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
263 (let ((ptype (gethash name *backend-predicate-types*)))
265 (add 'typep (ok-lvar-lambda-var (first args) constraints)
267 (values consequent-constraints alternative-constraints))))
269 ;;;; Applying constraints
271 ;;; Return true if X is an integer NUMERIC-TYPE.
272 (defun integer-type-p (x)
273 (declare (type ctype x))
274 (and (numeric-type-p x)
275 (eq (numeric-type-class x) 'integer)
276 (eq (numeric-type-complexp x) :real)))
278 ;;; Given that an inequality holds on values of type X and Y, return a
279 ;;; new type for X. If GREATER is true, then X was greater than Y,
280 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
281 ;;; inclusive, i.e. >=.
283 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
284 ;;; bound into X and return that result. If not OR-EQUAL, we can go
285 ;;; one greater (less) than Y's bound.
286 (defun constrain-integer-type (x y greater or-equal)
287 (declare (type numeric-type x y))
294 (if greater (numeric-type-low x) (numeric-type-high x))))
295 (let* ((x-bound (bound x))
296 (y-bound (exclude (bound y)))
297 (new-bound (cond ((not x-bound) y-bound)
298 ((not y-bound) x-bound)
299 (greater (max x-bound y-bound))
300 (t (min x-bound y-bound)))))
302 (modified-numeric-type x :low new-bound)
303 (modified-numeric-type x :high new-bound)))))
305 ;;; Return true if X is a float NUMERIC-TYPE.
306 (defun float-type-p (x)
307 (declare (type ctype x))
308 (and (numeric-type-p x)
309 (eq (numeric-type-class x) 'float)
310 (eq (numeric-type-complexp x) :real)))
312 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
313 (defun constrain-float-type (x y greater or-equal)
314 (declare (type numeric-type x y))
315 (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
317 (aver (eql (numeric-type-class x) 'float))
318 (aver (eql (numeric-type-class y) 'float))
319 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
321 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
322 (labels ((exclude (x)
330 (if greater (numeric-type-low x) (numeric-type-high x)))
335 (= (type-bound-number x) (type-bound-number ref)))
336 ;; X is tighter if REF is not an open bound and X is
337 (and (not (consp ref)) (consp x)))
339 (< (type-bound-number ref) (type-bound-number x)))
341 (> (type-bound-number ref) (type-bound-number x))))))
342 (let* ((x-bound (bound x))
343 (y-bound (exclude (bound y)))
344 (new-bound (cond ((not x-bound)
348 ((tighter-p y-bound x-bound)
353 (modified-numeric-type x :low new-bound)
354 (modified-numeric-type x :high new-bound)))))
356 ;;; Given the set of CONSTRAINTS for a variable and the current set of
357 ;;; restrictions from flow analysis IN, set the type for REF
359 (defun constrain-ref-type (ref constraints in)
360 (declare (type ref ref) (type sset constraints in))
361 ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
362 ;; cons up endless union types when propagating large number of EQL
363 ;; constraints -- eg. from large CASE forms -- instead we just
364 ;; directly accumulate one XSET, and a set of fp zeroes, which we at
365 ;; the end turn into a MEMBER-TYPE.
367 ;; Since massive symbol cases are an especially atrocious pattern
368 ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
369 ;; a more useful type, don't propagate their negation except for NIL
370 ;; unless SPEED > COMPILATION-SPEED.
371 (let ((res (single-value-type (node-derived-type ref)))
372 (constrain-symbols (policy ref (> speed compilation-speed)))
373 (not-set (alloc-xset))
375 (not-res *empty-type*)
376 (leaf (ref-leaf ref)))
380 (when (or constrain-symbols (null x) (not (symbolp x)))
381 (add-to-xset x not-set)))))
382 (do-sset-elements (con constraints)
383 (when (sset-member con in)
384 (let* ((x (constraint-x con))
385 (y (constraint-y con))
386 (not-p (constraint-not-p con))
387 (other (if (eq x leaf) y x))
388 (kind (constraint-kind con)))
392 (if (member-type-p other)
393 (mapc-member-type-members #'note-not other)
394 (setq not-res (type-union not-res other)))
395 (setq res (type-approx-intersection2 res other))))
397 (unless (lvar-p other)
398 (let ((other-type (leaf-type other)))
400 (when (and (constant-p other)
401 (member-type-p other-type))
402 (note-not (constant-value other)))
403 (let ((leaf-type (leaf-type leaf)))
405 ((or (constant-p other)
406 (and (leaf-refs other) ; protect from
408 (csubtypep other-type leaf-type)
409 (not (type= other-type leaf-type))))
410 (change-ref-leaf ref other)
411 (when (constant-p other) (return)))
413 (setq res (type-approx-intersection2
414 res other-type)))))))))
417 ((and (integer-type-p res) (integer-type-p y))
418 (let ((greater (eq kind '>)))
419 (let ((greater (if not-p (not greater) greater)))
421 (constrain-integer-type res y greater not-p)))))
422 ((and (float-type-p res) (float-type-p y))
423 (let ((greater (eq kind '>)))
424 (let ((greater (if not-p (not greater) greater)))
426 (constrain-float-type res y greater not-p))))))))))))
427 (cond ((and (if-p (node-dest ref))
428 (or (xset-member-p nil not-set)
429 (csubtypep (specifier-type 'null) not-res)))
430 (setf (node-derived-type ref) *wild-type*)
431 (change-ref-leaf ref (find-constant t)))
434 (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
435 (derive-node-type ref
436 (make-single-value-type
437 (or (type-difference res not-res)
439 (maybe-terminate-block ref nil))))
444 (defun maybe-add-eql-var-lvar-constraint (ref gen)
445 (let ((lvar (ref-lvar ref))
446 (leaf (ref-leaf ref)))
447 (when (and (lambda-var-p leaf) lvar)
448 (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
451 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
452 ;;; LVAR) ones - to all of the variables in the VARS list.
453 (defun inherit-constraints (vars from-var constraints target)
454 (do-sset-elements (con constraints)
455 ;; Constant substitution is controversial.
456 (unless (constant-p (constraint-y con))
458 (let ((eq-x (eq from-var (constraint-x con)))
459 (eq-y (eq from-var (constraint-y con))))
460 (when (or (and eq-x (not (lvar-p (constraint-y con))))
462 (sset-adjoin (find-or-create-constraint
463 (constraint-kind con)
464 (if eq-x var (constraint-x con))
465 (if eq-y var (constraint-y con))
466 (constraint-not-p con))
469 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
470 ;; inherit each other's constraints.
471 (defun add-eql-var-var-constraint (var1 var2 constraints
472 &optional (target constraints))
473 (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
474 (when (sset-adjoin con target)
475 (collect ((eql1) (eql2))
476 (do-eql-vars (var1 (var1 constraints))
478 (do-eql-vars (var2 (var2 constraints))
480 (inherit-constraints (eql1) var2 constraints target)
481 (inherit-constraints (eql2) var1 constraints target))
484 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
485 ;; LAMBDA-VAR if possible.
486 (defun maybe-add-eql-var-var-constraint (var lvar constraints
487 &optional (target constraints))
488 (declare (type lambda-var var) (type lvar lvar))
489 (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
491 (add-eql-var-var-constraint var lambda-var constraints target))))
493 ;;; Local propagation
494 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
496 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
497 ;;; a type constraint based on the new value type.
498 (declaim (ftype (function (cblock sset boolean)
500 constraint-propagate-in-block))
501 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
502 (do-nodes (node lvar block)
505 (let ((fun (bind-lambda node)))
506 (when (eq (functional-kind fun) :let)
507 (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
508 for var in (lambda-vars fun)
509 and val in (combination-args call)
510 when (and val (lambda-var-constraints var))
511 do (let* ((type (lvar-type val))
512 (con (find-or-create-constraint 'typep var type
514 (sset-adjoin con gen))
515 (maybe-add-eql-var-var-constraint var val gen)))))
517 (when (ok-ref-lambda-var node)
518 (maybe-add-eql-var-lvar-constraint node gen)
519 (when preprocess-refs-p
520 (let* ((var (ref-leaf node))
521 (con (lambda-var-constraints var)))
522 (constrain-ref-type node con gen)))))
524 (let ((lvar (cast-value node)))
525 (let ((var (ok-lvar-lambda-var lvar gen)))
527 (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
528 (do-eql-vars (var (var gen))
529 (let ((con (find-or-create-constraint 'typep var atype nil)))
530 (sset-adjoin con gen))))))))
532 (binding* ((var (set-var node))
533 (nil (lambda-var-p var) :exit-if-null)
534 (cons (lambda-var-constraints var) :exit-if-null))
535 (sset-difference gen cons)
536 (let* ((type (single-value-type (node-derived-type node)))
537 (con (find-or-create-constraint 'typep var type nil)))
538 (sset-adjoin con gen))
539 (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
542 (defun constraint-propagate-if (block gen)
543 (let ((node (block-last block)))
545 (let ((use (lvar-uses (if-test node))))
547 (add-test-constraints use node gen))))))
549 ;;; Starting from IN compute OUT and (consequent/alternative
550 ;;; constraints if the block ends with and IF). Return the list of
551 ;;; successors that may need to be recomputed.
552 (defun find-block-type-constraints (block final-pass-p)
553 (declare (type cblock block))
554 (let ((gen (constraint-propagate-in-block
558 (copy-sset (block-in block)))
560 (setf (block-gen block) gen)
561 (multiple-value-bind (consequent-constraints alternative-constraints)
562 (constraint-propagate-if block gen)
563 (if consequent-constraints
564 (let* ((node (block-last block))
565 (old-consequent-constraints (if-consequent-constraints node))
566 (old-alternative-constraints (if-alternative-constraints node))
568 ;; Add the consequent and alternative constraints to GEN.
569 (cond ((sset-empty consequent-constraints)
570 (setf (if-consequent-constraints node) gen)
571 (setf (if-alternative-constraints node) gen))
573 (setf (if-consequent-constraints node) (copy-sset gen))
574 (sset-union (if-consequent-constraints node)
575 consequent-constraints)
576 (setf (if-alternative-constraints node) gen)
577 (sset-union (if-alternative-constraints node)
578 alternative-constraints)))
579 ;; Has the consequent been changed?
580 (unless (and old-consequent-constraints
581 (sset= (if-consequent-constraints node)
582 old-consequent-constraints))
583 (push (if-consequent node) succ))
584 ;; Has the alternative been changed?
585 (unless (and old-alternative-constraints
586 (sset= (if-alternative-constraints node)
587 old-alternative-constraints))
588 (push (if-alternative node) succ))
591 (unless (and (block-out block)
592 (sset= gen (block-out block)))
593 (setf (block-out block) gen)
594 (block-succ block))))))
596 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
597 ;;; During this pass, we also do local constraint propagation by
598 ;;; adding in constraints as we see them during the pass through the
600 (defun use-result-constraints (block)
601 (declare (type cblock block))
602 (constraint-propagate-in-block block (block-in block) t))
604 ;;; Give an empty constraints set to any var that doesn't have one and
605 ;;; isn't a set closure var. Since a var that we previously rejected
606 ;;; looks identical to one that is new, so we optimistically keep
607 ;;; hoping that vars stop being closed over or lose their sets.
608 (defun init-var-constraints (component)
609 (declare (type component component))
610 (dolist (fun (component-lambdas component))
612 (dolist (var (lambda-vars x))
613 (unless (lambda-var-constraints var)
614 (when (or (null (lambda-var-sets var))
615 (not (closure-var-p var)))
616 (setf (lambda-var-constraints var) (make-sset)))))))
618 (dolist (let (lambda-lets fun))
621 ;;; Return the constraints that flow from PRED to SUCC. This is
622 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
624 (defun block-out-for-successor (pred succ)
625 (declare (type cblock pred succ))
626 (let ((last (block-last pred)))
627 (or (when (if-p last)
628 (cond ((eq succ (if-consequent last))
629 (if-consequent-constraints last))
630 ((eq succ (if-alternative last))
631 (if-alternative-constraints last))))
634 (defun compute-block-in (block)
636 (dolist (pred (block-pred block))
637 ;; If OUT has not been calculated, assume it to be the universal
639 (let ((out (block-out-for-successor pred block)))
642 (sset-intersection in out)
643 (setq in (copy-sset out))))))
644 (or in (make-sset))))
646 (defun update-block-in (block)
647 (let ((in (compute-block-in block)))
648 (cond ((and (block-in block) (sset= in (block-in block)))
651 (setf (block-in block) in)))))
653 ;;; Return two lists: one of blocks that precede all loops and
654 ;;; therefore require only one constraint propagation pass and the
655 ;;; rest. This implementation does not find all such blocks.
657 ;;; A more complete implementation would be:
659 ;;; (do-blocks (block component)
660 ;;; (if (every #'(lambda (pred)
661 ;;; (or (member pred leading-blocks)
663 ;;; (block-pred block))
664 ;;; (push block leading-blocks)
665 ;;; (push block rest-of-blocks)))
667 ;;; Trailing blocks that succeed all loops could be found and handled
668 ;;; similarly. In practice though, these more complex solutions are
669 ;;; slightly worse performancewise.
670 (defun leading-component-blocks (component)
671 (declare (type component component))
672 (flet ((loopy-p (block)
673 (let ((n (block-number block)))
674 (dolist (pred (block-pred block))
675 (unless (< n (block-number pred))
677 (let ((leading-blocks ())
680 (do-blocks (block component)
681 (when (and (not seen-loop-p) (loopy-p block))
682 (setq seen-loop-p t))
684 (push block rest-of-blocks)
685 (push block leading-blocks)))
686 (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
688 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
689 ;;; a member already.
690 (defun nconc-new (obj list)
691 (do ((x list (cdr x))
695 (setf (cdr prev) (list obj))
698 (when (eql (car x) obj)
699 (return-from nconc-new list))))
701 (defun find-and-propagate-constraints (component)
702 (let ((blocks-to-process ()))
703 (flet ((enqueue (blocks)
704 (dolist (block blocks)
705 (setq blocks-to-process (nconc-new block blocks-to-process)))))
706 (multiple-value-bind (leading-blocks rest-of-blocks)
707 (leading-component-blocks component)
708 ;; Update every block once to account for changes in the
709 ;; IR1. The constraints of the lead blocks cannot be changed
710 ;; after the first pass so we might as well use them and skip
711 ;; USE-RESULT-CONSTRAINTS later.
712 (dolist (block leading-blocks)
713 (setf (block-in block) (compute-block-in block))
714 (find-block-type-constraints block t))
715 (setq blocks-to-process (copy-list rest-of-blocks))
716 ;; The rest of the blocks.
717 (dolist (block rest-of-blocks)
718 (aver (eq block (pop blocks-to-process)))
719 (setf (block-in block) (compute-block-in block))
720 (enqueue (find-block-type-constraints block nil)))
721 ;; Propagate constraints
722 (loop for block = (pop blocks-to-process)
724 (unless (eq block (component-tail component))
725 (when (update-block-in block)
726 (enqueue (find-block-type-constraints block nil)))))
729 (defun constraint-propagate (component)
730 (declare (type component component))
731 (init-var-constraints component)
733 (unless (block-out (component-head component))
734 (setf (block-out (component-head component)) (make-sset)))
736 (dolist (block (find-and-propagate-constraints component))
737 (unless (block-delete-p block)
738 (use-result-constraints block)))