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