+\f
+;;; Actual conset interface
+;;;
+;;; Constraint propagation needs to iterate over the set of lambda-vars known to
+;;; be EQL to a given variable (including itself), via DO-EQL-VARS.
+;;;
+;;; It also has to iterate through constraints that are inherited by EQL variables
+;;; (DO-INHERITABLE-CONSTRAINTS), and through constraints used by
+;;; CONSTRAIN-REF-TYPE (to derive the type of a REF to a lambda-var).
+;;;
+;;; Consets must keep track of which lvars are EQL to a given lambda-var (result
+;;; from a REF to the lambda-var): CONSET-LVAR-LAMBDA-VAR-EQL-P and
+;;; CONSET-ADD-LVAR-LAMBDA-VAR-EQL. This, as all other constraints, must of
+;;; course be cleared when a lambda-var's constraints are dropped because of
+;;; assignment.
+;;;
+;;; Consets must be able to add constraints to a given lambda-var
+;;; (CONSET-ADD-CONSTRAINT), and to the set of variables EQL to a given
+;;; lambda-var (CONSET-ADD-CONSTRAINT-TO-EQL).
+;;;
+;;; When a lambda-var is assigned to, all the constraints involving that variable
+;;; must be dropped: constraint propagation is flow-sensitive, so the constraints
+;;; relate to the variable at a given range of program point. In such cases,
+;;; constraint propagation calls CONSET-CLEAR-LAMBDA-VAR.
+;;;
+;;; Finally, one of the main strengths of constraint propagation in SBCL is the
+;;; tracking of EQL variables to help constraint propagation. When two variables
+;;; are known to be EQL (e.g. after a branch), ADD-EQL-VAR-VAR-CONSTRAINT is
+;;; called to add the EQL constraint, but also have each equality class inherit
+;;; the other's (inheritable) constraints.
+;;;
+;;; On top of that, we have the usual bulk set operations: intersection, copy,
+;;; equality or emptiness testing. There's also union, but that's only an
+;;; optimisation to avoid useless copies in ADD-TEST-CONSTRAINTS and
+;;; FIND-BLOCK-TYPE-CONSTRAINTS.
+(defmacro do-conset-constraints-intersection ((symbol (conset constraints) &optional result)
+ &body body)
+ (let ((min (gensym "MIN"))
+ (max (gensym "MAX")))
+ (once-only ((conset conset)
+ (constraints constraints))
+ `(flet ((body (,symbol)
+ (declare (type constraint ,symbol))
+ ,@body))
+ (when ,constraints
+ (let ((,min (conset-min ,conset))
+ (,max (conset-max ,conset)))
+ (declare (optimize speed))
+ (map nil (lambda (constraint)
+ (declare (type constraint constraint))
+ (let ((number (constraint-number constraint)))
+ (when (and (<= ,min number)
+ (< number ,max)
+ (conset-member constraint ,conset))
+ (body constraint))))
+ ,constraints)))
+ ,result))))
+
+(defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
+ (once-only ((var var)
+ (constraints constraints))
+ `(flet ((body-fun (,symbol)
+ ,@body))
+ (body-fun ,var)
+ (do-conset-constraints-intersection
+ (con (,constraints (lambda-var-eql-var-constraints ,var)) ,result)
+ (let ((x (constraint-x con))
+ (y (constraint-y con)))
+ (body-fun (if (eq ,var x) y x)))))))
+
+(defmacro do-inheritable-constraints ((symbol (conset variable) &optional result)
+ &body body)
+ (once-only ((conset conset)
+ (variable variable))
+ `(block nil
+ (flet ((body-fun (,symbol)
+ ,@body))
+ (do-conset-constraints-intersection
+ (con (,conset (lambda-var-inheritable-constraints ,variable)))
+ (body-fun con))
+ (do-conset-constraints-intersection
+ (con (,conset (lambda-var-eql-var-constraints ,variable)) ,result)
+ (body-fun con))))))
+
+(defmacro do-propagatable-constraints ((symbol (conset variable) &optional result)
+ &body body)
+ (once-only ((conset conset)
+ (variable variable))
+ `(block nil
+ (flet ((body-fun (,symbol)
+ ,@body))
+ (do-conset-constraints-intersection
+ (con (,conset (lambda-var-private-constraints ,variable)))
+ (body-fun con))
+ (do-conset-constraints-intersection
+ (con (,conset (lambda-var-eql-var-constraints ,variable)))
+ (body-fun con))
+ (do-conset-constraints-intersection
+ (con (,conset (lambda-var-inheritable-constraints ,variable)) ,result)
+ (body-fun con))))))
+
+(declaim (inline conset-lvar-lambda-var-eql-p conset-add-lvar-lambda-var-eql))
+(defun conset-lvar-lambda-var-eql-p (conset lvar lambda-var)
+ (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
+ (and constraint
+ (conset-member constraint conset))))