devirtualize protocol dispatch on known record receivers (jolt-41m)

A protocol method call compiles to (protocol-dispatch proto method this rest) — a
runtime registry walk (type-tag -> proto -> method) on every call, ~19x a direct
call. When the inference proves the receiver (arg 0) is a known record type, the
call now resolves to a DIRECT method call at compile time, skipping the registry.

- defprotocol registers each method's var-key 'ns/method' -> [proto method] (a
  ctx-capturing register-protocol-methods! emitted into the do-block); infer-unit!
  feeds it to the inference via a box (like record-shapes).
- the record-ctor return type carries :type (the record tag) so the inference
  knows the receiver type; the :else invoke case annotates a protocol call whose
  arg0 has a known :type with :devirt-{type,proto,method}.
- emit-invoke resolves the impl via find-protocol-method at emit time and emits a
  direct call to the embedded impl fn value. Unknown/polymorphic receivers (no
  proven :type) fall back to the dispatch path unchanged.

Measured: removes the dispatch overhead (14.7s -> 9.3s on a 10M-call loop); the
remaining cost is the method body itself (non-inlined, unproven reads) — inlining
the resolved method is the follow-up (jolt-t6r) toward direct-call speed.

Sound under the closed-world assumption direct-linking already makes (the impl is
resolved + embedded at compile time). Adds devirt-test (subprocess: dispatched ==
devirtualized across polymorphic dispatch, unknown-receiver fallback, and
heterogeneous collections). Stalin's compile-call/callee-environment is the model.

jolt-core/clojure/core/30-macros.clj

@@ -318,6 +318,9 @@
                         {} sigs)]
     `(do
        (def ~pname (make-protocol ~(name pname) ~methods))
+       ;; register method var-keys for devirtualization (jolt-41m); the inference
+       ;; reads this (via infer-unit!) to resolve a protocol call on a known record
+       (register-protocol-methods! ~(name pname) [~@(map (fn [s] (name (first s))) sigs)])
        ~@(map (fn [sig]
                 `(def ~(first sig)
                    ;; protocol-dispatch is a fn (clojure.core); pass the protocol /

jolt-core/jolt/passes.clj

@@ -881,6 +881,9 @@
 ;; struct of this shape, so field reads on the result bare-index — declared
 ;; shapes are clean fuel: a lookup, not fragile inference.
 (def ^:private record-shapes-box (atom {}))
+;; jolt-41m: protocol-method registry "ns/method" -> [proto method], for
+;; devirtualizing a protocol call whose receiver is a known record type.
+(def ^:private protocol-methods-box (atom {}))
 ;; jolt-t34: whether to shape generic const-key MAP literals (opt-in, JOLT_SHAPE).
 ;; Records are shaped regardless; maps only when this is on.
 (def ^:private map-shapes-box (atom false))
@@ -909,9 +912,11 @@
       (= op :var) (let [rs (get @record-shapes-box (var-key fnode))]
                     (if rs
                       ;; record ctor -> struct of declared shape (jolt-t34); :shape
-                      ;; is the DECLARED field order, which the back end indexes by
+                      ;; is the DECLARED field order the back end indexes by, and
-                      (assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} rs))
+                      ;; :type is the record tag (for devirtualizing protocol calls)
-                             :shape (vec rs))
+                      (let [fields (get rs :fields)]
+                        (assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} fields))
+                               :shape (vec fields) :type (get rs :type)))
                       (let [r (get @rtenv-box (var-key fnode))]
                         (if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))]
                                   (cond (nil? nm) :any
@@ -1116,13 +1121,23 @@
                 (when (and @strict-box iscall-var)
                   (let [k (var-key fnode) usig (get @user-sig-box k)]
                     (when usig (check-user-call k usig ats pos))))))
