X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=60e0a7bd1b697c4ff3e8623f45a15b75ff24dff4;hb=c2431e2d0d0222a3cf20cfdfa48201bdcc65cd76;hp=507eaf824b12d65f2864dd1e79ea78768c60db17;hpb=a7c2a16d0c2be6709becc962be1cb5e0aeda68c6;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 507eaf8..60e0a7b 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -44,17 +44,13 @@ ;;; ;;; -- this code does not check whether SET appears between REF and a ;;; test (bug 233b) -;;; -;;; -- type check is assumed to be inserted immediately after a node -;;; producing the value; it disagrees with the rest of Python (bug -;;; 233a) (in-package "SB!C") (defstruct (constraint - (:include sset-element) - (:constructor make-constraint (number kind x y not-p)) - (:copier nil)) + (:include sset-element) + (:constructor make-constraint (number kind x y not-p)) + (:copier nil)) ;; the kind of constraint we have: ;; ;; TYPEP @@ -84,35 +80,35 @@ ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set. (defun find-constraint (kind x y not-p) (declare (type lambda-var x) (type (or constant lambda-var ctype) y) - (type boolean not-p)) + (type boolean not-p)) (or (etypecase y - (ctype - (do-sset-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)))) - (constant - (do-sset-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) - (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))))) + (ctype + (do-sset-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)))) + (constant + (do-sset-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) + (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))))) (let ((new (make-constraint (incf *constraint-number*) kind x y not-p))) - (sset-adjoin new (lambda-var-constraints x)) - (when (lambda-var-p y) - (sset-adjoin new (lambda-var-constraints y))) - new))) + (sset-adjoin new (lambda-var-constraints x)) + (when (lambda-var-p y) + (sset-adjoin new (lambda-var-constraints y))) + new))) ;;; 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. @@ -121,15 +117,15 @@ (declare (type ref ref)) (let ((leaf (ref-leaf ref))) (when (and (lambda-var-p leaf) - (lambda-var-constraints leaf)) + (lambda-var-constraints leaf)) leaf))) -;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, +;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE, ;;; otherwise NIL. -#!-sb-fluid (declaim (inline ok-cont-lambda-var)) -(defun ok-cont-lambda-var (cont) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) +#!-sb-fluid (declaim (inline ok-lvar-lambda-var)) +(defun ok-lvar-lambda-var (lvar) + (declare (type lvar lvar)) + (let ((use (lvar-uses lvar))) (when (ref-p use) (ok-ref-lambda-var use)))) @@ -142,20 +138,20 @@ (defun add-test-constraint (block fun x y not-p) (unless (rest (block-pred block)) (let ((con (find-constraint fun x y not-p)) - (old (or (block-test-constraint block) - (setf (block-test-constraint block) (make-sset))))) + (old (or (block-test-constraint block) + (setf (block-test-constraint block) (make-sset))))) (when (sset-adjoin con old) - (setf (block-type-asserted block) t)))) + (setf (block-type-asserted block) t)))) (values)) ;;; Add complementary constraints to the consequent and alternative ;;; blocks of IF. We do nothing if X is NIL. (defun add-complement-constraints (if fun x y not-p) (when (and x - ;; Note: Even if we do (IF test exp exp) => (PROGN test exp) - ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means - ;; that we can't guarantee that the optimization will be - ;; done, so we still need to avoid barfing on this case. + ;; Note: Even if we do (IF test exp exp) => (PROGN test exp) + ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means + ;; that we can't guarantee that the optimization will be + ;; done, so we still need to avoid barfing on this case. (not (eq (if-consequent if) (if-alternative if)))) (add-test-constraint (if-consequent if) fun x y not-p) @@ -169,53 +165,53 @@ (typecase use (ref (add-complement-constraints if 'typep (ok-ref-lambda-var use) - (specifier-type 'null) t)) + (specifier-type 'null) t)) (combination (unless (eq (combination-kind use) :error) - (let ((name (continuation-fun-name + (let ((name (lvar-fun-name (basic-combination-fun use))) (args (basic-combination-args use))) (case name ((%typep %instance-typep) (let ((type (second args))) - (when (constant-continuation-p type) - (let ((val (continuation-value type))) + (when (constant-lvar-p type) + (let ((val (lvar-value type))) (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) (if (ctype-p val) val (specifier-type val)) nil))))) ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) + (let* ((var1 (ok-lvar-lambda-var (first args))) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (cond ((not var1)) (var2 (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) + ((constant-lvar-p arg2) (add-complement-constraints if 'eql var1 (ref-leaf - (continuation-use arg2)) + (principal-lvar-use arg2)) nil))))) ((< >) (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) + (var1 (ok-lvar-lambda-var arg1)) (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) + (var2 (ok-lvar-lambda-var arg2))) (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) + (add-complement-constraints if name var1 (lvar-type arg2) nil)) (when var2 (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) + var2 (lvar-type arg1) nil)))) (t (let ((ptype (gethash name *backend-predicate-types*))) (when ptype (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) + (ok-lvar-lambda-var (first args)) ptype nil))))))))) (values)) @@ -225,9 +221,9 @@ (declare (type cblock block)) (let ((last (block-last block))) (when (if-p last) - (let ((use (continuation-use (if-test last)))) - (when use - (add-test-constraints use last))))) + (let ((use (lvar-uses (if-test last)))) + (when (node-p use) + (add-test-constraints use last))))) (setf (block-test-modified block) nil) (values)) @@ -252,21 +248,21 @@ (defun constrain-integer-type (x y greater or-equal) (declare (type numeric-type x y)) (flet ((exclude (x) - (cond ((not x) nil) - (or-equal x) - (greater (1+ x)) - (t (1- x)))) - (bound (x) - (if greater (numeric-type-low x) (numeric-type-high x)))) + (cond ((not x) nil) + (or-equal x) + (greater (1+ x)) + (t (1- x)))) + (bound (x) + (if greater (numeric-type-low x) (numeric-type-high 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 x-bound y-bound)) - (t (min x-bound y-bound))))) + (y-bound (exclude (bound y))) + (new-bound (cond ((not x-bound) y-bound) + ((not y-bound) x-bound) + (greater (max x-bound y-bound)) + (t (min x-bound y-bound))))) (if greater - (modified-numeric-type x :low new-bound) - (modified-numeric-type x :high new-bound))))) + (modified-numeric-type x :low new-bound) + (modified-numeric-type x :high new-bound))))) ;;; Return true if X is a float NUMERIC-TYPE. (defun float-type-p (x) @@ -279,55 +275,55 @@ (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 - + (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) x #-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)))))) + (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)))))) (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)) - (t - (min-upper-bound x-bound y-bound))))) + (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)) + (t + (min-upper-bound x-bound y-bound))))) (if greater - (modified-numeric-type x :low new-bound) - (modified-numeric-type x :high new-bound))))) + (modified-numeric-type x :low new-bound) + (modified-numeric-type x :high new-bound))))) ;;; Given the set of CONSTRAINTS for a variable and the current set of ;;; restrictions from flow analysis IN, set the type for REF @@ -337,54 +333,55 @@ (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))) + (not-res *empty-type*) + (leaf (ref-leaf ref))) (do-sset-elements (con var-cons) - (let* ((x (constraint-x con)) - (y (constraint-y con)) - (not-p (constraint-not-p con)) - (other (if (eq x leaf) y x)) - (kind (constraint-kind con))) - (case kind - (typep - (if not-p - (setq not-res (type-union not-res other)) - (setq res (type-approx-intersection2 res other)))) - (eql - (let ((other-type (leaf-type other))) - (if not-p - (when (and (constant-p other) - (member-type-p other-type)) - (setq not-res (type-union not-res other-type))) - (let ((leaf-type (leaf-type leaf))) - (when (or (constant-p other) - (and (csubtypep other-type leaf-type) - (not (type= other-type leaf-type)))) - (change-ref-leaf ref other) - (when (constant-p other) (return))))))) - ((< >) - (cond ((and (integer-type-p res) (integer-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-integer-type res y greater not-p))))) - ((and (float-type-p res) (float-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-float-type res y greater not-p))))) - ))))) - - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) - (cond ((and (if-p dest) - (csubtypep (specifier-type 'null) not-res) - (eq (continuation-asserted-type cont) *wild-type*)) - (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant t))) - (t - (derive-node-type ref (or (type-difference res not-res) - res))))))) + (let* ((x (constraint-x con)) + (y (constraint-y con)) + (not-p (constraint-not-p con)) + (other (if (eq x leaf) y x)) + (kind (constraint-kind con))) + (case kind + (typep + (if not-p + (setq not-res (type-union not-res other)) + (setq res (type-approx-intersection2 res other)))) + (eql + (let ((other-type (leaf-type other))) + (if not-p + (when (and (constant-p other) + (member-type-p other-type)) + (setq not-res (type-union not-res other-type))) + (let ((leaf-type (leaf-type leaf))) + (when (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))))))) + ((< >) + (cond ((and (integer-type-p res) (integer-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-integer-type res y greater not-p))))) + ((and (float-type-p res) (float-type-p y)) + (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))))) (values)) @@ -407,43 +404,42 @@ (when test (sset-union gen test))) - (do-nodes (node cont block) + (do-nodes (node lvar block) (typecase node (bind (let ((fun (bind-lambda node))) (when (eq (functional-kind fun) :let) - (loop with call = (continuation-dest - (node-cont (first (lambda-refs fun)))) - for var in (lambda-vars fun) - and val in (combination-args call) - when (and val - (lambda-var-constraints var) - ;; if VAR has no SETs, type inference is - ;; fully performed by IR1 optimizer - (lambda-var-sets var)) - do (let* ((type (continuation-type val)) - (con (find-constraint 'typep var type nil))) - (sset-adjoin con gen)))))) + (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) + ;; if VAR has no SETs, type inference is + ;; fully performed by IR1 optimizer + (lambda-var-sets var)) + do (let* ((type (lvar-type val)) + (con (find-constraint 'typep var type nil))) + (sset-adjoin con gen)))))) (ref (let ((var (ok-ref-lambda-var node))) (when var (when ref-preprocessor (funcall ref-preprocessor node gen)) - (when (continuation-type-check cont) - (let* ((atype (continuation-derived-type cont)) - (con (find-constraint 'typep var atype nil))) - (sset-adjoin con gen)))))) + (let ((dest (and lvar (lvar-dest lvar)))) + (when (cast-p dest) + (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME + (con (find-constraint 'typep var atype nil))) + (sset-adjoin con gen))))))) (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (when set-preprocessor - (funcall set-preprocessor var)) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference gen cons) - (let* ((type (node-derived-type node)) - (con (find-constraint 'typep var type nil))) - (sset-adjoin con gen))))))))) + (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-constraint 'typep var type nil))) + (sset-adjoin con gen)))))) gen) @@ -459,19 +455,19 @@ (kill (block-kill block)) (out (copy-sset (block-gen block)))) (cond ((null kill) - (sset-union out in)) - ((null (rest kill)) - (let ((con (lambda-var-constraints (first kill)))) - (if con - (sset-union-of-difference out in con) - (sset-union out in)))) - (t - (let ((kill-set (make-sset))) - (dolist (var kill) - (let ((con (lambda-var-constraints var))) - (when con - (sset-union kill-set con)))) - (sset-union-of-difference out in kill-set)))) + (sset-union out in)) + ((null (rest kill)) + (let ((con (lambda-var-constraints (first kill)))) + (if con + (sset-union-of-difference out in con) + (sset-union out in)))) + (t + (let ((kill-set (make-sset))) + (dolist (var kill) + (let ((con (lambda-var-constraints var))) + (when con + (sset-union kill-set con)))) + (sset-union-of-difference out in kill-set)))) out)) ;;; Compute the initial flow analysis sets for BLOCK: @@ -514,7 +510,7 @@ ;;; Return True if we have done something. (defun flow-propagate-constraints (block) (let* ((pred (block-pred block)) - (in (progn (aver pred) + (in (progn (aver pred) (let ((res (copy-sset (block-out (first pred))))) (dolist (b (rest pred)) (sset-intersection res (block-out b))) @@ -534,24 +530,9 @@ (constraint-propagate-in-block block (block-in block) :ref-preprocessor (lambda (node cons) - (let ((var (ref-leaf node))) - (when (lambda-var-p var) - (let ((con (lambda-var-constraints var))) - (when con - (constrain-ref-type node con cons)))))))) - -;;; Return true if VAR would have to be closed over if environment -;;; analysis ran now (i.e. if there are any uses that have a different -;;; home lambda than VAR's home.) -(defun closure-var-p (var) - (declare (type lambda-var var)) - (let ((home (lambda-home (lambda-var-home var)))) - (flet ((frob (l) - (dolist (node l nil) - (unless (eq (node-home-lambda node) home) - (return t))))) - (or (frob (leaf-refs var)) - (frob (basic-var-sets var)))))) + (let* ((var (ref-leaf node)) + (con (lambda-var-constraints var))) + (constrain-ref-type node con cons))))) ;;; 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 @@ -561,14 +542,14 @@ (declare (type component component)) (dolist (fun (component-lambdas component)) (flet ((frob (x) - (dolist (var (lambda-vars x)) - (unless (lambda-var-constraints var) - (when (or (null (lambda-var-sets var)) - (not (closure-var-p var))) - (setf (lambda-var-constraints var) (make-sset))))))) + (dolist (var (lambda-vars x)) + (unless (lambda-var-constraints var) + (when (or (null (lambda-var-sets var)) + (not (closure-var-p var))) + (setf (lambda-var-constraints var) (make-sset))))))) (frob fun) (dolist (let (lambda-lets fun)) - (frob let))))) + (frob let))))) ;;; How many blocks does COMPONENT have? (defun component-n-blocks (component) @@ -608,6 +589,7 @@ (return)))))) (do-blocks (block component) - (use-result-constraints block)) + (unless (block-delete-p block) + (use-result-constraints block))) (values))