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
22 ;;; -- Constraint propagation badly interacts with bottom-up type
23 ;;; inference. Consider
25 ;;; (defun foo (n &aux (i 42))
26 ;;; (declare (optimize speed))
27 ;;; (declare (fixnum n)
28 ;;; #+nil (type (integer 0) i))
32 ;;; (when (>= i n) (go :exit))
37 ;;; In this case CP cannot even infer that I is of class INTEGER.
39 ;;; -- In the above example if we place the check after SETQ, CP will
40 ;;; fail to infer (< I FIXNUM): it does not understand that this
41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
45 (deftype constraint-y
() '(or ctype lvar lambda-var constant
))
47 (defstruct (constraint
48 (:include sset-element
)
49 (:constructor make-constraint
(number kind x y not-p
))
51 ;; the kind of constraint we have:
54 ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
55 ;; constrained to be of type Y.
58 ;; X is a lambda-var and Y is a CTYPE. The relation holds
59 ;; between X and some object of type Y.
62 ;; X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
63 ;; The relation is asserted to hold.
64 (kind nil
:type
(member typep
< > eql
))
65 ;; The operands to the relation.
66 (x nil
:type lambda-var
)
67 (y nil
:type constraint-y
)
68 ;; If true, negates the sense of the constraint, so the relation
70 (not-p nil
:type boolean
))
72 (defvar *constraint-number
*)
73 (declaim (type (integer 0) *constraint-number
*))
75 (defun find-constraint (kind x y not-p
)
76 (declare (type lambda-var x
) (type constraint-y y
) (type boolean not-p
))
79 (do-sset-elements (con (lambda-var-constraints x
) nil
)
80 (when (and (eq (constraint-kind con
) kind
)
81 (eq (constraint-not-p con
) not-p
)
82 (type= (constraint-y con
) y
))
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 (eq (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 (let ((cx (constraint-x con
)))
101 ;;; Return a constraint for the specified arguments. We only create a
102 ;;; new constraint if there isn't already an equivalent old one,
103 ;;; guaranteeing that all equivalent constraints are EQ. This
104 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
105 (defun find-or-create-constraint (kind x y not-p
)
106 (declare (type lambda-var x
) (type constraint-y y
) (type boolean not-p
))
107 (or (find-constraint kind x y not-p
)
108 (let ((new (make-constraint (incf *constraint-number
*) kind x y not-p
)))
109 (sset-adjoin new
(lambda-var-constraints x
))
110 (when (lambda-var-p y
)
111 (sset-adjoin new
(lambda-var-constraints y
)))
114 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
115 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
116 #!-sb-fluid
(declaim (inline ok-ref-lambda-var
))
117 (defun ok-ref-lambda-var (ref)
118 (declare (type ref ref
))
119 (let ((leaf (ref-leaf ref
)))
120 (when (and (lambda-var-p leaf
)
121 (lambda-var-constraints leaf
))
124 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
125 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
126 (defun ok-lvar-lambda-var (lvar constraints
)
127 (declare (type lvar lvar
))
128 (let ((use (lvar-uses lvar
)))
130 (let ((lambda-var (ok-ref-lambda-var use
)))
132 (let ((constraint (find-constraint 'eql lambda-var lvar nil
)))
133 (when (and constraint
(sset-member constraint constraints
))
136 (ok-lvar-lambda-var (cast-value use
) constraints
)))))
138 (defmacro do-eql-vars
((symbol (var constraints
) &optional result
) &body body
)
139 (once-only ((var var
))
140 `(let ((,symbol
,var
))
144 (do-sset-elements (con ,constraints
,result
)
145 (let ((other (and (eq (constraint-kind con
) 'eql
)
146 (eq (constraint-not-p con
) nil
)
147 (cond ((eq ,var
(constraint-x con
))
149 ((eq ,var
(constraint-y con
))
155 (when (lambda-var-p ,symbol
)
158 ;;;; Searching constraints
160 ;;; Add the indicated test constraint to BLOCK. We don't add the
161 ;;; constraint if the block has multiple predecessors, since it only
162 ;;; holds on this particular path.
163 (defun add-test-constraint (fun x y not-p constraints target
)
164 (cond ((and (eq 'eql fun
) (lambda-var-p y
) (not not-p
))
165 (add-eql-var-var-constraint x y constraints target
))
167 (do-eql-vars (x (x constraints
))
168 (let ((con (find-or-create-constraint fun x y not-p
)))
169 (sset-adjoin con target
)))))
172 ;;; Add complementary constraints to the consequent and alternative
173 ;;; blocks of IF. We do nothing if X is NIL.
174 (defun add-complement-constraints (fun x y not-p constraints
175 consequent-constraints
176 alternative-constraints
)
178 (add-test-constraint fun x y not-p constraints
179 consequent-constraints
)
180 (add-test-constraint fun x y
(not not-p
) constraints
181 alternative-constraints
))
184 ;;; Add test constraints to the consequent and alternative blocks of
185 ;;; the test represented by USE.
186 (defun add-test-constraints (use if constraints
)
187 (declare (type node use
) (type cif if
))
188 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
189 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
190 ;; can't guarantee that the optimization will be done, so we still
191 ;; need to avoid barfing on this case.
192 (unless (eq (if-consequent if
) (if-alternative if
))
193 (let ((consequent-constraints (make-sset))
194 (alternative-constraints (make-sset)))
195 (macrolet ((add (fun x y not-p
)
196 `(add-complement-constraints ,fun
,x
,y
,not-p
198 consequent-constraints
199 alternative-constraints
)))
202 (add 'typep
(ok-lvar-lambda-var (ref-lvar use
) constraints
)
203 (specifier-type 'null
) t
))
205 (unless (eq (combination-kind use
)
207 (let ((name (lvar-fun-name
208 (basic-combination-fun use
)))
209 (args (basic-combination-args use
)))
211 ((%typep %instance-typep
)
212 (let ((type (second args
)))
213 (when (constant-lvar-p type
)
214 (let ((val (lvar-value type
)))
216 (ok-lvar-lambda-var (first args
) constraints
)
219 (specifier-type val
))
222 (let* ((arg1 (first args
))
223 (var1 (ok-lvar-lambda-var arg1 constraints
))
225 (var2 (ok-lvar-lambda-var arg2 constraints
)))
226 ;; The code below assumes that the constant is the
227 ;; second argument in case of variable to constant
228 ;; comparision which is sometimes true (see source
229 ;; transformations for EQ, EQL and CHAR=). Fixing
230 ;; that would result in more constant substitutions
231 ;; which is not a universally good thing, thus the
232 ;; unnatural asymmetry of the tests.
235 (add-test-constraint 'typep var2
(lvar-type arg1
)
237 consequent-constraints
)))
239 (add 'eql var1 var2 nil
))
240 ((constant-lvar-p arg2
)
241 (add 'eql var1
(ref-leaf (principal-lvar-use arg2
))
244 (add-test-constraint 'typep var1
(lvar-type arg2
)
246 consequent-constraints
)))))
248 (let* ((arg1 (first args
))
249 (var1 (ok-lvar-lambda-var arg1 constraints
))
251 (var2 (ok-lvar-lambda-var arg2 constraints
)))
253 (add name var1
(lvar-type arg2
) nil
))
255 (add (if (eq name
'<) '> '<) var2
(lvar-type arg1
) nil
))))
257 (let ((ptype (gethash name
*backend-predicate-types
*)))
259 (add 'typep
(ok-lvar-lambda-var (first args
) constraints
)
261 (values consequent-constraints alternative-constraints
))))
263 ;;;; Applying constraints
265 ;;; Return true if X is an integer NUMERIC-TYPE.
266 (defun integer-type-p (x)
267 (declare (type ctype x
))
268 (and (numeric-type-p x
)
269 (eq (numeric-type-class x
) 'integer
)
270 (eq (numeric-type-complexp x
) :real
)))
272 ;;; Given that an inequality holds on values of type X and Y, return a
273 ;;; new type for X. If GREATER is true, then X was greater than Y,
274 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
275 ;;; inclusive, i.e. >=.
277 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
278 ;;; bound into X and return that result. If not OR-EQUAL, we can go
279 ;;; one greater (less) than Y's bound.
280 (defun constrain-integer-type (x y greater or-equal
)
281 (declare (type numeric-type x y
))
288 (if greater
(numeric-type-low x
) (numeric-type-high x
))))
289 (let* ((x-bound (bound x
))
290 (y-bound (exclude (bound y
)))
291 (new-bound (cond ((not x-bound
) y-bound
)
292 ((not y-bound
) x-bound
)
293 (greater (max x-bound y-bound
))
294 (t (min x-bound y-bound
)))))
296 (modified-numeric-type x
:low new-bound
)
297 (modified-numeric-type x
:high new-bound
)))))
299 ;;; Return true if X is a float NUMERIC-TYPE.
300 (defun float-type-p (x)
301 (declare (type ctype x
))
302 (and (numeric-type-p x
)
303 (eq (numeric-type-class x
) 'float
)
304 (eq (numeric-type-complexp x
) :real
)))
306 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
307 (defun constrain-float-type (x y greater or-equal
)
308 (declare (type numeric-type x y
))
309 (declare (ignorable x y greater or-equal
)) ; for CROSS-FLOAT-INFINITY-KLUDGE
311 (aver (eql (numeric-type-class x
) 'float
))
312 (aver (eql (numeric-type-class y
) 'float
))
313 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
315 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
316 (labels ((exclude (x)
324 (if greater
(numeric-type-low x
) (numeric-type-high x
)))
329 (= (type-bound-number x
) (type-bound-number ref
)))
330 ;; X is tighter if REF is not an open bound and X is
331 (and (not (consp ref
)) (consp x
)))
333 (< (type-bound-number ref
) (type-bound-number x
)))
335 (> (type-bound-number ref
) (type-bound-number x
))))))
336 (let* ((x-bound (bound x
))
337 (y-bound (exclude (bound y
)))
338 (new-bound (cond ((not x-bound
)
342 ((tighter-p y-bound x-bound
)
347 (modified-numeric-type x
:low new-bound
)
348 (modified-numeric-type x
:high new-bound
)))))
350 ;;; Given the set of CONSTRAINTS for a variable and the current set of
351 ;;; restrictions from flow analysis IN, set the type for REF
353 (defun constrain-ref-type (ref constraints in
)
354 (declare (type ref ref
) (type sset constraints in
))
355 (let ((var-cons (copy-sset constraints
)))
356 (sset-intersection var-cons in
)
357 (let ((res (single-value-type (node-derived-type ref
)))
358 (not-res *empty-type
*)
359 (leaf (ref-leaf ref
)))
360 (do-sset-elements (con var-cons
)
361 (let* ((x (constraint-x con
))
362 (y (constraint-y con
))
363 (not-p (constraint-not-p con
))
364 (other (if (eq x leaf
) y x
))
365 (kind (constraint-kind con
)))
369 (setq not-res
(type-union not-res other
))
370 (setq res
(type-approx-intersection2 res other
))))
372 (unless (lvar-p other
)
373 (let ((other-type (leaf-type other
)))
375 (when (and (constant-p other
)
376 (member-type-p other-type
))
377 (setq not-res
(type-union not-res other-type
)))
378 (let ((leaf-type (leaf-type leaf
)))
380 ((or (constant-p other
)
381 (and (leaf-refs other
) ; protect from
383 (csubtypep other-type leaf-type
)
384 (not (type= other-type leaf-type
))))
385 (change-ref-leaf ref other
)
386 (when (constant-p other
) (return)))
388 (setq res
(type-approx-intersection2
389 res other-type
)))))))))
392 ((and (integer-type-p res
) (integer-type-p y
))
393 (let ((greater (eq kind
'>)))
394 (let ((greater (if not-p
(not greater
) greater
)))
396 (constrain-integer-type res y greater not-p
)))))
397 ((and (float-type-p res
) (float-type-p y
))
398 (let ((greater (eq kind
'>)))
399 (let ((greater (if not-p
(not greater
) greater
)))
401 (constrain-float-type res y greater not-p
))))))))))
402 (cond ((and (if-p (node-dest ref
))
403 (csubtypep (specifier-type 'null
) not-res
))
404 (setf (node-derived-type ref
) *wild-type
*)
405 (change-ref-leaf ref
(find-constant t
)))
407 (derive-node-type ref
408 (make-single-value-type
409 (or (type-difference res not-res
)
411 (maybe-terminate-block ref nil
)))))
417 (defun maybe-add-eql-var-lvar-constraint (ref gen
)
418 (let ((lvar (ref-lvar ref
))
419 (leaf (ref-leaf ref
)))
420 (when (and (lambda-var-p leaf
) lvar
)
421 (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil
)
424 ;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
426 (defun inherit-constraints (var from-var constraints target
)
427 (do-sset-elements (con constraints
)
428 (let ((eq-x (eq from-var
(constraint-x con
)))
429 (eq-y (eq from-var
(constraint-y con
))))
430 ;; Constant substitution is controversial.
431 (unless (constant-p (constraint-y con
))
432 (when (or (and eq-x
(not (lvar-p (constraint-y con
))))
434 (sset-adjoin (find-or-create-constraint
435 (constraint-kind con
)
436 (if eq-x var
(constraint-x con
))
437 (if eq-y var
(constraint-y con
))
438 (constraint-not-p con
))
441 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
442 ;; inherit each other's constraints.
443 (defun add-eql-var-var-constraint (var1 var2 constraints
444 &optional
(target constraints
))
445 (let ((con (find-or-create-constraint 'eql var1 var2 nil
)))
446 (when (sset-adjoin con target
)
447 (do-eql-vars (var2 (var2 constraints
))
448 (inherit-constraints var1 var2 constraints target
))
449 (do-eql-vars (var1 (var1 constraints
))
450 (inherit-constraints var1 var2 constraints target
))
453 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
454 ;; LAMBDA-VAR if possible.
455 (defun maybe-add-eql-var-var-constraint (var lvar constraints
456 &optional
(target constraints
))
457 (declare (type lambda-var var
) (type lvar lvar
))
458 (let ((lambda-var (ok-lvar-lambda-var lvar constraints
)))
460 (add-eql-var-var-constraint var lambda-var constraints target
))))
462 ;;; Local propagation
463 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
465 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
466 ;;; a type constraint based on the new value type.
467 (declaim (ftype (function (cblock sset
468 &key
(:ref-preprocessor
(or null function
))
469 (:set-preprocessor
(or null function
)))
471 constraint-propagate-in-block
))
472 (defun constraint-propagate-in-block
473 (block gen
&key ref-preprocessor set-preprocessor
)
475 (do-nodes (node lvar block
)
478 (let ((fun (bind-lambda node
)))
479 (when (eq (functional-kind fun
) :let
)
480 (loop with call
= (lvar-dest (node-lvar (first (lambda-refs fun
))))
481 for var in
(lambda-vars fun
)
482 and val in
(combination-args call
)
483 when
(and val
(lambda-var-constraints var
))
484 do
(let* ((type (lvar-type val
))
485 (con (find-or-create-constraint 'typep var type
487 (sset-adjoin con gen
))
488 (maybe-add-eql-var-var-constraint var val gen
)))))
490 (when (ok-ref-lambda-var node
)
491 (maybe-add-eql-var-lvar-constraint node gen
)
492 (when ref-preprocessor
493 (funcall ref-preprocessor node gen
))))
495 (let ((lvar (cast-value node
)))
496 (let ((var (ok-lvar-lambda-var lvar gen
)))
498 (let ((atype (single-value-type (cast-derived-type node
)))) ;FIXME
499 (do-eql-vars (var (var gen
))
500 (let ((con (find-or-create-constraint 'typep var atype nil
)))
501 (sset-adjoin con gen
))))))))
503 (binding* ((var (set-var node
))
504 (nil (lambda-var-p var
) :exit-if-null
)
505 (cons (lambda-var-constraints var
) :exit-if-null
))
506 (when set-preprocessor
507 (funcall set-preprocessor var
))
508 (sset-difference gen cons
)
509 (let* ((type (single-value-type (node-derived-type node
)))
510 (con (find-or-create-constraint 'typep var type nil
)))
511 (sset-adjoin con gen
))
512 (maybe-add-eql-var-var-constraint var
(set-value node
) gen
)))))
516 (defun constraint-propagate-if (block gen
)
517 (let ((node (block-last block
)))
519 (let ((use (lvar-uses (if-test node
))))
521 (add-test-constraints use node gen
))))))
523 (defun constrain-node (node cons
)
524 (let* ((var (ref-leaf node
))
525 (con (lambda-var-constraints var
)))
526 (constrain-ref-type node con cons
)))
528 ;;; Starting from IN compute OUT and (consequent/alternative
529 ;;; constraints if the block ends with and IF). Return the list of
530 ;;; successors that may need to be recomputed.
531 (defun find-block-type-constraints (block &key final-pass-p
)
532 (declare (type cblock block
))
533 (let ((gen (constraint-propagate-in-block
537 (copy-sset (block-in block
)))
538 :ref-preprocessor
(if final-pass-p
#'constrain-node nil
))))
539 (setf (block-gen block
) gen
)
540 (multiple-value-bind (consequent-constraints alternative-constraints
)
541 (constraint-propagate-if block gen
)
542 (if consequent-constraints
543 (let* ((node (block-last block
))
544 (old-consequent-constraints (if-consequent-constraints node
))
545 (old-alternative-constraints (if-alternative-constraints node
))
547 ;; Add the consequent and alternative constraints to GEN.
548 (cond ((sset-empty consequent-constraints
)
549 (setf (if-consequent-constraints node
) gen
)
550 (setf (if-alternative-constraints node
) gen
))
552 (setf (if-consequent-constraints node
) (copy-sset gen
))
553 (sset-union (if-consequent-constraints node
)
554 consequent-constraints
)
555 (setf (if-alternative-constraints node
) gen
)
556 (sset-union (if-alternative-constraints node
)
557 alternative-constraints
)))
558 ;; Has the consequent been changed?
559 (unless (and old-consequent-constraints
560 (sset= (if-consequent-constraints node
)
561 old-consequent-constraints
))
562 (push (if-consequent node
) succ
))
563 ;; Has the alternative been changed?
564 (unless (and old-alternative-constraints
565 (sset= (if-alternative-constraints node
)
566 old-alternative-constraints
))
567 (push (if-alternative node
) succ
))
570 (unless (and (block-out block
)
571 (sset= gen
(block-out block
)))
572 (setf (block-out block
) gen
)
573 (block-succ block
))))))
575 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
576 ;;; During this pass, we also do local constraint propagation by
577 ;;; adding in constraints as we see them during the pass through the
579 (defun use-result-constraints (block)
580 (declare (type cblock block
))
581 (constraint-propagate-in-block block
(block-in block
)
582 :ref-preprocessor
#'constrain-node
))
584 ;;; Give an empty constraints set to any var that doesn't have one and
585 ;;; isn't a set closure var. Since a var that we previously rejected
586 ;;; looks identical to one that is new, so we optimistically keep
587 ;;; hoping that vars stop being closed over or lose their sets.
588 (defun init-var-constraints (component)
589 (declare (type component component
))
590 (dolist (fun (component-lambdas component
))
592 (dolist (var (lambda-vars x
))
593 (unless (lambda-var-constraints var
)
594 (when (or (null (lambda-var-sets var
))
595 (not (closure-var-p var
)))
596 (setf (lambda-var-constraints var
) (make-sset)))))))
598 (dolist (let (lambda-lets fun
))
601 ;;; Return the constraints that flow from PRED to SUCC. This is
602 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
604 (defun block-out-for-successor (pred succ
)
605 (declare (type cblock pred succ
))
606 (let ((last (block-last pred
)))
607 (or (when (if-p last
)
608 (cond ((eq succ
(if-consequent last
))
609 (if-consequent-constraints last
))
610 ((eq succ
(if-alternative last
))
611 (if-alternative-constraints last
))))
614 (defun compute-block-in (block)
616 (dolist (pred (block-pred block
))
617 ;; If OUT has not been calculated, assume it to be the universal
619 (let ((out (block-out-for-successor pred block
)))
622 (sset-intersection in out
)
623 (setq in
(copy-sset out
))))))
624 (or in
(make-sset))))
626 (defun update-block-in (block)
627 (let ((in (compute-block-in block
)))
628 (cond ((and (block-in block
) (sset= in
(block-in block
)))
631 (setf (block-in block
) in
)))))
633 ;;; Return two lists: one of blocks that precede all loops and
634 ;;; therefore require only one constraint propagation pass and the
635 ;;; rest. This implementation does not find all such blocks.
637 ;;; A more complete implementation would be:
639 ;;; (do-blocks (block component)
640 ;;; (if (every #'(lambda (pred)
641 ;;; (or (member pred leading-blocks)
643 ;;; (block-pred block))
644 ;;; (push block leading-blocks)
645 ;;; (push block rest-of-blocks)))
647 ;;; Trailing blocks that succeed all loops could be found and handled
648 ;;; similarly. In practice though, these more complex solutions are
649 ;;; slightly worse performancewise.
650 (defun leading-component-blocks (component)
651 (declare (type component component
))
652 (flet ((loopy-p (block)
653 (let ((n (block-number block
)))
654 (dolist (pred (block-pred block
))
655 (unless (< n
(block-number pred
))
657 (let ((leading-blocks ())
660 (do-blocks (block component
)
661 (when (and (not seen-loop-p
) (loopy-p block
))
662 (setq seen-loop-p t
))
664 (push block rest-of-blocks
)
665 (push block leading-blocks
)))
666 (values (nreverse leading-blocks
) (nreverse rest-of-blocks
)))))
668 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
669 ;;; a member already.
670 (defun nconc-new (obj list
)
671 (do ((x list
(cdr x
))
675 (setf (cdr prev
) (list obj
))
678 (when (eql (car x
) obj
)
679 (return-from nconc-new list
))))
681 (defun find-and-propagate-constraints (component)
682 (let ((blocks-to-process ()))
683 (flet ((enqueue (blocks)
684 (dolist (block blocks
)
685 (setq blocks-to-process
(nconc-new block blocks-to-process
)))))
686 (multiple-value-bind (leading-blocks rest-of-blocks
)
687 (leading-component-blocks component
)
688 ;; Update every block once to account for changes in the
689 ;; IR1. The constraints of the lead blocks cannot be changed
690 ;; after the first pass so we might as well use them and skip
691 ;; USE-RESULT-CONSTRAINTS later.
692 (dolist (block leading-blocks
)
693 (setf (block-in block
) (compute-block-in block
))
694 (find-block-type-constraints block
:final-pass-p t
))
695 (setq blocks-to-process
(copy-list rest-of-blocks
))
696 ;; The rest of the blocks.
697 (dolist (block rest-of-blocks
)
698 (aver (eq block
(pop blocks-to-process
)))
699 (setf (block-in block
) (compute-block-in block
))
700 (enqueue (find-block-type-constraints block
)))
701 ;; Propagate constraints
702 (loop for block
= (pop blocks-to-process
)
704 (unless (eq block
(component-tail component
))
705 (when (update-block-in block
)
706 (enqueue (find-block-type-constraints block
)))))
709 (defun constraint-propagate (component)
710 (declare (type component component
))
711 (init-var-constraints component
)
713 (unless (block-out (component-head component
))
714 (setf (block-out (component-head component
)) (make-sset)))
716 (dolist (block (find-and-propagate-constraints component
))
717 (unless (block-delete-p block
)
718 (use-result-constraints block
)))