-            [(cond
+            ;; devirtualization (jolt-41m): a protocol-method call whose receiver
-               (= cn "range") (mk-vec :num)
+            ;; (arg 0) is a known record type resolves to a direct method call.
-               ;; element-returning fn over a typed vector -> the element type
+            ;; Annotate the node with [type-tag proto method]; the back end looks
-               (and cn (contains? elem-fns cn) (> n 0))
+            ;; up the impl at emit time and calls it directly, skipping the
-               (let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any))
+            ;; registry dispatch (~19x cheaper than protocol-dispatch).
-               :else (call-ret-type fnode))
+            (let [pm (and iscall-var (get @protocol-methods-box (var-key fnode)))
-             (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))])))
+                  rtype (when (and pm (pos? n)) (get (nth (nth ares 0) 0) :type))
+                  base (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))]
+              [(cond
+                 (= cn "range") (mk-vec :num)
+                 ;; element-returning fn over a typed vector -> the element type
+                 (and cn (contains? elem-fns cn) (> n 0))
+                 (let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any))
+                 :else (call-ret-type fnode))
+               (if rtype
+                 (assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
+                 base)]))))
       (= op :let)
       (let [res (reduce (fn [acc b]
                           (let [te (nth acc 0) binds (nth acc 1)
@@ -1330,6 +1345,7 @@
 ;; jolt-t34: install record-ctor shapes ("ns/->Name" -> [field-kw ...]) and the
 ;; map-shaping flag (opt-in JOLT_SHAPE), both read by infer.
 (defn set-record-shapes! [m] (reset! record-shapes-box (or m {})))
+(defn set-protocol-methods! [m] (reset! protocol-methods-box (or m {})))
 (defn set-map-shapes! [b] (reset! map-shapes-box (boolean b)))
 
 (defn set-vtypes!

src/jolt/backend.janet

@@ -417,7 +417,16 @@
   (def args (map |(emit ctx $) (vview (node :args))))
   (def nop (native-op fnode (length args)))
   (def argnodes (vview (node :args)))
+  # devirtualization (jolt-41m): the inference proved this is a protocol call on a
+  # known record type. Resolve the method impl at COMPILE time and emit a direct
+  # call to it, skipping the runtime protocol-dispatch registry walk. The impl is
+  # embedded as a constant fn value in the call head.
+  (def dvt (node :devirt-type))
+  (def devirt-impl
+    (when dvt (find-protocol-method ctx dvt (node :devirt-proto) (node :devirt-method))))
   (cond
+    devirt-impl (tuple devirt-impl ;args)
+
     nop (case nop
           '++ ['+ (in args 0) 1]
           '-- ['- (in args 0) 1]
@@ -952,6 +961,7 @@
   (def f-reset-esc (and pns (ns-find pns "reset-escapes!")))
   (def f-set-rshapes (and pns (ns-find pns "set-record-shapes!")))   # jolt-t34
   (def f-set-mshapes (and pns (ns-find pns "set-map-shapes!")))      # jolt-t34
+  (def f-set-pmethods (and pns (ns-find pns "set-protocol-methods!"))) # jolt-41m
   (def f-get-esc (and pns (ns-find pns "collected-escapes")))
   (def report @{})
   (when (and f-set-rtenv f-set-vtypes f-join f-infer-body f-reinfer f-reset-esc f-get-esc)
@@ -989,6 +999,8 @@
       # jolt-t34: feed record-ctor shapes + the map-shaping flag to the inference
       (when f-set-rshapes ((var-get f-set-rshapes) (or (get (ctx :env) :record-shapes) @{})))
       (when f-set-mshapes ((var-get f-set-mshapes) (get (ctx :env) :map-shapes?)))
+      # jolt-41m: feed the protocol-method registry for devirtualization
+      (when f-set-pmethods ((var-get f-set-pmethods) (or (get (ctx :env) :protocol-methods) @{})))
       # --- param/return/value-type fixpoint (chaotic iteration to LEAST fixpoint) ---
       # Param types are RECOMPUTED FRESH each iteration, not accumulated: :any is
       # the lattice top, so a join with an early-iteration :any (a caller whose own

src/jolt/evaluator.janet

@@ -1381,7 +1381,8 @@
   # the IR names the call head. Harmless when records aren't shaped (sidx gated).
   (let [rs (or (get (ctx :env) :record-shapes)
                (let [t @{}] (put (ctx :env) :record-shapes t) t))]
-    (put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name)) (tuple ;kws)))
+    (put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name))
+         {:fields (tuple ;kws) :type type-tag}))
   # Records are shape-recs when shapes are active (:shapes? = direct-link, where
   # the inference proves the reads) — the whole field-access pipeline handles
   # them; otherwise the original :jolt/deftype tables. Read at ctor-BUILD time so
@@ -1409,6 +1410,16 @@
   (ns-intern core "protocol-dispatch"
     (fn [proto-name method-name obj rest-args]
       (protocol-dispatch-impl ctx proto-name method-name obj rest-args)))
+  # Devirtualization registry (jolt-41m): defprotocol calls this at load so the
+  # inference can recognize a protocol-method call site. Maps the method's
+  # var-key "ns/method" -> [proto-name method-name].
+  (ns-intern core "register-protocol-methods!"
+    (fn [proto-name method-names]
+      (def reg (or (get (ctx :env) :protocol-methods)
+                   (let [t @{}] (put (ctx :env) :protocol-methods t) t)))
+      (def ns (ctx-current-ns ctx))
+      (each m (d-realize method-names) (put reg (string ns "/" m) (tuple proto-name m)))
+      nil))
   (ns-intern core "extenders"
     (fn [proto]
       # All type-tags whose registry entry implements this protocol, as symbols

test/integration/devirt-test.janet

@@ -0,0 +1,41 @@
+# Protocol-dispatch devirtualization (jolt-41m): when the inference proves a
+# protocol call's receiver is a known record type, the call is compiled to a
+# DIRECT method call, skipping the runtime dispatch registry. This must stay
+# SOUND — same results as the dispatched path — including polymorphic dispatch
+# (the right method per type), fallback when the receiver type is unknown, and
+# heterogeneous collections. Runs a protocol+record program through the built
+# binary (devirt needs infer-unit!, which runs on ns load, not eval-string) and
+# checks the output. Skips cleanly if build/jolt is absent.
+(def jolt "build/jolt")
+
+(defn- run [whole?]
+  (def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dv-test"))
+  (os/mkdir dir)
+  (spit (string dir "/dv.clj")
+        (string
+         "(ns dv)\n"
+         "(defprotocol Shape (area [s]) (kind [s]))\n"
+         "(defrecord Rect [w h] Shape (area [r] (* (:w r) (:h r))) (kind [_] :rect))\n"
+         "(defrecord Circ [r] Shape (area [c] (* 3 (:r c) (:r c))) (kind [_] :circ))\n"
+         "(defn poly [s] (area s))\n"  # receiver unknown -> must fall back
+         "(defn -main []\n"
+         "  (println (area (->Rect 3 4)) (area (->Circ 5))\n"            # devirt: 12 75
+         "           (kind (->Rect 1 1)) (kind (->Circ 1))\n"           # devirt: :rect :circ
+         "           (poly (->Rect 3 4)) (poly (->Circ 5))\n"           # fallback: 12 75
+         "           (mapv area [(->Rect 2 3) (->Circ 2)])))\n"))       # heterogeneous: [6 12]
+  (def out (string dir "/out.txt"))
+  (def jbin (string (os/cwd) "/" jolt))
+  (def cmd (string (if whole? "JOLT_WHOLE_PROGRAM=1 " "")
+                   "JOLT_DIRECT_LINK=1 JOLT_PATH=" dir " " jbin " -m dv > " out " 2>&1"))
+  (os/execute ["sh" "-c" cmd] :p)
+  (string/trimr (slurp out)))
+
+(def expected "12 75 :rect :circ 12 75 [6 12]")
+(if (not (os/stat jolt))
+  (print "devirt: SKIP (no build/jolt — run from source)")
+  (let [per-ns (run false) whole (run true)]
+    (printf "  per-ns:        %s" per-ns)
+    (printf "  whole-program: %s" whole)
+    (if (and (= per-ns expected) (= whole expected))
+      (print "devirt: correct (dispatched == devirtualized)")
+      (do (printf "devirt: WRONG — expected %q" expected) (os/exit 1)))))