X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=8844aeb59e96a8f82c92683c762c0565c5329516;hb=8f4ef01b8c9930d7dd0a56a96845a6d84ca5774d;hp=5e6162479e65af8adba667ecf33aaf953c457159;hpb=6a756846fe0fe89835ec5eb68327b612c93f82c4;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 5e61624..8844aeb 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -44,10 +44,6 @@ ;;; ;;; -- 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") @@ -124,12 +120,12 @@ (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)))) @@ -173,49 +169,49 @@ (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)) + (lvar-uses 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,8 +221,8 @@ (declare (type cblock block)) (let ((last (block-last block))) (when (if-p last) - (let ((use (continuation-use (if-test last)))) - (when use + (let ((use (lvar-uses (if-test last)))) + (when (node-p use) (add-test-constraints use last))))) (setf (block-test-modified block) nil) @@ -279,7 +275,7 @@ (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.) @@ -358,7 +354,8 @@ (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) + (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))))))) @@ -375,16 +372,15 @@ (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))))))) + (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))))))) (values)) @@ -407,43 +403,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) @@ -534,11 +529,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)))))))) + (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