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

core: Stage 2 Task 2 tier 2a — compile defprotocol/extend-type/extend-protocol

Browse source 
Applies the proven enabler: stateful primitives become per-ctx closures
captured over ctx, interned in clojure.core (install-stateful-fns!), so
they resolve + compile as plain :var invokes and work for deferred calls.

- protocol-dispatch / register-method: extracted from the interpreter
  special handlers into ctx-taking impls (protocol-dispatch-impl /
  register-method-impl) + interned as ctx-capturing clojure.core fns.
  Removed their special-symbol? entries + handler arms, and dropped them
  from host_iface special-names + compiler uncompilable-heads.
- defprotocol/extend-type/extend-protocol macros now pass the protocol/
  method/type NAMES as strings (not symbols), so the emitted calls compile
  as ordinary invokes; removed the three macros from special-names so the
  analyzer expands+compiles them instead of punting to the interpreter.
- Both interpreter and compiled paths now call the same ctx-capturing
  closures (one dispatch implementation, no special-form duplication).

reify/make-reified deferred to tier 2b (map-eval shape); defrecord waits
on deftype (tier 5).

Gate green: conformance 267x3, fallback-zero 31/5, bootstrap-fixpoint
stage1==2==3, self-host, staged-bootstrap, clojure-test-suite >=4034/67,
features 78/78, all unit + spec (protocols 7/7, multimethods 9/9).
This commit is contained in:
Yogthos 2026-06-09 14:29:33 -04:00
parent 534007641e
commit 70176005db
5 changed files with 91 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

10
jolt-core/clojure/core/30-macros.clj
View file

