Stage2 task2 (#13)
* core: Stage 2 Task 2 tier 2a — compile defprotocol/extend-type/extend-protocol
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).
* core: Stage 2 Task 2 tier 2b — compile reify (make-reified as a fn)
Completes the protocol machinery: make-reified joins protocol-dispatch/
register-method as a ctx-capturing clojure.core fn (install-stateful-fns!).
- make-reified-impl takes the EVALUATED {keyword fn} method map (a phm when
compiled, struct/table when interpreted) and builds the reified object.
- reify macro passes the protocol NAME as a string; method map is an ordinary
map literal evaluating to {keyword fn}.
- Removed make-reified's special-symbol? entry + handler arm, and dropped
make-reified + reify from host_iface special-names + compiler
uncompilable-heads.
reify now compiles and dispatches in both modes (single- and multi-method).
With tier 2a, the full protocol surface (defprotocol/extend-type/
extend-protocol/reify) compiles; defrecord still 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/7x3).
* core: Stage 2 Task 2 tier 3 — compile (var x) + binding
binding keys its thread-binding frame on var cells via (var x), so it
needed (var x) to compile. Added a the-var IR node that emits the embedded
var cell itself (vs var-ref, which derefs):
- ir.clj: the-var node.
- analyzer: 'var' added to handled; analyze-special resolves the symbol to
its var and emits the-var (uncompilable for a non-var, matching Clojure).
- backend: :the-var emits (quote cell) — the exact per-ctx cell var-get
keys on, so a compiled binding overrides + restores correctly.
- removed var from loader stateful-head? + host_iface special-names, and
binding from special-names so it expands+compiles.
Dynamic binding now compiles end-to-end (override/restore, and a compiled
fn reading the dynamic var under the binding) in both modes.
Gate green: conformance 267x3, fallback-zero 31/5, bootstrap-fixpoint
stage1==2==3, self-host, clojure-test-suite >=4034/67, features 78/78,
all unit + spec (state/metadata).
---------
Co-authored-by: Yogthos <yogthos@gmail.com>
This commit is contained in:
Dmitri Sotnikov
GitHub
parent
534007641e
commit
124cbf370a
9 changed files with 125 additions and 89 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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})
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue