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

perf: generation-guarded cache for multimethod hierarchy dispatch

Browse source 
The expensive multimethod path is the hierarchy fallback: when a dispatch value
isn't a direct method key, mm-fn walks every key with isa? (derive-based
dispatch). That resolution is now cached per dispatch value on the multimethod
var (:jolt/dispatch-cache), cleared in place by defmethod/prefer-method/
remove-method/remove-all-methods so a redefinition can't be served stale. Direct
(get methods dv) hits stay uncached — already a single lookup.

Test cases added to dispatch-cache-test (compile, interpret, aot-core off):
hierarchy hit is cached, a newly-added specific method is seen, removal re-exposes
the fallback. Conformance 218/218; full suite green.
This commit is contained in:
Yogthos 2026-06-06 18:36:11 -04:00
parent e02ccab4c0
commit c975f5d1c3
2 changed files with 54 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

53
src/jolt/evaluator.janet
View file

@ -1185,27 +1185,38 @@
(+= i 2))) h) (+= i 2))) h)
ns (ctx-find-ns ctx (ctx-current-ns ctx)) ns (ctx-find-ns ctx (ctx-current-ns ctx))
methods @{} methods @{}
# Cache for hierarchy-resolved dispatch values: the isa? walk
# over every method key is the expensive path (derive-based
# dispatch). Direct (get methods dv) hits stay uncached (already
# fast). Cleared in place when methods/prefs change (defmethod,
# prefer-method, remove-method, …) so a redef can't be hidden.
dispatch-cache @{}
mm-fn (fn [& args] mm-fn (fn [& args]
(let [dv (apply dispatch-fn args) (let [dv (apply dispatch-fn args)
method (get methods dv)] method (get methods dv)]
(if method (if method
(apply method args) (apply method args)
# hierarchy-based match (explicit :hierarchy or (let [cached (get dispatch-cache dv)]
# the global hierarchy from derive) (if cached
(let [h (or hierarchy the-global-hierarchy) (apply cached args)
found (do (var f nil) (var i 0) # hierarchy-based match (explicit :hierarchy or
(let [ks (keys methods)] # the global hierarchy from derive)
(while (and (nil? f) (< i (length ks))) (let [h (or hierarchy the-global-hierarchy)
(if (isa? h dv (in ks i)) (set f (get methods (in ks i)))) found (do (var f nil) (var i 0)
(++ i))) f)] (let [ks (keys methods)]
(if found (apply found args) (while (and (nil? f) (< i (length ks)))
# fall back to the method registered under the default key (if (isa? h dv (in ks i)) (set f (get methods (in ks i))))
(let [dm (get methods default-key)] (++ i))) f)]
(if dm (apply dm args) (if found
(error (string "No method in multimethod " (do (put dispatch-cache dv found) (apply found args))
(name-sym :name) " for dispatch value: " dv)))))))))] # fall back to the method registered under the default key
(let [dm (get methods default-key)]
(if dm (apply dm args)
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv))))))))))) ]
(def v (ns-intern ns (name-sym :name) mm-fn)) (def v (ns-intern ns (name-sym :name) mm-fn))
(put v :jolt/methods methods) (put v :jolt/methods methods)
(put v :jolt/dispatch-cache dispatch-cache)
(put v :jolt/default default-key) (put v :jolt/default default-key)
(when hierarchy (put v :jolt/hierarchy hierarchy)) (when hierarchy (put v :jolt/hierarchy hierarchy))
(var-get v)) (var-get v))
@ -1230,6 +1241,8 @@
methods (or (get mm-var :jolt/methods) methods (or (get mm-var :jolt/methods)
(let [m @{}] (put mm-var :jolt/methods m) m))] (let [m @{}] (put mm-var :jolt/methods m) m))]
(put methods dispatch-val impl) (put methods dispatch-val impl)
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil))))
mm-var) mm-var)
"prefer-method" (let [mm-arg (in form 1) "prefer-method" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
@ -1247,6 +1260,8 @@
prefs (or (get mm-var :jolt/prefers) prefs (or (get mm-var :jolt/prefers)
(do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))] (do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))]
(put prefs dispatch-val-a dispatch-val-b) (put prefs dispatch-val-a dispatch-val-b)
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil))))
mm-var) mm-var)
# A multimethod's methods live on its VAR, but the value is the dispatch fn; # A multimethod's methods live on its VAR, but the value is the dispatch fn;
# so resolve the var from the symbol rather than evaluating it. # so resolve the var from the symbol rather than evaluating it.
@ -1270,11 +1285,15 @@
dispatch-val (eval-form ctx bindings (in form 2))] dispatch-val (eval-form ctx bindings (in form 2))]
(when mm-var (when mm-var
(let [methods (get mm-var :jolt/methods)] (let [methods (get mm-var :jolt/methods)]
(when methods (put methods dispatch-val nil)))) (when methods (put methods dispatch-val nil)))
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil)))))
mm-var) mm-var)
"remove-all-methods" (let [mm-var (eval-form ctx bindings (in form 1))] "remove-all-methods" (let [mm-var (eval-form ctx bindings (in form 1))]
(if mm-var (when mm-var
(put mm-var :jolt/methods @{})) (put mm-var :jolt/methods @{})
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil)))))
mm-var) mm-var)
"deftype" (let [raw-name (in form 1) "deftype" (let [raw-name (in form 1)
type-name (unwrap-meta-name raw-name) type-name (unwrap-meta-name raw-name)

18
test/integration/dispatch-cache-test.janet
View file

@ -28,6 +28,24 @@
(check (string mode " other class") (eval-string ctx "(m \"hi\")") "s:hi") (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)) (check (string mode " number after other-class extend") (eval-string ctx "(m 3)") 103))
# Multimethod hierarchy-fallback cache (jolt-g8w): the isa? walk result for a
# dispatch value is cached; defmethod/remove-method must invalidate it.
(each mode [{:compile? true} {} {:aot-core? false}]
(def ctx (init mode))
(eval-string ctx "(derive ::circle ::shape)")
(eval-string ctx "(derive ::square ::shape)")
(eval-string ctx "(defmulti area identity)")
(eval-string ctx "(defmethod area ::shape [_] :generic)")
(check (string mode " mm hierarchy") (eval-string ctx "(area ::circle)") :generic)
(check (string mode " mm cache hit") (eval-string ctx "(area ::circle)") :generic)
# adding a more specific method must invalidate the cached hierarchy result
(eval-string ctx "(defmethod area ::circle [_] :specific)")
(check (string mode " mm sees new method") (eval-string ctx "(area ::circle)") :specific)
(check (string mode " mm other still hierarchy") (eval-string ctx "(area ::square)") :generic)
# removing it must re-expose the hierarchy fallback
(eval-string ctx "(remove-method area ::circle)")
(check (string mode " mm sees removal") (eval-string ctx "(area ::circle)") :generic))
(if (pos? failures) (if (pos? failures)
(do (printf "dispatch-cache: %d failure(s)" failures) (os/exit 1)) (do (printf "dispatch-cache: %d failure(s)" failures) (os/exit 1))
(print "dispatch-cache: all cases passed (compile, interpret, aot-core off)")) (print "dispatch-cache: all cases passed (compile, interpret, aot-core off)"))