diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index 1379e63..8378619 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))) @@ -181,13 +187,13 @@ ;; definterface is JVM-only; bind the name to an empty marker. (defmacro definterface [name-sym & body] `(def ~name-sym {})) -;; Build a method map {kw (fn* ...)} as an embedded map literal — make-reified -;; evaluates it (the fn* forms become fns) via build-eval-map, which yields a -;; struct it can iterate; a (hash-map ...) call would instead yield a phm it can't. +;; make-reified is a fn (clojure.core); the method map {kw (fn* ...)} is an +;; ordinary map literal that evaluates to {keyword fn}, and the protocol NAME is +;; passed as a string (not the symbol) so the call compiles as a plain invoke. (defmacro reify [& forms] (loop [items (seq forms) proto nil methods {}] (if (empty? items) - `(make-reified ~proto ~methods) + `(make-reified ~(name proto) ~methods) (let [x (first items)] (if (symbol? x) (recur (rest items) (if proto proto x) methods) diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index d820318..66ac5e7 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -14,7 +14,7 @@ Definitions are ordered so only `analyze` (mutually recursive) is forward declared — the bootstrap compiles forward refs through var cells, but keeping them to one keeps the compiled namespace simple." - (:require [jolt.ir :refer [const local var-ref host-ref if-node do-node invoke + (:require [jolt.ir :refer [const local var-ref the-var host-ref if-node do-node invoke def-node let-node fn-node vector-node map-node set-node quote-node throw-node]] [jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list? @@ -28,7 +28,7 @@ (def ^:private handled #{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try" - "syntax-quote"}) + "syntax-quote" "var"}) (defn- uncompilable [why] (throw (str "jolt/uncompilable: " why))) @@ -163,6 +163,11 @@ ;; Lower the backtick to construction code (zero runtime cost), then analyze ;; it — the macroexpand/compile-time step, per read -> macroexpand -> compile. "syntax-quote" (analyze ctx (form-syntax-quote-lower ctx (second items)) env) + "var" (let [sym (second items) + r (resolve-global ctx sym)] + (if (= :var (:kind r)) + (the-var (:ns r) (:name r)) + (uncompilable (str "var of non-var " (form-sym-name sym))))) (uncompilable (str "special form " op)))) (defn- analyze-symbol [ctx form env] diff --git a/jolt-core/jolt/ir.clj b/jolt-core/jolt/ir.clj index af34cdb..b869f24 100644 --- a/jolt-core/jolt/ir.clj +++ b/jolt-core/jolt/ir.clj @@ -16,6 +16,10 @@ ;; A global var reference, by name. The back end resolves it to a host var. (defn var-ref [ns name] {:op :var :ns ns :name name}) +;; The var object itself — (var x) / #'x. Unlike var-ref (which derefs), the back +;; end emits the embedded var cell so `binding`'s thread-binding frame can key on it. +(defn the-var [ns name] {:op :the-var :ns ns :name name}) + ;; A runtime primitive (cons, +, get, apply, …) the back end maps to the host RT. (defn rt [name] {:op :rt :name name}) 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/backend.janet b/src/jolt/backend.janet index 9352517..767d8af 100644 --- a/src/jolt/backend.janet +++ b/src/jolt/backend.janet @@ -250,6 +250,9 @@ # reference (a bare table in arg position would be re-evaluated as # a constructor — deep-copying it, and any atom in :root, each call). (tuple var-get (tuple 'quote cell)))) + # (var x): the var object itself (not its value) — the embedded cell, by + # reference. binding keys its thread-binding frame on this exact cell. + :the-var (tuple 'quote (cell-for ctx (node :ns) (node :name))) :if ['if (emit ctx (node :test)) (emit ctx (node :then)) (emit ctx (node :else))] :do (emit-seq ctx node) :loop (emit-loop ctx node) diff --git a/src/jolt/compiler.janet b/src/jolt/compiler.janet index abd27ca..d3f60b0 100644 --- a/src/jolt/compiler.janet +++ b/src/jolt/compiler.janet @@ -157,8 +157,8 @@ (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" - "make-reified" "satisfies?" "instance?" "set!" "var" "var-get" + "get-method" "methods" + "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" "ns-resolve" "ns-aliases" "ns-imports" "ns-interns" diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index dfcae00..6c07416 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -27,7 +27,6 @@ (= 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 "prefer-method") (= name "remove-method") (= name "remove-all-methods") (= name "get-method") (= name "methods"))) @@ -690,6 +689,85 @@ (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 make-reified-impl [ctx proto-name methods-map] + # methods-map is the EVALUATED {keyword fn} map (a phm when compiled, a struct/ + # table when interpreted) — the fn* literals are already fns, just store them. + (def obj @{:jolt/deftype (string "reified-" proto-name) :jolt/protocol-methods @{}}) + (def pairs (if (phm? methods-map) + (phm-entries methods-map) + (map (fn [k] [k (get methods-map k)]) (keys methods-map)))) + (each p pairs (put (obj :jolt/protocol-methods) (in p 0) (in p 1))) + obj) + +(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))) + (ns-intern core "make-reified" + (fn [proto-name methods-map] (make-reified-impl ctx proto-name methods-map))) + 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,78 +1251,10 @@ (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)) - "make-reified" (let [proto-sym (in form 1) - methods-map (eval-form ctx bindings (in form 2)) - proto-name (proto-sym :name) - reified-tag (string "reified-" proto-name)] - (def obj @{:jolt/deftype reified-tag :jolt/protocol-methods @{}}) - (loop [[k v] :pairs methods-map] - (let [fn-value (if (and (table? v) (get v :fn*)) - (let [args-vec (get v :args) - body-forms (get v :body)] - (eval-form ctx @{} - @[{:jolt/type :symbol :ns nil :name "fn*"} args-vec ;body-forms])) - v)] - (put (obj :jolt/protocol-methods) k fn-value))) - obj) + # protocol-dispatch / register-method / make-reified are now ordinary + # clojure.core fns (install-stateful-fns!) — the defprotocol/extend-type/reify + # macros call them with name STRINGS, so they compile + interpret as plain + # invokes (no special-form arms). "satisfies?" (let [proto-sym (eval-form ctx bindings (in form 1)) obj (eval-form ctx bindings (in form 2)) type-tag (if (and (table? obj) (get obj :jolt/deftype)) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet index 96574c7..0edf6db 100644 --- a/src/jolt/host_iface.janet +++ b/src/jolt/host_iface.janet @@ -71,21 +71,25 @@ (def- special-names (let [t @{}] (each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" - "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var" + "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "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/make-reified are now clojure.core + # fns (compile as plain invokes). + "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/reify now expand to plain + # def + protocol-dispatch/register-method/make-reified invokes. + "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"] + "monitor-enter" "monitor-exit" "letfn"] (put t n true)) t)) diff --git a/src/jolt/loader.janet b/src/jolt/loader.janet index f7608ea..36b5edc 100644 --- a/src/jolt/loader.janet +++ b/src/jolt/loader.janet @@ -17,7 +17,7 @@ (= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod") (= head-name "require") (= head-name "in-ns") (= head-name "set!") - (= head-name "var") (= head-name ".") (= head-name "new") + (= head-name ".") (= head-name "new") (= head-name "eval"))) (defn- form-head-name [form]