Two new optimizer types for flow-sensitive type propagation

CONSTRAINT-PROPAGATE optimizers can add new information about the
state of the world after/if the function has returned.  Function
type declarations/propagation suffice for simple patterns (e.g.
return types, or unconditional type requirements on arguments),
but this optimizer is more general.

Such optimizers receive two arguments, the combination node and the
current set of constraints, and return a sequence of constraints.
Constraints are lists of three or four values:
 1. a constraint kind (either TYPEP, <, >, or EQL);
 2, 3. two arguments, either LVARs, LAMBDA-VARs or a CTYPE;
 4. optionally, whether the meaning of the constraint must be
    flipped.
This mimics the (defstruct (constraint ...)) in constraint.lisp.
If any of the argument is NIL, the constraint is skipped; otherwise,
it is added to current set of constraints.  Optimizers have access
to that set, and can thus map LVARs to LAMBDA-VARs thanks to
OK-LVAR-LAMBDA-VAR.

CONSTRAINT-PROPAGATE-IF optimizers can instead hook into the
interpretation of functions as predicate, when their result feeds
into an IF node.  They also receive the node and the current set
of constraints as arguments, and return four values.  The first two
values are an LVAR and a CTYPE: if they are non-NIL, that LVAR is
of that CTYPE iff the combination returns true.  The two remaining
values are sequences of constraints (see previous paragraph) for
the consequent (if-true) and alternative (if-false) branches,
respectively.  These are useful for more complex tests, but also
to represent partial information, e.g., if an EQUAL test fails,
the two values are not EQL either.

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index b30ecd2..02c0628 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -561,9 +561,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)
@@ -607,6 +605,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)
@@ -686,10 +726,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
@@ -954,7 +994,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)

diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 100f3ee..bce0879 100644 (file)
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -131,6 +131,27 @@
   ;; If true, the function can stack-allocate the result. The
   ;; COMBINATION node is passed as an argument.
   (stack-allocate-result nil :type (or function null))
+  ;; If true, the function can add flow-sensitive type information
+  ;; about the state of the world after its execution. The COMBINATION
+  ;; node is passed as an argument, along with the current set of
+  ;; active constraints for the block.  The function returns a
+  ;; sequence of constraints; a constraint is a triplet of a
+  ;; constraint kind (a symbol, see (defstruct (constraint ...)) in
+  ;; constraint.lisp) and arguments, either LVARs, LAMBDA-VARs, or
+  ;; CTYPEs.  If any of these arguments is NIL, the constraint is
+  ;; skipped. This simplifies integration with OK-LVAR-LAMBDA-VAR,
+  ;; which maps LVARs to LAMBDA-VARs.  An optional fourth value in
+  ;; each constraint flips the meaning of the constraint if it is
+  ;; non-NIL.
+  (constraint-propagate nil :type (or function null))
+  ;; If true, the function can add flow-sensitive type information
+  ;; depending on the truthiness of its return value.  Returns two
+  ;; values, a LVAR and a CTYPE. The LVAR is of that CTYPE iff the
+  ;; function returns true.
+  ;; It may also return additional third and fourth values. Each is
+  ;; a sequence of constraints (see CONSTRAINT-PROPAGATE), for the
+  ;; consequent and alternative branches, respectively.
+  (constraint-propagate-if nil :type (or function null))
   ;; all the templates that could be used to translate this function
   ;; into IR2, sorted by increasing cost.
   (templates nil :type list)