X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=cd9f9f7e84fe777e686835a3d6da97cde0f66e9d;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=d14a982c1a2500b7d532c27114c16bc15ff67b0d;hpb=e7100f143ac497232623ada89aa364b720faa345;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index d14a982..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,28 +557,92 @@ (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. -(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 - (conset-add-constraint-to-eql constraints fun x y not-p 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) @@ -592,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))) @@ -627,27 +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 - (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 'typep var1 (lvar-type arg2) + (add-test-constraint quick-p + 'typep var1 (lvar-type arg2) nil constraints consequent-constraints))))) ((< >) @@ -660,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 @@ -710,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 @@ -731,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 @@ -913,11 +979,36 @@ (binding* ((var (set-var node)) (nil (lambda-var-p var) :exit-if-null) (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))) - (maybe-add-eql-var-var-constraint var (set-value node) gen))))) + (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) @@ -928,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))