X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=823a16324d2edcc3d22fe133b0a18d05cad21c4c;hb=bf4aee82dd12d132a82fa39355d66f2ac67c8fc5;hp=e8369eec2521feae234b0e9fa3e65c952744da3a;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index e8369ee..823a163 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -15,14 +15,15 @@ (defstruct (constraint (:include sset-element) - (:constructor make-constraint (number kind x y not-p))) - ;; The kind of constraint we have: + (:constructor make-constraint (number kind x y not-p)) + (:copier nil)) + ;; the kind of constraint we have: ;; ;; TYPEP ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is ;; constrained to be of type Y. ;; - ;; >, < + ;; > or < ;; X is a lambda-var and Y is a CTYPE. The relation holds ;; between X and some object of type Y. ;; @@ -109,9 +110,14 @@ ;;; Add complementary constraints to the consequent and alternative ;;; blocks of IF. We do nothing if X is NIL. -#!-sb-fluid (declaim (inline add-complement-constraints)) (defun add-complement-constraints (if fun x y not-p) - (when x + (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. + (not (eq (if-consequent if) + (if-alternative if)))) (add-test-constraint (if-consequent if) fun x y not-p) (add-test-constraint (if-alternative if) fun x y (not not-p))) (values)) @@ -125,50 +131,52 @@ (add-complement-constraints if 'typep (ok-ref-lambda-var use) (specifier-type 'null) t)) (combination - (let ((name (continuation-function-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))) - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - (if (ctype-p val) - val - (specifier-type val)) - nil))))) - ((eq eql) - (let* ((var1 (ok-cont-lambda-var (first args))) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (cond ((not var1)) - (var2 - (add-complement-constraints if 'eql var1 var2 nil)) - ((constant-continuation-p arg2) - (add-complement-constraints if 'eql var1 - (ref-leaf - (continuation-use arg2)) - nil))))) - ((< >) - (let* ((arg1 (first args)) - (var1 (ok-cont-lambda-var arg1)) - (arg2 (second args)) - (var2 (ok-cont-lambda-var arg2))) - (when var1 - (add-complement-constraints if name var1 (continuation-type arg2) - nil)) - (when var2 - (add-complement-constraints if (if (eq name '<) '> '<) - var2 (continuation-type arg1) - nil)))) - (t - (let ((ptype (gethash name *backend-predicate-types*))) - (when ptype - (add-complement-constraints if 'typep - (ok-cont-lambda-var (first args)) - ptype nil)))))))) + (unless (eq (combination-kind use) + :error) + (let ((name (continuation-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))) + (add-complement-constraints if 'typep + (ok-cont-lambda-var (first args)) + (if (ctype-p val) + val + (specifier-type val)) + nil))))) + ((eq eql) + (let* ((var1 (ok-cont-lambda-var (first args))) + (arg2 (second args)) + (var2 (ok-cont-lambda-var arg2))) + (cond ((not var1)) + (var2 + (add-complement-constraints if 'eql var1 var2 nil)) + ((constant-continuation-p arg2) + (add-complement-constraints if 'eql var1 + (ref-leaf + (continuation-use arg2)) + nil))))) + ((< >) + (let* ((arg1 (first args)) + (var1 (ok-cont-lambda-var arg1)) + (arg2 (second args)) + (var2 (ok-cont-lambda-var arg2))) + (when var1 + (add-complement-constraints if name var1 (continuation-type arg2) + nil)) + (when var2 + (add-complement-constraints if (if (eq name '<) '> '<) + var2 (continuation-type arg1) + nil)))) + (t + (let ((ptype (gethash name *backend-predicate-types*))) + (when ptype + (add-complement-constraints if 'typep + (ok-cont-lambda-var (first args)) + ptype nil))))))))) (values)) ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to @@ -186,7 +194,7 @@ ;;; Compute the initial flow analysis sets for BLOCK: ;;; -- For any lambda-var ref with a type check, add that constraint. -;;; -- For any lambda-var set, delete all constraints on that var, and add +;;; -- For any LAMBDA-VAR set, delete all constraints on that var, and add ;;; those constraints to the set nuked by this block. (defun find-block-type-constraints (block) (declare (type cblock block)) @@ -216,7 +224,7 @@ (setf (block-in block) nil) (setf (block-gen block) gen) - (setf (block-kill block) (kill)) + (setf (block-kill-list block) (kill)) (setf (block-out block) (copy-sset gen)) (setf (block-type-asserted block) nil) (values)))) @@ -244,23 +252,16 @@ (greater (1+ x)) (t (1- x)))) (bound (x) - (if greater (numeric-type-low x) (numeric-type-high x))) - (validate (x) - (if (and (numeric-type-low x) (numeric-type-high x) - (> (numeric-type-low x) (numeric-type-high x))) - *empty-type* - 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)))) - (res (copy-numeric-type x))) + (t (min x-bound y-bound))))) (if greater - (setf (numeric-type-low res) new-bound) - (setf (numeric-type-high res) new-bound)) - (validate res)))) + (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) @@ -272,12 +273,13 @@ ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers. (defun constrain-float-type (x y greater or-equal) (declare (type numeric-type x y)) - ;; Unless :PROPAGATE-FLOAT-TYPE is in target features, then - ;; SB!C::BOUND-VALUE (used in the code below) is not defined, so we - ;; just return X without trying to calculate additional constraints. - #!-propagate-float-type (declare (ignore y greater or-equal)) - #!-propagate-float-type x - #!+propagate-float-type + (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) @@ -292,8 +294,8 @@ (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 (bound-value x) (bound-value 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 @@ -301,19 +303,13 @@ (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 (bound-value x) (bound-value y)))) + ;; 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))))) - (validate (x) - (let ((x-lo (numeric-type-low x)) - (x-hi (numeric-type-high x))) - (if (and x-lo x-hi (> (bound-value x-lo) (bound-value x-hi))) - *empty-type* - x)))) + (set-bound res (or (consp x) (consp y)))))) (let* ((x-bound (bound x)) (y-bound (exclude (bound y))) (new-bound (cond ((not x-bound) @@ -323,12 +319,10 @@ (greater (max-lower-bound x-bound y-bound)) (t - (min-upper-bound x-bound y-bound)))) - (res (copy-numeric-type x))) + (min-upper-bound x-bound y-bound))))) (if greater - (setf (numeric-type-low res) new-bound) - (setf (numeric-type-high res) new-bound)) - (validate res)))) + (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 @@ -350,7 +344,7 @@ (typep (if not-p (setq not-res (type-union not-res other)) - (setq res (type-intersection res other)))) + (setq res (type-approx-intersection2 res other)))) (eql (let ((other-type (leaf-type other))) (if not-p @@ -369,7 +363,6 @@ (let ((greater (if not-p (not greater) greater))) (setq res (constrain-integer-type res y greater not-p))))) - #!+constrain-float-type ((and (float-type-p res) (float-type-p y)) (let ((greater (eq kind '>))) (let ((greater (if not-p (not greater) greater))) @@ -383,7 +376,7 @@ (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))) + (change-ref-leaf ref (find-constant t))) (t (derive-node-type ref (or (type-difference res not-res) res))))))) @@ -453,11 +446,11 @@ (dolist (let (lambda-lets fun)) (frob let))))) -;;; BLOCK-IN becomes the intersection of the OUT of the prececessors. +;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. ;;; Our OUT is: ;;; out U (in - kill) ;;; -;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must +;;; BLOCK-KILL-LIST is just a list of the LAMBDA-VARs killed, so we must ;;; compute the kill set when there are any vars killed. We bum this a ;;; bit by special-casing when only one var is killed, and just using ;;; that var's constraints as the kill set. This set could possibly be @@ -471,31 +464,38 @@ (sset-intersection res (block-out b))) res)) (t - (when *check-consistency* - (let ((*compiler-error-context* (block-last block))) - (compiler-warning - "*** Unreachable code in constraint ~ - propagation... Bug?"))) + (let ((*compiler-error-context* (block-last block))) + (compiler-warn + "unreachable code in constraint ~ + propagation -- apparent compiler bug")) (make-sset)))) - (kill (block-kill block)) + (kill-list (block-kill-list block)) (out (block-out block))) (setf (block-in block) in) - (cond ((null kill) + (cond ((null kill-list) (sset-union (block-out block) in)) - ((null (rest kill)) - (let ((con (lambda-var-constraints (first kill)))) + ((null (rest kill-list)) + (let ((con (lambda-var-constraints (first kill-list)))) (if con (sset-union-of-difference out in con) (sset-union out in)))) (t (let ((kill-set (make-sset))) - (dolist (var kill) + (dolist (var kill-list) (let ((con (lambda-var-constraints var))) (when con (sset-union kill-set con)))) (sset-union-of-difference (block-out block) in kill-set)))))) +;;; How many blocks does COMPONENT have? +(defun component-n-blocks (component) + (let ((result 0)) + (declare (type index result)) + (do-blocks (block component :both) + (incf result)) + result)) + (defun constraint-propagate (component) (declare (type component component)) (init-var-constraints component) @@ -513,17 +513,20 @@ (setf (block-out (component-head component)) (make-sset)) - (let ((did-something nil)) - (loop - (do-blocks (block component) - (when (flow-propagate-constraints block) - (setq did-something t))) - - (unless did-something (return)) - (setq did-something nil))) + (let (;; If we have to propagate changes more than this many times, + ;; something is wrong. + (max-n-changes-remaining (component-n-blocks component))) + (declare (type fixnum max-n-changes-remaining)) + (loop (aver (plusp max-n-changes-remaining)) + (decf max-n-changes-remaining) + (let ((did-something nil)) + (do-blocks (block component) + (when (flow-propagate-constraints block) + (setq did-something t))) + (unless did-something + (return))))) (do-blocks (block component) (use-result-constraints block)) (values)) -