- (do-conset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (type= (constraint-y con) y))
- (return con))))
- ((or lvar constant)
- (do-conset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (eq (constraint-y con) y))
- (return con))))
- (lambda-var
- (do-conset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (let ((cx (constraint-x con)))
- (eq (if (eq cx x)
- (constraint-y con)
- cx)
- y)))
- (return con))))))
+ (awhen (lambda-var-ctype-constraints x)
+ (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (type= (constraint-y con) y))
+ (return-from find-constraint con)))
+ nil))
+ (lvar
+ (awhen (lambda-var-eq-constraints x)
+ (gethash y it)))
+ ((or constant lambda-var)
+ (awhen (lambda-var-eq-constraints x)
+ (let ((cache (gethash y it)))
+ (declare (type list cache))
+ (if not-p (cdr cache) (car cache)))))))
+
+;;; The most common operations on consets are iterating through the constraints
+;;; that are related to a certain variable in a given conset. Storing the
+;;; constraints related to each variable in vectors allows us to easily iterate
+;;; through the intersection of such constraints and the constraints in a conset.
+;;;
+;;; EQL-var constraints assert that two lambda-vars are EQL.
+;;; Private constraints assert that a lambda-var is EQL or not EQL to a constant.
+;;; Inheritable constraints are constraints that may be propagated to EQL
+;;; lambda-vars (along with EQL-var constraints).
+;;;
+;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
+;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
+;;; propagated.
+
+(defun register-constraint (x con y)
+ (declare (type lambda-var x) (type constraint con) (type constraint-y y))
+ (conset-adjoin con (lambda-var-constraints x))
+ (macrolet ((ensuref (place default)
+ `(or ,place (setf ,place ,default)))
+ (ensure-hash (place)
+ `(ensuref ,place (make-hash-table)))
+ (ensure-vec (place)
+ `(ensuref ,place (make-array 8 :adjustable t :fill-pointer 0))))
+ (etypecase y
+ (ctype
+ (let ((index (ensure-hash (lambda-var-ctype-constraints x)))
+ (vec (ensure-vec (lambda-var-inheritable-constraints x))))
+ (push con (gethash (sb!kernel::type-class-info y) index))
+ (vector-push-extend con vec)))
+ (lvar
+ (let ((index (ensure-hash (lambda-var-eq-constraints x))))
+ (setf (gethash y index) con)))
+ ((or constant lambda-var)
+ (let* ((index (ensure-hash (lambda-var-eq-constraints x)))
+ (cons (ensuref (gethash y index) (list nil))))
+ (if (constraint-not-p con)
+ (setf (cdr cons) con)
+ (setf (car cons) con)))
+ (typecase y
+ (constant
+ (let ((vec (ensure-vec (lambda-var-private-constraints x))))
+ (vector-push-extend con vec)))
+ (lambda-var
+ (let ((vec (if (constraint-not-p con)
+ (ensure-vec (lambda-var-inheritable-constraints x))
+ (ensure-vec (lambda-var-eql-var-constraints x)))))
+ (vector-push-extend con vec)))))))
+ nil)