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 ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
356 ;; cons up endless union types when propagating large number of EQL
357 ;; constraints -- eg. from large CASE forms -- instead we just
358 ;; directly accumulate one XSET, and a set of fp zeroes, which we at
359 ;; the end turn into a MEMBER-TYPE.
361 ;; Since massive symbol cases are an especially atrocious pattern
362 ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
363 ;; a more useful type, don't propagate their negation except for NIL
364 ;; unless SPEED > COMPILATION-SPEED.
365 (let ((res (single-value-type (node-derived-type ref
)))
366 (constrain-symbols (policy ref
(> speed compilation-speed
)))
367 (not-set (alloc-xset))
369 (not-res *empty-type
*)
370 (leaf (ref-leaf ref
)))
374 (when (or constrain-symbols
(null x
) (not (symbolp x
)))
375 (add-to-xset x not-set
)))))
376 (do-sset-elements (con constraints
)
377 (when (sset-member con in
)
378 (let* ((x (constraint-x con
))
379 (y (constraint-y con
))
380 (not-p (constraint-not-p con
))
381 (other (if (eq x leaf
) y x
))
382 (kind (constraint-kind con
)))
386 (if (member-type-p other
)
387 (mapc-member-type-members #'note-not other
)
388 (setq not-res
(type-union not-res other
)))
389 (setq res
(type-approx-intersection2 res other
))))
391 (unless (lvar-p other
)
392 (let ((other-type (leaf-type other
)))
394 (when (and (constant-p other
)
395 (member-type-p other-type
))
396 (note-not (constant-value other
)))
397 (let ((leaf-type (leaf-type leaf
)))
399 ((or (constant-p other
)
400 (and (leaf-refs other
) ; protect from
402 (csubtypep other-type leaf-type
)
403 (not (type= other-type leaf-type
))))
404 (change-ref-leaf ref other
)
405 (when (constant-p other
) (return)))
407 (setq res
(type-approx-intersection2
408 res other-type
)))))))))
411 ((and (integer-type-p res
) (integer-type-p y
))
412 (let ((greater (eq kind
'>)))
413 (let ((greater (if not-p
(not greater
) greater
)))
415 (constrain-integer-type res y greater not-p
)))))
416 ((and (float-type-p res
) (float-type-p y
))
417 (let ((greater (eq kind
'>)))
418 (let ((greater (if not-p
(not greater
) greater
)))
420 (constrain-float-type res y greater not-p
))))))))))))
421 (cond ((and (if-p (node-dest ref
))
422 (or (xset-member-p nil not-set
)
423 (csubtypep (specifier-type 'null
) not-res
)))
424 (setf (node-derived-type ref
) *wild-type
*)
425 (change-ref-leaf ref
(find-constant t
)))
428 (type-union not-res
(make-member-type :xset not-set
:fp-zeroes not-fpz
)))
429 (derive-node-type ref
430 (make-single-value-type
431 (or (type-difference res not-res
)
433 (maybe-terminate-block ref nil
))))
438 (defun maybe-add-eql-var-lvar-constraint (ref gen
)
439 (let ((lvar (ref-lvar ref
))
440 (leaf (ref-leaf ref
)))
441 (when (and (lambda-var-p leaf
) lvar
)
442 (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil
)
445 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
446 ;;; LVAR) ones - to all of the variables in the VARS list.
447 (defun inherit-constraints (vars from-var constraints target
)
448 (do-sset-elements (con constraints
)
449 ;; Constant substitution is controversial.
450 (unless (constant-p (constraint-y con
))
452 (let ((eq-x (eq from-var
(constraint-x con
)))
453 (eq-y (eq from-var
(constraint-y con
))))
454 (when (or (and eq-x
(not (lvar-p (constraint-y con
))))
456 (sset-adjoin (find-or-create-constraint
457 (constraint-kind con
)
458 (if eq-x var
(constraint-x con
))
459 (if eq-y var
(constraint-y con
))
460 (constraint-not-p con
))
463 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
464 ;; inherit each other's constraints.
465 (defun add-eql-var-var-constraint (var1 var2 constraints
466 &optional
(target constraints
))
467 (let ((con (find-or-create-constraint 'eql var1 var2 nil
)))
468 (when (sset-adjoin con target
)
469 (collect ((eql1) (eql2))
470 (do-eql-vars (var1 (var1 constraints
))
472 (do-eql-vars (var2 (var2 constraints
))
474 (inherit-constraints (eql1) var2 constraints target
)
475 (inherit-constraints (eql2) var1 constraints target
))
478 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
479 ;; LAMBDA-VAR if possible.
480 (defun maybe-add-eql-var-var-constraint (var lvar constraints
481 &optional
(target constraints
))
482 (declare (type lambda-var var
) (type lvar lvar
))
483 (let ((lambda-var (ok-lvar-lambda-var lvar constraints
)))
485 (add-eql-var-var-constraint var lambda-var constraints target
))))
487 ;;; Local propagation
488 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
490 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
491 ;;; a type constraint based on the new value type.
492 (declaim (ftype (function (cblock sset
493 &key
(:ref-preprocessor
(or null function
))
494 (:set-preprocessor
(or null function
)))
496 constraint-propagate-in-block
))
497 (defun constraint-propagate-in-block (block gen
&key
498 ref-preprocessor set-preprocessor
)
499 (do-nodes (node lvar block
)
502 (let ((fun (bind-lambda node
)))
503 (when (eq (functional-kind fun
) :let
)
504 (loop with call
= (lvar-dest (node-lvar (first (lambda-refs fun
))))
505 for var in
(lambda-vars fun
)
506 and val in
(combination-args call
)
507 when
(and val
(lambda-var-constraints var
))
508 do
(let* ((type (lvar-type val
))
509 (con (find-or-create-constraint 'typep var type
511 (sset-adjoin con gen
))
512 (maybe-add-eql-var-var-constraint var val gen
)))))
514 (when (ok-ref-lambda-var node
)
515 (maybe-add-eql-var-lvar-constraint node gen
)
516 (when ref-preprocessor
517 (funcall ref-preprocessor node gen
))))
519 (let ((lvar (cast-value node
)))
520 (let ((var (ok-lvar-lambda-var lvar gen
)))
522 (let ((atype (single-value-type (cast-derived-type node
)))) ;FIXME
523 (do-eql-vars (var (var gen
))
524 (let ((con (find-or-create-constraint 'typep var atype nil
)))
525 (sset-adjoin con gen
))))))))
527 (binding* ((var (set-var node
))
528 (nil (lambda-var-p var
) :exit-if-null
)
529 (cons (lambda-var-constraints var
) :exit-if-null
))
530 (when set-preprocessor
531 (funcall set-preprocessor var
))
532 (sset-difference gen cons
)
533 (let* ((type (single-value-type (node-derived-type node
)))
534 (con (find-or-create-constraint 'typep var type nil
)))
535 (sset-adjoin con gen
))
536 (maybe-add-eql-var-var-constraint var
(set-value node
) gen
)))))
539 (defun constraint-propagate-if (block gen
)
540 (let ((node (block-last block
)))
542 (let ((use (lvar-uses (if-test node
))))
544 (add-test-constraints use node gen
))))))
546 (defun constrain-node (node cons
)
547 (let* ((var (ref-leaf node
))
548 (con (lambda-var-constraints var
)))
549 (constrain-ref-type node con cons
)))
551 ;;; Starting from IN compute OUT and (consequent/alternative
552 ;;; constraints if the block ends with and IF). Return the list of
553 ;;; successors that may need to be recomputed.
554 (defun find-block-type-constraints (block &key final-pass-p
)
555 (declare (type cblock block
))
556 (let ((gen (constraint-propagate-in-block
560 (copy-sset (block-in block
)))
561 :ref-preprocessor
(if final-pass-p
#'constrain-node nil
))))
562 (setf (block-gen block
) gen
)
563 (multiple-value-bind (consequent-constraints alternative-constraints
)
564 (constraint-propagate-if block gen
)
565 (if consequent-constraints
566 (let* ((node (block-last block
))
567 (old-consequent-constraints (if-consequent-constraints node
))
568 (old-alternative-constraints (if-alternative-constraints node
))
570 ;; Add the consequent and alternative constraints to GEN.
571 (cond ((sset-empty consequent-constraints
)
572 (setf (if-consequent-constraints node
) gen
)
573 (setf (if-alternative-constraints node
) gen
))
575 (setf (if-consequent-constraints node
) (copy-sset gen
))
576 (sset-union (if-consequent-constraints node
)
577 consequent-constraints
)
578 (setf (if-alternative-constraints node
) gen
)
579 (sset-union (if-alternative-constraints node
)
580 alternative-constraints
)))
581 ;; Has the consequent been changed?
582 (unless (and old-consequent-constraints
583 (sset= (if-consequent-constraints node
)
584 old-consequent-constraints
))
585 (push (if-consequent node
) succ
))
586 ;; Has the alternative been changed?
587 (unless (and old-alternative-constraints
588 (sset= (if-alternative-constraints node
)
589 old-alternative-constraints
))
590 (push (if-alternative node
) succ
))
593 (unless (and (block-out block
)
594 (sset= gen
(block-out block
)))
595 (setf (block-out block
) gen
)
596 (block-succ block
))))))
598 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
599 ;;; During this pass, we also do local constraint propagation by
600 ;;; adding in constraints as we see them during the pass through the
602 (defun use-result-constraints (block)
603 (declare (type cblock block
))
604 (constraint-propagate-in-block block
(block-in block
)
605 :ref-preprocessor
#'constrain-node
))
607 ;;; Give an empty constraints set to any var that doesn't have one and
608 ;;; isn't a set closure var. Since a var that we previously rejected
609 ;;; looks identical to one that is new, so we optimistically keep
610 ;;; hoping that vars stop being closed over or lose their sets.
611 (defun init-var-constraints (component)
612 (declare (type component component
))
613 (dolist (fun (component-lambdas component
))
615 (dolist (var (lambda-vars x
))
616 (unless (lambda-var-constraints var
)
617 (when (or (null (lambda-var-sets var
))
618 (not (closure-var-p var
)))
619 (setf (lambda-var-constraints var
) (make-sset)))))))
621 (dolist (let (lambda-lets fun
))
624 ;;; Return the constraints that flow from PRED to SUCC. This is
625 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
627 (defun block-out-for-successor (pred succ
)
628 (declare (type cblock pred succ
))
629 (let ((last (block-last pred
)))
630 (or (when (if-p last
)
631 (cond ((eq succ
(if-consequent last
))
632 (if-consequent-constraints last
))
633 ((eq succ
(if-alternative last
))
634 (if-alternative-constraints last
))))
637 (defun compute-block-in (block)
639 (dolist (pred (block-pred block
))
640 ;; If OUT has not been calculated, assume it to be the universal
642 (let ((out (block-out-for-successor pred block
)))
645 (sset-intersection in out
)
646 (setq in
(copy-sset out
))))))
647 (or in
(make-sset))))
649 (defun update-block-in (block)
650 (let ((in (compute-block-in block
)))
651 (cond ((and (block-in block
) (sset= in
(block-in block
)))
654 (setf (block-in block
) in
)))))
656 ;;; Return two lists: one of blocks that precede all loops and
657 ;;; therefore require only one constraint propagation pass and the
658 ;;; rest. This implementation does not find all such blocks.
660 ;;; A more complete implementation would be:
662 ;;; (do-blocks (block component)
663 ;;; (if (every #'(lambda (pred)
664 ;;; (or (member pred leading-blocks)
666 ;;; (block-pred block))
667 ;;; (push block leading-blocks)
668 ;;; (push block rest-of-blocks)))
670 ;;; Trailing blocks that succeed all loops could be found and handled
671 ;;; similarly. In practice though, these more complex solutions are
672 ;;; slightly worse performancewise.
673 (defun leading-component-blocks (component)
674 (declare (type component component
))
675 (flet ((loopy-p (block)
676 (let ((n (block-number block
)))
677 (dolist (pred (block-pred block
))
678 (unless (< n
(block-number pred
))
680 (let ((leading-blocks ())
683 (do-blocks (block component
)
684 (when (and (not seen-loop-p
) (loopy-p block
))
685 (setq seen-loop-p t
))
687 (push block rest-of-blocks
)
688 (push block leading-blocks
)))
689 (values (nreverse leading-blocks
) (nreverse rest-of-blocks
)))))
691 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
692 ;;; a member already.
693 (defun nconc-new (obj list
)
694 (do ((x list
(cdr x
))
698 (setf (cdr prev
) (list obj
))
701 (when (eql (car x
) obj
)
702 (return-from nconc-new list
))))
704 (defun find-and-propagate-constraints (component)
705 (let ((blocks-to-process ()))
706 (flet ((enqueue (blocks)
707 (dolist (block blocks
)
708 (setq blocks-to-process
(nconc-new block blocks-to-process
)))))
709 (multiple-value-bind (leading-blocks rest-of-blocks
)
710 (leading-component-blocks component
)
711 ;; Update every block once to account for changes in the
712 ;; IR1. The constraints of the lead blocks cannot be changed
713 ;; after the first pass so we might as well use them and skip
714 ;; USE-RESULT-CONSTRAINTS later.
715 (dolist (block leading-blocks
)
716 (setf (block-in block
) (compute-block-in block
))
717 (find-block-type-constraints block
:final-pass-p t
))
718 (setq blocks-to-process
(copy-list rest-of-blocks
))
719 ;; The rest of the blocks.
720 (dolist (block rest-of-blocks
)
721 (aver (eq block
(pop blocks-to-process
)))
722 (setf (block-in block
) (compute-block-in block
))
723 (enqueue (find-block-type-constraints block
)))
724 ;; Propagate constraints
725 (loop for block
= (pop blocks-to-process
)
727 (unless (eq block
(component-tail component
))
728 (when (update-block-in block
)
729 (enqueue (find-block-type-constraints block
)))))
732 (defun constraint-propagate (component)
733 (declare (type component component
))
734 (init-var-constraints component
)
736 (unless (block-out (component-head component
))
737 (setf (block-out (component-head component
)) (make-sset)))
739 (dolist (block (find-and-propagate-constraints component
))
740 (unless (block-delete-p block
)
741 (use-result-constraints block
)))