X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=550f9b9bd54da23892cbddfb74aa7803820459c0;hb=d7e55b414d180341d79e0eddc957e1aa52551c38;hp=d14a982c1a2500b7d532c27114c16bc15ff67b0d;hpb=e7100f143ac497232623ada89aa364b720faa345;p=sbcl.git diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index d14a982..550f9b9 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -427,6 +427,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))) @@ -563,25 +564,49 @@ ;;; 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))) +(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 - (add-test-constraint fun x y not-p constraints - consequent-constraints) - (add-test-constraint fun x y (not not-p) constraints - alternative-constraints)) + (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 + (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))) + ;;; Add test constraints to the consequent and alternative blocks of ;;; the test represented by USE. (defun add-test-constraints (use if constraints) @@ -592,9 +617,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))) @@ -634,20 +661,19 @@ ;; 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))))) ((< >) @@ -710,6 +736,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 +762,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 +943,18 @@ (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)))))) gen) (defun constraint-propagate-if (block gen)