@ -161,12 +161,18 @@
(def ~pname (make-protocol ~(name pname) ~methods))
~@(map (fn [sig]
`(def ~(first sig)
(fn* [this# & rest#] (protocol-dispatch ~pname ~(first sig) this# rest#))))
;; protocol-dispatch is a fn (clojure.core); pass the protocol /
;; method NAMES as strings (not the symbols) so it compiles as a
;; plain invoke rather than evaluating the symbols as vars.
(fn* [this# & rest#]
(protocol-dispatch ~(name pname) ~(name (first sig)) this# rest#))))
sigs))))
(defmacro extend-type [tsym psym & impls]
;; register-method is a fn (clojure.core); pass type/protocol/method NAMES as
;; strings (not the symbols) so the call compiles as a plain invoke.
`(do ~@(map (fn [spec]
`(register-method ~tsym ~psym ~(first spec)
`(register-method ~(name tsym) ~(name psym) ~(name (first spec))
(fn* ~(nth spec 1) ~@(drop 2 spec))))
impls)))

4
src/jolt/api.janet
View file

@ -136,6 +136,10 @@
(install-async! ctx)
# Host contract (ns jolt.host): the seam the portable jolt-core compiler calls.
(host/install! ctx)
# Stateful primitives as ctx-capturing clojure.core fns (protocol-dispatch,
# register-method, …) — so the protocol macros compile to plain invokes. Must
# precede the overlay (its defprotocol/extend-type expansions call these).
(install-stateful-fns! ctx)
# Clojure portion of clojure.core (jolt-core/clojure/core.clj): fns expressed
# in plain Clojure on top of the Janet primitives interned above. Loaded into
# clojure.core and compiled by the self-hosted pipeline (or interpreted when

2
src/jolt/compiler.janet
View file

@ -157,7 +157,7 @@
(each n ["syntax-quote" "unquote" "unquote-splicing" "eval" "read-string"
"macroexpand-1" "defonce" "defmacro" "deftype" "defmulti"
"defmethod" "prefer-method" "remove-method" "remove-all-methods"
"get-method" "methods" "register-method" "protocol-dispatch"
"get-method" "methods"
"make-reified" "satisfies?" "instance?" "set!" "var" "var-get"
"var-set" "var?" "in-ns" "ns" "require" "create-ns" "remove-ns"
"find-ns" "all-ns" "the-ns" "find-var" "intern" "resolve"

130
src/jolt/evaluator.janet
View file

@ -27,7 +27,7 @@
(= name "alter-var-root") (= name "find-var") (= name "intern")
(= name "alter-meta!") (= name "reset-meta!")
(= name "satisfies?")
(= name "protocol-dispatch") (= name "register-method") (= name "make-reified")
(= name "make-reified")
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")
(= name "get-method") (= name "methods")))
@ -690,6 +690,73 @@
(nil? obj) ["nil" "Object"]
["Object"]))
# ---------------------------------------------------------------------------
# Stateful primitives as ordinary fns (Stage 2 jolt-eaa). These mutate/read the
# per-ctx protocol registry, so they need ctx. They're interned into clojure.core
# as closures over ctx (install-stateful-fns!), which makes them resolve + COMPILE
# as plain :var invokes — the back end embeds the per-ctx var cell, and the closure
# captures ctx so a compiled protocol dispatcher works even when called later.
# Both the interpreter and compiled code call these same closures; there is no
# longer a special-form handler for them. proto/method/type names arrive as
# STRINGS (the defprotocol/extend-type macros pass (name sym), not the symbol).
(defn protocol-dispatch-impl [ctx proto-name method-name obj rest-args]
(def type-tag (if (and (table? obj) (get obj :jolt/deftype))
(get obj :jolt/deftype)
(if (get obj :jolt/protocol-methods) (get obj :jolt/deftype))))
(if (and (table? obj) (get obj :jolt/protocol-methods))
(let [reified-fns (get obj :jolt/protocol-methods)
f (get reified-fns (keyword method-name))]
(if f (apply f obj rest-args)
(error (string "No reified method " method-name " for " type-tag))))
(if type-tag
(let [f (find-protocol-method ctx type-tag proto-name method-name)]
(if f (apply f 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/...), with a
# generation-guarded inline cache (same walk for every value of a host class).
(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))))))))
(defn register-method-impl [ctx type-name proto-name method-name f]
# host types register under a bare canonical tag; deftype/record names stay
# namespace-qualified to the ns the (extend-)type form runs in.
(def host (canonical-host-tag type-name))
(def type-tag (if host host (string (ctx-current-ns ctx) "." type-name)))
(register-protocol-method ctx type-tag proto-name method-name f))
(defn install-stateful-fns!
"Intern ctx-capturing closures for the stateful primitives into clojure.core, so
both the interpreter and the compiler reach them as ordinary fns. Called by
api/init after init-core! and before the overlay loads (the protocol macros
expand to calls of these)."
[ctx]
(def core (ctx-find-ns ctx "clojure.core"))
(ns-intern core "protocol-dispatch"
(fn [proto-name method-name obj rest-args]
(protocol-dispatch-impl ctx proto-name method-name obj rest-args)))
(ns-intern core "register-method"
(fn [type-name proto-name method-name f]
(register-method-impl ctx type-name proto-name method-name f)))
core)
# Dispatch a special form by its string name.
(defn- unwrap-meta-name
"Recursively unwrap (with-meta sym meta) forms to extract the underlying symbol.
@ -1173,64 +1240,9 @@
(ns-intern ns (if (struct? sym-name) (sym-name :name) sym-name) val))
# set?/disj are plain clojure.core fns now (core-set?/core-disj) — no longer
# special-cased here, the analyzer, or compiler.janet (jolt-g3h).
"protocol-dispatch" (let [proto-sym (in form 1)
method-sym (in form 2)
obj (eval-form ctx bindings (in form 3))
rest-args (eval-form ctx bindings (in form 4))
type-tag (if (and (table? obj) (get obj :jolt/deftype))
(get obj :jolt/deftype)
(if (get obj :jolt/protocol-methods)
(get obj :jolt/deftype)))
proto-name (proto-sym :name)
method-name (method-sym :name)]
(if (and (table? obj) (get obj :jolt/protocol-methods))
(let [reified-fns (get obj :jolt/protocol-methods)
fn (get reified-fns (keyword method-name))]
(if fn (apply fn obj rest-args)
(error (string "No reified method " method-name " for " type-tag))))
(if type-tag
(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/...).
# 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)
proto-sym (in form 2)
method-sym (in form 3)
fn (eval-form ctx bindings (in form 4))
ns-name (ctx-current-ns ctx)
type-name (type-sym :name)
host (canonical-host-tag type-name)
# host types register under a bare canonical tag;
# deftype/record names stay namespace-qualified
type-tag (if host host (string ns-name "." type-name))
proto-name (proto-sym :name)
method-name (method-sym :name)]
(register-protocol-method ctx type-tag proto-name method-name fn))
# protocol-dispatch / register-method are now ordinary clojure.core fns
# (install-stateful-fns!) — the defprotocol/extend-type macros call them with
# name STRINGS, so they compile + interpret as plain invokes (no special arm).
"make-reified" (let [proto-sym (in form 1)
methods-map (eval-form ctx bindings (in form 2))
proto-name (proto-sym :name)

10
src/jolt/host_iface.janet
View file

@ -75,14 +75,18 @@
"locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "new"
"." "var-get" "var-set" "var?" "alter-var-root" "find-var" "intern"
"alter-meta!" "reset-meta!" "satisfies?"
"protocol-dispatch" "register-method" "make-reified" "prefer-method"
# protocol-dispatch/register-method are now clojure.core fns (compile
# as plain invokes); only make-reified is still a special.
"make-reified" "prefer-method"
"remove-method" "remove-all-methods" "get-method" "methods"
# ns-management forms dispatched by the interpreter (not core vars)
"create-ns" "remove-ns" "find-ns" "all-ns" "the-ns" "resolve"
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
"read-string" "macroexpand-1" "defonce" "ns" "in-ns" "require"
"import" "use" "refer" "defrecord" "defprotocol"
"reify" "extend-type" "extend-protocol" "gen-class"
"import" "use" "refer" "defrecord"
# defprotocol/extend-type/extend-protocol now expand to plain
# def + protocol-dispatch/register-method invokes — let them compile.
"reify" "gen-class"
# letfn stays: its let* expansion needs letrec semantics (mutual
# recursion between the fns), which compiled sequential let* lacks.
"monitor-enter" "monitor-exit" "binding" "letfn"]