master: Propagate local call argument types optimistically as well.
apache--- via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via ae55fe64435d4015b8d640532196885b3323d4a7 (commit)
from 59adbea07c30bd1047e51cd83ffd9d9ae17688cd (commit)
- Log -----------------------------------------------------------------
commit ae55fe64435d4015b8d640532196885b3323d4a7
Author: Charles Zhang <[email protected]>
Date: Thu Aug 6 02:17:28 2026 +0200
Propagate local call argument types optimistically as well.
PROPAGATE-LOCAL-CALL-ARGS computes a local function's parameter types
by unioning the argument types across its call sites, starting each
parameter at T and narrowing. That descends the lattice, and it cannot
converge once the argument flow has a cycle in it: a call that hands a
parameter back to itself contributes the parameter's own current type,
so the union comes out (UNION <whatever> T) = T on every round and
stays there.
This means that a loop written tail recursively often gets less
precise types than its imperative variant:
(do ((i n (1- i)) (x (list 1) x)) ((zerop i) x)) => CONS
(labels ((rec (i x) (if (zerop i) x (rec (1- i) x))))
(rec n (list 1))) => T
We solve this by solving the local call argument type equations from
the bottom of the type lattice (i.e. from the empty type) as well,
only propagating the final optimistic type once the least fixpoint is
hit.
Fixes lp#486416.
Test cases and implementation sketch written by Claude Opus 5, code
and comments heavily simplified and edited by me.
---
src/compiler/ir1opt.lisp | 177 +++++++++++++++++++++++++++++++++++++++++++++++
src/compiler/main.lisp | 2 +
src/compiler/node.lisp | 11 +++
tests/compiler.pure.lisp | 111 +++++++++++++++++++++++++++++
4 files changed, 301 insertions(+)
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 4a93d91b6..c221eb69d 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1434,6 +1434,7 @@
(ecase kind
(:local
(let ((fun (combination-lambda node)))
+ (accumulate-optimistic-arg-types node fun)
(if (functional-kind-eq fun let)
(propagate-let-args node fun)
(propagate-local-call-args node fun))))
@@ -3050,6 +3051,182 @@
(declaim (end-block))
+;;;; types of local call arguments that flow in a cycle
+
+;;;; Ordinary forward type propagation in IR1 as in
+;;;; PROPAGATE-LOCAL-CALL-ARGS starts at T and iteratively unions and
+;;;; narrows across call sites. While these intermediate types are
+;;;; conservative and hence always sound, this presents a precision
+;;;; problem in the presence of cyclical dataflow. For example, in
+;;;; local functions whose parameters end up eventually feeding
+;;;; arguments of calls to themselves, the union of the argument types
+;;;; stays fixed at T nd nothing further can be derived. This is
+;;;; particularly harmful for loops expressed as recursive functions
+;;;; which frequently take this shape.
+;;;;
+;;;; To solve this impasse, we track optimistic types on parameter
+;;;; variables which start out as holding the empty type. Such types
+;;;; are pushed around the flow graphand and iterated upward to the
+;;;; least fixpoint and must not be propagated elsewhere or published
+;;;; until then, as these intermediate types underapproximate the
+;;;; real type and are not sound.
+
+;;; True if we can tell what FUN's parameters might be just by looking
+;;; at its local calls. We can't do anything when FUN has an XEP.
+(defun optimistic-type-propagatable-fun-p (fun)
+ (declare (type clambda fun))
+ (and (not (functional-entry-fun fun))
+ (not (lambda-optional-dispatch fun))
+ (let ((vars (lambda-vars fun))
+ (refs (leaf-refs fun)))
+ (and refs
+ ;; &OPTIONAL, &REST and &KEY parameters are not filled in
+ ;; from the argument list position by position.
+ (notany #'lambda-var-arg-info vars)
+ (dolist (ref refs t)
+ (let ((dest (node-dest ref)))
+ (unless (and (combination-p dest)
+ (eq (combination-kind dest) :local)
+ (eq (basic-combination-fun dest) (node-lvar ref))
+ (= (length (basic-combination-args dest))
+ (length vars)))
+ (return nil))))))))
+
+;;; Return whether VAR is eligible for optimistic parameter type
+;;; inference. If it is, initialize the optimistic type of VAR to the
+;;; empty type if needed. Set variables are currently too hairy to
+;;; handle.
+(defun init-variable-optimistic-type (var)
+ (declare (type lambda-var var))
+ (or (lambda-var-optimistic-type var)
+ (let ((home (lambda-var-home var)))
+ (when (and home
+ (not (basic-var-sets var))
+ (not (lambda-var-deleted var))
+ (optimistic-type-propagatable-fun-p home))
+ (setf (lambda-var-optimistic-type var) *empty-type*)
+ (setf (lambda-optimistic-pending home) t)
+ (dolist (ref (leaf-refs home))
+ (let ((dest (node-dest ref)))
+ (when (and dest (combination-p dest) (node-prev dest))
+ (reoptimize-node dest))))
+ t))))
+
+;;; Return the lambda variable referenced by USE if it is eligible for
+;;; optimistic type inference.
+(defun optimistic-var (use)
+ (and (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (and (lambda-var-p leaf)
+ (init-variable-optimistic-type leaf)
+ leaf))))
+
+;;; Return the optimistic type of the lvar ARG by taking into account
+;;; any variable references which may have optimistic types. Otherwise
+;;; fall back to any derived types.
+(defun optimistic-arg-types (arg)
+ (declare (type (or null lvar) arg))
+ (if (null arg)
+ (list *universal-type*)
+ (let* ((has-optimistic-p nil)
+ (types (mapcar (lambda (use)
+ (let ((var (optimistic-var use)))
+ (cond (var
+ (setf has-optimistic-p t)
+ (lambda-var-optimistic-type var))
+ (t
+ (single-value-type (node-derived-type use))))))
+ (ensure-list (lvar-uses arg)))))
+ ;; Fall back to LVAR-TYPE if no tracked parameters were
+ ;; present, since it takes casts into account as well.
+ (if has-optimistic-p
+ types
+ (list (lvar-type arg))))))
+
+;;; Note that anything affected by the optimistic type of VAR is
+;;; pending for reanalysis.
+(defun note-optimistic-change (var)
+ (dolist (ref (leaf-refs var))
+ (let* ((lvar (node-lvar ref))
+ (dest (and lvar (lvar-dest lvar))))
+ (when (and dest
+ (combination-p dest)
+ (eq (combination-kind dest) :local)
+ (neq lvar (basic-combination-fun dest)))
+ (let ((callee (combination-lambda dest)))
+ (when callee
+ (setf (lambda-optimistic-pending callee) t)))
+ (reoptimize-lvar lvar)))))
+
+;;; Compute the union of the optimistic types of every variable of FUN
+;;; across all calls and update those types whenever there is a reason
+;;; to do so. If any types ended up growing, we note that things have
+;;; changed.
+(defun accumulate-optimistic-arg-types (call fun)
+ (declare (type basic-combination call) (type clambda fun))
+ (let* ((vars (lambda-vars fun))
+ (requested (shiftf (lambda-optimistic-pending fun) nil)))
+ (when (and (or requested
+ (some (lambda (arg) (and arg (lvar-reoptimize arg)))
+ (basic-combination-args call))
+ (some (lambda (var) (null (lambda-var-optimistic-type var)))
+ vars))
+ (optimistic-type-propagatable-fun-p fun))
+ (dolist (var vars)
+ (init-variable-optimistic-type var))
+ (let ((accum-types (make-array (length vars) :initial-element *empty-type*)))
+ (declare (dynamic-extent accum-types))
+
+ (dolist (ref (leaf-refs fun))
+ (let ((dest (node-dest ref)))
+ (when dest
+ (loop for var in vars
+ for arg in (basic-combination-args dest)
+ for i from 0
+ when (lambda-var-optimistic-type var)
+ do (dolist (type (optimistic-arg-types arg))
+ (setf (aref accum-types i)
+ (type-union (aref accum-types i) type)))))))
+
+ (loop for var in vars
+ for new across accum-types
+ when (lambda-var-optimistic-type var)
+ do (unless (type= new (lambda-var-optimistic-type var))
+ (setf (lambda-var-optimistic-type var) new)
+ (note-optimistic-change var))))))
+ (values))
+
+;;; Check whether any functions in COMPONENT are still waiting for the
+;;; optimistic types of any of their variables to reach fixpoint. If
+;;; the types have settled, then publish the types by propagating them
+;;; to their corresponding variable refs (which in turn may cause
+;;; reoptimization of the component).
+;;;
+;;; If the optimistic type of a variable is empty, its function must
+;;; be unreachable and will be cleaned up later.
+(defun publish-optimistic-types (component)
+ (declare (type component component))
+ (flet ((check (fun)
+ (when (lambda-optimistic-pending fun)
+ (return-from publish-optimistic-types nil)))
+ (propagate (fun)
+ (unless (functional-kind-eq fun deleted zombie)
+ (dolist (var (lambda-vars fun))
+ (let ((type (lambda-var-optimistic-type var)))
+ (when (and type (neq type *empty-type*))
+ ;; It shouldn't be possible for FUN to acquire an
+ ;; XEP once we've decided its parameters are
+ ;; eligible for optimistic type propagation.
+ (aver (not (functional-entry-fun fun)))
+ (propagate-to-refs var type)))))))
+ (dolist (fun (component-lambdas component))
+ (check fun)
+ (mapc #'check (lambda-lets fun)))
+ (dolist (fun (component-lambdas component))
+ (propagate fun)
+ (mapc #'propagate (lambda-lets fun))))
+ (values))
+
(defun count-values (call &optional min)
(loop for arg in (basic-combination-args call)
for nvals = (nth-value 1 (values-types (lvar-derived-type arg)))
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 09d600efb..be48346bc 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -418,6 +418,8 @@ necessary, since type inference may take arbitrarily long to converge.")
(component-reanalyze component) nil))
(setf (component-reoptimize component) nil)
(ir1-optimize component fastp)
+ (unless (component-reoptimize component)
+ (publish-optimistic-types component))
(cond ((component-reoptimize component)
(setf reoptimized t)
(incf count)
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index b1a45cb92..031878523 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -1229,6 +1229,9 @@
;; all the lambdas that have been LET-substituted in this lambda.
;; This is only non-null in lambdas that aren't LETs.
(lets nil :type list)
+ ;; True if any of this lambdas variables are still in the process of
+ ;; having their optimistic types reach fixpoint.
+ (optimistic-pending nil :type boolean)
;; all the ENTRY nodes in this function and its LETs, or null in a LET
(entries nil :type list)
;; all the DYNAMIC-EXTENT nodes in this function and its LETs, or
@@ -1438,6 +1441,14 @@
(equality-constraints nil :type (or null (vector t)))
(equality-constraints-hash nil :type (or null hash-table))
(vector-length-constraint nil)
+ ;; The type we are assuming for this variable while doing local call
+ ;; argument type propagation. This is an under-approximation
+ ;; starting from the empty type which local call propagation
+ ;; steadily accumulates into until fixpoint and must not be used
+ ;; anywhere else during the process. Only once fixpoint is reached
+ ;; do we publish the type. Null if there is no need to do a fixpoint
+ ;; analysis.
+ (optimistic-type nil :type (or null ctype))
source-form)
(defprinter (lambda-var :identity t)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index bc48cd53d..e0f277d71 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -6252,3 +6252,114 @@
`(lambda ()
(let ((x (error "fail")))
x)))))
+
+;;; lp#486416: a local function's parameter types were computed by
+;;; unioning the argument types across its call sites, starting from T
+;;; and narrowing. That cannot converge once the argument flow has a
+;;; cycle in it: a call that hands a parameter back to itself
+;;; contributes the parameter's own current type, so the union comes
+;;; out (UNION <whatever> T) = T on every round and stays there. The
+;;; same loop therefore got two different answers depending on how it
+;;; was written,
+;;;
+;;; (do ((i n (1- i)) (x (list 1) x)) ((zerop i) x)) => CONS
+;;; (labels ((rec (i x) (if (zerop i) x (rec (1- i) x))))
+;;; (rec n (list 1))) => T
+;;;
+;;; because the DO loop assigns to X, and PROPAGATE-FROM-SETS derives
+;;; a variable's type from the values assigned to it, which do not
+;;; depend on the variable's own type. The equations are now also
+;;; solved from the other end of the lattice, upward from the empty
+;;; type, which converges on the cyclic case too.
+(with-test (:name (:local-call-arg-type :cycle))
+ (flet ((derived (form &rest args)
+ (apply (checked-compile form) args)))
+ ;; The parameter is handed straight back to itself.
+ (assert (eq 'cons
+ (derived '(lambda (n)
+ (labels ((rec (i x)
+ (if (zerop i)
+ (ctu:compiler-derived-type x)
+ (rec (1- i) x))))
+ (rec n (list 1))))
+ 0)))
+ ;; The cycle runs through a second function, so it is not enough to
+ ;; ignore arguments that reference the callee's own parameters.
+ (assert (eq 'cons
+ (derived '(lambda (n)
+ (labels ((a (i x)
+ (if (zerop i)
+ (ctu:compiler-derived-type x)
+ (b (1- i) x)))
+ (b (i x) (a (1- i) x)))
+ (a n (list 1))))
+ 0)))
+ ;; Two entering edges of different types: the answer is the union
+ ;; of them, not either one on its own.
+ (assert (eq 'list
+ (derived '(lambda (n p)
+ (labels ((rec (i x)
+ (if (zerop i)
+ (ctu:compiler-derived-type x)
+ (rec (1- i) x))))
+ (if p (rec n (list 1)) (rec n nil))))
+ 0 t)))
+ ;; The back edge carries a type no entering edge does, and it
+ ;; reaches the parameter through an argument that merges it with a
+ ;; reference to the parameter itself.
+ (assert (eq 'list
+ (derived '(lambda (n p)
+ (labels ((rec (i x)
+ (if (zerop i)
+ (ctu:compiler-derived-type x)
+ (rec (1- i) (if p x nil)))))
+ (rec n (list 1))))
+ 0 nil)))
+ ;; FIXME: In an ideal world, we would derive UNSIGNED-BYTE here
+ ;; like the corresponding imperative loop would.
+ (assert (eq 'number
+ (derived '(lambda (k)
+ (labels ((rec (i n)
+ (if (zerop i)
+ (ctu:compiler-derived-type n)
+ (rec (1- i) (1+ n)))))
+ (rec k 0)))
+ 0)))))
+
+;;; Check that a local function's return type depending on optimistic
+;;; type propagation derives to a tight result as well.
+(with-test (:name (:local-call-arg-type :return-type))
+ (flet ((result-type (form)
+ (let ((type (sb-kernel:%simple-fun-type (checked-compile form))))
+ (second (third type)))))
+ (assert (eq 'cons (result-type '(lambda (p)
+ (labels ((rec (x) (if p (rec x) x)))
+ (rec (list 1)))))))
+ (assert (eq 'cons (result-type '(lambda (n)
+ (labels ((rec (i x)
+ (if (zerop i) x (rec (1- i) x))))
+ (rec n (list 1)))))))
+ (assert (eq 'cons (result-type '(lambda (n)
+ (labels ((a (i x)
+ (if (zerop i) x (b (1- i) x)))
+ (b (i x) (a (1- i) x)))
+ (a n (list 1)))))))
+ ;; The value comes back through a non-tail call, so the result is
+ ;; not simply the parameter's type.
+ (assert (eq 'cons (result-type '(lambda (p)
+ (labels ((rec (x) (if p (list (rec x)) x)))
+ (rec (list 1)))))))))
+
+;;; The note lp#486416 was reported for: FN is declared FUNCTION at the
+;;; outer call, but the declaration did not survive the trip around the
+;;; recursion, so the FUNCALL was compiled as a full call through
+;;; FDEFINITION.
+(with-test (:name (:local-call-arg-type :lp486416))
+ (checked-compile '(lambda (x fn)
+ (declare (optimize speed) (type function fn) (type fixnum x))
+ (labels ((recurse (x fn)
+ (if (zerop x)
+ (funcall fn x)
+ (recurse (the fixnum (1- x)) fn))))
+ (recurse x fn)))
+ :allow-notes nil))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL