+;;;; Flow analysis
+
+(defun maybe-add-eql-var-lvar-constraint (ref gen)
+ (let ((lvar (ref-lvar ref))
+ (leaf (ref-leaf ref)))
+ (when (and (lambda-var-p leaf) lvar)
+ (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
+ gen))))
+
+;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
+;;; LVAR) ones - to all of the variables in the VARS list.
+(defun inherit-constraints (vars from-var constraints target)
+ (do-sset-elements (con constraints)
+ ;; Constant substitution is controversial.
+ (unless (constant-p (constraint-y con))
+ (dolist (var vars)
+ (let ((eq-x (eq from-var (constraint-x con)))
+ (eq-y (eq from-var (constraint-y con))))
+ (when (or (and eq-x (not (lvar-p (constraint-y con))))
+ eq-y)
+ (sset-adjoin (find-or-create-constraint
+ (constraint-kind con)
+ (if eq-x var (constraint-x con))
+ (if eq-y var (constraint-y con))
+ (constraint-not-p con))
+ target)))))))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
+;; inherit each other's constraints.
+(defun add-eql-var-var-constraint (var1 var2 constraints
+ &optional (target constraints))
+ (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
+ (when (sset-adjoin con target)
+ (collect ((eql1) (eql2))
+ (do-eql-vars (var1 (var1 constraints))
+ (eql1 var1))
+ (do-eql-vars (var2 (var2 constraints))
+ (eql2 var2))
+ (inherit-constraints (eql1) var2 constraints target)
+ (inherit-constraints (eql2) var1 constraints target))
+ t)))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
+;; LAMBDA-VAR if possible.
+(defun maybe-add-eql-var-var-constraint (var lvar constraints
+ &optional (target constraints))
+ (declare (type lambda-var var) (type lvar lvar))
+ (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
+ (when lambda-var
+ (add-eql-var-var-constraint var lambda-var constraints target))))
+
+;;; 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 (or null function))
+ (:set-preprocessor (or null function)))
+ sset)
+ constraint-propagate-in-block))
+(defun constraint-propagate-in-block (block gen &key
+ ref-preprocessor set-preprocessor)
+ (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))
+ do (let* ((type (lvar-type val))
+ (con (find-or-create-constraint 'typep var type
+ nil)))
+ (sset-adjoin con gen))
+ (maybe-add-eql-var-var-constraint var val gen)))))
+ (ref
+ (when (ok-ref-lambda-var node)
+ (maybe-add-eql-var-lvar-constraint node gen)
+ (when ref-preprocessor
+ (funcall ref-preprocessor node gen))))
+ (cast
+ (let ((lvar (cast-value node)))
+ (let ((var (ok-lvar-lambda-var lvar gen)))
+ (when var
+ (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
+ (do-eql-vars (var (var gen))
+ (let ((con (find-or-create-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-or-create-constraint 'typep var type nil)))
+ (sset-adjoin con gen))
+ (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
+ gen)
+
+(defun constraint-propagate-if (block gen)
+ (let ((node (block-last block)))
+ (when (if-p node)
+ (let ((use (lvar-uses (if-test node))))
+ (when (node-p use)
+ (add-test-constraints use node gen))))))
+
+(defun constrain-node (node cons)
+ (let* ((var (ref-leaf node))
+ (con (lambda-var-constraints var)))
+ (constrain-ref-type node con cons)))
+
+;;; Starting from IN compute OUT and (consequent/alternative
+;;; constraints if the block ends with and IF). Return the list of
+;;; successors that may need to be recomputed.
+(defun find-block-type-constraints (block &key final-pass-p)
+ (declare (type cblock block))
+ (let ((gen (constraint-propagate-in-block
+ block
+ (if final-pass-p
+ (block-in block)
+ (copy-sset (block-in block)))
+ :ref-preprocessor (if final-pass-p #'constrain-node nil))))
+ (setf (block-gen block) gen)
+ (multiple-value-bind (consequent-constraints alternative-constraints)
+ (constraint-propagate-if block gen)
+ (if consequent-constraints
+ (let* ((node (block-last block))
+ (old-consequent-constraints (if-consequent-constraints node))
+ (old-alternative-constraints (if-alternative-constraints node))
+ (succ ()))
+ ;; Add the consequent and alternative constraints to GEN.
+ (cond ((sset-empty consequent-constraints)
+ (setf (if-consequent-constraints node) gen)
+ (setf (if-alternative-constraints node) gen))
+ (t
+ (setf (if-consequent-constraints node) (copy-sset gen))
+ (sset-union (if-consequent-constraints node)
+ consequent-constraints)
+ (setf (if-alternative-constraints node) gen)
+ (sset-union (if-alternative-constraints node)
+ alternative-constraints)))
+ ;; Has the consequent been changed?
+ (unless (and old-consequent-constraints
+ (sset= (if-consequent-constraints node)
+ old-consequent-constraints))
+ (push (if-consequent node) succ))
+ ;; Has the alternative been changed?
+ (unless (and old-alternative-constraints
+ (sset= (if-alternative-constraints node)
+ old-alternative-constraints))
+ (push (if-alternative node) succ))
+ succ)
+ ;; There is no IF.
+ (unless (and (block-out block)
+ (sset= gen (block-out block)))
+ (setf (block-out block) gen)
+ (block-succ block))))))
+