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
)))