From 279c8e176b136b282e754f430e423b052e60d563 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sat, 6 Jun 2026 17:38:44 -0400 Subject: [PATCH] perf: generation-guarded inline cache for host-value protocol dispatch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Host-value protocol dispatch (a protocol extended to Number/String/… called on a host value) recomputed the candidate type-tag list and walked the registry — up to ~15 map lookups plus an array alloc — on every call. It now caches (most-specific-host-tag, protocol, method) -> fn, guarded by a registry generation that bumps in register-protocol-method; re-extending a protocol invalidates the cache. The single-lookup fast paths (deftype protocol dispatch, direct multimethod dispatch) are untouched — they're already cheap, so no cache overhead there. The multimethod hierarchy-fallback cache (narrower: only derive-based dispatch) is deferred. Test in test/integration/dispatch-cache-test.janet covers correctness under re-extension in all three modes. Conformance 218/218; battery 3916. --- src/jolt/evaluator.janet | 30 ++++++++++++++++---- src/jolt/types.janet | 7 +++-- test/integration/dispatch-cache-test.janet | 33 ++++++++++++++++++++++ 3 files changed, 62 insertions(+), 8 deletions(-) create mode 100644 test/integration/dispatch-cache-test.janet diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index 21ac9c9..c9bdc38 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -1069,12 +1069,30 @@ (let [fn (find-protocol-method ctx type-tag proto-name method-name)] (if fn (apply fn obj rest-args) (error (string "No method " method-name " in " proto-name " for " type-tag)))) - # host value: try candidate host type-tags (Long/String/Object/...) - (let [cands (value-host-tags obj)] - (var found nil) - (each tag cands - (when (nil? found) - (set found (find-protocol-method ctx tag proto-name method-name)))) + # host value: try candidate host type-tags (Long/String/Object/...). + # Generation-guarded inline cache: the candidate + # walk (array alloc + up to ~15 registry lookups) is + # the same for every value of a given host class, so + # cache (most-specific-tag, proto, method) -> fn, + # invalidated when the registry generation bumps. + (let [env (ctx :env) + reg-gen (or (get env :type-registry-gen) 0) + pc (let [c (get env :proto-dispatch-cache)] + (if (and c (= (c :gen) reg-gen)) c + (let [n @{:gen reg-gen :map @{}}] + (put env :proto-dispatch-cache n) n))) + cands (value-host-tags obj) + ckey [(first cands) proto-name method-name] + cached (get (pc :map) ckey) + found (if (nil? cached) + (let [f (do (var r nil) + (each tag cands + (when (nil? r) + (set r (find-protocol-method ctx tag proto-name method-name)))) + r)] + (put (pc :map) ckey (if f f :jolt/none)) + f) + (if (= cached :jolt/none) nil cached))] (if found (apply found obj rest-args) (error (string "No dispatch for " method-name " on " (type obj)))))))) "register-method" (let [type-sym (in form 1) diff --git a/src/jolt/types.janet b/src/jolt/types.janet index ae56e4e..11746b6 100644 --- a/src/jolt/types.janet +++ b/src/jolt/types.janet @@ -500,12 +500,15 @@ (defn register-protocol-method "Register a protocol method implementation for a type." [ctx type-tag protocol-name method-name fn] - (let [registry (get (ctx :env) :type-registry) + (let [env (ctx :env) + registry (get env :type-registry) type-impls (or (get registry type-tag) (do (put registry type-tag @{}) (get registry type-tag))) proto-impls (or (get type-impls protocol-name) (do (put type-impls protocol-name @{}) (get type-impls protocol-name)))] - (put proto-impls method-name fn))) + (put proto-impls method-name fn) + # Bump the registry generation so any dispatch cache keyed on it invalidates. + (put env :type-registry-gen (+ 1 (or (get env :type-registry-gen) 0))))) (defn find-protocol-method "Find a protocol method implementation for a type." diff --git a/test/integration/dispatch-cache-test.janet b/test/integration/dispatch-cache-test.janet new file mode 100644 index 0000000..424d02f --- /dev/null +++ b/test/integration/dispatch-cache-test.janet @@ -0,0 +1,33 @@ +# Protocol host-value dispatch cache (jolt-4ay). +# +# Host-value protocol dispatch used to recompute the candidate type-tag list and +# walk the registry on every call. It's now a generation-guarded cache keyed by +# (most-specific-host-tag, protocol, method); registering a protocol impl bumps +# the registry generation and invalidates it. This pins correctness: the cache +# must never hide a re-extension. + +(use ../../src/jolt/api) + +(var failures 0) +(defn- check [label got want] + (unless (= got want) + (++ failures) + (printf "FAIL [%s] got %q want %q" label got want))) + +(each mode [{:compile? true} {} {:aot-core? false}] + (def ctx (init mode)) + (eval-string ctx "(defprotocol P (m [x]))") + (eval-string ctx "(extend-protocol P Number (m [x] (* x 2)))") + (check (string mode " host dispatch") (eval-string ctx "(m 5)") 10) + (check (string mode " cache hit (same class)") (eval-string ctx "(m 7)") 14) + # Re-extend: registry generation bumps, cache must invalidate. + (eval-string ctx "(extend-protocol P Number (m [x] (+ x 100)))") + (check (string mode " sees re-extension") (eval-string ctx "(m 5)") 105) + # Extending a different host class bumps gen too; number impl re-resolves. + (eval-string ctx "(extend-protocol P String (m [x] (str \"s:\" x)))") + (check (string mode " other class") (eval-string ctx "(m \"hi\")") "s:hi") + (check (string mode " number after other-class extend") (eval-string ctx "(m 3)") 103)) + +(if (pos? failures) + (do (printf "dispatch-cache: %d failure(s)" failures) (os/exit 1)) + (print "dispatch-cache: all cases passed (compile, interpret, aot-core off)"))