+ (frob let)))))
+
+;;; Return the constraints that flow from PRED to SUCC. This is
+;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; added.
+(defun block-out-for-successor (pred succ)
+ (declare (type cblock pred succ))
+ (let ((last (block-last pred)))
+ (or (when (if-p last)
+ (cond ((eq succ (if-consequent last))
+ (if-consequent-constraints last))
+ ((eq succ (if-alternative last))
+ (if-alternative-constraints last))))
+ (block-out pred))))
+
+(defun compute-block-in (block)
+ (let ((in nil))
+ (dolist (pred (block-pred block))
+ ;; If OUT has not been calculated, assume it to be the universal
+ ;; set.
+ (let ((out (block-out-for-successor pred block)))
+ (when out
+ (if in
+ (sset-intersection in out)
+ (setq in (copy-sset out))))))
+ (or in (make-sset))))
+
+(defun update-block-in (block)
+ (let ((in (compute-block-in block)))
+ (cond ((and (block-in block) (sset= in (block-in block)))
+ nil)
+ (t
+ (setf (block-in block) in)))))
+
+;;; Return two lists: one of blocks that precede all loops and
+;;; therefore require only one constraint propagation pass and the
+;;; rest. This implementation does not find all such blocks.
+;;;
+;;; A more complete implementation would be:
+;;;
+;;; (do-blocks (block component)
+;;; (if (every #'(lambda (pred)
+;;; (or (member pred leading-blocks)
+;;; (eq pred head)))
+;;; (block-pred block))
+;;; (push block leading-blocks)
+;;; (push block rest-of-blocks)))
+;;;
+;;; Trailing blocks that succeed all loops could be found and handled
+;;; similarly. In practice though, these more complex solutions are
+;;; slightly worse performancewise.
+(defun leading-component-blocks (component)
+ (declare (type component component))
+ (flet ((loopy-p (block)
+ (let ((n (block-number block)))
+ (dolist (pred (block-pred block))
+ (unless (< n (block-number pred))
+ (return t))))))
+ (let ((leading-blocks ())
+ (rest-of-blocks ())
+ (seen-loop-p ()))
+ (do-blocks (block component)
+ (when (and (not seen-loop-p) (loopy-p block))
+ (setq seen-loop-p t))
+ (if seen-loop-p
+ (push block rest-of-blocks)
+ (push block leading-blocks)))
+ (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
+
+;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
+;;; a member already.
+(defun nconc-new (obj list)
+ (do ((x list (cdr x))
+ (prev nil x))
+ ((endp x) (if prev
+ (progn
+ (setf (cdr prev) (list obj))
+ list)
+ (list obj)))
+ (when (eql (car x) obj)
+ (return-from nconc-new list))))
+
+(defun find-and-propagate-constraints (component)
+ (let ((blocks-to-process ()))
+ (flet ((enqueue (blocks)
+ (dolist (block blocks)
+ (setq blocks-to-process (nconc-new block blocks-to-process)))))
+ (multiple-value-bind (leading-blocks rest-of-blocks)
+ (leading-component-blocks component)
+ ;; Update every block once to account for changes in the
+ ;; IR1. The constraints of the lead blocks cannot be changed
+ ;; after the first pass so we might as well use them and skip
+ ;; USE-RESULT-CONSTRAINTS later.
+ (dolist (block leading-blocks)
+ (setf (block-in block) (compute-block-in block))
+ (find-block-type-constraints block :final-pass-p t))
+ (setq blocks-to-process (copy-list rest-of-blocks))
+ ;; The rest of the blocks.
+ (dolist (block rest-of-blocks)
+ (aver (eq block (pop blocks-to-process)))
+ (setf (block-in block) (compute-block-in block))
+ (enqueue (find-block-type-constraints block)))
+ ;; Propagate constraints
+ (loop for block = (pop blocks-to-process)
+ while block do
+ (unless (eq block (component-tail component))
+ (when (update-block-in block)
+ (enqueue (find-block-type-constraints block)))))
+ rest-of-blocks))))
+
+(defun constraint-propagate (component)