Whole-program param-type inference (closed world) (#226)

Re-derive each app fn's param types from its call sites under --opt, so a
record type flows across fn boundaries: a ctor's return reaches a callee
param, and a typed vector's element reaches a HOF closure's param. The back
end can then bare-index field reads and devirtualize protocol calls at those
sites (it reads the resulting :hint/:devirt annotations; consuming them is
separate work).

This rebuilds the inter-procedural driver the Janet host had — the API
(infer-body/reinfer-def) survived the rehost but nothing drove it, and the
record-shapes/protocol-methods registries were empty stubs.

- records.ss: populate record-shapes (ctor key -> fields/tags/type, resolving
  nested record field tags) and protocol-methods (method var -> [proto method])
  registries at deftype/defprotocol load time; jolt.host accessors materialize
  them.
- passes/types.clj: wp-infer! runs a closed-world fixpoint joining call-site
  arg types into callee params; reinfer-def re-seeds each def at emit. Self-
  recursive calls and fn-level recur are collected so a recursive fn's params
  are constrained by its recursion, not just external callers — else a param
  the recursion widens (e.g. binary-trees check-tree, whose untagged child can
  be nil) would be unsoundly typed non-nil. A fn used in value position keeps
  :any params (callers unknown). Megamorphic sites join to :any.
- build.ss: analyze all app forms and run the fixpoint before per-form emit.
- run-wp.ss: gate (cross-fn propagation, escape soundness, self-recursion).

make test / shakesmoke green, 0 new divergences, selfhost holds.

Co-authored-by: Yogthos <yogthos@gmail.com>

Makefile

@@ -4,7 +4,7 @@
 # build step. `make test` is the full gate. `make remint` rebuilds the seed after a
 # source change.
 
-.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer directlink numeric inline shakesmoke remint
+.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp directlink numeric inline shakesmoke remint
 
 # Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
 # on the same Chez that minted the seed.
@@ -15,7 +15,7 @@ test: selfhost ci
 # lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
 # different Chez version may emit byte-different (gensym/order) output, so the
 # byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
-ci: values corpus unit smoke buildsmoke sci ffi transient infer directlink numeric inline certify
+ci: values corpus unit smoke buildsmoke sci ffi transient infer wp directlink numeric inline certify
 	@echo "OK: CI gates passed"
 
 # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@@ -61,6 +61,12 @@ transient:
 infer:
 	@chez --script host/chez/run-infer.ss
 
+# Whole-program param-type fixpoint: record types flowing across fn boundaries
+# (a callee's param picks up its callers' ctor return types), the foundation the
+# bare-index field reads + protocol devirtualization build on.
+wp:
+	@chez --script host/chez/run-wp.ss
+
 # Direct-linking emission: a closed-world build binds top-level app defs to jv$
 # Scheme bindings and routes app->app calls/refs to them, skipping var-deref +
 # jolt-invoke; ^:dynamic/^:redef and nested defs opt out.

host/chez/build.ss

@@ -170,6 +170,38 @@
 ;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
 (define (bld-emit-ns ns-name src) (ei-emit-ns* ns-name src #t #f))
 
+;; --- whole-program inference pre-pass ---------------------------------------
+;; Analyze every app form (all namespaces, deps-first) to IR and run the
+;; closed-world param-type fixpoint, so each fn's param types pick up the record
+;; types its callers pass. The per-ns emit below then bare-indexes field reads and
+;; devirtualizes protocol calls at those sites (the back end reads the resulting
+;; :hint/:devirt annotations). Optimized builds only; registries come from the
+;; runtime tables populated as the app loaded.
+(define jolt-wp-infer!             (var-deref "jolt.passes.types" "wp-infer!"))
+(define jolt-wp-set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
+(define jolt-wp-set-proto-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
+(define jolt-wp-host-record-shapes (var-deref "jolt.host" "record-shapes"))
+(define jolt-wp-host-proto-methods (var-deref "jolt.host" "protocol-methods"))
+
+(define (bld-wp-infer! ordered)
+  (jolt-wp-set-record-shapes! (jolt-wp-host-record-shapes #f))
+  (jolt-wp-set-proto-methods! (jolt-wp-host-proto-methods #f))
+  (let ((nodes '()))
+    (for-each
+      (lambda (nf)
+        (set-chez-ns! (car nf))
+        (let ((src (read-file-string (cdr nf))))
+          (parameterize ((rdr-source-file (cdr nf)))
+            (for-each
+              (lambda (f)
+                (ce-scan-requires! f (car nf))
+                (unless (or (ei-ns-form? f) (ce-macro-form? f))
+                  (guard (e (#t #f))
+                    (set! nodes (cons (jolt-ce-analyze (make-analyze-ctx (car nf)) f) nodes)))))
+              (ei-read-all src)))))
+      ordered)
+    (jolt-wp-infer! (apply jolt-vector (reverse nodes)))))
+
 ;; Strings emitted before each app ns's forms, replaying what the source loader
 ;; does per file: (1) set chez-current-ns so runtime ns-sensitive setup forms
 ;; (defmulti/defmethod resolve their target var through it) land in the right ns;
@@ -326,7 +358,9 @@
                 (set-optimize! (string=? mode "optimized"))
                 (when direct-link?
                   ((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
-                  ((var-deref "jolt.backend-scheme" "direct-link-reset!"))))
+                  ((var-deref "jolt.backend-scheme" "direct-link-reset!")))
+                ;; whole-program param-type fixpoint before per-form emit
+                (when (string=? mode "optimized") (bld-wp-infer! ordered)))
               (lambda ()
                 (if tree-shake?
                     (dce-shake

host/chez/host-contract.ss

@@ -363,7 +363,10 @@
   (hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
 (define (hc-record-type? ctx name) #f)
 (define (hc-record-ctor-key ctx name) jolt-nil)
-(define (hc-record-shapes ctx) (jolt-hash-map))
+;; record + protocol-method shapes for the inference, from the runtime registries
+;; (records.ss) populated as deftype/defprotocol forms load.
+(define (hc-record-shapes ctx) (chez-record-shapes-map))
+(define (hc-protocol-methods ctx) (chez-protocol-methods-map))
 ;; Optimization gate. Off for ordinary runs (open world, redefinition); `jolt
 ;; build` flips it on during app emission for release/optimized modes (closed
 ;; world), turning on the inference + flatten + scalar-replace passes.
@@ -432,6 +435,7 @@
   (def-var! "jolt.host" "record-type?" hc-record-type?)
   (def-var! "jolt.host" "record-ctor-key" hc-record-ctor-key)
   (def-var! "jolt.host" "record-shapes" hc-record-shapes)
+  (def-var! "jolt.host" "protocol-methods" hc-protocol-methods)
   (def-var! "jolt.host" "inline-enabled?" hc-inline-enabled?)
   (def-var! "jolt.host" "inline-ir" hc-inline-ir)
   (def-var! "jolt.host" "stash-inline!" hc-stash-inline!))

host/chez/records.ss

@@ -36,6 +36,71 @@
 ;; in the extension map is distinguished from a genuine miss).
 (define jrec-absent (list 'jrec-absent))
 
+;; --- whole-program inference registries -------------------------------------
+;; Populated at definition/load time (deftype/defrecord and defprotocol forms run
+;; before `jolt build` re-emits), read by the inference driver to seed record and
+;; protocol-method types across fn boundaries. A no-op for the runtime itself; the
+;; tables just accumulate. jolt.host/record-shapes and /protocol-methods (host-
+;; contract.ss) materialize them into the shape jolt.passes.types expects.
+
+;; ctor-key "ns/->Name" -> (vector field-kw-list field-tag-list type-tag).
+;; field-tag-list parallels the fields: "num", a record simple-name string, or #f.
+(define chez-record-shapes-tbl (make-hashtable string-hash string=?))
+;; method var-key "ns/method" -> (cons proto-name method-name).
+(define chez-protocol-methods-tbl (make-hashtable string-hash string=?))
+
+(define (register-record-shape! ctor-key field-kws field-tags type-tag)
+  (hashtable-set! chez-record-shapes-tbl ctor-key
+                  (vector field-kws field-tags type-tag)))
+
+;; simple name of a dotted/slashed string: the segment after the last . or /.
+(define (chez-shape-simple-name s)
+  (let loop ((i (- (string-length s) 1)))
+    (cond ((< i 0) s)
+          ((or (char=? (string-ref s i) #\.) (char=? (string-ref s i) #\/))
+           (substring s (+ i 1) (string-length s)))
+          (else (loop (- i 1))))))
+
+;; resolve a field's declared type tag to what jolt.passes.types wants: "num"
+;; passes through; a record name (simple "Vec3" or qualified "ns.Vec3") resolves
+;; to its ctor-key (so the field reads back as that record); anything else -> nil.
+(define (chez-resolve-field-tag tag by-name)
+  (cond ((or (not tag) (jolt-nil-t? tag)) jolt-nil)
+        ((string=? tag "num") "num")
+        (else (let ((ck (hashtable-ref by-name (chez-shape-simple-name tag) #f)))
+                (if ck ck jolt-nil)))))
+
+;; materialize chez-record-shapes-tbl into "ns/->Name" -> {:fields :tags :type},
+;; the shape record-type-from-entry consumes.
+(define (chez-record-shapes-map)
+  (let ((by-name (make-hashtable string-hash string=?))
+        (kw-fields (keyword #f "fields")) (kw-tags (keyword #f "tags")) (kw-type (keyword #f "type"))
+        (out (jolt-hash-map)))
+    ;; index simple record name (from the type tag "ns.Name") -> ctor-key for
+    ;; nested-field-tag resolution.
+    (let-values (((ks vs) (hashtable-entries chez-record-shapes-tbl)))
+      (vector-for-each
+        (lambda (k v) (hashtable-set! by-name (chez-shape-simple-name (vector-ref v 2)) k)) ks vs)
+      (vector-for-each
+        (lambda (k v)
+          (let* ((fields (vector-ref v 0)) (tags (vector-ref v 1)) (type-tag (vector-ref v 2))
+                 (rtags (map (lambda (t) (chez-resolve-field-tag t by-name)) tags)))
+            (set! out (jolt-assoc out k
+                                  (jolt-hash-map kw-fields (apply jolt-vector fields)
+                                                 kw-tags   (apply jolt-vector rtags)
+                                                 kw-type   type-tag)))))
+        ks vs))
+    out))
+
+;; materialize chez-protocol-methods-tbl into "ns/method" -> [proto method].
+(define (chez-protocol-methods-map)
+  (let ((out (jolt-hash-map)))
+    (let-values (((ks vs) (hashtable-entries chez-protocol-methods-tbl)))
+      (vector-for-each
+        (lambda (k v) (set! out (jolt-assoc out k (jolt-vector (car v) (cdr v)))))
+        ks vs))
+    out))
+
 ;; index of a declared field key, or #f (only an interned keyword can be one).
 (define (jrec-field-index r k) (hashtable-ref (jrdesc-index (jrec-desc r)) k #f))
 ;; a vector-copy that doesn't depend on the optional rnrs vector-copy being present.
@@ -351,9 +416,10 @@
 ;; ---- the native that handles the analyzer/overlay call ----------------------
 ;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure.
 ;; The tag is baked at definition time in the type's ns (chez-current-ns).
-(define (make-deftype-ctor name-sym field-kws . _ignored)
+(define (make-deftype-ctor name-sym field-kws . rest-args)
   (let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
          (kws (seq->list field-kws))
+         (field-tags (if (pair? rest-args) (seq->list (car rest-args)) '()))
          (desc (make-jrdesc tag kws))
          (nf (length kws))
          (ctor (lambda args
@@ -368,6 +434,10 @@
     ;; even when the runtime current ns is the caller's, not the defining ns
     ;; (host-new checks class-ctors-tbl before the current-ns var fallback).
     (register-class-ctor! (symbol-t-name name-sym) ctor)
+    ;; record the shape for whole-program inference, keyed by the positional
+    ;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
+    (register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
+                            kws field-tags tag)
     ctor))
 
 ;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
@@ -376,10 +446,18 @@
                  (keyword #f "name") (jolt-symbol jolt-nil name-str)
                  (keyword #f "methods") methods))
 
-;; register-protocol-methods!: intentional no-op. Chez dispatches a protocol method
+;; register-protocol-methods!: record each method's var-key -> [proto method] for
-;; by the receiver's type tag at call time, so there is no method table to register;
+;; the inference driver (devirtualization). Dispatch itself is by the receiver's
-;; this binding exists only because defprotocol-emitted code calls it.
+;; type tag at call time, so this table is read only by `jolt build` inference.
-(define (register-protocol-methods! proto-name method-names) jolt-nil)
+;; Called by defprotocol-emitted code in the protocol's ns.
+(define (register-protocol-methods! proto-name method-names)
+  (let ((ns (chez-current-ns)))
+    (for-each (lambda (mn)
+                (let ((m (if (symbol-t? mn) (symbol-t-name mn) mn)))
+                  (hashtable-set! chez-protocol-methods-tbl
+                                  (string-append ns "/" m) (cons proto-name m))))
+              (seq->list method-names)))
+  jolt-nil)
 
 ;; register-method: extend-type/extend register an impl. Host type names keep a
 ;; bare canonical tag; record names qualify to the current ns.

host/chez/run-wp.ss

@@ -0,0 +1,96 @@
+;; run-wp.ss — whole-program param-type fixpoint gate (jolt.passes.types/wp-infer!).
+;;
+;; run-infer.ss drives the per-form inference; this drives the inter-procedural
+;; driver: analyze a multi-def unit, run wp-infer!, and assert that a record type
+;; flows across fn boundaries — a callee's param picks up its caller's ctor return
+;; type, so a field read off it is marked for the bare-index back-end path.
+;;
+;;   chez --script host/chez/run-wp.ss
+(import (chezscheme))
+(load "host/chez/rt.ss")
+(set-chez-ns! "clojure.core")
+(load "host/chez/seed/prelude.ss")
+(load "host/chez/post-prelude.ss")
+(set-chez-ns! "user")
+(load "host/chez/host-contract.ss")
+(load "host/chez/seed/image.ss")
+(load "host/chez/compile-eval.ss")
+
+(define analyze            (var-deref "jolt.analyzer" "analyze"))
+(define run-inference      (var-deref "jolt.passes.types" "run-inference"))
+(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
+(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
+(define wp-infer!          (var-deref "jolt.passes.types" "wp-infer!"))
+(define param-seeds-for    (var-deref "jolt.passes.types" "param-seeds-for"))
+(define reinfer-def        (var-deref "jolt.passes.types" "reinfer-def"))
+(define pr-str             (var-deref "clojure.core" "pr-str"))
+
+(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
+(define (contains-sub? s sub)
+  (let ((n (string-length s)) (m (string-length sub)))
+    (let loop ((i 0))
+      (cond ((> (+ i m) n) #f)
+            ((string=? (substring s i (+ i m)) sub) #t)
+            (else (loop (+ i 1)))))))
+
+(define fails 0) (define total 0)
+(define (check label actual expected)
+  (set! total (+ total 1))
+  (unless (equal? actual expected)
+    (set! fails (+ fails 1))
+    (printf "  FAIL ~a: got ~s expected ~s\n" label actual expected)))
+
+;; Node record shape (left/right untagged), like binary-trees.
+(set-record-shapes!
+  (jolt-hash-map "user/->Node"
+                 (jolt-hash-map (keyword #f "fields") (jolt-vector (keyword #f "left") (keyword #f "right"))
+                                (keyword #f "tags")   (jolt-vector jolt-nil jolt-nil)
+                                (keyword #f "type")   "user.Node")))
+(set-protocol-methods! (jolt-hash-map))
+
+;; a 3-def unit: make-tree returns ->Node, run calls check-tree with a make-tree
+;; result, so check-tree's `node` param must be inferred as a Node.
+(define mt (anode "(def make-tree (fn [depth] (if (zero? depth) (->Node nil nil) (->Node (make-tree (dec depth)) (make-tree (dec depth))))))"))
+(define ct (anode "(def check-tree (fn [node] (:left node)))"))
+(define rn (anode "(def run (fn [d] (check-tree (make-tree d))))"))
+
+(wp-infer! (jolt-vector mt ct rn))
+
+;; check-tree's param `node` should be seeded with a struct carrying the Node type
+(define seed (param-seeds-for "user/check-tree"))
+(check "check-tree has a param seed" (jolt-truthy? seed) #t)
+(when (jolt-truthy? seed)
+  (check "node seeded as user.Node struct"
+         (contains-sub? (pr-str seed) "user.Node") #t))
+
+;; reinfer-def then must mark the (:left node) read site for the bare-index path
+(define marked (reinfer-def ct seed))
+(check "read site marked :hint :struct" (contains-sub? (pr-str marked) ":hint :struct") #t)
+
+;; a fn used only via value position (escape) must NOT be specialized — unknown
+;; callers make a concrete seed unsound.
+(define ev (anode "(def use-it (fn [f] (f 1)))"))
+(define ec (anode "(def caller (fn [] (use-it check-tree)))"))  ; check-tree escapes
+(wp-infer! (jolt-vector mt ct rn ev ec))
+(check "escaped fn keeps no param seed" (jolt-truthy? (param-seeds-for "user/check-tree")) #f)
+
+;; a self-recursive fn that recurses on a NILABLE field (an untagged record field
+;; is :any, so the child can be nil) must NOT be specialized — the recursion can
+;; pass nil, so typing the param as a non-nil record would be unsound.
+(define ctr (anode "(def walk (fn [node] (let [l (:left node)] (if (nil? l) 1 (walk l)))))"))
+(define rnr (anode "(def run2 (fn [d] (walk (make-tree d))))"))
+(wp-infer! (jolt-vector mt ctr rnr))
+(check "self-recursive nilable param not specialized"
+       (jolt-truthy? (param-seeds-for "user/walk")) #f)
+
+;; a self-recursive fn that recurses passing the SAME record type (make-tree always
+;; returns a Node) is still safe to specialize — the recursion preserves the type.
+(define mtt (anode "(def grow (fn [n acc] (if (zero? n) acc (grow (dec n) (->Node acc acc)))))"))
+(define gcl (anode "(def gcaller (fn [] (grow 5 (->Node nil nil))))"))
+(wp-infer! (jolt-vector mtt gcl))
+(check "self-recursive same-type param keeps its seed"
+       (jolt-truthy? (param-seeds-for "user/grow")) #t)
+
+(if (= fails 0)
+    (begin (printf "wp gate: ~a/~a passed\n" total total) (exit 0))
+    (begin (printf "wp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

jolt-core/jolt/passes.clj

@@ -13,7 +13,7 @@
   :refer, so jolt.passes stays the only namespace the back end imports.
 
   Portable Clojure: kernel-tier fns + seed primitives only."
-  (:require [jolt.host :refer [inline-enabled? record-shapes stash-inline!]]
+  (:require [jolt.host :refer [inline-enabled? record-shapes protocol-methods stash-inline!]]
             [jolt.passes.fold :refer [const-fold]]
             [jolt.passes.numeric :as numeric]
             [jolt.passes.inline :refer [inline-node flatten-lets scalar-replace dirty set-rec-shapes!]]
@@ -22,6 +22,7 @@
                                        set-rtenv! set-vtypes! join-types
                                        set-record-shapes! set-map-shapes! set-protocol-methods!
                                        reset-escapes! collected-escapes
+                                       wp-infer! param-seeds-for
                                        set-check-mode! take-diags!]]))
 
 ;; Cap on inline -> flatten -> scalar-replace -> const-fold iterations. Each pass
@@ -62,13 +63,18 @@
             ;; `this`) to bare field reads per-form, not only under whole-program.
             ;; Same shapes the inline pass uses.
             _ (set-record-shapes! (record-shapes ctx))
+            _ (set-protocol-methods! (protocol-methods ctx))  ;; devirtualization
             opt (loop [i 0 n (const-fold node)]
                   (reset! dirty false)
                   (let [n2 (const-fold (scalar-replace (flatten-lets (inline-node n ctx))))]
                     (if (and @dirty (< i inline-fixpoint-cap))
                       (recur (inc i) n2)
-                      n2)))]
+                      n2)))
+            ;; a top-level def whose params the whole-program fixpoint typed gets
+            ;; reinferred with those seeds (record types flow in from its callers);
+            ;; everything else takes the ordinary per-form inference.
+            seeds (when (= :def (:op opt)) (param-seeds-for (str (:ns opt) "/" (:name opt))))]
         ;; a final const-fold after inference propagates any predicate folded to a
         ;; constant, collapsing the `if` it gates to the taken branch.
-        (const-fold (run-inference opt)))
+        (const-fold (if seeds (reinfer-def opt seeds) (run-inference opt))))
       (const-fold node))))

jolt-core/jolt/passes/types.clj

@@ -283,6 +283,14 @@
         ares (mapv (fn [a] (infer a tenv env)) args)]
     (when iscall-var
       (swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (ty r)) ares)]))
+    ;; a named fn calling itself binds its name as a :local, so the recursion is
+    ;; invisible to the var-call collection above — yet it constrains the fn's own
+    ;; params. Collect it under the fn's var-key so the whole-program fixpoint joins
+    ;; the recursive arg types (else a self-recursive param is typed from external
+    ;; callers alone and may be specialized to a type the recursion violates).
+    (when (and (= :local (get fnode :op)) (get env :self-key)
+               (= (get fnode :name) (get env :self-name)))
+      (swap! (get env :calls) conj [(get env :self-key) (mapv (fn [r] (ty r)) ares)]))
     ;; success-type check at this call, reusing the arg types just computed (jolt
     ;; audit): core error domains always, user-fn domains in strict mode.
     (when (get env :checking?)
@@ -419,12 +427,19 @@
       (= op :loop)
       ;; conservative + sound: loop bindings join across recur, which we don't
       ;; track here, so they stay :any. Still descend to annotate any
-      ;; known-type lookups inside the body.
+      ;; known-type lookups inside the body. A recur inside this body targets the
-      [:any (assoc node
+      ;; loop, not the enclosing fn, so mark :in-loop? to suppress self-collection.
-                   :bindings (mapv (fn [b] [(nth b 0) (nth (infer (nth b 1) tenv env) 1)]) (get node :bindings))
+      (let [lenv (assoc env :in-loop? true)]
-                   :body (nth (infer (get node :body) tenv env) 1))]
+        [:any (assoc node
+                     :bindings (mapv (fn [b] [(nth b 0) (nth (infer (nth b 1) tenv env) 1)]) (get node :bindings))
+                     :body (nth (infer (get node :body) tenv lenv) 1))])
       (= op :recur)
-      [:any (assoc node :args (mapv (fn [a] (nth (infer a tenv env) 1)) (get node :args)))]
+      (let [ares (mapv (fn [a] (infer a tenv env)) (get node :args))]
+        ;; a fn-level recur (not inside a loop) rebinds the enclosing fn's params,
+        ;; so its args constrain them like a self-call — collect under the fn key.
+        (when (and (not (get env :in-loop?)) (get env :self-key))
+          (swap! (get env :calls) conj [(get env :self-key) (mapv (fn [r] (ty r)) ares)]))
+        [:any (assoc node :args (mapv (fn [r] (nd r)) ares))])
       (= op :fn)
       ;; a closure inherits the enclosing tenv so CAPTURED locals keep their
       ;; types (e.g. a reduce closure that calls (f captured-struct ...)). Its own
@@ -433,19 +448,23 @@
       ;; reads off it bare-index per-form, not only under whole-program. This is
       ;; what makes a protocol method's `this` (hinted by defrecord/extend-type)
       ;; read its fields without the runtime tag guard.
-      [:any (assoc node :arities
+      ;; a nested closure resets the self/loop context: its own recur/self-call
-                   (mapv (fn [a]
+      ;; targets IT, not the enclosing whole-program def, so it must not collect
-                           (let [shapes (get env :record-shapes)
+      ;; into that def's param key.
-                                 phm (reduce (fn [m pr] (assoc m (nth pr 0) (nth pr 1)))
+      (let [fenv (assoc env :self-name nil :self-key nil :in-loop? false)]
-                                             {} (get a :phints))
+        [:any (assoc node :arities
-                                 pe (reduce (fn [e p]
+                     (mapv (fn [a]
-                                              (assoc e p
+                             (let [shapes (get env :record-shapes)
-                                                     (let [ent (get shapes (get phm p))]
+                                   phm (reduce (fn [m pr] (assoc m (nth pr 0) (nth pr 1)))
-                                                       (if ent (record-type-from-entry ent type-depth shapes) :any))))
+                                               {} (get a :phints))
-                                            tenv (get a :params))
+                                   pe (reduce (fn [e p]
-                                 pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)]
+                                                (assoc e p
-                             (assoc a :body (nth (infer (get a :body) pe env) 1))))
+                                                       (let [ent (get shapes (get phm p))]
-                         (get node :arities)))]
+                                                         (if ent (record-type-from-entry ent type-depth shapes) :any))))
+                                              tenv (get a :params))
+                                   pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)]
+                               (assoc a :body (nth (infer (get a :body) pe fenv) 1))))
+                           (get node :arities)))])
       (= op :def)
       (do (when (get env :checking?) (register-user-fn! node env))
           [:any (assoc node :init (nth (infer (get node :init) tenv env) 1))])
@@ -585,11 +604,14 @@
   "Type `body` under tenv (local-name -> type). Returns [ret-type node' calls],
   where calls is the [[\"ns/name\" [arg-types...]] ...] this body invokes (for
   propagating into callee param types). Also accumulates escapes (read with
-  collected-escapes after a full sweep)."
+  collected-escapes after a full sweep). With self-name/self-key, a recursive
-  [body tenv]
+  self-call or fn-level recur in `body` is collected under self-key too, so a
-  (let [env (mk-env false false)
+  self-recursive fn's params are constrained by its recursion, not just callers."
-        r (infer body tenv env)]
+  ([body tenv] (infer-body body tenv nil nil))
-    [(nth r 0) (nth r 1) @(get env :calls)]))
+  ([body tenv self-name self-key]
+   (let [env (assoc (mk-env false false) :self-name self-name :self-key self-key)
+         r (infer body tenv env)]
+     [(nth r 0) (nth r 1) @(get env :calls)])))
 
 (defn reinfer-def
   "Re-run inference on a stashed :def's fn arity bodies with param types seeded
@@ -639,6 +661,98 @@
               (when e (record-type-from-entry e type-depth shapes))))
           params)))
 
+;; --- whole-program param-type fixpoint --------------------------------------
+;; Re-derive each app fn's param types from its call sites under closed world
+;; (--opt), so a record type flows across fn boundaries: a ctor's return type
+;; reaches a callee param ((check-tree (make-tree d)) -> node is a Node), and a
+;; typed vector's element reaches a HOF closure's param (sum-area's reduce sees a
+;; Circle). The back end then bare-indexes a field read and devirtualizes a
+;; protocol call at those sites. Only single-fixed-arity fns are specialized;
+;; anything called in value position (collected-escapes) keeps :any params —
+;; its callers aren't all visible, so a concrete seed would be unsound.
+(def ^:private wp-seeds-box (atom {}))
+(defn param-seeds-for
+  "The param-name -> type seed map a top-level def should be reinferred with, or
+  nil. Set by wp-infer!, read by run-passes during the final per-def emit."
+  [k] (get @wp-seeds-box k))
+
+;; var-key -> {:params [names] :body ir} for each single-fixed-arity fn def.
+(defn- wp-specializable [nodes]
+  (reduce (fn [m d]
+            (let [f (get d :init)]
+              (if (and (= :def (get d :op)) (= :fn (get f :op))
+                       (= 1 (count (get f :arities)))
+                       (not (get (first (get f :arities)) :rest)))
+                (let [a (first (get f :arities))]
+                  (assoc m (str (get d :ns) "/" (get d :name))
+                         {:name (get d :name) :params (get a :params) :body (get a :body)}))
+                m)))
+          {} nodes))
+
+(defn- wp-empty-ptypes [spec ks]
+  (reduce (fn [m k] (assoc m k (vec (repeat (count (:params (get spec k))) nil)))) {} ks))
+
+;; join one call's arg types into its (specializable) callee's param slots.
+(defn- wp-accum [pt spec calls]
+  (reduce (fn [pt2 c]
+            (let [callee (nth c 0) args (nth c 1)]
+              (if (contains? spec callee)
+                (let [cur (get pt2 callee)]
+                  (assoc pt2 callee
+                         (vec (map-indexed
+                                (fn [i t] (if (< i (count args)) (join t (nth args i)) t)) cur))))
+                pt2)))
+          pt calls))
+
+;; one fixpoint pass over every top-level node: a specializable def is typed
+;; under the current param seeds (so a seeded record flows into the calls it
+;; makes) and contributes its return type; any other form is typed only to
+;; harvest its call sites and escapes. Returns {:rets :ptypes}, with ptypes
+;; recomputed fresh each pass — :any is absorbing, so accumulating across passes
+;; would pin a param at :any before its callers' return types are known.
+(defn- wp-pass [nodes spec ks ptypes]
+  (reduce
+    (fn [acc node]
+      (let [k (when (= :def (get node :op)) (str (get node :ns) "/" (get node :name)))
+            s (and k (get spec k))]
+        (if s
+          (let [r (infer-body (:body s) (zipmap (:params s) (get ptypes k)) (:name s) k)]
+            (-> acc (assoc-in [:rets k] (nth r 0))
+                    (update :ptypes wp-accum spec (nth r 2))))
+          (update acc :ptypes wp-accum spec (nth (infer-body node {}) 2)))))
+    {:rets {} :ptypes (wp-empty-ptypes spec ks)} nodes))
+
+(defn wp-infer!
+  "Run the closed-world param-type fixpoint over the unit's analyzed top-level
+  nodes and stash the resulting per-def seed maps (read via param-seeds-for).
+  record-shapes / protocol-methods must already be installed. Idempotent — resets
+  the seed box; called once per build before per-form emit."
+  [nodes]
+  (let [spec (wp-specializable nodes)
+        ks (keys spec)]
+    (loop [iter 0 ptypes (wp-empty-ptypes spec ks) rets {}]
+      (set-rtenv! (reduce (fn [m k] (let [v (get rets k)] (if (some? v) (assoc m k v) m))) {} ks))
+      (reset-escapes!)
+      (let [pass (wp-pass nodes spec ks ptypes)
+            escaped (set (collected-escapes))
+            ;; a fn used in value position has callers we can't see -> :any params
+            new-ptypes (reduce (fn [m k]
+                                 (if (contains? escaped k)
+                                   (assoc m k (vec (repeat (count (get m k)) :any))) m))
+                               (:ptypes pass) ks)
+            new-rets (:rets pass)]
+        (if (or (and (= new-ptypes ptypes) (= new-rets rets)) (>= iter 16))
+          (reset! wp-seeds-box
+                  (reduce (fn [m k]
+                            (let [s (get spec k)
+                                  ptmap (reduce (fn [pm pr]
+                                                  (let [nm (nth pr 0) t (nth pr 1)]
+                                                    (if (and t (not= t :any)) (assoc pm nm t) pm)))
+                                                {} (map vector (:params s) (get new-ptypes k)))]
+                              (if (seq ptmap) (assoc m k ptmap) m)))
+                          {} ks))
+          (recur (inc iter) new-ptypes new-rets))))))
+
 ;; Piggyback checking (jolt audit). In direct-link mode infer-top already runs
 ;; one inference pass for specialization; turning checking? on during it makes
 ;; the success checker nearly free there (no extra traversal — just the