From fa02c8f93d02a277f3238469f776c21b8251baf2 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sun, 14 Jun 2026 03:33:48 -0400 Subject: [PATCH] devirtualize protocol dispatch on known record receivers (jolt-41m) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 | 3 ++ jolt-core/jolt/passes.clj | 36 +++++++++++++++++------- src/jolt/backend.janet | 12 ++++++++ src/jolt/evaluator.janet | 13 ++++++++- test/integration/devirt-test.janet | 41 ++++++++++++++++++++++++++++ 5 files changed, 94 insertions(+), 11 deletions(-) create mode 100644 test/integration/devirt-test.janet diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index a786c3b..dc54a97 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/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 / diff --git a/jolt-core/jolt/passes.clj b/jolt-core/jolt/passes.clj index 3793b3e..ad08082 100644 --- a/jolt-core/jolt/passes.clj +++ b/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 - (assoc (mk-struct (reduce (fn [m k] (assoc m k :any)) {} rs)) - :shape (vec rs)) + ;; is the DECLARED field order the back end indexes by, and + ;; :type is the record tag (for devirtualizing protocol calls) + (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 - (= 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)) - (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))]))) + ;; devirtualization (jolt-41m): a protocol-method call whose receiver + ;; (arg 0) is a known record type resolves to a direct method call. + ;; Annotate the node with [type-tag proto method]; the back end looks + ;; up the impl at emit time and calls it directly, skipping the + ;; registry dispatch (~19x cheaper than protocol-dispatch). + (let [pm (and iscall-var (get @protocol-methods-box (var-key fnode))) + 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! diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet index d70ffed..c2abfb6 100644 --- a/src/jolt/backend.janet +++ b/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 diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index 7cd9cfe..df84c71 100644 --- a/src/jolt/evaluator.janet +++ b/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 diff --git a/test/integration/devirt-test.janet b/test/integration/devirt-test.janet new file mode 100644 index 0000000..2304153 --- /dev/null +++ b/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)))))