X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=cd9f9f7e84fe777e686835a3d6da97cde0f66e9d;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=88a8252b0359279a87d49be115233ea92bc1d801;hpb=74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 88a8252..cd9f9f7 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -155,16 +155,12 @@ (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))) @@ -427,6 +423,7 @@ (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))) @@ -560,9 +557,7 @@ (ok-lvar-lambda-var (cast-value use) constraints))))) ;;;; 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. +;;; 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) @@ -584,7 +579,7 @@ (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)) + alternative-constraints)) (values)) (defun quick-add-complement-constraints (fun x y not-p @@ -606,6 +601,48 @@ 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) @@ -653,7 +690,7 @@ (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 @@ -668,10 +705,7 @@ (add 'eql var1 var2 nil)) ((constant-lvar-p arg2) (add 'eql var1 - (let ((use (principal-lvar-use arg2))) - (if (ref-p use) - (ref-leaf use) - (find-constant (lvar-value arg2)))) + (find-constant (lvar-value arg2)) nil)) (t (add-test-constraint quick-p @@ -688,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 @@ -738,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 @@ -759,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 @@ -952,7 +990,25 @@ (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)))))) + (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) @@ -963,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))