(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)))
(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)
(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
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)
(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
(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
(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
(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)
(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))