diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index 1379e63..9a4e6d1 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/jolt-core/clojure/core/30-macros.clj @@ -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))) diff --git a/src/jolt/api.janet b/src/jolt/api.janet index fe10f27..a6fc968 100644 --- a/src/jolt/api.janet +++ b/src/jolt/api.janet @@ -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 diff --git a/src/jolt/compiler.janet b/src/jolt/compiler.janet index abd27ca..1529805 100644 --- a/src/jolt/compiler.janet +++ b/src/jolt/compiler.janet @@ -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" diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index dfcae00..402657a 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -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) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet index 96574c7..66c23dd 100644 --- a/src/jolt/host_iface.janet +++ b/src/jolt/host_iface.janet @@ -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"]