Delete the Janet host — Chez is the sole substrate
Remove the Janet seed (src/jolt/*.janet: reader, value layer, vars/ns, the
tree-walking interpreter, the Janet backend, the optimizing compiler), the
Janet->Scheme cross-compiler (host/chez/{driver,emit,jolt-chez}.janet),
bin/jolt-chez, the jpm build (project.janet) and the Janet test runner
(run-tests.janet), plus the entire Janet test suite. jolt now builds and runs
on Chez alone: bin/joltc off the checked-in seed, bootstrap.ss to rebuild it.
The portable Clojure stays: jolt-core/**, host/chez/**.ss, and the stdlib +
tooling under src/jolt/clojure + src/jolt/jolt (read by the seed build, no
Janet). The gate is 'make test' (self-host, corpus, unit, cli smoke, certify).
Drop the sci and clojure-test-suite submodules (used only by deleted Janet
integration tests); irregex stays.
Filesystem corpus/unit cases that probed project.janet now probe README.md.
jolt-cf1q.6
This commit is contained in:
Yogthos
parent
5c1fdfc336
commit
58d03d67be
221 changed files with 16 additions and 29925 deletions
|
|
@ -1,648 +0,0 @@
|
|||
# Phase 1 (jolt-cf1q.2) — live-analyzer -> Chez driver.
|
||||
#
|
||||
# Boots a real jolt ctx, runs the EXISTING Janet-hosted analyzer on actual
|
||||
# Clojure source to produce host-neutral IR, feeds that IR to the Scheme emitter
|
||||
# (emit.janet), and assembles a runnable Chez program. This is the Option-2
|
||||
# backend swap end to end: same front end, Scheme back end, run on Chez.
|
||||
#
|
||||
# Analysis still happens on Janet here (the analyzer is portable Clojure but not
|
||||
# yet bootstrapped onto Chez — that's Phase 2); EXECUTION happens on Chez. The
|
||||
# point of this increment is to validate that the real IR the analyzer emits
|
||||
# compiles to correct, fast Scheme.
|
||||
|
||||
(import ../../src/jolt/api :as api)
|
||||
(import ../../src/jolt/backend :as backend)
|
||||
(import ../../src/jolt/reader :as r)
|
||||
(import ../../src/jolt/evaluator :as evlr)
|
||||
(import ../../src/jolt/types_ctx :as tctx)
|
||||
(import ../../src/jolt/types_ns :as tns)
|
||||
(import ../../src/jolt/types_var :as tvar)
|
||||
(import ./emit :as emit)
|
||||
|
||||
# Chez Phase 3 (jolt-duot): the IR->Scheme emitter is now the PORTABLE Clojure
|
||||
# jolt.backend-scheme (jolt-core), not emit.janet. It's loaded into the ctx and
|
||||
# called from here the same way the analyzer is. emit.janet stays only as the
|
||||
# program-string wrapper (emit/program) until program assembly ports to Clojure
|
||||
# with compile-from-source. This is the step that takes the emitter off Janet.
|
||||
(defn- ensure-clj-emitter [ctx]
|
||||
(def env (ctx :env))
|
||||
(unless (get env :clj-emit-fn)
|
||||
(def src (get (get env :embedded-sources @{}) "jolt.backend-scheme"))
|
||||
(assert src "jolt.backend-scheme not embedded (check stdlib_embed)")
|
||||
(backend/bootstrap-load-source ctx "jolt.backend-scheme" src)
|
||||
(def ns (tctx/ctx-find-ns ctx "jolt.backend-scheme"))
|
||||
(put env :clj-emit-fn (tvar/var-get (tns/ns-find ns "emit")))
|
||||
(put env :clj-set-prelude-fn (tvar/var-get (tns/ns-find ns "set-prelude-mode!"))))
|
||||
ctx)
|
||||
|
||||
# Emit IR -> Scheme via the Clojure emitter (returns a Janet string).
|
||||
(defn- cemit [ctx ir] (string ((get (ctx :env) :clj-emit-fn) ir)))
|
||||
(defn- cset-prelude! [ctx on] ((get (ctx :env) :clj-set-prelude-fn) on))
|
||||
|
||||
# Public: emit IR -> Scheme via the portable Clojure emitter (jolt.backend-scheme).
|
||||
# The single seam tests use so emit.janet's emit fn is no longer exercised.
|
||||
(defn scheme-emit [ctx ir] (ensure-clj-emitter ctx) (cemit ctx ir))
|
||||
|
||||
(defn chez-available?
|
||||
"True when a `chez` binary is on PATH — lets the chez tests skip cleanly on
|
||||
hosts without it (CI without Chez), like the clojure-test-suite skips when its
|
||||
corpus dir is absent."
|
||||
[]
|
||||
(def r (protect (let [p (os/spawn ["chez" "--version"] :p {:out :pipe :err :pipe})]
|
||||
(ev/read (p :out) 1024)
|
||||
(ev/read (p :err) 1024)
|
||||
(os/proc-wait p))))
|
||||
(and (r 0) (zero? (r 1))))
|
||||
|
||||
(defn make-ctx []
|
||||
"A compile-mode jolt ctx (the analyzer pipeline is only built under :compile?).
|
||||
Late-bind unresolved symbols: the Chez back end has no interpreter to punt to,
|
||||
so a forward reference to a runtime-interned var (defmulti/defmethod's setup
|
||||
call) lowers to a var-deref instead of failing to compile (jolt-9ls5)."
|
||||
(def ctx (api/init {:compile? true}))
|
||||
(put (get ctx :env) :late-bind-unresolved? true)
|
||||
(ensure-clj-emitter ctx)
|
||||
ctx)
|
||||
|
||||
(defn- parse-all [src]
|
||||
(def out @[])
|
||||
(var s src)
|
||||
(while (> (length (string/trim s)) 0)
|
||||
(def parsed (r/parse-next s))
|
||||
(set s (in parsed 1))
|
||||
(def f (in parsed 0))
|
||||
(unless (nil? f) (array/push out f)))
|
||||
out)
|
||||
|
||||
(defn compile-program
|
||||
"Compile a Clojure program string to a runnable Chez program. Every top-level
|
||||
form is analyzed to real IR and emitted to Scheme; all but the LAST form are
|
||||
treated as defs (also interned in the ctx so later forms resolve their vars),
|
||||
and the last form is the expression whose value the program prints."
|
||||
[ctx src]
|
||||
(ensure-clj-emitter ctx)
|
||||
(def forms (parse-all src))
|
||||
(assert (> (length forms) 0) "compile-program: empty program")
|
||||
(def n (length forms))
|
||||
(def def-scm @[])
|
||||
(for i 0 (- n 1)
|
||||
(def f (in forms i))
|
||||
# emit the def, then intern it (interpreted) so a later form's reference to
|
||||
# this var resolves to a :var node rather than an unresolved symbol.
|
||||
(array/push def-scm (cemit ctx (backend/analyze-form ctx f)))
|
||||
(evlr/eval-form ctx @{} f))
|
||||
(def final-scm (cemit ctx (backend/analyze-form ctx (in forms (- n 1)))))
|
||||
(emit/program def-scm final-scm))
|
||||
|
||||
# Drain a pipe to EOF. A single (ev/read pipe N) can return BEFORE the child has
|
||||
# flushed everything — a program with a stdout side effect (newline/print) flushes
|
||||
# in two writes, and the first ev/read sometimes catches only the first chunk, so
|
||||
# the trailing real value is lost (intermittent gate divergence). Loop until EOF.
|
||||
(defn- drain [pipe]
|
||||
(def b @"")
|
||||
(var c (ev/read pipe 0x10000))
|
||||
(while c (buffer/push b c) (set c (ev/read pipe 0x10000)))
|
||||
(string b))
|
||||
|
||||
(defn run-on-chez
|
||||
"Compile `src` and run it on Chez; returns [exit-code stdout stderr]."
|
||||
[ctx src &opt scheme-out]
|
||||
(def prog (compile-program ctx src))
|
||||
(def path (or scheme-out "/tmp/chez-jolt-prog.ss"))
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
[code (string/trim out) (string/trim err)])
|
||||
|
||||
# --- clojure.core prelude assembly (jolt-9ziu) --------------------------------
|
||||
# The -e-capable jolt-chez path: emit EVERY non-macro clojure.core form across
|
||||
# the dependency-ordered tiers as a def-var! in prelude mode, concatenated into
|
||||
# a Scheme prelude loaded before the user expression. var-deref then resolves any
|
||||
# core fn at runtime from the prelude's own def-var! cells. Macros are skipped
|
||||
# (analyze-time only — the Janet analyzer expands them before emit, so they have
|
||||
# no runtime value). Each form is wrapped in a tolerant load guard so a form that
|
||||
# fails to LOAD (currently only the Phase-2 multimethod defmulti/defmethod
|
||||
# print-method forms) doesn't break the rest of the prelude; it logs to stderr
|
||||
# and becomes a lazy gap rather than a hard prelude failure.
|
||||
|
||||
(def core-tier-files
|
||||
["00-syntax" "00-kernel" "10-seq" "20-coll" "25-sorted" "30-macros" "40-lazy" "50-io"])
|
||||
|
||||
# stdlib namespaces (beyond clojure.core) emitted into the prelude as their own
|
||||
# def-var! tier. Each is pure Clojure over clojure.core + host natives, so the
|
||||
# same analyze->emit pipeline lowers it; an aliased ref resolves via var-deref at
|
||||
# runtime once the alias is registered (the driver pre-evals requires). jolt-nfca.
|
||||
(def stdlib-ns-files
|
||||
[["clojure.string" "src/jolt/clojure/string.clj"]
|
||||
["clojure.walk" "src/jolt/clojure/walk.clj"]
|
||||
# clojure.template requires clojure.walk (apply-template over postwalk-replace)
|
||||
# — must follow it so the alias resolves at emit time.
|
||||
["clojure.template" "src/jolt/clojure/template.clj"]
|
||||
# clojure.edn requires clojure.string; read-string/__read-tagged are the
|
||||
# reader.ss seams. The reader-arity's drain-reader is Janet-coupled (janet/type)
|
||||
# so it's a lazy gap on Chez — read-string/edn->value are the live path. jolt-r8ku.
|
||||
["clojure.edn" "src/jolt/clojure/edn.clj"]
|
||||
# clojure.set / clojure.pprint: pure Clojure over core. set = relational ops
|
||||
# (union/intersection/difference/join/index/...); pprint = the minimal jolt
|
||||
# shim (pprint -> prn + recognized dispatch vars, with-pprint-dispatch macro).
|
||||
# jolt-j5vg, clojure.pprint Phase-2 parity.
|
||||
["clojure.set" "src/jolt/clojure/set.clj"]
|
||||
["clojure.pprint" "src/jolt/clojure/pprint.clj"]])
|
||||
|
||||
(defn- sym-name [x]
|
||||
(when (and (struct? x) (= :symbol (get x :jolt/type))) (get x :name)))
|
||||
|
||||
(defn- macro-form? [f]
|
||||
(and (indexed? f) (> (length f) 0)
|
||||
(let [h (sym-name (in f 0))] (and h (or (= h "defmacro") (= h "definline"))))))
|
||||
|
||||
# Extract [name-string fn-form] from (defmacro NAME ...rest): the macro's expander
|
||||
# as a bare (fn ...rest), docstring/attr-map stripped. Mirrors eval_special.janet/
|
||||
# eval-defmacro's parsing — bare name (no metadata on the name in core/stdlib),
|
||||
# optional docstring, optional attr-map, then a params vector + body (single arity)
|
||||
# OR arity clauses. Uses the `fn` MACRO (not fn*) so a destructured macro arglist
|
||||
# desugars before lowering, like api/macro-compile-hook.
|
||||
#
|
||||
# We emit the BARE fn (not (def NAME ...)) on purpose: analyzing a def would
|
||||
# host-intern! NAME in the Janet build ctx as a non-macro nil-root stub, and that
|
||||
# stub makes a later (require '[stdlib-ns]) skip loading the REAL macro — so the
|
||||
# Janet-hosted analyzer (the parity oracle) would treat e.g. with-pprint-dispatch
|
||||
# as a fn and return its unexpanded template. The caller wraps the emitted lambda
|
||||
# in def-var! manually, so NAME is never interned and require still works (jolt-r9lm).
|
||||
(defn- defmacro->fn [f]
|
||||
(def name-sym (in f 1))
|
||||
(def after-name (tuple/slice f 2))
|
||||
(def a1 (if (and (> (length after-name) 0) (string? (first after-name)))
|
||||
(tuple/slice after-name 1) after-name))
|
||||
(def after-meta (if (and (> (length a1) 0) (struct? (first a1))
|
||||
(not= :symbol (get (first a1) :jolt/type)))
|
||||
(tuple/slice a1 1) a1))
|
||||
(def fn-sym {:jolt/type :symbol :ns nil :name "fn"})
|
||||
[(sym-name name-sym) (array fn-sym ;after-meta)])
|
||||
|
||||
# Cross-compile one top-level form to its guard-wrapped Scheme string, or nil if it
|
||||
# doesn't emit (out of subset). A defmacro emits as (def-var! ns name <expander fn>)
|
||||
# plus (mark-macro! ns name) so the on-Chez analyzer expands it (jolt-r9lm). The
|
||||
# caller handles ns forms (alias registration only) before calling this.
|
||||
(defn- emit-form-scheme [ctx ns-name f]
|
||||
(defn- jts [x] (string/format "%j" x))
|
||||
(if (macro-form? f)
|
||||
(let [[nm fn-form] (defmacro->fn f)]
|
||||
(when nm
|
||||
(def res (protect (cemit ctx (backend/analyze-form ctx fn-form))))
|
||||
(when (res 0)
|
||||
(string "(guard (e (#t #f))\n (def-var! " (jts ns-name) " " (jts nm) "\n "
|
||||
(res 1) ")\n (mark-macro! " (jts ns-name) " " (jts nm) "))"))))
|
||||
(let [res (protect (cemit ctx (backend/analyze-form ctx f)))]
|
||||
(when (res 0)
|
||||
(string "(guard (e (#t #f))\n " (res 1) ")")))))
|
||||
|
||||
(defn- form-label [f]
|
||||
(if (and (indexed? f) (> (length f) 1))
|
||||
(let [h (or (sym-name (in f 0)) "?") n (sym-name (in f 1))] (if n (string h " " n) h))
|
||||
"?"))
|
||||
|
||||
(defn- require-head? [f]
|
||||
(and (indexed? f) (> (length f) 0)
|
||||
(let [h (sym-name (in f 0))] (and h (or (= h "require") (= h "use"))))))
|
||||
|
||||
(defn- scan-eval-requires! [ctx form]
|
||||
"Recursively eval any (require ...)/(use ...) sub-form against the ctx so the
|
||||
alias registers + the aliased ns loads BEFORE the AOT analyzer resolves its
|
||||
qualified refs — the whole user form is analyzed up front, before any require
|
||||
would run at eval time (jolt-nfca). Failures are swallowed (the ref then stays
|
||||
an emit-err, the prior behavior)."
|
||||
(when (indexed? form)
|
||||
(if (require-head? form)
|
||||
(protect (api/eval-one ctx form))
|
||||
(each sub form (scan-eval-requires! ctx sub)))))
|
||||
|
||||
(defn emit-core-prelude
|
||||
"Assemble the clojure.core prelude as a Scheme string. `ctx` must be a
|
||||
compile-mode ctx; its current ns is set to clojure.core for the duration.
|
||||
Returns [scheme emitted total skipped-load-guards-unknown]; `scheme` is the
|
||||
joined, guard-wrapped def-var! forms (no rt.ss load — add that at program
|
||||
assembly via emit/program or program-with-prelude)."
|
||||
[ctx &opt core-dir]
|
||||
(default core-dir "jolt-core/clojure/core/")
|
||||
(ensure-clj-emitter ctx)
|
||||
(cset-prelude! ctx true)
|
||||
(def prev-ns (tctx/ctx-current-ns ctx))
|
||||
(tctx/ctx-set-current-ns ctx "clojure.core")
|
||||
(def out @[])
|
||||
(var total 0) (var emitted 0)
|
||||
(defn- emit-ns-forms [ns-name src]
|
||||
(tctx/create-ns ctx ns-name)
|
||||
(tctx/ctx-set-current-ns ctx ns-name)
|
||||
(each f (parse-all src)
|
||||
# Register any aliases this ns depends on before analyzing its forms, so an
|
||||
# aliased ref (e.g. clojure.template's walk/postwalk-replace) resolves at emit
|
||||
# time instead of lowering to an "Unknown class walk" host-static. The ns
|
||||
# form's :require is a keyword-headed clause that scan-eval-requires! (matching
|
||||
# the `require`/`use` symbol heads) doesn't catch, so eval the ns form whole.
|
||||
(def ns-form? (and (indexed? f) (> (length f) 0) (= "ns" (sym-name (in f 0)))))
|
||||
(if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f))
|
||||
# Skip emitting ns forms: their only role here is alias registration, and a
|
||||
# runtime ns-switch would leak into the prelude's trailing *ns* (the def-var!s
|
||||
# already carry explicit ns names). Macros ARE emitted now (jolt-r9lm): each
|
||||
# defmacro becomes a def of its expander fn + (mark-macro! ns name) so the
|
||||
# on-Chez analyzer (inc6b) can expand it — previously skipped (the Janet
|
||||
# analyzer expanded them at analyze time, before they reached the prelude).
|
||||
# Tolerant load guard (inside emit-form-scheme): a form that fails to LOAD
|
||||
# (the 8 Phase-2 multimethod print-method forms in 50-io) is swallowed so it
|
||||
# doesn't break the rest of the prelude — it becomes a lazy gap.
|
||||
(unless ns-form?
|
||||
(++ total)
|
||||
(def scm (emit-form-scheme ctx ns-name f))
|
||||
(when scm (++ emitted) (array/push out scm)))))
|
||||
(each tf core-tier-files
|
||||
(emit-ns-forms "clojure.core" (slurp (string core-dir tf ".clj"))))
|
||||
# stdlib namespaces beyond clojure.core that are pure Clojure over core/host
|
||||
# natives — emitted as their own def-var! tier so an aliased ref (e.g. s/split
|
||||
# after (require '[clojure.string :as s])) resolves at runtime (jolt-nfca).
|
||||
(each [ns-name path] stdlib-ns-files
|
||||
(emit-ns-forms ns-name (slurp path)))
|
||||
(tctx/ctx-set-current-ns ctx prev-ns)
|
||||
(cset-prelude! ctx false)
|
||||
[(string/join out "\n") emitted total])
|
||||
|
||||
# --- analyzer/emitter cross-compile (jolt-hs9n, the zero-Janet spine) ---------
|
||||
# Phase 3 inc6: cross-compile the PORTABLE compiler (jolt.ir + jolt.analyzer +
|
||||
# jolt.backend-scheme) to Scheme def-var! forms so analyze->IR->emit runs ON CHEZ.
|
||||
# Same emit pipeline as the core prelude, but for jolt-core/jolt/* namespaces
|
||||
# rather than clojure.core: jolt.* refs lower to var-deref (the prelude-mode gate
|
||||
# only rejects clojure.* refs), clojure.core refs resolve from the loaded prelude,
|
||||
# and the jolt.host form-*/resolve-global/... refs resolve from host-contract.ss.
|
||||
|
||||
(defn- emit-ns-forms-list
|
||||
"Cross-compile one namespace's source to a list of guard-wrapped def-var! Scheme
|
||||
strings (prelude mode must already be ON). Registers the ns' requires/aliases in
|
||||
ctx first so cross-ns refs resolve at emit time; skips ns + macro forms (macros
|
||||
are analyze-time only, already expanded at their use sites)."
|
||||
[ctx ns-name src]
|
||||
(tctx/create-ns ctx ns-name)
|
||||
(tctx/ctx-set-current-ns ctx ns-name)
|
||||
(def out @[])
|
||||
(each f (parse-all src)
|
||||
(def ns-form? (and (indexed? f) (> (length f) 0) (= "ns" (sym-name (in f 0)))))
|
||||
(if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f))
|
||||
# The compiler namespaces define no macros, but route through the shared helper
|
||||
# anyway (a defmacro would emit as a def + mark-macro!, jolt-r9lm).
|
||||
(unless ns-form?
|
||||
(def scm (emit-form-scheme ctx ns-name f))
|
||||
(when scm (array/push out scm))))
|
||||
out)
|
||||
|
||||
(def compiler-ns-files
|
||||
[["jolt.ir" "jolt-core/jolt/ir.clj"]
|
||||
["jolt.analyzer" "jolt-core/jolt/analyzer.clj"]
|
||||
["jolt.backend-scheme" "jolt-core/jolt/backend_scheme.clj"]])
|
||||
|
||||
(defn emit-compiler-image
|
||||
"Cross-compile the analyzer pipeline (jolt.ir + jolt.analyzer +
|
||||
jolt.backend-scheme) to a Scheme string of prelude-mode def-var! forms — the
|
||||
analyze->IR->emit spine running ON CHEZ (jolt-hs9n). Load AFTER rt.ss +
|
||||
host-contract.ss + the core prelude. Returns [scheme total]."
|
||||
[ctx]
|
||||
(ensure-clj-emitter ctx)
|
||||
# ensure-analyzer is lazy; a trivial analyze builds jolt.ir/jolt.analyzer/
|
||||
# jolt.passes in the Janet ctx so their vars resolve while we emit their source.
|
||||
(protect (backend/analyze-form ctx (in (r/parse-next "nil") 0)))
|
||||
(cset-prelude! ctx true)
|
||||
(def prev-ns (tctx/ctx-current-ns ctx))
|
||||
(def out @[])
|
||||
(each [ns-name path] compiler-ns-files
|
||||
(array/concat out (emit-ns-forms-list ctx ns-name (slurp path))))
|
||||
(tctx/ctx-set-current-ns ctx prev-ns)
|
||||
(cset-prelude! ctx false)
|
||||
[(string/join out "\n") (length out)])
|
||||
|
||||
(defn ensure-compiler-image
|
||||
"Build (once) and return the path to the cross-compiled compiler image — the
|
||||
jolt.ir/jolt.analyzer/jolt.backend-scheme def-var! forms (jolt-hs9n). Cached on
|
||||
disk keyed by the same fingerprint scheme as the prelude; pass an explicit path
|
||||
to control caching from the test harness."
|
||||
[ctx path]
|
||||
(unless (os/stat path)
|
||||
(def [img _] (emit-compiler-image ctx))
|
||||
(spit path img))
|
||||
path)
|
||||
|
||||
(defn program-zero-janet
|
||||
"Assemble a fully self-hosted Chez program: rt.ss + the core prelude +
|
||||
host-contract.ss + the cross-compiled compiler image + compile-eval.ss, then
|
||||
compile AND eval `src` ON CHEZ (read->analyze->emit->eval, no Janet). The
|
||||
zero-Janet spine (jolt-hs9n)."
|
||||
[prelude-path image-path src ns]
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
"(set-chez-ns! \"clojure.core\")\n"
|
||||
"(load " (string/format "%j" prelude-path) ")\n"
|
||||
"(load \"host/chez/post-prelude.ss\")\n"
|
||||
"(set-chez-ns! \"user\")\n"
|
||||
"(load \"host/chez/host-contract.ss\")\n"
|
||||
"(load " (string/format "%j" image-path) ")\n"
|
||||
"(load \"host/chez/compile-eval.ss\")\n"
|
||||
"(printf \"~a\\n\" (jolt-final-str (jolt-compile-eval "
|
||||
(string/format "%j" src) " " (string/format "%j" ns) ")))\n"))
|
||||
|
||||
(defn eval-zero-janet
|
||||
"Compile+run `src` through the ON-CHEZ analyzer/emitter (zero Janet). Needs a
|
||||
prebuilt core prelude (`prelude-path`) and compiler image (`image-path`).
|
||||
Returns [code stdout stderr]."
|
||||
[prelude-path image-path src &opt ns scheme-out]
|
||||
(default ns "user")
|
||||
(def prog (program-zero-janet prelude-path image-path src ns))
|
||||
(def path (or scheme-out (string "/tmp/jolt-zero-janet-" (os/getpid) ".ss")))
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
[code (string/trim out) (string/trim err)])
|
||||
|
||||
# --- self-hosting fixpoint (jolt-cf1q.4 inc8) ---------------------------------
|
||||
# emit-compiler-image (above) builds stage1: the Janet analyzer/emitter
|
||||
# cross-compiles the compiler sources to a Scheme def-var! image. To prove the
|
||||
# ON-CHEZ compiler reproduces itself we recompile the SAME sources WITH the loaded
|
||||
# image (emit-image.ss's jolt-emit-image runs analyze->emit on Chez): feeding it
|
||||
# stage1 yields stage2, feeding it stage2 yields stage3, and stage2 == stage3
|
||||
# byte-for-byte is the fixpoint (self-hosting-bootstrap-research §4).
|
||||
|
||||
(defn program-emit-image
|
||||
"A Chez program that loads the zero-Janet runtime + the compiler `image-path`,
|
||||
then re-emits the compiler image (or, with emit-fn \"jolt-emit-prelude\", the
|
||||
clojure.core prelude) ON CHEZ and writes it to `out-path`. Running this with
|
||||
image = stageN produces stage(N+1)."
|
||||
[prelude-path image-path out-path &opt emit-fn]
|
||||
(default emit-fn "jolt-emit-image")
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
"(set-chez-ns! \"clojure.core\")\n"
|
||||
"(load " (string/format "%j" prelude-path) ")\n"
|
||||
"(load \"host/chez/post-prelude.ss\")\n"
|
||||
"(set-chez-ns! \"user\")\n"
|
||||
"(load \"host/chez/host-contract.ss\")\n"
|
||||
"(load " (string/format "%j" image-path) ")\n"
|
||||
"(load \"host/chez/compile-eval.ss\")\n"
|
||||
"(load \"host/chez/emit-image.ss\")\n"
|
||||
"(let ((p (open-output-file " (string/format "%j" out-path) " 'replace)))\n"
|
||||
" (put-string p (" emit-fn ")) (close-port p))\n"))
|
||||
|
||||
(defn emit-image-on-chez
|
||||
"Re-emit the compiler image on Chez: load `image-path` (stageN) and write the
|
||||
re-emitted image (stage N+1) to `out-path`. Each runs in a fresh chez process so
|
||||
gensym/state start clean (essential for a byte-stable fixpoint). emit-fn selects
|
||||
jolt-emit-image (the compiler) or jolt-emit-prelude (clojure.core). Returns
|
||||
[code stderr]."
|
||||
[prelude-path image-path out-path &opt emit-fn]
|
||||
(def prog (program-emit-image prelude-path image-path out-path emit-fn))
|
||||
(def path (string "/tmp/jolt-emit-image-" (os/getpid) "-" (hash out-path) ".ss"))
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
[code (string/trim (string out err))])
|
||||
|
||||
# --- pure-Chez self-build (jolt-9phg, inc9a) ----------------------------------
|
||||
# host/chez/bootstrap.ss rebuilds the prelude + compiler image from source ON
|
||||
# CHEZ given a seed (prelude, image) pair. run-bootstrap drives ONE bootstrap.ss
|
||||
# pass (no Janet in the compile path — Janet only spawns chez). mint-chez-seed
|
||||
# iterates it from the Janet seed to the joint fixpoint and writes the checked-in
|
||||
# bootstrap seed under host/chez/seed/.
|
||||
|
||||
(defn run-bootstrap
|
||||
"Run one pure-Chez bootstrap pass: load (seed-prelude, seed-image), rebuild the
|
||||
prelude + image from source on Chez, write them to (out-prelude, out-image).
|
||||
Returns [code stdout stderr]. The compilation is 100% Chez; Janet only spawns
|
||||
the process."
|
||||
[seed-prelude seed-image out-prelude out-image]
|
||||
(def proc (os/spawn ["chez" "--script" "host/chez/bootstrap.ss"
|
||||
seed-prelude seed-image out-prelude out-image]
|
||||
:p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
[code (string/trim out) (string/trim err)])
|
||||
|
||||
(defn mint-chez-seed*
|
||||
"Mint the checked-in bootstrap seed. Takes the Janet-emitted starting pair
|
||||
(janet-prelude + janet-image, e.g. from jolt-chez/ensure-prelude +
|
||||
ensure-compiler-image) and iterates bootstrap.ss to the joint byte-fixpoint, then
|
||||
writes the converged pair to seed-prelude/seed-image. Run once (and whenever the
|
||||
seed sources change) to refresh the checked-in seed. Returns iteration count."
|
||||
[janet-prelude janet-image seed-prelude seed-image &opt max-iter]
|
||||
(default max-iter 8)
|
||||
(defn b= [a b] (= (string (slurp a)) (string (slurp b))))
|
||||
(def tmp (or (os/getenv "TMPDIR") "/tmp"))
|
||||
(var cur-pre janet-prelude)
|
||||
(var cur-img janet-image)
|
||||
(var converged false)
|
||||
(var iters 0)
|
||||
(for i 0 max-iter
|
||||
(def npre (string tmp "/mint-pre-" i ".ss"))
|
||||
(def nimg (string tmp "/mint-img-" i ".ss"))
|
||||
(def [code _ err] (run-bootstrap cur-pre cur-img npre nimg))
|
||||
(unless (zero? code) (errorf "bootstrap pass %d failed: %s" i err))
|
||||
(set iters (inc i))
|
||||
# A pass is a fixpoint once its output equals its input AND the input is no
|
||||
# longer the Janet seed (the Janet prelude/image differ only in gensym ids).
|
||||
(when (and (not= cur-pre janet-prelude)
|
||||
(b= cur-pre npre) (b= cur-img nimg))
|
||||
(set converged true)
|
||||
(set cur-pre npre) (set cur-img nimg)
|
||||
(break))
|
||||
(set cur-pre npre) (set cur-img nimg))
|
||||
(unless converged (errorf "seed did not converge in %d iterations" max-iter))
|
||||
(os/mkdir (string/slice seed-prelude 0 (last (string/find-all "/" seed-prelude))))
|
||||
(spit seed-prelude (slurp cur-pre))
|
||||
(spit seed-image (slurp cur-img))
|
||||
iters)
|
||||
|
||||
# --- batched zero-Janet corpus runner (jolt-qjr0, inc7) -----------------------
|
||||
# eval-zero-janet spawns a fresh chez per case, each reloading rt.ss + the prelude
|
||||
# (~282KB) + the compiler image (~89KB) from source — ~0.5s of pure reload per
|
||||
# case, the entire cost. This runs ALL cases in ONE chez process: load the runtime
|
||||
# once, then loop. Each case is guarded (errors isolated) and the user namespace is
|
||||
# reset between cases (var-table keys added by a case are removed, *ns* restored) so
|
||||
# there is no state leakage vs the per-process path. ~10-30x faster.
|
||||
|
||||
(defn program-corpus-zero-janet
|
||||
"A Chez program that loads the zero-Janet runtime once, then runs every case in
|
||||
`cases-tsv` (label<TAB>src per line) through jolt-compile-eval, printing one
|
||||
result line per case: PASS<TAB>label | DIVERGE<TAB>label<TAB>value |
|
||||
CRASH<TAB>label<TAB>message."
|
||||
[prelude-path image-path cases-tsv]
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
"(set-chez-ns! \"clojure.core\")\n"
|
||||
"(load " (string/format "%j" prelude-path) ")\n"
|
||||
"(load \"host/chez/post-prelude.ss\")\n"
|
||||
"(set-chez-ns! \"user\")\n"
|
||||
"(load \"host/chez/host-contract.ss\")\n"
|
||||
"(load " (string/format "%j" image-path) ")\n"
|
||||
"(load \"host/chez/compile-eval.ss\")\n"
|
||||
# Snapshot mutable global state after setup so each case sees a clean world (as
|
||||
# if it ran in its own process): (1) var-table keys a case ADDS (its defs) are
|
||||
# removed; (2) a base cell whose ROOT a case mutated (e.g. in-ns rebinds
|
||||
# clojure.core/*ns*) is restored; (3) the ns + type registries are pruned back to
|
||||
# their base keys. Without this, *ns*/find-ns/all-ns/satisfies? leak across cases.
|
||||
"(define zj-base (let ((h (make-hashtable string-hash string=?)))\n"
|
||||
" (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys var-table)) h))\n"
|
||||
"(define zj-roots '())\n"
|
||||
"(vector-for-each (lambda (k) (let ((c (hashtable-ref var-table k #f)))\n"
|
||||
" (when c (set! zj-roots (cons (cons c (var-cell-root c)) zj-roots)))))\n"
|
||||
" (hashtable-keys var-table))\n"
|
||||
"(define (zj-snap ht) (let ((h (make-hashtable string-hash string=?)))\n"
|
||||
" (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys ht)) h))\n"
|
||||
"(define (zj-prune! ht base) (vector-for-each\n"
|
||||
" (lambda (k) (unless (hashtable-ref base k #f) (hashtable-delete! ht k))) (hashtable-keys ht)))\n"
|
||||
"(define zj-ns-base (zj-snap ns-registry))\n"
|
||||
"(define zj-type-base (zj-snap type-registry))\n"
|
||||
# global-hierarchy is a core atom whose CONTENTS `derive` mutates (its var root
|
||||
# stays the same atom object, so the root-restore above misses it). Reset its
|
||||
# contents to a fresh hierarchy each case.
|
||||
"(define zj-ghier (var-cell-lookup \"clojure.core\" \"global-hierarchy\"))\n"
|
||||
"(define (zj-reset!)\n"
|
||||
" (vector-for-each (lambda (k) (unless (hashtable-ref zj-base k #f) (hashtable-delete! var-table k)))\n"
|
||||
" (hashtable-keys var-table))\n"
|
||||
" (for-each (lambda (cr) (unless (eq? (var-cell-root (car cr)) (cdr cr))\n"
|
||||
" (var-cell-root-set! (car cr) (cdr cr)))) zj-roots)\n"
|
||||
" (zj-prune! ns-registry zj-ns-base)\n"
|
||||
" (zj-prune! type-registry zj-type-base)\n"
|
||||
" (hashtable-clear! ns-alias-table)\n"
|
||||
" (hashtable-clear! ns-refer-table)\n"
|
||||
" (when zj-ghier (jolt-invoke (var-deref \"clojure.core\" \"reset!\")\n"
|
||||
" (var-cell-root zj-ghier) (jolt-invoke (var-deref \"clojure.core\" \"make-hierarchy\"))))\n"
|
||||
" (set-chez-ns! \"user\"))\n"
|
||||
"(define kw-message (keyword #f \"message\"))\n"
|
||||
"(define (zj-err->str e)\n"
|
||||
" (cond ((and (pmap? e) (string? (jolt-get e kw-message))) (jolt-get e kw-message))\n"
|
||||
" ((condition? e) (call-with-string-output-port (lambda (p) (display-condition e p))))\n"
|
||||
" ((string? e) e)\n"
|
||||
" (else (call-with-string-output-port (lambda (p) (write e p))))))\n"
|
||||
"(define (zj-clean s)\n" # strip tabs/newlines from a message so it stays one TSV line
|
||||
" (list->string (map (lambda (c) (if (or (char=? c #\\tab) (char=? c #\\newline)) #\\space c))\n"
|
||||
" (string->list s))))\n"
|
||||
# cases are stored one-per-line with \\n / \\t / \\\\ escaped (a source may be
|
||||
# multi-line — e.g. a ;comment\\n inside a map literal); unescape before eval.
|
||||
"(define (zj-unescape s)\n"
|
||||
" (let ((out (open-output-string)) (n (string-length s)))\n"
|
||||
" (let loop ((i 0))\n"
|
||||
" (if (>= i n) (get-output-string out)\n"
|
||||
" (let ((c (string-ref s i)))\n"
|
||||
" (if (and (char=? c #\\\\) (< (+ i 1) n))\n"
|
||||
" (let ((d (string-ref s (+ i 1))))\n"
|
||||
" (write-char (cond ((char=? d #\\n) #\\newline) ((char=? d #\\t) #\\tab) (else d)) out)\n"
|
||||
" (loop (+ i 2)))\n"
|
||||
" (begin (write-char c out) (loop (+ i 1)))))))))\n"
|
||||
# ACTUAL is compiled+eval'd as its OWN top-level program (jolt-compile-eval
|
||||
# unrolls a top-level do), so a macro defined earlier in the program is usable
|
||||
# later (runtime defmacro) — matching certify.clj's eval-isolated. Then compare
|
||||
# to EXPECTED with =. (Wrapping in (= E A) would nest ACTUAL's do; wrapping A in
|
||||
# (eval (quote A)) would quote a map literal and lose its source eval-order.)
|
||||
"(define (zj-run label e-esc a-esc)\n"
|
||||
" (define esrc (zj-unescape e-esc))\n"
|
||||
" (define asrc (zj-unescape a-esc))\n"
|
||||
" (guard (e (#t (printf \"CRASH\\t~a\\t~a\\n\" label (zj-clean (zj-err->str e)))))\n"
|
||||
" (let* ((av (jolt-compile-eval asrc \"user\")) (ev (jolt-compile-eval esrc \"user\")))\n"
|
||||
" (if (jolt= ev av)\n"
|
||||
" (printf \"PASS\\t~a\\n\" label)\n"
|
||||
" (printf \"DIVERGE\\t~a\\t~a\\n\" label (zj-clean (jolt-final-str av))))))\n"
|
||||
" (zj-reset!))\n"
|
||||
"(define (zj-tab s from)\n"
|
||||
" (let loop ((i from)) (cond ((>= i (string-length s)) #f)\n"
|
||||
" ((char=? (string-ref s i) #\\tab) i) (else (loop (+ i 1))))))\n"
|
||||
"(let ((p (open-input-file " (string/format "%j" cases-tsv) ")))\n"
|
||||
" (let loop ()\n"
|
||||
" (let ((line (get-line p)))\n"
|
||||
" (unless (eof-object? line)\n"
|
||||
" (let* ((t1 (zj-tab line 0)) (t2 (and t1 (zj-tab line (+ t1 1)))))\n"
|
||||
" (when (and t1 t2)\n"
|
||||
" (zj-run (substring line 0 t1) (substring line (+ t1 1) t2)\n"
|
||||
" (substring line (+ t2 1) (string-length line)))))\n"
|
||||
" (loop)))))\n"))
|
||||
|
||||
(defn eval-corpus-zero-janet
|
||||
"Run all `cases` ([label src] pairs) through the ON-CHEZ analyzer in ONE chez
|
||||
process. Returns a struct mapping label -> [:pass] | [:diverge value] |
|
||||
[:crash message]. Vastly faster than per-case eval-zero-janet (single runtime
|
||||
load); use eval-zero-janet to isolate a single case for debugging."
|
||||
[prelude-path image-path cases &opt scheme-out cases-out]
|
||||
(def tsv-path (or cases-out (string "/tmp/jolt-zj-cases-" (os/getpid) ".tsv")))
|
||||
(def buf @"")
|
||||
# escape so each case is one TSV line even if its source is multi-line; the
|
||||
# runner's zj-unescape reverses it. Backslash first, then newline/tab.
|
||||
(defn- tsv-esc [s]
|
||||
(->> s (string/replace-all "\\" "\\\\") (string/replace-all "\n" "\\n")
|
||||
(string/replace-all "\t" "\\t")))
|
||||
(each [label e a] cases (buffer/push buf label "\t" (tsv-esc e) "\t" (tsv-esc a) "\n"))
|
||||
(spit tsv-path buf)
|
||||
(def prog (program-corpus-zero-janet prelude-path image-path tsv-path))
|
||||
(def path (or scheme-out (string "/tmp/jolt-zj-runner-" (os/getpid) ".ss")))
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
(def res @{})
|
||||
(each line (string/split "\n" (string/trim out))
|
||||
(when (> (length line) 0)
|
||||
(def parts (string/split "\t" line))
|
||||
(def status (in parts 0))
|
||||
(def label (get parts 1 ""))
|
||||
(cond
|
||||
(= status "PASS") (put res label [:pass])
|
||||
(= status "DIVERGE") (put res label [:diverge (get parts 2 "")])
|
||||
(= status "CRASH") (put res label [:crash (get parts 2 "")]))))
|
||||
# If chez died mid-run (e.g. an uncatchable error), surface what we have + stderr.
|
||||
{:results res :code code :stderr (string/trim err) :count (length res)})
|
||||
|
||||
(defn program-with-prelude
|
||||
"Assemble a runnable Chez program that loads rt.ss, loads the assembled core
|
||||
prelude from `prelude-path` (a file written once), then prints `final-scm`."
|
||||
[prelude-path final-scm]
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
# the prelude's defmultis (print-method/print-dup) must land in clojure.core,
|
||||
# not the default user ns (jolt-9ls5); set the multimethod current-ns around
|
||||
# the prelude load, then restore it to user for the program form.
|
||||
"(set-chez-ns! \"clojure.core\")\n"
|
||||
"(load " (string/format "%j" prelude-path) ")\n"
|
||||
# native-wins overrides for overlay predicates that read :jolt/type (char?,
|
||||
# atom?) — must load AFTER the prelude's own def-var! to take effect.
|
||||
"(load \"host/chez/post-prelude.ss\")\n"
|
||||
"(set-chez-ns! \"user\")\n"
|
||||
"(printf \"~a\\n\" (jolt-final-str " final-scm "))\n"))
|
||||
|
||||
(defn eval-e-with-prelude
|
||||
"Run a single user expression `src` on Chez with the full clojure.core prelude
|
||||
(loaded from `prelude-path`). Emits `src` in prelude mode so any core ref
|
||||
resolves via var-deref. Returns [code stdout stderr], or [:emit-err msg \"\"]
|
||||
if the user form itself can't be emitted."
|
||||
[ctx src prelude-path &opt scheme-out]
|
||||
(ensure-clj-emitter ctx)
|
||||
(cset-prelude! ctx true)
|
||||
(def form (in (r/parse-next src) 0))
|
||||
(scan-eval-requires! ctx form)
|
||||
(def res (protect (cemit ctx (backend/analyze-form ctx form))))
|
||||
(cset-prelude! ctx false)
|
||||
(if (not (res 0))
|
||||
[:emit-err (string (res 1)) ""]
|
||||
(let [prog (program-with-prelude prelude-path (res 1))
|
||||
# PID-unique default so concurrent processes (a foreground -e while the
|
||||
# parity gate runs) never read each other's half-written program file.
|
||||
path (or scheme-out (string "/tmp/jolt-chez-e-" (os/getpid) ".ss"))]
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
[code (string/trim out) (string/trim err)])))
|
||||
|
|
@ -1,552 +0,0 @@
|
|||
# Phase 1 — jolt IR -> Chez Scheme emitter (jolt-cf1q.2).
|
||||
#
|
||||
# The new back end: consumes the SAME host-neutral IR (jolt.ir, see
|
||||
# jolt-core/jolt/ir.clj) the live analyzer produces and the Janet backend
|
||||
# consumes, but emits Scheme source text instead of Janet. `host/compile` (Chez
|
||||
# `eval`) turns that into a procedure. Covers the pure-functional + numeric
|
||||
# subset (const/local/var/host/if/do/let/fn/invoke/def/loop/recur) — enough to
|
||||
# run fib/mandelbrot-shaped code through the REAL analyzer.
|
||||
#
|
||||
# IR access mirrors the Janet backend: live IR fields are jolt VALUES — vectors
|
||||
# are persistent (pv), and a nil-valued node densifies to a phm. `nn`/`vv` below
|
||||
# normalize both into Janet structs/arrays, so the same code drives hand-built
|
||||
# IR (the unit tests) and live analyzer output (the driver).
|
||||
|
||||
(import ../../src/jolt/pv :as pv)
|
||||
(import ../../src/jolt/phm :as phm)
|
||||
|
||||
# Normalize a node (phm -> struct) and a vector field (pvec -> array view); both
|
||||
# pass plain Janet values through untouched, so hand-built IR still works.
|
||||
(defn- nn [n] (if (phm/phm? n) (phm/phm-to-struct n) n))
|
||||
(defn- vv [x] (if (pv/pvec? x) (pv/pv->array x) x))
|
||||
|
||||
# Hot clojure.core primitives lowered to native Scheme, mirroring the Janet
|
||||
# backend's native-ops (documented numbers-only relaxation). `=` is the
|
||||
# exactness-aware jolt= from values.ss; inc/dec/not are rt shims; mod/rem/quot
|
||||
# map to Scheme's (correct: Scheme has all three, unlike Janet which lacked quot).
|
||||
(def- native-ops
|
||||
{"+" "+" "-" "-" "*" "*" "/" "/"
|
||||
"<" "<" ">" ">" "<=" "<=" ">=" ">="
|
||||
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
|
||||
"min" "min" "max" "max"
|
||||
"mod" "modulo" "rem" "remainder" "quot" "quotient"
|
||||
# persistent-collection leaf ops (jolt-wgbz) -> rt prims in collections.ss
|
||||
"vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set"
|
||||
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
|
||||
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
|
||||
"empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop"
|
||||
# seq tier (jolt-5pso) -> rt prims in seq.ss
|
||||
"first" "jolt-first" "rest" "jolt-rest" "next" "jolt-next" "seq" "jolt-seq"
|
||||
"cons" "jolt-cons" "list" "jolt-list" "reverse" "jolt-reverse" "last" "jolt-last"
|
||||
"map" "jolt-map" "filter" "jolt-filter" "remove" "jolt-remove"
|
||||
"reduce" "jolt-reduce" "into" "jolt-into" "concat" "jolt-concat" "apply" "jolt-apply"
|
||||
"range" "jolt-range" "take" "jolt-take" "drop" "jolt-drop"
|
||||
"keys" "jolt-keys" "vals" "jolt-vals"
|
||||
"even?" "jolt-even?" "odd?" "jolt-odd?" "pos?" "jolt-pos?" "neg?" "jolt-neg?"
|
||||
"zero?" "jolt-zero?" "identity" "jolt-identity"
|
||||
# exceptions (jolt-vcsl): ex-info builds the tagged map; ex-data/ex-message/
|
||||
# ex-cause are pure-over-get Clojure tier fns (no native-op needed).
|
||||
"ex-info" "jolt-ex-info"})
|
||||
|
||||
# Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
|
||||
# filter / reduce / apply). Each native-op already names a usable Scheme
|
||||
# procedure; arithmetic is the exception — Scheme's +/-/*// return EXACT results
|
||||
# for exact/zero-arg inputs, breaking the all-double model in higher-order use,
|
||||
# so value-position arithmetic routes to the flonum-coercing rt wrappers.
|
||||
(def- core-value-procs
|
||||
(merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"}))
|
||||
|
||||
# Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
|
||||
# this arity. Ops absent from the table are variadic (arith/compare/=, the
|
||||
# collection constructors, conj/assoc/dissoc) and legal at any arity.
|
||||
(def- op-arity
|
||||
{"inc" |(= $ 1) "dec" |(= $ 1) "not" |(= $ 1)
|
||||
"count" |(= $ 1) "empty?" |(= $ 1) "peek" |(= $ 1) "pop" |(= $ 1)
|
||||
"mod" |(= $ 2) "rem" |(= $ 2) "quot" |(= $ 2) "contains?" |(= $ 2)
|
||||
"get" |(or (= $ 2) (= $ 3)) "nth" |(or (= $ 2) (= $ 3))
|
||||
"assoc" |(and (>= $ 3) (odd? $)) "dissoc" |(>= $ 1) "conj" |(>= $ 1)
|
||||
# seq tier arities the shims support
|
||||
"first" |(= $ 1) "rest" |(= $ 1) "next" |(= $ 1) "seq" |(= $ 1)
|
||||
"reverse" |(= $ 1) "last" |(= $ 1) "keys" |(= $ 1) "vals" |(= $ 1)
|
||||
"even?" |(= $ 1) "odd?" |(= $ 1) "pos?" |(= $ 1) "neg?" |(= $ 1)
|
||||
"zero?" |(= $ 1) "identity" |(= $ 1)
|
||||
"cons" |(= $ 2) "filter" |(= $ 2) "remove" |(= $ 2) "into" |(= $ 2)
|
||||
"take" |(= $ 2) "drop" |(= $ 2) "map" |(>= $ 2) "apply" |(>= $ 2)
|
||||
"reduce" |(or (= $ 2) (= $ 3)) "range" |(and (>= $ 0) (<= $ 3))
|
||||
"ex-info" |(or (= $ 2) (= $ 3))})
|
||||
|
||||
# If fnode is a clojure.core (or host) ref to a native-op primitive, return the
|
||||
# Scheme op string — only at an arity where the Scheme op and the jolt fn agree.
|
||||
(defn- native-op [fnode nargs]
|
||||
(def nm (case (get fnode :op)
|
||||
:var (when (= "clojure.core" (get fnode :ns)) (get fnode :name))
|
||||
:host (get fnode :name)
|
||||
nil))
|
||||
(def op (and nm (get native-ops nm)))
|
||||
(def arity-ok (get op-arity nm))
|
||||
(cond
|
||||
(nil? op) nil
|
||||
(and arity-ok (not (arity-ok nargs))) nil
|
||||
op))
|
||||
|
||||
# PRELUDE MODE (inc 3d). The default (subset) mode rejects any clojure.core ref
|
||||
# that isn't a native-op — a clean "out of subset" signal for user-facing `-e`.
|
||||
# When emitting clojure.core ITSELF as a Scheme prelude, core fns reference each
|
||||
# other constantly; those refs must lower to `var-deref` (resolved at runtime
|
||||
# from the prelude's own def-var! forms) instead of being rejected. Host interop
|
||||
# (:host) and unhandled IR ops still error in both modes — those are the real
|
||||
# gaps that need a hand-written RT shim.
|
||||
(var- prelude-mode? false)
|
||||
(defn set-prelude-mode! [on] (set prelude-mode? on))
|
||||
|
||||
(var- recur-target nil)
|
||||
# Munged local names known to hold a procedure (a named fn's self-recursion name).
|
||||
# Calls to these stay DIRECT; any other :local callee routes through jolt-invoke
|
||||
# (dynamic IFn dispatch) — keeps the fib self-call off the invoke fallback.
|
||||
(def- known-procs @{})
|
||||
(var- gensym-n 0)
|
||||
(defn- fresh-label [prefix] (string prefix (++ gensym-n)))
|
||||
|
||||
# Emit a call `(ctor a0 a1 ...)` with the args evaluated LEFT-TO-RIGHT. Chez's
|
||||
# procedure-argument evaluation order is unspecified (and in practice right-to-
|
||||
# left), but Clojure/JVM evaluates collection-literal elements left-to-right, so a
|
||||
# literal like [(read r) (read r)] over side-effecting reads must bind in source
|
||||
# order. Bind each arg to a fresh temp in a let* (sequential) then construct. Only
|
||||
# wraps when there are >= 2 args (0/1 have no ordering to preserve), keeping the
|
||||
# common small-literal output compact (jolt-avt6).
|
||||
(defn- emit-ordered [ctor arg-strs]
|
||||
(if (< (length arg-strs) 2)
|
||||
(string "(" ctor (if (empty? arg-strs) "" (string " " (string/join arg-strs " "))) ")")
|
||||
(let [tmps (map (fn [_] (fresh-label "_o$")) arg-strs)
|
||||
binds (string/join (map (fn [t a] (string "(" t " " a ")")) tmps arg-strs) " ")]
|
||||
(string "(let* (" binds ") (" ctor " " (string/join tmps " ") "))"))))
|
||||
|
||||
# Most jolt names are already valid Scheme identifiers (inc, even?, +, ->str all
|
||||
# are — Scheme allows ! $ % & * + - . / : < = > ? @ ^ _ ~). The one that isn't is
|
||||
# `#`, which jolt auto-gensyms use as a suffix (e.g. p1__0000X4# from #(...)
|
||||
# shorthand) — `#` starts a datum in Scheme, so replace it with `_`.
|
||||
(defn- munge [name] (string/replace-all "#" "_" name))
|
||||
|
||||
(var emit nil) # forward declaration (mutual recursion with the helpers below)
|
||||
|
||||
# A Chez string literal (jolt-x0os). Janet's %j renders a non-ASCII char as raw
|
||||
# UTF-8 bytes (\xC3\xA9) and a control char / DEL as \xHH with NO terminating
|
||||
# semicolon — both forms Chez's reader rejects ("invalid character \ in string
|
||||
# hex escape"). Emit a Chez string where every byte outside printable ASCII
|
||||
# becomes a codepoint hex escape \x<cp>; (UTF-8 decoded for multibyte) and the
|
||||
# named escapes (\n \t \r \" \\) match what both readers accept. For pure
|
||||
# printable ASCII this is byte-identical to %j.
|
||||
(defn- utf8-cp [s i]
|
||||
# decode the UTF-8 sequence starting at byte i -> [codepoint byte-length]
|
||||
(def b (in s i))
|
||||
(cond
|
||||
(< b 0x80) [b 1]
|
||||
(= (band b 0xE0) 0xC0) [(bor (blshift (band b 0x1F) 6)
|
||||
(band (in s (+ i 1)) 0x3F)) 2]
|
||||
(= (band b 0xF0) 0xE0) [(bor (blshift (band b 0x0F) 12)
|
||||
(blshift (band (in s (+ i 1)) 0x3F) 6)
|
||||
(band (in s (+ i 2)) 0x3F)) 3]
|
||||
(= (band b 0xF8) 0xF0) [(bor (blshift (band b 0x07) 18)
|
||||
(blshift (band (in s (+ i 1)) 0x3F) 12)
|
||||
(blshift (band (in s (+ i 2)) 0x3F) 6)
|
||||
(band (in s (+ i 3)) 0x3F)) 4]
|
||||
[b 1])) # malformed lead byte: pass through one byte
|
||||
(defn- chez-str-lit [s]
|
||||
(def out @"\"")
|
||||
(def n (length s))
|
||||
(var i 0)
|
||||
(while (< i n)
|
||||
(def b (in s i))
|
||||
(cond
|
||||
(= b 0x22) (do (buffer/push-string out "\\\"") (++ i))
|
||||
(= b 0x5C) (do (buffer/push-string out "\\\\") (++ i))
|
||||
(= b 0x0A) (do (buffer/push-string out "\\n") (++ i))
|
||||
(= b 0x09) (do (buffer/push-string out "\\t") (++ i))
|
||||
(= b 0x0D) (do (buffer/push-string out "\\r") (++ i))
|
||||
(and (>= b 0x20) (< b 0x7F)) (do (buffer/push-byte out b) (++ i))
|
||||
(< b 0x80) (do (buffer/push-string out (string/format "\\x%x;" b)) (++ i))
|
||||
(let [[cp len] (utf8-cp s i)]
|
||||
(buffer/push-string out (string/format "\\x%x;" cp))
|
||||
(+= i len))))
|
||||
(buffer/push-string out "\"")
|
||||
(string out))
|
||||
|
||||
(defn- emit-const [v]
|
||||
(cond
|
||||
(nil? v) "jolt-nil"
|
||||
(boolean? v) (if v "#t" "#f")
|
||||
# jolt models every number as a double (no ratios/bignums; see reader.janet).
|
||||
# Emit flonums so arithmetic matches the Janet host and Chez doesn't fall into
|
||||
# exploding exact rationals (mandelbrot). Integer-valued -> append ".0".
|
||||
# ##Inf/##-Inf/##NaN: Janet stringifies these as inf/-inf/nan, which are
|
||||
# unbound symbols in Chez — emit Chez's flonum literals instead.
|
||||
(number? v) (cond
|
||||
(= v math/inf) "+inf.0"
|
||||
(= v (- math/inf)) "-inf.0"
|
||||
(not= v v) "+nan.0"
|
||||
(let [s (string v)]
|
||||
(if (or (string/find "." s) (string/find "e" s)) s (string s ".0"))))
|
||||
(string? v) (chez-str-lit v) # quoted+escaped string literal
|
||||
# keyword literal -> (keyword ns name); ns is everything before the first "/"
|
||||
(keyword? v) (let [s (string v) idx (string/find "/" s)]
|
||||
(if (and idx (> idx 0))
|
||||
(string "(keyword " (chez-str-lit (string/slice s 0 idx)) " "
|
||||
(chez-str-lit (string/slice s (inc idx))) ")")
|
||||
(string "(keyword #f " (chez-str-lit s) ")")))
|
||||
# jolt char value {:ch <codepoint> :jolt/type :jolt/char}
|
||||
(and (struct? v) (= :jolt/char (get v :jolt/type)))
|
||||
(string "(integer->char " (get v :ch) ")")
|
||||
(errorf "emit-const: unsupported literal %p" v)))
|
||||
|
||||
# Quoted literals (jolt-u8j7). A :quote node's :form is the RAW reader form (a
|
||||
# Janet value): scalars are Janet natives, a symbol is {:jolt/type :symbol …}, a
|
||||
# list is an array, a vector a tuple, a map a struct/phm, a set a tagged struct.
|
||||
# Reconstruct each as the matching Chez RT constructor — the runtime value of a
|
||||
# quote is just that literal data (the interpreter returns the reader form
|
||||
# verbatim; the Janet backend Janet-quotes it; here we rebuild it on the RT).
|
||||
(var emit-quoted nil)
|
||||
(defn- emit-quoted-map [m]
|
||||
(def flat @[])
|
||||
(eachp [k v] m (array/push flat (emit-quoted k)) (array/push flat (emit-quoted v)))
|
||||
(string "(jolt-hash-map " (string/join flat " ") ")"))
|
||||
(set emit-quoted (fn emit-quoted [form]
|
||||
(cond
|
||||
# scalars emit-const already lowers (nil/bool/number/string/keyword/char)
|
||||
(or (nil? form) (boolean? form) (number? form) (string? form) (keyword? form))
|
||||
(emit-const form)
|
||||
(and (struct? form) (= :symbol (get form :jolt/type)))
|
||||
(let [ns (get form :ns)
|
||||
m (get form :meta)]
|
||||
(if (and m (not (nil? m)) (> (length m) 0))
|
||||
# carry reader metadata (^:foo bar) onto the quoted symbol so (meta 'x) sees it
|
||||
(string "(jolt-symbol/meta " (if ns (chez-str-lit ns) "#f") " "
|
||||
(chez-str-lit (get form :name)) " " (emit-quoted m) ")")
|
||||
(string "(jolt-symbol " (if ns (chez-str-lit ns) "#f") " "
|
||||
(chez-str-lit (get form :name)) ")")))
|
||||
(and (struct? form) (= :jolt/char (get form :jolt/type))) (emit-const form)
|
||||
(and (struct? form) (= :jolt/set (get form :jolt/type)))
|
||||
(string "(jolt-hash-set " (string/join (map emit-quoted (get form :value)) " ") ")")
|
||||
(array? form) (string "(jolt-list " (string/join (map emit-quoted form) " ") ")")
|
||||
(tuple? form) (string "(jolt-vector " (string/join (map emit-quoted form) " ") ")")
|
||||
(phm/phm? form) (emit-quoted-map (phm/phm-to-struct form))
|
||||
(or (struct? form) (table? form)) (emit-quoted-map form)
|
||||
(errorf "emit-quoted: unsupported quoted form %p" form))))
|
||||
|
||||
# A def's :meta is a jolt map value (Janet struct/table or phm). Non-empty?
|
||||
# (a plain def carries {} — keep it on the lean def-var! path).
|
||||
(defn- jmeta-nonempty? [m]
|
||||
(cond
|
||||
(nil? m) false
|
||||
(phm/phm? m) (> (length (phm/phm-to-struct m)) 0)
|
||||
(or (struct? m) (table? m)) (> (length m) 0)
|
||||
false))
|
||||
|
||||
(defn- emit-binding [b]
|
||||
(def b (vv b))
|
||||
(string "(" (munge (get b 0)) " " (emit (get b 1)) ")"))
|
||||
|
||||
# letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
|
||||
# Scheme `letrec*` binds them so each sees its siblings (and itself), which a
|
||||
# sequential let* can't. A plain let uses let* (Clojure let binds sequentially).
|
||||
(defn- emit-let [node]
|
||||
(def kw (if (get node :letrec) "letrec*" "let*"))
|
||||
(string "(" kw " (" (string/join (map emit-binding (vv (get node :bindings))) " ") ") "
|
||||
(emit (get node :body)) ")"))
|
||||
|
||||
(defn- emit-loop [node]
|
||||
(def label (fresh-label "loop"))
|
||||
(def pairs (map vv (vv (get node :bindings))))
|
||||
(def names (map |(munge (get $ 0)) pairs))
|
||||
# inits are evaluated in the OUTER scope (recur-target unchanged) and, like
|
||||
# Clojure loop/let, SEQUENTIALLY — a later init sees earlier bindings. Scheme's
|
||||
# named `let` binds in parallel, so wrap a sequential let* around the loop.
|
||||
(def inits (map |(emit (get $ 1)) pairs))
|
||||
(def seq-bs (string/join (map (fn [n i] (string "(" n " " i ")")) names inits) " "))
|
||||
(def rebinds (string/join (map (fn [n] (string "(" n " " n ")")) names) " "))
|
||||
(def prev recur-target)
|
||||
(set recur-target label)
|
||||
(def body (emit (get node :body)))
|
||||
(set recur-target prev)
|
||||
(string "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))"))
|
||||
|
||||
(defn- emit-recur [node]
|
||||
(unless recur-target (error "emit: recur outside a loop/fn target"))
|
||||
(string "(" recur-target " " (string/join (map emit (vv (get node :args))) " ") ")"))
|
||||
|
||||
# One arity -> a Scheme lambda param-list + a named-let-wrapped body. The named
|
||||
# let lets fn-level `recur` rebind this arity's params. A variadic arity takes a
|
||||
# Scheme rest arg (proper list) and the let binding coerces it to a jolt seq
|
||||
# (nil when empty — Clojure's rest semantics; list->cseq already does this); recur
|
||||
# carries the rest seq directly, and the named let's init only runs on first
|
||||
# entry, so the coercion isn't re-applied on a recur.
|
||||
# try/catch/finally (jolt-vcsl). throw raises the jolt value RAW (jolt-throw =
|
||||
# Scheme `raise`), mirroring the Janet COMPILED backend (which does `(error v)`,
|
||||
# no :jolt/exception envelope) — so catch binds the value directly, no unwrap.
|
||||
# catch lowers to `guard` with an `else` clause (catch-all: the IR drops the
|
||||
# class), finally to `dynamic-wind`'s after-thunk (runs on success, catch, and
|
||||
# escape — Clojure finally semantics). Both keys are optional on the node.
|
||||
(defn- emit-try [node]
|
||||
(def core
|
||||
(if-let [cs (get node :catch-sym)]
|
||||
(string "(guard (" (munge cs) " (else " (emit (get node :catch-body)) ")) "
|
||||
(emit (get node :body)) ")")
|
||||
(emit (get node :body))))
|
||||
(if-let [fin (get node :finally)]
|
||||
(string "(dynamic-wind (lambda () #f) (lambda () " core ") (lambda () " (emit fin) "))")
|
||||
core))
|
||||
|
||||
(defn- emit-arity-clause [a]
|
||||
(def params (map munge (vv (get a :params))))
|
||||
(def restp (when-let [r (get a :rest)] (munge r)))
|
||||
(def label (fresh-label "fnrec"))
|
||||
(def prev recur-target)
|
||||
(set recur-target label)
|
||||
(def body (emit (get a :body)))
|
||||
(set recur-target prev)
|
||||
(def paramlist
|
||||
(cond
|
||||
# only a rest param: Scheme formals are the bare symbol, not `( . xs)`
|
||||
(and restp (empty? params)) restp
|
||||
restp (string "(" (string/join params " ") " . " restp ")")
|
||||
(string "(" (string/join params " ") ")")))
|
||||
(def binds
|
||||
(if restp
|
||||
[;(map (fn [p] (string "(" p " " p ")")) params)
|
||||
(string "(" restp " (list->cseq " restp "))")]
|
||||
(map (fn [p] (string "(" p " " p ")")) params)))
|
||||
[paramlist (string "(let " label " (" (string/join binds " ") ") " body ")")])
|
||||
|
||||
(defn- emit-fn [node]
|
||||
(def arities (map nn (vv (get node :arities))))
|
||||
# a named fn binds its own name as a known-procedure local across ALL arities,
|
||||
# so self-calls (to any arity) emit directly rather than via jolt-invoke; the
|
||||
# case-lambda value dispatches on argument count.
|
||||
(def self (when-let [nm (get node :name)] (munge nm)))
|
||||
(def had-self (and self (get known-procs self)))
|
||||
(when self (put known-procs self true))
|
||||
# Restore known-procs even when a body is uncompilable: a throw mid-emit must
|
||||
# not leak this fn's name into the module global, or a LATER case binding the
|
||||
# same name to a keyword/coll would emit a direct call to a non-procedure
|
||||
# (runtime crash). The corpus probe shares one emit state across all cases, so
|
||||
# this leak is order-dependent and otherwise invisible in single-case tests.
|
||||
(def clauses
|
||||
(try (map emit-arity-clause arities)
|
||||
([err fib]
|
||||
(unless had-self (when self (put known-procs self nil)))
|
||||
(propagate err fib))))
|
||||
(unless had-self (when self (put known-procs self nil)))
|
||||
(def lambda
|
||||
(if (= 1 (length clauses))
|
||||
(let [[pl body] (first clauses)] (string "(lambda " pl " " body ")"))
|
||||
(string "(case-lambda "
|
||||
(string/join (map (fn [c] (string "(" (get c 0) " " (get c 1) ")")) clauses) " ")
|
||||
")")))
|
||||
# A named fn (defn / (fn self [..])) references itself by name — the analyzer
|
||||
# binds that name as a :local in the body. letrec makes the name visible to the
|
||||
# lambda so self-calls resolve (recur stays a separate self-call to the arity).
|
||||
(if-let [nm (get node :name)]
|
||||
(let [m (munge nm)] (string "(letrec ((" m " " lambda ")) " m ")"))
|
||||
lambda))
|
||||
|
||||
# The Clojure stdlib (clojure.core, clojure.math, clojure.string, …) and host
|
||||
# interop (Math/sqrt etc.) have no implementation on Chez yet (Phase 2+). A
|
||||
# reference to one — except a clojure.core call lowered to a native op — is
|
||||
# genuinely uncompilable here. Reject it at emit time (a clean "out of subset"
|
||||
# signal) rather than emitting a var-deref that resolves to nil and fails
|
||||
# confusingly at runtime.
|
||||
(defn- stdlib-var? [n]
|
||||
(and (= :var (get n :op)) (string/has-prefix? "clojure." (or (get n :ns) ""))))
|
||||
|
||||
# Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method`
|
||||
# call on any other method is out of subset until shimmed — keep this in sync.
|
||||
# `.write` is NOT here: StringWriter (a jhost, host-static.ss) handles .write via
|
||||
# record-method-dispatch; the old jolt-host-call "write" fast-path (display to a
|
||||
# port) would mis-route a writer to `(display x jhost)`. Keep the File-op methods.
|
||||
(def- supported-host-methods {"isDirectory" true "listFiles" true})
|
||||
|
||||
# jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg
|
||||
# (so (< :kw) is true), but Scheme's < demands a number even there — special-case.
|
||||
(def- cmp1-ops {"<" true ">" true "<=" true ">=" true})
|
||||
|
||||
# IFn dispatch for a LITERAL callee (Clojure's "value as fn"): a keyword looks
|
||||
# itself up in its arg ((:k m) = (get m :k)); a map/set/vector literal looks up
|
||||
# its arg ((m :k) = (get m :k)). This static lowering avoids the jolt-invoke
|
||||
# dispatch overhead; the dynamic case (a local holding a keyword/coll/fn) routes
|
||||
# through jolt-invoke in the emit-invoke fallback below.
|
||||
(defn- ifn-kind [fnode]
|
||||
(case (get fnode :op)
|
||||
:const (when (keyword? (get fnode :val)) :keyword)
|
||||
:map :coll :set :coll :vector :coll
|
||||
nil))
|
||||
|
||||
(defn- emit-invoke [node]
|
||||
(def fnode (nn (get node :fn)))
|
||||
(def args (map emit (vv (get node :args))))
|
||||
(def nop (native-op fnode (length args)))
|
||||
(def kind (ifn-kind fnode))
|
||||
(def default (if (> (length args) 1) (string " " (in args 1)) ""))
|
||||
(cond
|
||||
# zero-arg + / * : Scheme's identity is the EXACT 0 / 1, but jolt models every
|
||||
# number as a double, so emit the flonum identity to keep (= 0 (+)) true.
|
||||
(and nop (empty? args) (= nop "+")) "0.0"
|
||||
(and nop (empty? args) (= nop "*")) "1.0"
|
||||
(and nop (= 1 (length args)) (get cmp1-ops nop)) (string "(begin " (first args) " #t)")
|
||||
nop (string "(" nop " " (string/join args " ") ")")
|
||||
# (:k coll [default]) -> (jolt-get coll :k [default])
|
||||
(= kind :keyword) (string "(jolt-get " (first args) " " (emit fnode) default ")")
|
||||
# (coll k [default]) -> (jolt-get coll k [default])
|
||||
(= kind :coll) (string "(jolt-get " (emit fnode) " " (first args) default ")")
|
||||
(and (stdlib-var? fnode) (not prelude-mode?))
|
||||
(errorf "emit: unsupported stdlib fn `%s/%s` (no core on Chez yet)" (get fnode :ns) (get fnode :name))
|
||||
# static method call (Class/method arg*) -> (host-static-call "Class"
|
||||
# "method" arg*). host-static.ss resolves the method from the class-statics
|
||||
# registry and applies it (jolt-avt6).
|
||||
(= :host-static (get fnode :op))
|
||||
(string "(host-static-call " (chez-str-lit (get fnode :class)) " "
|
||||
(chez-str-lit (get fnode :member))
|
||||
(if (empty? args) "" (string " " (string/join args " "))) ")")
|
||||
(= :host (get fnode :op))
|
||||
(errorf "emit: unsupported host call `%s` (no host interop on Chez yet)" (get fnode :name))
|
||||
# a :local callee that isn't a known procedure (a let/param binding holding a
|
||||
# keyword/coll/fn) -> dynamic IFn dispatch. Excludes the named-fn self-call.
|
||||
(and (= :local (get fnode :op)) (not (get known-procs (munge (get fnode :name)))))
|
||||
(string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")")
|
||||
# a late-bound :var call head can hold a plain procedure OR a non-applicable
|
||||
# value the RT dispatches (a multimethod record, a keyword/coll IFn) — route it
|
||||
# through jolt-invoke so all of those work. Transparent for a procedure
|
||||
# (jolt-invoke just applies it); the hot self-recursive call is a :local
|
||||
# known-proc above, so it stays a direct call.
|
||||
(= :var (get fnode :op))
|
||||
(string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")")
|
||||
# a computed callee (an :invoke / :if / :do expression) can yield ANY IFn —
|
||||
# a procedure, but also a coll/keyword/multimethod (e.g. ((sorted-map …) k)).
|
||||
# Route through jolt-invoke: transparent for a procedure, correct for the rest.
|
||||
(string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")")))
|
||||
|
||||
# Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an
|
||||
# :if test built from them needs no jolt-truthy? wrapper (jolt-nkcb). Comparisons
|
||||
# and `not` are #t/#f; the numeric/collection predicates bottom out in fx=?/>/etc.
|
||||
(def- bool-returning-ops
|
||||
{"<" true "<=" true ">" true ">=" true "jolt=" true "jolt-not" true
|
||||
"jolt-even?" true "jolt-odd?" true "jolt-pos?" true "jolt-neg?" true
|
||||
"jolt-zero?" true "jolt-empty?" true "jolt-contains?" true})
|
||||
|
||||
# Does this IR node emit to an expression that yields a Scheme boolean? Used to
|
||||
# drop the redundant jolt-truthy? on an :if test — sound because jolt-truthy? of
|
||||
# #t/#f is the identity. Conservative: only a boolean const or an :invoke that
|
||||
# lowers to a bool-returning native op (any other shape keeps the wrapper).
|
||||
(defn- returns-scheme-bool? [node]
|
||||
(def node (nn node))
|
||||
(cond
|
||||
(and (= :const (get node :op)) (boolean? (get node :val))) true
|
||||
(= :invoke (get node :op))
|
||||
(let [nop (native-op (nn (get node :fn)) (length (vv (get node :args))))]
|
||||
(truthy? (and nop (get bool-returning-ops nop))))
|
||||
false))
|
||||
|
||||
(set emit (fn emit [node]
|
||||
(def node (nn node))
|
||||
(case (get node :op)
|
||||
:const (emit-const (get node :val))
|
||||
:local (munge (get node :name))
|
||||
# late-bound var: read the cell's current root at use time. A value-position
|
||||
# ref to a clojure.core fn the RT provides (e.g. passing `inc`/`even?`/`:k` to
|
||||
# (map inc xs)) lowers to the RT procedure — native-ops names a real Scheme
|
||||
# procedure for each. Any OTHER stdlib var (clojure.string, an unimplemented
|
||||
# core fn) has no impl on Chez yet, so it's out of subset.
|
||||
:var (let [core-proc (and (= "clojure.core" (get node :ns)) (get core-value-procs (get node :name)))]
|
||||
(cond
|
||||
core-proc core-proc
|
||||
(and (stdlib-var? node) (not prelude-mode?))
|
||||
(errorf "emit: unsupported stdlib ref `%s/%s` (no core on Chez yet)" (get node :ns) (get node :name))
|
||||
(string "(var-deref " (chez-str-lit (get node :ns)) " "
|
||||
(chez-str-lit (get node :name)) ")")))
|
||||
:host (errorf "emit: unsupported host ref `%s` (no host interop on Chez yet)" (get node :name))
|
||||
# value-position static ref (Class/member, e.g. Long/MAX_VALUE, System/exit
|
||||
# passed as a value) -> the registered static value/procedure (host-static.ss).
|
||||
:host-static (string "(host-static-ref " (chez-str-lit (get node :class)) " "
|
||||
(chez-str-lit (get node :member)) ")")
|
||||
# constructor (Class. args*) / (new Class args*) -> (host-new "Class" args*).
|
||||
:host-new (string "(host-new " (chez-str-lit (get node :class))
|
||||
(let [args (map emit (vv (get node :args)))]
|
||||
(if (empty? args) "" (string " " (string/join args " ")))) ")")
|
||||
# (var x) / #'x -> the var cell itself (the rt.ss var-cell, a first-class var
|
||||
# object). var?/var-get/deref/invoke/= operate on it (vars.ss).
|
||||
:the-var (string "(jolt-var " (chez-str-lit (get node :ns)) " " (chez-str-lit (get node :name)) ")")
|
||||
:if (let [test (get node :test)
|
||||
t (if (returns-scheme-bool? test) (emit test)
|
||||
(string "(jolt-truthy? " (emit test) ")"))]
|
||||
(string "(if " t " " (emit (get node :then)) " " (emit (get node :else)) ")"))
|
||||
:do (string "(begin "
|
||||
(string/join (map emit (vv (get node :statements))) " ")
|
||||
(if (empty? (vv (get node :statements))) "" " ")
|
||||
(emit (get node :ret)) ")")
|
||||
:invoke (emit-invoke node)
|
||||
# collection literals -> rt constructors (collections.ss). Elements evaluate
|
||||
# LEFT-TO-RIGHT (emit-ordered) to match Clojure for side-effecting elements.
|
||||
:vector (emit-ordered "jolt-vector" (map emit (vv (get node :items))))
|
||||
:set (emit-ordered "jolt-hash-set" (map emit (vv (get node :items))))
|
||||
:map (let [flat @[]]
|
||||
(each p (vv (get node :pairs))
|
||||
(def p (vv p))
|
||||
(array/push flat (emit (get p 0)))
|
||||
(array/push flat (emit (get p 1))))
|
||||
(emit-ordered "jolt-hash-map" flat))
|
||||
:let (emit-let node)
|
||||
:loop (emit-loop node)
|
||||
:recur (emit-recur node)
|
||||
:throw (string "(jolt-throw " (emit (get node :expr)) ")")
|
||||
:try (emit-try node)
|
||||
:quote (emit-quoted (get node :form))
|
||||
# regex literal #"…" -> a jolt-regex value (regex.ss compiles the source via
|
||||
# the vendored irregex). chez-str-lit quotes+escapes the source; a backslash
|
||||
# in the pattern becomes \\ in the Scheme string literal -> the 1-char
|
||||
# backslash irregex expects (same escaping emit-const uses for strings).
|
||||
:regex (string "(jolt-regex " (chez-str-lit (get node :source)) ")")
|
||||
# #inst / #uuid literals -> a runtime inst / uuid value (inst-time.ss /
|
||||
# natives-misc.ss). The source string round-trips through chez-str-lit.
|
||||
:inst (string "(jolt-inst-from-string " (chez-str-lit (get node :source)) ")")
|
||||
:uuid (string "(jolt-uuid-from-string " (chez-str-lit (get node :source)) ")")
|
||||
# host interop (jolt-0kf5): (.method target arg*) -> (jolt-host-call "method"
|
||||
# target arg*). Only the methods the RT dispatcher (rt.ss) actually shims are
|
||||
# IN the subset; any other method is out of subset (a clean emit-time reject,
|
||||
# like an unimplemented stdlib fn), so it doesn't masquerade as a compiled-but-
|
||||
# broken divergence. The Janet back end punts ALL :host-call to the interpreter.
|
||||
:host-call (let [m (get node :method)
|
||||
target (emit (get node :target))
|
||||
args (map emit (vv (get node :args)))]
|
||||
(if (get supported-host-methods m)
|
||||
(string "(jolt-host-call " (chez-str-lit m) " "
|
||||
target (if (empty? args) "" (string " " (string/join args " "))) ")")
|
||||
# a non-shimmed method: dispatch at runtime by the target's type
|
||||
# — a record/reify protocol method (jolt-jgoc). On a non-record
|
||||
# host value this errors (was an emit-fail before, so no new
|
||||
# divergence), but it lets (.protoMethod record …) compile.
|
||||
(string "(record-method-dispatch " target " " (chez-str-lit m)
|
||||
" (jolt-vector" (if (empty? args) "" (string " " (string/join args " "))) "))")))
|
||||
:fn (emit-fn node)
|
||||
# (def name) with no init (declare): reserve the var cell (declare-var!
|
||||
# doesn't clobber an existing root) so a forward reference resolves.
|
||||
# A def with non-empty reader metadata (^:private / ^Type tag / docstring ->
|
||||
# {:doc}) lowers to def-var-with-meta! so (meta (var x)) sees it (jolt-zikh).
|
||||
:def (cond
|
||||
(get node :no-init)
|
||||
(string "(declare-var! " (chez-str-lit (get node :ns)) " "
|
||||
(chez-str-lit (get node :name)) ")")
|
||||
(jmeta-nonempty? (get node :meta))
|
||||
(string "(def-var-with-meta! " (chez-str-lit (get node :ns)) " "
|
||||
(chez-str-lit (get node :name)) " " (emit (get node :init)) " "
|
||||
(emit-quoted (get node :meta)) ")")
|
||||
(string "(def-var! " (chez-str-lit (get node :ns)) " "
|
||||
(chez-str-lit (get node :name)) " " (emit (get node :init)) ")"))
|
||||
(errorf "emit: unhandled op %p" (get node :op)))))
|
||||
|
||||
# Wrap emitted top-level forms into a runnable Chez program: load the RT, then
|
||||
# the def forms, then print `final` (an emitted Scheme expr string) via jolt's
|
||||
# number/value printing.
|
||||
(defn program [forms-scheme final]
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
(string/join forms-scheme "\n") "\n"
|
||||
"(printf \"~a\\n\" (jolt-final-str " final "))\n"))
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
# -e-capable jolt-chez (jolt-9ziu): the Option-2 back end as a runnable CLI.
|
||||
#
|
||||
# Analysis runs on Janet (the portable analyzer); EXECUTION runs on Chez with the
|
||||
# full clojure.core assembled as a Scheme prelude (driver/emit-core-prelude). The
|
||||
# prelude is assembled once and cached on disk keyed by a fingerprint of the core
|
||||
# sources + the Chez RT/emitter, so repeated invocations (e.g. the run-corpus.janet
|
||||
# gate, one subprocess per case) reuse it.
|
||||
#
|
||||
# Usage (the run-corpus.janet boundary): jolt-chez -e "EXPR"
|
||||
# Run from the repo root (the prelude loads host/chez/rt.ss by relative path).
|
||||
(import ../../src/jolt/api :as api)
|
||||
(import ./driver :as d)
|
||||
|
||||
(defn fingerprint []
|
||||
# Hash the inputs that shape the prelude: the core tiers + the emitter + the
|
||||
# Chez RT shims. Any change invalidates the cached prelude.
|
||||
(def parts @[])
|
||||
(each tf d/core-tier-files
|
||||
(array/push parts (slurp (string "jolt-core/clojure/core/" tf ".clj"))))
|
||||
(each f ["jolt-core/jolt/backend_scheme.clj" "src/jolt/host_iface.janet"
|
||||
"host/chez/emit.janet" "host/chez/driver.janet" "host/chez/rt.ss"
|
||||
"host/chez/values.ss" "host/chez/collections.ss" "host/chez/seq.ss"
|
||||
"host/chez/atoms.ss" "host/chez/predicates.ss" "host/chez/regex.ss"
|
||||
"host/chez/ns.ss" "host/chez/post-prelude.ss" "host/chez/natives-meta.ss"
|
||||
"host/chez/natives-str.ss" "host/chez/records.ss"
|
||||
"host/chez/host-class.ss" "host/chez/io.ss"
|
||||
"host/chez/inst-time.ss" "host/chez/reader.ss" "host/chez/math.ss"
|
||||
"host/chez/syntax-quote.ss"
|
||||
"host/chez/host-static.ss" "host/chez/dot-forms.ss"
|
||||
"src/jolt/clojure/string.clj" "src/jolt/clojure/walk.clj"
|
||||
"src/jolt/clojure/template.clj" "src/jolt/clojure/edn.clj"
|
||||
"src/jolt/clojure/set.clj" "src/jolt/clojure/pprint.clj"]
|
||||
(array/push parts (slurp f)))
|
||||
(string/slice (string (hash (string/join parts))) 0))
|
||||
|
||||
(defn ensure-prelude [ctx]
|
||||
(def dir (or (os/getenv "JOLT_IMAGE_CACHE_DIR") (os/getenv "TMPDIR") "/tmp"))
|
||||
(def path (string dir "/jolt-chez-prelude-" (fingerprint) ".ss"))
|
||||
(unless (os/stat path)
|
||||
(def [scm _ _] (d/emit-core-prelude ctx))
|
||||
(spit path scm))
|
||||
path)
|
||||
|
||||
(defn main [& argv]
|
||||
# argv: [script "-e" EXPR]
|
||||
(def args (drop 1 argv))
|
||||
(unless (and (= (length args) 2) (= (first args) "-e"))
|
||||
(eprint "usage: jolt-chez -e EXPR")
|
||||
(os/exit 2))
|
||||
(def src (in args 1))
|
||||
(def ctx (api/init-cached {:compile? true}))
|
||||
# late-bind unresolved symbols (no interpreter to punt to) so defmulti/defmethod
|
||||
# forward references lower to a var-deref (jolt-9ls5), matching d/make-ctx.
|
||||
(put (get ctx :env) :late-bind-unresolved? true)
|
||||
(def prelude-path (ensure-prelude ctx))
|
||||
(def [code out err] (d/eval-e-with-prelude ctx src prelude-path))
|
||||
(when (= code :emit-err)
|
||||
(eprint "jolt-chez: cannot compile: " out)
|
||||
(os/exit 1))
|
||||
(unless (= "" out) (print out))
|
||||
(unless (= "" err) (eprint err))
|
||||
(os/exit code))
|
||||
Loading…
Add table
Add a link
Reference in a new issue