X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=cd9f9f7e84fe777e686835a3d6da97cde0f66e9d;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=fae2b81a814da4b5f0db9cbd7aed3758b8affe97;hpb=0dda5090b6c16a641000b4eb2dcd479f39b784ca;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index fae2b81..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))) @@ -561,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) @@ -585,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 @@ -607,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) @@ -654,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 @@ -669,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 @@ -689,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 @@ -957,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) @@ -968,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))