X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=cd9f9f7e84fe777e686835a3d6da97cde0f66e9d;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=de2beecd3c7f33f75fb9f5e4e3bde480cda0be52;hpb=da5a7ccd58c2bf3c5287a11fb41e01403e5745e8;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index de2beec..cd9f9f7 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -153,49 +153,14 @@ (min 0 :type fixnum) (max 0 :type fixnum)) - (defmacro do-conset-elements ((constraint conset &optional result) &body body) - (with-unique-names (vector index start end - #-sb-xc-host ignore - #-sb-xc-host 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 (conset-min ,conset)) - (,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 (= (conset-min conset) (conset-max 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) - )))) + ;; the :end argument can be commented out when + ;; bootstrapping on a < 1.0.9 SBCL errors out with + ;; a full call to DATA-VECTOR-REF-WITH-OFFSET. + :end (conset-max conset))))) (defun copy-conset (conset) (let ((ret (%copy-conset conset))) @@ -227,14 +192,13 @@ (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 (conset-min conset))) - (when (>= number (conset-max conset)) - (setf (conset-max conset) (1+ number)))))) + (let ((number (%constraint-number constraint))) + (conset-grow conset (1+ number)) + (setf (sbit (conset-vector conset) number) 1) + (setf (conset-min conset) (min number (conset-min conset))) + (when (>= number (conset-max conset)) + (setf (conset-max conset) (1+ number)))) + conset) (defun conset= (conset1 conset2) (let* ((vector1 (conset-vector conset1)) @@ -321,31 +285,81 @@ (defconsetop conset-intersection bit-and) (defconsetop conset-difference bit-andc2))) +;;; Constraints are hash-consed. Unfortunately, types aren't, so we have +;;; to over-approximate and then linear search through the potential hits. +;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant +;;; and lambda-vars can only be found in EQL constraints. (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-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. +;;; +;;; Finally, the lambda-var conset is only used to track the whole set of +;;; constraints associated with a given lambda-var, and thus easily delete +;;; such constraints from a conset. +(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) ;;; Return a constraint for the specified arguments. We only create a ;;; new constraint if there isn't already an equivalent old one, @@ -357,12 +371,168 @@ (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)) + (1+ (length *constraint-universe*))) + (register-constraint x new y) (when (lambda-var-p y) - (conset-adjoin new (lambda-var-constraints y))) + (register-constraint y new x)) new))) + +;;; 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)))) +(defun conset-add-lvar-lambda-var-eql (conset lvar lambda-var) + (let ((constraint (find-or-create-constraint 'eql lambda-var lvar nil))) + (conset-adjoin constraint conset))) + +(declaim (inline conset-add-constraint conset-add-constraint-to-eql)) +(defun conset-add-constraint (conset kind x y not-p) + (declare (type conset conset) + (type lambda-var x)) + (conset-adjoin (find-or-create-constraint kind x y not-p) + conset)) + +(defun conset-add-constraint-to-eql (conset kind x y not-p &optional (target conset)) + (declare (type conset target conset) + (type lambda-var x)) + (do-eql-vars (x (x conset)) + (conset-add-constraint target kind x y not-p))) + +(declaim (inline conset-clear-lambda-var)) +(defun conset-clear-lambda-var (conset var) + (conset-difference conset (lambda-var-constraints var))) + +;;; 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-inheritable-constraints (con (constraints from-var)) + (let ((eq-x (eq from-var (constraint-x con))) + (eq-y (eq from-var (constraint-y con)))) + (dolist (var vars) + (conset-add-constraint target + (constraint-kind con) + (if eq-x var (constraint-x con)) + (if eq-y var (constraint-y con)) + (constraint-not-p con)))))) + +;; 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 ((constraint (find-or-create-constraint 'eql var1 var2 nil))) + (unless (conset-member constraint target) + (conset-adjoin constraint 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))) + ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL. #!-sb-fluid (declaim (inline ok-ref-lambda-var)) @@ -380,59 +550,99 @@ (let ((use (lvar-uses lvar))) (cond ((ref-p use) (let ((lambda-var (ok-ref-lambda-var use))) - (when lambda-var - (let ((constraint (find-constraint 'eql lambda-var lvar nil))) - (when (and constraint (conset-member constraint constraints)) - lambda-var))))) + (and lambda-var + (conset-lvar-lambda-var-eql-p constraints lvar lambda-var) + lambda-var))) ((cast-p use) (ok-lvar-lambda-var (cast-value use) constraints))))) - -(defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body) - (once-only ((var var)) - `(let ((,symbol ,var)) - (flet ((body-fun () - ,@body)) - (body-fun) - (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)) - (constraint-y con)) - ((eq ,var (constraint-y con)) - (constraint-x con)) - (t - nil))))) - (when other - (setq ,symbol other) - (when (lambda-var-p ,symbol) - (body-fun))))))))) - ;;;; Searching constraints -;;; Add the indicated test constraint to BLOCK. We don't add the -;;; constraint if the block has multiple predecessors, since it only -;;; holds on this particular path. -(defun add-test-constraint (fun x y not-p constraints target) - (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p)) - (add-eql-var-var-constraint x y constraints target)) - (t - (do-eql-vars (x (x constraints)) - (let ((con (find-or-create-constraint fun x y not-p))) - (conset-adjoin con target))))) +;;; Add the indicated test constraint to TARGET. +(defun precise-add-test-constraint (fun x y not-p constraints target) + (if (and (eq 'eql fun) (lambda-var-p y) (not not-p)) + (add-eql-var-var-constraint x y constraints target) + (conset-add-constraint-to-eql constraints fun x y not-p target)) (values)) +(defun add-test-constraint (quick-p fun x y not-p constraints target) + (cond (quick-p + (conset-add-constraint target fun x y not-p)) + (t + (precise-add-test-constraint fun x y not-p constraints target)))) ;;; Add complementary constraints to the consequent and alternative ;;; blocks of IF. We do nothing if X is NIL. -(defun add-complement-constraints (fun x y not-p constraints - consequent-constraints - alternative-constraints) +(declaim (inline precise-add-test-constraint quick-add-complement-constraints)) +(defun precise-add-complement-constraints (fun x y not-p constraints + consequent-constraints + alternative-constraints) + (when x + (precise-add-test-constraint fun x y not-p constraints + consequent-constraints) + (precise-add-test-constraint fun x y (not not-p) constraints + alternative-constraints)) + (values)) + +(defun quick-add-complement-constraints (fun x y not-p + consequent-constraints + alternative-constraints) (when x - (add-test-constraint fun x y not-p constraints - consequent-constraints) - (add-test-constraint fun x y (not not-p) constraints - alternative-constraints)) + (conset-add-constraint consequent-constraints fun x y not-p) + (conset-add-constraint alternative-constraints fun x y (not not-p))) (values)) +(defun add-complement-constraints (quick-p fun x y not-p constraints + consequent-constraints + alternative-constraints) + (if quick-p + (quick-add-complement-constraints fun x y not-p + consequent-constraints + alternative-constraints) + (precise-add-complement-constraints fun x y not-p constraints + consequent-constraints + alternative-constraints))) + +(defun add-combination-test-constraints (use constraints + consequent-constraints + alternative-constraints + quick-p) + (flet ((add (fun x y not-p) + (add-complement-constraints quick-p + fun x y not-p + constraints + consequent-constraints + alternative-constraints)) + (prop (triples target) + (map nil (lambda (constraint) + (destructuring-bind (kind x y &optional not-p) + constraint + (when (and kind x y) + (add-test-constraint quick-p + kind x y + not-p constraints + target)))) + triples))) + (when (eq (combination-kind use) :known) + (binding* ((info (combination-fun-info use) :exit-if-null) + (propagate (fun-info-constraint-propagate-if + info) + :exit-if-null)) + (multiple-value-bind (lvar type if else) + (funcall propagate use constraints) + (prop if consequent-constraints) + (prop else alternative-constraints) + (when (and lvar type) + (add 'typep (ok-lvar-lambda-var lvar constraints) + type nil) + (return-from add-combination-test-constraints))))) + (let* ((name (lvar-fun-name + (basic-combination-fun use))) + (args (basic-combination-args use)) + (ptype (gethash name *backend-predicate-types*))) + (when ptype + (add 'typep (ok-lvar-lambda-var (first args) + constraints) + ptype nil))))) + ;;; Add test constraints to the consequent and alternative blocks of ;;; the test represented by USE. (defun add-test-constraints (use if constraints) @@ -443,9 +653,11 @@ ;; need to avoid barfing on this case. (unless (eq (if-consequent if) (if-alternative if)) (let ((consequent-constraints (make-conset)) - (alternative-constraints (make-conset))) + (alternative-constraints (make-conset)) + (quick-p (policy if (> compilation-speed speed)))) (macrolet ((add (fun x y not-p) - `(add-complement-constraints ,fun ,x ,y ,not-p + `(add-complement-constraints quick-p + ,fun ,x ,y ,not-p constraints consequent-constraints alternative-constraints))) @@ -468,7 +680,8 @@ (ok-lvar-lambda-var (first args) constraints) (if (ctype-p val) val - (specifier-type val)) + (let ((*compiler-error-context* use)) + (specifier-type val))) nil))))) ((eq eql) (let* ((arg1 (first args)) @@ -477,23 +690,26 @@ (var2 (ok-lvar-lambda-var arg2 constraints))) ;; The code below assumes that the constant is the ;; second argument in case of variable to constant - ;; comparision which is sometimes true (see source + ;; comparison which is sometimes true (see source ;; transformations for EQ, EQL and CHAR=). Fixing ;; that would result in more constant substitutions ;; which is not a universally good thing, thus the ;; unnatural asymmetry of the tests. (cond ((not var1) (when var2 - (add-test-constraint 'typep var2 (lvar-type arg1) + (add-test-constraint quick-p + 'typep var2 (lvar-type arg1) nil constraints consequent-constraints))) (var2 (add 'eql var1 var2 nil)) ((constant-lvar-p arg2) - (add 'eql var1 (ref-leaf (principal-lvar-use arg2)) + (add 'eql var1 + (find-constant (lvar-value arg2)) nil)) (t - (add-test-constraint 'typep var1 (lvar-type arg2) + (add-test-constraint quick-p + 'typep var1 (lvar-type arg2) nil constraints consequent-constraints))))) ((< >) @@ -506,10 +722,10 @@ (when var2 (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil)))) (t - (let ((ptype (gethash name *backend-predicate-types*))) - (when ptype - (add 'typep (ok-lvar-lambda-var (first args) constraints) - ptype nil)))))))))) + (add-combination-test-constraints use constraints + consequent-constraints + alternative-constraints + quick-p)))))))) (values consequent-constraints alternative-constraints)))) ;;;; Applying constraints @@ -556,6 +772,11 @@ (eq (numeric-type-complexp x) :real))) ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers. +;;; +;;; In contrast to the integer version, here the input types can have +;;; open bounds in addition to closed ones and we don't increment or +;;; decrement a bound to honor OR-EQUAL being NIL but put an open bound +;;; into the result instead, if appropriate. (defun constrain-float-type (x y greater or-equal) (declare (type numeric-type x y)) (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE @@ -577,10 +798,9 @@ (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))) + ((= (type-bound-number x) (type-bound-number ref)) + ;; X is tighter if X is an open bound and REF is not + (and (consp x) (not (consp ref)))) (greater (< (type-bound-number ref) (type-bound-number x))) (t @@ -599,11 +819,29 @@ (modified-numeric-type x :low new-bound) (modified-numeric-type x :high new-bound))))) +;;; Return true if LEAF is "visible" from NODE. +(defun leaf-visible-from-node-p (leaf node) + (cond + ((lambda-var-p leaf) + ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an + ;; ancestor for NODE. + (let ((leaf-lambda (lambda-var-home leaf))) + (loop for lambda = (node-home-lambda node) + then (lambda-parent lambda) + while lambda + when (eq lambda leaf-lambda) + return t))) + ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes), + ;; not just LAMBDA-VARs. + (t + ;; Assume everything else is globally visible. + t))) + ;;; Given the set of CONSTRAINTS for a variable and the current set of ;;; restrictions from flow analysis IN, set the type for REF ;;; accordingly. -(defun constrain-ref-type (ref constraints in) - (declare (type ref ref) (type conset constraints in)) +(defun constrain-ref-type (ref in) + (declare (type ref ref) (type conset 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 @@ -620,15 +858,13 @@ (not-fpz nil) (not-res *empty-type*) (leaf (ref-leaf ref))) + (declare (type lambda-var leaf)) (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) + (do-propagatable-constraints (con (in leaf)) (let* ((x (constraint-x con)) (y (constraint-y con)) (not-p (constraint-not-p con)) @@ -642,24 +878,25 @@ (setq not-res (type-union not-res other))) (setq res (type-approx-intersection2 res other)))) (eql - (unless (lvar-p other) - (let ((other-type (leaf-type other))) - (if not-p - (when (and (constant-p other) - (member-type-p other-type)) - (note-not (constant-value other))) - (let ((leaf-type (leaf-type leaf))) - (cond - ((or (constant-p other) - (and (leaf-refs other) ; protect from + (let ((other-type (leaf-type other))) + (if not-p + (when (and (constant-p other) + (member-type-p other-type)) + (note-not (constant-value other))) + (let ((leaf-type (leaf-type leaf))) + (cond + ((or (constant-p other) + (and (leaf-refs other) ; protect from ; deleted vars - (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) - (change-ref-leaf ref other) - (when (constant-p other) (return))) - (t - (setq res (type-approx-intersection2 - res other-type))))))))) + (csubtypep other-type leaf-type) + (not (type= other-type leaf-type)) + ;; Don't change to a LEAF not visible here. + (leaf-visible-from-node-p other ref))) + (change-ref-leaf ref other) + (when (constant-p other) (return))) + (t + (setq res (type-approx-intersection2 + res other-type)))))))) ((< >) (cond ((and (integer-type-p res) (integer-type-p y)) @@ -693,41 +930,7 @@ (let ((lvar (ref-lvar ref)) (leaf (ref-leaf ref))) (when (and (lambda-var-p leaf) lvar) - (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 (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))) + (conset-add-lvar-lambda-var-eql gen lvar leaf)))) ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's ;; LAMBDA-VAR if possible. @@ -756,35 +959,56 @@ 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))) - (conset-adjoin con gen)) - (maybe-add-eql-var-var-constraint var val gen))))) + do (let ((type (lvar-type val))) + (unless (eq type *universal-type*) + (conset-add-constraint gen 'typep var type nil))) + (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 preprocess-refs-p - (let* ((var (ref-leaf node)) - (con (lambda-var-constraints var))) - (constrain-ref-type node con gen))))) + (constrain-ref-type 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))) - (conset-adjoin con gen)))))))) + (unless (eq atype *universal-type*) + (conset-add-constraint-to-eql gen 'typep var atype nil))))))) (cset (binding* ((var (set-var node)) (nil (lambda-var-p var) :exit-if-null) - (cons (lambda-var-constraints var) :exit-if-null)) - (conset-difference gen cons) - (let* ((type (single-value-type (node-derived-type node))) - (con (find-or-create-constraint 'typep var type nil))) - (conset-adjoin con gen)) - (maybe-add-eql-var-var-constraint var (set-value node) gen))))) + (nil (lambda-var-constraints var) :exit-if-null)) + (when (policy node (and (= speed 3) (> speed compilation-speed))) + (let ((type (lambda-var-type var))) + (unless (eql *universal-type* type) + (do-eql-vars (other (var gen)) + (unless (eql other var) + (conset-add-constraint gen 'typep other type nil)))))) + (conset-clear-lambda-var gen var) + (let ((type (single-value-type (node-derived-type node)))) + (unless (eq type *universal-type*) + (conset-add-constraint gen 'typep var type nil))) + (unless (policy node (> compilation-speed speed)) + (maybe-add-eql-var-var-constraint var (set-value node) gen)))) + (combination + (when (eq (combination-kind node) :known) + (binding* ((info (combination-fun-info node) :exit-if-null) + (propagate (fun-info-constraint-propagate info) + :exit-if-null) + (constraints (funcall propagate node gen)) + (register (if (policy node + (> compilation-speed speed)) + #'conset-add-constraint + #'conset-add-constraint-to-eql))) + (map nil (lambda (constraint) + (destructuring-bind (kind x y &optional not-p) + constraint + (when (and kind x y) + (funcall register gen + kind x y + not-p)))) + constraints)))))) gen) (defun constraint-propagate-if (block gen) @@ -795,7 +1019,7 @@ (add-test-constraints use node gen)))))) ;;; Starting from IN compute OUT and (consequent/alternative -;;; constraints if the block ends with and IF). Return the list of +;;; constraints if the block ends with an IF). Return the list of ;;; successors that may need to be recomputed. (defun find-block-type-constraints (block final-pass-p) (declare (type cblock block))