+;;;; Flow analysis
+
+;;; Local propagation
+;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
+;;; constraint.]
+;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
+;;; a type constraint based on the new value type.
+(declaim (ftype (function (cblock sset
+ &key (:ref-preprocessor function)
+ (:set-preprocessor function))
+ sset)
+ constraint-propagate-in-block))
+(defun constraint-propagate-in-block
+ (block gen &key ref-preprocessor set-preprocessor)
+
+ (let ((test (block-test-constraint block)))
+ (when test
+ (sset-union gen test)))
+
+ (do-nodes (node lvar block)
+ (typecase node
+ (bind
+ (let ((fun (bind-lambda node)))
+ (when (eq (functional-kind fun) :let)
+ (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
+ for var in (lambda-vars fun)
+ and val in (combination-args call)
+ when (and val
+ (lambda-var-constraints var)
+ ;; if VAR has no SETs, type inference is
+ ;; fully performed by IR1 optimizer
+ (lambda-var-sets var))
+ do (let* ((type (lvar-type val))
+ (con (find-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
+ (ref
+ (let ((var (ok-ref-lambda-var node)))
+ (when var
+ (when ref-preprocessor
+ (funcall ref-preprocessor node gen))
+ (let ((dest (and lvar (lvar-dest lvar))))
+ (when (cast-p dest)
+ (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
+ (con (find-constraint 'typep var atype nil)))
+ (sset-adjoin con gen)))))))
+ (cset
+ (binding* ((var (set-var node))
+ (nil (lambda-var-p var) :exit-if-null)
+ (cons (lambda-var-constraints var) :exit-if-null))
+ (when set-preprocessor
+ (funcall set-preprocessor var))
+ (sset-difference gen cons)
+ (let* ((type (single-value-type (node-derived-type node)))
+ (con (find-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
+
+ gen)
+
+;;; BLOCK-KILL is just a list of the LAMBDA-VARs killed, so we must
+;;; compute the kill set when there are any vars killed. We bum this a
+;;; bit by special-casing when only one var is killed, and just using
+;;; that var's constraints as the kill set. This set could possibly be
+;;; precomputed, but it would have to be invalidated whenever any
+;;; constraint is added, which would be a pain.
+(defun compute-block-out (block)
+ (declare (type cblock block))
+ (let ((in (block-in block))
+ (kill (block-kill block))
+ (out (copy-sset (block-gen block))))
+ (cond ((null kill)
+ (sset-union out in))
+ ((null (rest kill))
+ (let ((con (lambda-var-constraints (first kill))))
+ (if con
+ (sset-union-of-difference out in con)
+ (sset-union out in))))
+ (t
+ (let ((kill-set (make-sset)))
+ (dolist (var kill)
+ (let ((con (lambda-var-constraints var)))
+ (when con
+ (sset-union kill-set con))))
+ (sset-union-of-difference out in kill-set))))
+ out))
+
+;;; Compute the initial flow analysis sets for BLOCK:
+;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet
+;;; computed, assume it to be a universal set (this is only
+;;; possible in a loop)
+;;;
+;;; Return T if we have found a loop.
+(defun find-block-type-constraints (block)
+ (declare (type cblock block))
+ (collect ((kill nil adjoin))
+ (let ((gen (constraint-propagate-in-block
+ block (make-sset)
+ :set-preprocessor (lambda (var)
+ (kill var)))))
+ (setf (block-gen block) gen)
+ (setf (block-kill block) (kill))
+ (setf (block-type-asserted block) nil)
+ (let* ((n (block-number block))
+ (pred (block-pred block))
+ (in nil)
+ (loop-p nil))
+ (dolist (b pred)
+ (cond ((> (block-number b) n)
+ (if in
+ (sset-intersection in (block-out b))
+ (setq in (copy-sset (block-out b)))))
+ (t (setq loop-p t))))
+ (unless in
+ (bug "Unreachable code is found or flow graph is not ~
+ properly depth-first ordered."))
+ (setf (block-in block) in)
+ (setf (block-out block) (compute-block-out block))
+ loop-p))))
+
+;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
+;;; Our OUT is:
+;;; gen U (in - kill)
+;;;
+;;; Return True if we have done something.
+(defun flow-propagate-constraints (block)
+ (let* ((pred (block-pred block))
+ (in (progn (aver pred)
+ (let ((res (copy-sset (block-out (first pred)))))
+ (dolist (b (rest pred))
+ (sset-intersection res (block-out b)))
+ res))))
+ (setf (block-in block) in)
+ (let ((out (compute-block-out block)))
+ (if (sset= out (block-out block))
+ nil
+ (setf (block-out block) out)))))
+