X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=3d7bd357e09280254d6e9f6a85f5daefd7d08064;hb=0c8643845555805048f50c783e118762e2c43a26;hp=cec677001e7b415c4f6087c0d3c6aa0bbb8deee5;hpb=a3d84edc295f60e459ec917e8bc1e3d19829381e;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index cec6770..3d7bd35 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -16,6 +16,12 @@ ;;; -- documentation ;;; ;;; -- MV-BIND, :ASSIGNMENT +;;; +;;; Note: The functions in this file that accept constraint sets are +;;; actually receiving the constraint sets associated with nodes, +;;; blocks, and lambda-vars. It might be make CP easier to understand +;;; and work on if these functions traded in nodes, blocks, and +;;; lambda-vars directly. ;;; Problems: ;;; @@ -42,6 +48,11 @@ (in-package "SB!C") +;;; *CONSTRAINT-UNIVERSE* gets bound in IR1-PHASES to a fresh, +;;; zero-length, non-zero-total-size vector-with-fill-pointer. +(declaim (type (and vector (not simple-vector)) *constraint-universe*)) +(defvar *constraint-universe*) + (deftype constraint-y () '(or ctype lvar lambda-var constant)) (defstruct (constraint @@ -68,27 +79,281 @@ ;; If true, negates the sense of the constraint, so the relation ;; does *not* hold. (not-p nil :type boolean)) - -(defvar *constraint-number*) -(declaim (type (integer 0) *constraint-number*)) - + +;;; Historically, CMUCL and SBCL have used a sparse set implementation +;;; for which most operations are O(n) (see sset.lisp), but at the +;;; cost of at least a full word of pointer for each constraint set +;;; element. Using bit-vectors instead of pointer structures saves a +;;; lot of space and thus GC time (particularly on 64-bit machines), +;;; and saves time on copy, union, intersection, and difference +;;; operations; but makes iteration slower. Circa September 2008, +;;; switching to bit-vectors gave a modest (5-10%) improvement in real +;;; compile time for most Lisp systems, and as much as 20-30% for some +;;; particularly CP-dependent systems. + +;;; It's bad to leave commented code in files, but if some clever +;;; person comes along and makes SSETs better than bit-vectors as sets +;;; for constraint propagation, or if bit-vectors on some XC host +;;; really lose compared to SSETs, here's the conset API as a wrapper +;;; around SSETs: +#+nil +(progn + (deftype conset () 'sset) + (declaim (ftype (sfunction (conset) boolean) conset-empty)) + (declaim (ftype (sfunction (conset) conset) copy-conset)) + (declaim (ftype (sfunction (constraint conset) boolean) conset-member)) + (declaim (ftype (sfunction (constraint conset) boolean) conset-adjoin)) + (declaim (ftype (sfunction (conset conset) boolean) conset=)) + (declaim (ftype (sfunction (conset conset) (values)) conset-union)) + (declaim (ftype (sfunction (conset conset) (values)) conset-intersection)) + (declaim (ftype (sfunction (conset conset) (values)) conset-difference)) + (defun make-conset () (make-sset)) + (defmacro do-conset-elements ((constraint conset &optional result) &body body) + `(do-sset-elements (,constraint ,conset ,result) ,@body)) + (defmacro do-conset-intersection + ((constraint conset1 conset2 &optional result) &body body) + `(do-conset-elements (,constraint ,conset1 ,result) + (when (conset-member ,constraint ,conset2) + ,@body))) + (defun conset-empty (conset) (sset-empty conset)) + (defun copy-conset (conset) (copy-sset conset)) + (defun conset-member (constraint conset) (sset-member constraint conset)) + (defun conset-adjoin (constraint conset) (sset-adjoin constraint conset)) + (defun conset= (conset1 conset2) (sset= conset1 conset2)) + ;; Note: CP doesn't ever care whether union, intersection, and + ;; difference change the first set. (This is an important degree of + ;; freedom, since some ways of implementing sets lose a great deal + ;; when these operations are required to track changes.) + (defun conset-union (conset1 conset2) + (sset-union conset1 conset2) (values)) + (defun conset-intersection (conset1 conset2) + (sset-intersection conset1 conset2) (values)) + (defun conset-difference (conset1 conset2) + (sset-difference conset1 conset2) (values))) + +(locally + ;; This is performance critical for the compiler, and benefits + ;; from the following declarations. Probably you'll want to + ;; disable these declarations when debugging consets. + (declare #-sb-xc-host (optimize (speed 3) (safety 0) (space 0))) + (declaim (inline constraint-number)) + (defun constraint-number (constraint) + (sset-element-number constraint)) + (defstruct (conset + (:constructor make-conset ()) + (:copier %copy-conset)) + (vector (make-array + ;; FIXME: make POWER-OF-TWO-CEILING available earlier? + (ash 1 (integer-length (1- (length *constraint-universe*)))) + :element-type 'bit :initial-element 0) + :type simple-bit-vector) + ;; Bit-vectors win over lightweight hashes for copy, union, + ;; intersection, difference, but lose for iteration if you iterate + ;; over the whole vector. Under some measurements in 2008, it + ;; turned out that constraint sets elements were normally clumped + ;; together: for compiling SBCL, the average difference between + ;; the maximum and minimum constraint-number was 90 (with the + ;; average constraint set having around 25 elements). So using + ;; the minimum and maximum constraint-number for iteration bounds + ;; makes iteration over a subrange of the bit-vector comparable to + ;; iteration across the hash storage. Note that the CONSET-MIN is + ;; NIL when the set is known to be empty. CONSET-MAX is a normal + ;; end bounding index. + (min nil :type (or fixnum null)) + (max 0 :type fixnum)) + + (defmacro do-conset-elements ((constraint conset &optional result) &body body) + (with-unique-names (vector index start end + ignore constraint-universe-end) + (let* ((constraint-universe #+sb-xc-host '*constraint-universe* + #-sb-xc-host (gensym)) + (with-array-data + #+sb-xc-host '(progn) + #-sb-xc-host `(with-array-data + ((,constraint-universe *constraint-universe*) + (,ignore 0) (,constraint-universe-end nil) + :check-fill-pointer t) + (declare (ignore ,ignore)) + (aver (<= ,end ,constraint-universe-end))))) + `(let* ((,vector (conset-vector ,conset)) + (,start (or (conset-min ,conset) 0)) + (,end (min (conset-max ,conset) (length ,vector)))) + (,@with-array-data + (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result) + (when (plusp (sbit ,vector ,index)) + (let ((,constraint (elt ,constraint-universe ,index))) + ,@body)))))))) + + ;; Oddly, iterating just between the maximum of the two sets' minima + ;; and the minimum of the sets' maxima slowed down CP. + (defmacro do-conset-intersection + ((constraint conset1 conset2 &optional result) &body body) + `(do-conset-elements (,constraint ,conset1 ,result) + (when (conset-member ,constraint ,conset2) + ,@body))) + + (defun conset-empty (conset) + (or (null (conset-min conset)) + ;; TODO: I bet FIND on bit-vectors can be optimized, if it + ;; isn't. + (not (find 1 (conset-vector conset) + :start (conset-min conset) + ;; By inspection, supplying :END here breaks the + ;; build with a "full call to + ;; DATA-VECTOR-REF-WITH-OFFSET" in the + ;; cross-compiler. If that should change, add + ;; :end (conset-max conset) + )))) + + (defun copy-conset (conset) + (let ((ret (%copy-conset conset))) + (setf (conset-vector ret) (copy-seq (conset-vector conset))) + ret)) + + (defun %conset-grow (conset new-size) + (declare (index new-size)) + (setf (conset-vector conset) + (replace (the simple-bit-vector + (make-array + (ash 1 (integer-length (1- new-size))) + :element-type 'bit + :initial-element 0)) + (the simple-bit-vector + (conset-vector conset))))) + + (declaim (inline conset-grow)) + (defun conset-grow (conset new-size) + (declare (index new-size)) + (when (< (length (conset-vector conset)) new-size) + (%conset-grow conset new-size)) + (values)) + + (defun conset-member (constraint conset) + (let ((number (constraint-number constraint)) + (vector (conset-vector conset))) + (when (< number (length vector)) + (plusp (sbit vector number))))) + + (defun conset-adjoin (constraint conset) + (prog1 + (not (conset-member constraint conset)) + (let ((number (constraint-number constraint))) + (conset-grow conset (1+ number)) + (setf (sbit (conset-vector conset) number) 1) + (setf (conset-min conset) (min number (or (conset-min conset) + most-positive-fixnum))) + (when (>= number (conset-max conset)) + (setf (conset-max conset) (1+ number)))))) + + (defun conset= (conset1 conset2) + (let* ((vector1 (conset-vector conset1)) + (vector2 (conset-vector conset2)) + (length1 (length vector1)) + (length2 (length vector2))) + (if (= length1 length2) + ;; When the lengths are the same, we can rely on EQUAL being + ;; nicely optimized on bit-vectors. + (equal vector1 vector2) + (multiple-value-bind (shorter longer) + (if (< length1 length2) + (values vector1 vector2) + (values vector2 vector1)) + ;; FIXME: make MISMATCH fast on bit-vectors. + (dotimes (index (length shorter)) + (when (/= (sbit vector1 index) (sbit vector2 index)) + (return-from conset= nil))) + (if (find 1 longer :start (length shorter)) + nil + t))))) + + (macrolet + ((defconsetop (name bit-op) + `(defun ,name (conset-1 conset-2) + (declare (optimize (speed 3) (safety 0))) + (let* ((size-1 (length (conset-vector conset-1))) + (size-2 (length (conset-vector conset-2))) + (new-size (max size-1 size-2))) + (conset-grow conset-1 new-size) + (conset-grow conset-2 new-size)) + (let ((vector1 (conset-vector conset-1)) + (vector2 (conset-vector conset-2))) + (declare (simple-bit-vector vector1 vector2)) + (setf (conset-vector conset-1) (,bit-op vector1 vector2 t)) + ;; Update the extrema. + (setf (conset-min conset-1) + ,(ecase name + ((conset-union) + `(min (or (conset-min conset-1) + most-positive-fixnum) + (or (conset-min conset-2) + most-positive-fixnum))) + ((conset-intersection) + `(position 1 (conset-vector conset-1) + :start + (max (or (conset-min conset-1) 0) + (or (conset-min conset-2) 0)) + :end (min (conset-max conset-1) + (conset-max conset-1)))) + ((conset-difference) + `(position 1 (conset-vector conset-1) + :start (or (conset-min conset-1) 0) + :end (conset-max conset-1) + ))) + (conset-max conset-1) + ,(ecase name + ((conset-union) + `(max (conset-max conset-1) + (conset-max conset-2))) + ((conset-intersection) + `(let ((position + (position + 1 (conset-vector conset-1) + :start (let ((max + (min (conset-max conset-1) + (conset-max conset-2)))) + (if (plusp max) + (1- max) + 0)) + :end (conset-min conset-1) + :from-end t))) + (if position + (1+ position) + 0))) + ((conset-difference) + `(let ((position + (position + 1 (conset-vector conset-1) + :start (let ((max (conset-max conset-1))) + (if (plusp max) + (1- max) + 0)) + :end (or (conset-min conset-1) 0) + :from-end t))) + (if position + (1+ position) + 0)))))) + (values)))) + (defconsetop conset-union bit-ior) + (defconsetop conset-intersection bit-and) + (defconsetop conset-difference bit-andc2))) + (defun find-constraint (kind x y not-p) (declare (type lambda-var x) (type constraint-y y) (type boolean not-p)) (etypecase y (ctype - (do-sset-elements (con (lambda-var-constraints x) nil) + (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-sset-elements (con (lambda-var-constraints x) nil) + (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-sset-elements (con (lambda-var-constraints x) nil) + (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))) @@ -105,10 +370,13 @@ (defun find-or-create-constraint (kind x y not-p) (declare (type lambda-var x) (type constraint-y y) (type boolean not-p)) (or (find-constraint kind x y not-p) - (let ((new (make-constraint (incf *constraint-number*) kind x y not-p))) - (sset-adjoin new (lambda-var-constraints x)) + (let ((new (make-constraint (length *constraint-universe*) + kind x y not-p))) + (vector-push-extend new *constraint-universe* + (* 2 (length *constraint-universe*))) + (conset-adjoin new (lambda-var-constraints x)) (when (lambda-var-p y) - (sset-adjoin new (lambda-var-constraints y))) + (conset-adjoin new (lambda-var-constraints y))) new))) ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow @@ -130,7 +398,7 @@ (let ((lambda-var (ok-ref-lambda-var use))) (when lambda-var (let ((constraint (find-constraint 'eql lambda-var lvar nil))) - (when (and constraint (sset-member constraint constraints)) + (when (and constraint (conset-member constraint constraints)) lambda-var))))) ((cast-p use) (ok-lvar-lambda-var (cast-value use) constraints))))) @@ -141,7 +409,7 @@ (flet ((body-fun () ,@body)) (body-fun) - (do-sset-elements (con ,constraints ,result) + (do-conset-elements (con ,constraints ,result) (let ((other (and (eq (constraint-kind con) 'eql) (eq (constraint-not-p con) nil) (cond ((eq ,var (constraint-x con)) @@ -166,7 +434,7 @@ (t (do-eql-vars (x (x constraints)) (let ((con (find-or-create-constraint fun x y not-p))) - (sset-adjoin con target))))) + (conset-adjoin con target))))) (values)) ;;; Add complementary constraints to the consequent and alternative @@ -190,13 +458,13 @@ ;; can't guarantee that the optimization will be done, so we still ;; need to avoid barfing on this case. (unless (eq (if-consequent if) (if-alternative if)) - (let ((consequent-constraints (make-sset)) - (alternative-constraints (make-sset))) + (let ((consequent-constraints (make-conset)) + (alternative-constraints (make-conset))) (macrolet ((add (fun x y not-p) `(add-complement-constraints ,fun ,x ,y ,not-p - constraints - consequent-constraints - alternative-constraints))) + constraints + consequent-constraints + alternative-constraints))) (typecase use (ref (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints) @@ -310,49 +578,39 @@ (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) - #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) x - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (labels ((exclude (x) (cond ((not x) nil) (or-equal x) - (greater - (if (consp x) - (car x) - x)) (t (if (consp x) x (list x))))) (bound (x) (if greater (numeric-type-low x) (numeric-type-high x))) - (max-lower-bound (x y) - ;; Both X and Y are not null. Find the max. - (let ((res (max (type-bound-number x) (type-bound-number y)))) - ;; An open lower bound is greater than a close - ;; lower bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y))))) - (min-upper-bound (x y) - ;; Same as above, but for the min of upper bounds - ;; Both X and Y are not null. Find the min. - (let ((res (min (type-bound-number x) (type-bound-number y)))) - ;; An open upper bound is less than a closed - ;; upper bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y)))))) + (tighter-p (x ref) + (cond ((null x) nil) + ((null ref) t) + ((and or-equal + (= (type-bound-number x) (type-bound-number ref))) + ;; X is tighter if REF is not an open bound and X is + (and (not (consp ref)) (consp x))) + (greater + (< (type-bound-number ref) (type-bound-number x))) + (t + (> (type-bound-number ref) (type-bound-number x)))))) (let* ((x-bound (bound x)) (y-bound (exclude (bound y))) (new-bound (cond ((not x-bound) y-bound) ((not y-bound) x-bound) - (greater - (max-lower-bound x-bound y-bound)) + ((tighter-p y-bound x-bound) + y-bound) (t - (min-upper-bound x-bound y-bound))))) + x-bound)))) (if greater (modified-numeric-type x :low new-bound) (modified-numeric-type x :high new-bound))))) @@ -361,13 +619,32 @@ ;;; restrictions from flow analysis IN, set the type for REF ;;; accordingly. (defun constrain-ref-type (ref constraints in) - (declare (type ref ref) (type sset constraints in)) - (let ((var-cons (copy-sset constraints))) - (sset-intersection var-cons in) - (let ((res (single-value-type (node-derived-type ref))) - (not-res *empty-type*) - (leaf (ref-leaf ref))) - (do-sset-elements (con var-cons) + (declare (type ref ref) (type conset constraints in)) + ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to + ;; cons up endless union types when propagating large number of EQL + ;; constraints -- eg. from large CASE forms -- instead we just + ;; directly accumulate one XSET, and a set of fp zeroes, which we at + ;; the end turn into a MEMBER-TYPE. + ;; + ;; Since massive symbol cases are an especially atrocious pattern + ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into + ;; a more useful type, don't propagate their negation except for NIL + ;; unless SPEED > COMPILATION-SPEED. + (let ((res (single-value-type (node-derived-type ref))) + (constrain-symbols (policy ref (> speed compilation-speed))) + (not-set (alloc-xset)) + (not-fpz nil) + (not-res *empty-type*) + (leaf (ref-leaf ref))) + (flet ((note-not (x) + (if (fp-zero-p x) + (push x not-fpz) + (when (or constrain-symbols (null x) (not (symbolp x))) + (add-to-xset x not-set))))) + ;; KLUDGE: the implementations of DO-CONSET-INTERSECTION will + ;; probably run faster when the smaller set comes first, so + ;; don't change the order here. + (do-conset-intersection (con constraints in) (let* ((x (constraint-x con)) (y (constraint-y con)) (not-p (constraint-not-p con)) @@ -376,7 +653,9 @@ (case kind (typep (if not-p - (setq not-res (type-union not-res other)) + (if (member-type-p other) + (mapc-member-type-members #'note-not other) + (setq not-res (type-union not-res other))) (setq res (type-approx-intersection2 res other)))) (eql (unless (lvar-p other) @@ -384,7 +663,7 @@ (if not-p (when (and (constant-p other) (member-type-p other-type)) - (setq not-res (type-union not-res other-type))) + (note-not (constant-value other))) (let ((leaf-type (leaf-type leaf))) (cond ((or (constant-p other) @@ -408,18 +687,20 @@ (let ((greater (eq kind '>))) (let ((greater (if not-p (not greater) greater))) (setq res - (constrain-float-type res y greater not-p)))))))))) - (cond ((and (if-p (node-dest ref)) - (csubtypep (specifier-type 'null) not-res)) - (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant t))) - (t - (derive-node-type ref - (make-single-value-type - (or (type-difference res not-res) - res))) - (maybe-terminate-block ref nil))))) - + (constrain-float-type res y greater not-p))))))))))) + (cond ((and (if-p (node-dest ref)) + (or (xset-member-p nil not-set) + (csubtypep (specifier-type 'null) not-res))) + (setf (node-derived-type ref) *wild-type*) + (change-ref-leaf ref (find-constant t))) + (t + (setf not-res + (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz))) + (derive-node-type ref + (make-single-value-type + (or (type-difference res not-res) + res))) + (maybe-terminate-block ref nil)))) (values)) ;;;; Flow analysis @@ -428,36 +709,40 @@ (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 to VAR except the (EQL VAR -;;; LVAR) ones. -(defun inherit-constraints (var from-var constraints target) - (do-sset-elements (con constraints) - (let ((eq-x (eq from-var (constraint-x con))) - (eq-y (eq from-var (constraint-y con)))) - ;; Constant substitution is controversial. - (unless (constant-p (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)))))) + (conset-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-conset-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) + (conset-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) - (do-eql-vars (var2 (var2 constraints)) - (inherit-constraints var1 var2 constraints target)) - (do-eql-vars (var1 (var1 constraints)) - (inherit-constraints var1 var2 constraints target)) + (when (conset-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 @@ -474,14 +759,10 @@ ;;; 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) +(declaim (ftype (function (cblock conset boolean) + conset) constraint-propagate-in-block)) -(defun constraint-propagate-in-block - (block gen &key ref-preprocessor set-preprocessor) - +(defun constraint-propagate-in-block (block gen preprocess-refs-p) (do-nodes (node lvar block) (typecase node (bind @@ -494,13 +775,15 @@ do (let* ((type (lvar-type val)) (con (find-or-create-constraint 'typep var type nil))) - (sset-adjoin con gen)) + (conset-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)))) + (when preprocess-refs-p + (let* ((var (ref-leaf node)) + (con (lambda-var-constraints var))) + (constrain-ref-type node con gen))))) (cast (let ((lvar (cast-value node))) (let ((var (ok-lvar-lambda-var lvar gen))) @@ -508,19 +791,16 @@ (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)))))))) + (conset-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) + (conset-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)) + (conset-adjoin con gen)) (maybe-add-eql-var-var-constraint var (set-value node) gen))))) - gen) (defun constraint-propagate-if (block gen) @@ -530,22 +810,17 @@ (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) +(defun find-block-type-constraints (block 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)))) + (copy-conset (block-in block))) + final-pass-p))) (setf (block-gen block) gen) (multiple-value-bind (consequent-constraints alternative-constraints) (constraint-propagate-if block gen) @@ -555,30 +830,30 @@ (old-alternative-constraints (if-alternative-constraints node)) (succ ())) ;; Add the consequent and alternative constraints to GEN. - (cond ((sset-empty consequent-constraints) + (cond ((conset-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-consequent-constraints node) (copy-conset gen)) + (conset-union (if-consequent-constraints node) + consequent-constraints) (setf (if-alternative-constraints node) gen) - (sset-union (if-alternative-constraints node) - alternative-constraints))) + (conset-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)) + (conset= (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)) + (conset= (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))) + (conset= gen (block-out block))) (setf (block-out block) gen) (block-succ block)))))) @@ -588,8 +863,7 @@ ;;; block. (defun use-result-constraints (block) (declare (type cblock block)) - (constraint-propagate-in-block block (block-in block) - :ref-preprocessor #'constrain-node)) + (constraint-propagate-in-block block (block-in block) t)) ;;; Give an empty constraints set to any var that doesn't have one and ;;; isn't a set closure var. Since a var that we previously rejected @@ -603,7 +877,7 @@ (unless (lambda-var-constraints var) (when (or (null (lambda-var-sets var)) (not (closure-var-p var))) - (setf (lambda-var-constraints var) (make-sset))))))) + (setf (lambda-var-constraints var) (make-conset))))))) (frob fun) (dolist (let (lambda-lets fun)) (frob let))))) @@ -629,13 +903,13 @@ (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)))) + (conset-intersection in out) + (setq in (copy-conset out)))))) + (or in (make-conset)))) (defun update-block-in (block) (let ((in (compute-block-in block))) - (cond ((and (block-in block) (sset= in (block-in block))) + (cond ((and (block-in block) (conset= in (block-in block))) nil) (t (setf (block-in block) in))))) @@ -701,19 +975,19 @@ ;; USE-RESULT-CONSTRAINTS later. (dolist (block leading-blocks) (setf (block-in block) (compute-block-in block)) - (find-block-type-constraints block :final-pass-p t)) + (find-block-type-constraints block t)) (setq blocks-to-process (copy-list rest-of-blocks)) ;; The rest of the blocks. (dolist (block rest-of-blocks) (aver (eq block (pop blocks-to-process))) (setf (block-in block) (compute-block-in block)) - (enqueue (find-block-type-constraints block))) + (enqueue (find-block-type-constraints block nil))) ;; Propagate constraints (loop for block = (pop blocks-to-process) while block do (unless (eq block (component-tail component)) (when (update-block-in block) - (enqueue (find-block-type-constraints block))))) + (enqueue (find-block-type-constraints block nil))))) rest-of-blocks)))) (defun constraint-propagate (component) @@ -721,7 +995,7 @@ (init-var-constraints component) (unless (block-out (component-head component)) - (setf (block-out (component-head component)) (make-sset))) + (setf (block-out (component-head component)) (make-conset))) (dolist (block (find-and-propagate-constraints component)) (unless (block-delete-p block)