0e3584884f
init in compile mode is ~2.4 s (tier loading, analyzer self-compile, macro recompilation), paid by every process that builds a ctx from source — each jpm-test file, embedders, workers. init-cached marshals the built ctx to a disk image (same root-env dicts as snapshot/fork) and later processes unmarshal it in ~5 ms, any process: nothing from the baking process is needed at load. The cache key fingerprints the embedded .clj stdlib (which covers jolt-core: analyzer, IR, core tiers), the .janet seed sources next to the module, the janet version, the init opts, and the env knobs that shape a ctx (JOLT_PATH/ MUTABLE/AOT_CORE/FEATURES) — any change rebuilds. Corrupt or non-ctx images fall back to a rebuild (unmarshal of garbage can 'succeed' with a scalar, so the shape is checked, not just the throw). Writes are atomic (tmp + rename) so racing cold starts never publish a torn image. JOLT_NO_IMAGE_CACHE=1 opts out; JOLT_IMAGE_CACHE_DIR overrides the location (default TMPDIR). Test consumers switch to init-cached (harness, suite-worker, conformance, the behavioral unit/integration tests); tests that validate the bootstrap itself (bootstrap-fixpoint, staged-bootstrap, aot round-trip, direct-linking) and the deps tests (tmp-dir :paths would fragment the key) keep real init. Full jpm test: 2:46 -> 1:58 (~29%). New ctx-image-test covers cold/warm, cross-process load (subprocess runs defn/redef/macros/protocols/multimethods off the baked image), per-opts keying, and corrupt-image fallback.
51 lines
2.7 KiB
Text
51 lines
2.7 KiB
Text
# 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-cached 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))
|
|
|
|
# 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-cached 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)
|
|
(do (printf "dispatch-cache: %d failure(s)" failures) (os/exit 1))
|
|
(print "dispatch-cache: all cases passed (compile, interpret, aot-core off)"))
|