simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

perf: generation-guarded inline cache for host-value protocol dispatch

Browse source 
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.
This commit is contained in:
Yogthos 2026-06-06 17:38:44 -04:00
parent db08cecde8
commit 279c8e176b
3 changed files with 62 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

30
src/jolt/evaluator.janet
View file

@ -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)

7
src/jolt/types.janet
View file

@ -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."

33
test/integration/dispatch-cache-test.janet Normal file
View file

@ -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)"))