self-host: compile the analyzer (full-suite parity, fast); fix interp multi-arity
The portable analyzer now refers the host contract + IR ctors unqualified (host form predicates renamed form-* to dodge core-renames), so the bootstrap compiles it via its plain :var path — no qualified-ref compilation needed. ensure-analyzer compile-loads jolt.ir + jolt.analyzer as native bytecode. Result: the self-hosted pipeline (portable Clojure analyzer -> IR -> Janet back end) runs the FULL clojure-test-suite at 3913 pass — parity with the interpreter baseline — and fast (no timeouts), via JOLT_SELFHOST=1. Conformance 218/218. Also fixes a real interpreter bug: multi-arity dispatch stored the variadic clause by fixed-count (colliding) and only matched exact counts, so (f a b c..) on an [a b & more] clause threw. Now the variadic clause dispatches for any count >= its fixed arity. Remaining (jolt-4xc): the compiled analyzer still errors analyzing a multi-arity fn literal (falls back to the interpreter, now correct); compiling that is the last coverage gap before flipping the self-hosted pipeline on by default.
This commit is contained in:
Yogthos
parent
98bf389f82
commit
06d5f51d4a
4 changed files with 134 additions and 109 deletions
|
|
@ -1,29 +1,34 @@
|
|||
(ns jolt.analyzer
|
||||
"Portable Clojure analyzer: reader form -> host-neutral IR (see jolt.ir).
|
||||
|
||||
Pure jolt-core — depends only on the host contract (jolt.host) for form
|
||||
introspection and symbol/macro resolution, never on Janet. ctx is an opaque
|
||||
Pure jolt-core — depends only on the host contract (jolt.host) and IR
|
||||
constructors (jolt.ir), never on Janet. The contract fns are referred unqualified
|
||||
(host form predicates are `form-*` to avoid colliding with clojure.core), so the
|
||||
bootstrap can compile this namespace via its plain :var path. ctx is an opaque
|
||||
host handle threaded to the contract fns; the analyzer never inspects it.
|
||||
|
||||
Coverage grows toward compiler.janet; unsupported forms throw :jolt/uncompilable
|
||||
so the caller falls back to the interpreter (the hybrid contract).
|
||||
|
||||
`env` carries lexical state: {:locals #{names} :recur recur-target-name|nil}."
|
||||
(:require [jolt.ir :as ir]
|
||||
[jolt.host :as h]))
|
||||
(:require [jolt.ir :refer [const local var-ref host-ref if-node do-node invoke
|
||||
def-node let-node fn-node vector-node map-node
|
||||
quote-node throw-node]]
|
||||
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
|
||||
form-vec? form-map? form-set? form-char?
|
||||
form-literal? form-elements form-vec-items
|
||||
form-map-pairs form-special? compile-ns
|
||||
form-macro? form-expand-1 resolve-global
|
||||
host-intern!]]))
|
||||
|
||||
(declare analyze analyze-fn analyze-try)
|
||||
|
||||
;; Special forms the analyzer compiles itself. Anything else h/special? returns
|
||||
;; true for is left to the interpreter via uncompilable.
|
||||
(def ^:private handled
|
||||
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"})
|
||||
|
||||
(defn- uncompilable [why]
|
||||
(throw (str "jolt/uncompilable: " why)))
|
||||
|
||||
;; Fresh recur-target names. A plain counter (analyzer is single-threaded during
|
||||
;; a compile); the leading "_r$" can't appear in source so it never collides.
|
||||
(def ^:private gensym-counter (atom 0))
|
||||
(defn- gen-name [prefix]
|
||||
(let [n @gensym-counter]
|
||||
|
|
@ -31,57 +36,51 @@
|
|||
(str "_r$" prefix n)))
|
||||
|
||||
(defn- empty-env [] {:locals #{} :recur nil})
|
||||
(defn- locals [env] (:locals env))
|
||||
(defn- local? [env nm] (contains? (:locals env) nm))
|
||||
(defn- add-locals [env names] (update env :locals #(reduce conj % names)))
|
||||
(defn- with-recur [env name] (assoc env :recur name))
|
||||
|
||||
(defn- analyze-seq
|
||||
"Analyze a body of forms into IR statements+ret (a :do, or the single node)."
|
||||
[ctx forms env]
|
||||
(defn- analyze-seq [ctx forms env]
|
||||
(let [v (mapv #(analyze ctx % env) forms)
|
||||
n (count v)]
|
||||
(cond
|
||||
(zero? n) (ir/const nil)
|
||||
(zero? n) (const nil)
|
||||
(= 1 n) (first v)
|
||||
:else (ir/do-node (subvec v 0 (dec n)) (peek v)))))
|
||||
:else (do-node (subvec v 0 (dec n)) (peek v)))))
|
||||
|
||||
(defn- analyze-bindings
|
||||
"let*/loop* binding vector -> [pairs env'] where pairs is [[name init-ir]...]
|
||||
and env' has the bound names in scope (each init sees the prior bindings)."
|
||||
[ctx bvec env]
|
||||
(defn- analyze-bindings [ctx bvec env]
|
||||
(loop [i 0 env env pairs []]
|
||||
(if (< i (count bvec))
|
||||
(let [bsym (nth bvec i)]
|
||||
(when-not (h/sym? bsym) (uncompilable "destructuring binding"))
|
||||
(let [nm (h/sym-name bsym)
|
||||
(when-not (form-sym? bsym) (uncompilable "destructuring binding"))
|
||||
(let [nm (form-sym-name bsym)
|
||||
init (analyze ctx (nth bvec (inc i)) env)]
|
||||
(recur (+ i 2) (add-locals env [nm]) (conj pairs [nm init]))))
|
||||
[pairs env])))
|
||||
|
||||
(defn- analyze-special [ctx op items env]
|
||||
(case op
|
||||
"quote" (ir/quote-node (second items))
|
||||
"if" (ir/if-node (analyze ctx (nth items 1) env)
|
||||
(analyze ctx (nth items 2) env)
|
||||
(if (> (count items) 3)
|
||||
(analyze ctx (nth items 3) env)
|
||||
(ir/const nil)))
|
||||
"quote" (quote-node (second items))
|
||||
"if" (if-node (analyze ctx (nth items 1) env)
|
||||
(analyze ctx (nth items 2) env)
|
||||
(if (> (count items) 3)
|
||||
(analyze ctx (nth items 3) env)
|
||||
(const nil)))
|
||||
"do" (analyze-seq ctx (rest items) env)
|
||||
"throw" (ir/throw-node (analyze ctx (nth items 1) env))
|
||||
"throw" (throw-node (analyze ctx (nth items 1) env))
|
||||
"def" (let [name-sym (nth items 1)
|
||||
nm (h/sym-name name-sym)
|
||||
cur (h/current-ns ctx)]
|
||||
(h/intern! ctx cur nm)
|
||||
(ir/def-node cur nm (analyze ctx (nth items 2) env)))
|
||||
"let*" (let [bvec (vec (h/vector-items (nth items 1)))
|
||||
[pairs env*] (analyze-bindings ctx bvec env)]
|
||||
(ir/let-node pairs (analyze-seq ctx (drop 2 items) env*)))
|
||||
"loop*" (let [bvec (vec (h/vector-items (nth items 1)))
|
||||
nm (form-sym-name name-sym)
|
||||
cur (compile-ns ctx)]
|
||||
(host-intern! ctx cur nm)
|
||||
(def-node cur nm (analyze ctx (nth items 2) env)))
|
||||
"let*" (let [bvec (vec (form-vec-items (nth items 1)))
|
||||
r (analyze-bindings ctx bvec env)]
|
||||
(let-node (first r) (analyze-seq ctx (drop 2 items) (second r))))
|
||||
"loop*" (let [bvec (vec (form-vec-items (nth items 1)))
|
||||
rname (gen-name "loop")
|
||||
[pairs env*] (analyze-bindings ctx bvec env)
|
||||
env** (with-recur env* rname)]
|
||||
{:op :loop :recur-name rname :bindings pairs
|
||||
r (analyze-bindings ctx bvec env)
|
||||
env** (with-recur (second r) rname)]
|
||||
{:op :loop :recur-name rname :bindings (first r)
|
||||
:body (analyze-seq ctx (drop 2 items) env**)})
|
||||
"recur" (let [rt (:recur env)]
|
||||
(when-not rt (uncompilable "recur outside loop/fn"))
|
||||
|
|
@ -92,22 +91,21 @@
|
|||
(uncompilable (str "special form " op))))
|
||||
|
||||
(defn- analyze-try [ctx items env]
|
||||
;; (try body... (catch Class e handler...) (finally cleanup...))
|
||||
(let [clauses (rest items)
|
||||
body (atom [])
|
||||
catch-sym (atom nil)
|
||||
catch-body (atom nil)
|
||||
finally-body (atom nil)]
|
||||
(doseq [c clauses]
|
||||
(let [head (when (h/list? c) (first (vec (h/elements c))))
|
||||
hname (when (and head (h/sym? head)) (h/sym-name head))]
|
||||
(let [head (when (form-list? c) (first (vec (form-elements c))))
|
||||
hname (when (and head (form-sym? head)) (form-sym-name head))]
|
||||
(cond
|
||||
(= hname "catch")
|
||||
(let [cl (vec (h/elements c))]
|
||||
(reset! catch-sym (h/sym-name (nth cl 2)))
|
||||
(let [cl (vec (form-elements c))]
|
||||
(reset! catch-sym (form-sym-name (nth cl 2)))
|
||||
(reset! catch-body (drop 3 cl)))
|
||||
(= hname "finally")
|
||||
(reset! finally-body (rest (vec (h/elements c))))
|
||||
(reset! finally-body (rest (vec (form-elements c))))
|
||||
:else (swap! body conj c))))
|
||||
{:op :try
|
||||
:body (analyze-seq ctx @body env)
|
||||
|
|
@ -120,84 +118,82 @@
|
|||
(loop [i 0 fixed [] rest-name nil]
|
||||
(if (< i (count pvec))
|
||||
(let [p (nth pvec i)]
|
||||
(when-not (h/sym? p) (uncompilable "destructuring fn param"))
|
||||
(if (= "&" (h/sym-name p))
|
||||
(when-not (form-sym? p) (uncompilable "destructuring fn param"))
|
||||
(if (= "&" (form-sym-name p))
|
||||
(let [r (nth pvec (inc i))]
|
||||
(when-not (h/sym? r) (uncompilable "destructuring fn rest"))
|
||||
(recur (+ i 2) fixed (h/sym-name r)))
|
||||
(recur (inc i) (conj fixed (h/sym-name p)) rest-name)))
|
||||
(when-not (form-sym? r) (uncompilable "destructuring fn rest"))
|
||||
(recur (+ i 2) fixed (form-sym-name r)))
|
||||
(recur (inc i) (conj fixed (form-sym-name p)) rest-name)))
|
||||
{:fixed fixed :rest rest-name})))
|
||||
|
||||
(defn- analyze-arity [ctx pvec body env fn-name]
|
||||
(let [{:keys [fixed rest]} (parse-params (vec (h/vector-items pvec)))
|
||||
;; recur into a variadic arity would re-wrap the rest seq under Janet's &,
|
||||
;; so only fixed arities are recur targets; recur in a variadic arity then
|
||||
;; hits a nil target -> uncompilable -> the whole fn interprets.
|
||||
rname (when-not rest (gen-name "arity"))
|
||||
names (cond-> (vec fixed) rest (conj rest) fn-name (conj fn-name))
|
||||
(let [pp (parse-params (vec (form-vec-items pvec)))
|
||||
fixed (:fixed pp)
|
||||
rst (:rest pp)
|
||||
rname (when-not rst (gen-name "arity"))
|
||||
names (cond-> (vec fixed) rst (conj rst) fn-name (conj fn-name))
|
||||
env* (-> (add-locals env names) (with-recur rname))]
|
||||
{:params fixed :rest rest :recur-name rname
|
||||
{:params fixed :rest rst :recur-name rname
|
||||
:body (analyze-seq ctx body env*)}))
|
||||
|
||||
(defn- analyze-fn [ctx items env]
|
||||
(let [named (h/sym? (nth items 1))
|
||||
fn-name (when named (h/sym-name (nth items 1)))
|
||||
(let [named (form-sym? (nth items 1))
|
||||
fn-name (when named (form-sym-name (nth items 1)))
|
||||
rest-items (if named (drop 2 items) (drop 1 items))
|
||||
first* (first rest-items)]
|
||||
(cond
|
||||
(h/vector? first*)
|
||||
(ir/fn-node fn-name [(analyze-arity ctx first* (rest rest-items) env fn-name)])
|
||||
(h/list? first*)
|
||||
(ir/fn-node fn-name
|
||||
(mapv (fn [clause]
|
||||
(let [cl (vec (h/elements clause))]
|
||||
(analyze-arity ctx (first cl) (rest cl) env fn-name)))
|
||||
rest-items))
|
||||
(form-vec? first*)
|
||||
(fn-node fn-name [(analyze-arity ctx first* (rest rest-items) env fn-name)])
|
||||
(form-list? first*)
|
||||
(fn-node fn-name
|
||||
(mapv (fn [clause]
|
||||
(let [cl (vec (form-elements clause))]
|
||||
(analyze-arity ctx (first cl) (rest cl) env fn-name)))
|
||||
rest-items))
|
||||
:else (uncompilable "fn: bad params"))))
|
||||
|
||||
(defn- analyze-symbol [ctx form env]
|
||||
(let [nm (h/sym-name form) ns (h/sym-ns form)]
|
||||
(let [nm (form-sym-name form) ns (form-sym-ns form)]
|
||||
(cond
|
||||
(and (nil? ns) (local? env nm)) (ir/local nm)
|
||||
ns (let [r (h/resolve-global ctx form)]
|
||||
(and (nil? ns) (local? env nm)) (local nm)
|
||||
ns (let [r (resolve-global ctx form)]
|
||||
(if (= :var (:kind r))
|
||||
(ir/var-ref (:ns r) (:name r))
|
||||
(var-ref (:ns r) (:name r))
|
||||
(uncompilable (str "qualified ref " ns "/" nm))))
|
||||
:else (let [r (h/resolve-global ctx form)]
|
||||
:else (let [r (resolve-global ctx form)]
|
||||
(case (:kind r)
|
||||
:var (ir/var-ref (:ns r) (:name r))
|
||||
:host (ir/host-ref (:name r))
|
||||
(ir/var-ref (h/current-ns ctx) nm))))))
|
||||
:var (var-ref (:ns r) (:name r))
|
||||
:host (host-ref (:name r))
|
||||
(var-ref (compile-ns ctx) nm))))))
|
||||
|
||||
(defn- analyze-list [ctx form env]
|
||||
(let [items (vec (h/elements form))]
|
||||
(let [items (vec (form-elements form))]
|
||||
(if (zero? (count items))
|
||||
(ir/quote-node form)
|
||||
(quote-node form)
|
||||
(let [head (first items)
|
||||
hname (when (and (h/sym? head) (nil? (h/sym-ns head))) (h/sym-name head))
|
||||
hname (when (and (form-sym? head) (nil? (form-sym-ns head))) (form-sym-name head))
|
||||
shadowed (and hname (local? env hname))]
|
||||
(cond
|
||||
(and hname (not shadowed) (contains? handled hname))
|
||||
(analyze-special ctx hname items env)
|
||||
(and hname (not shadowed) (h/special? hname))
|
||||
(and hname (not shadowed) (form-special? hname))
|
||||
(uncompilable (str "special form " hname))
|
||||
(and (h/sym? head) (not shadowed) (h/macro? ctx head))
|
||||
(analyze ctx (h/expand-1 ctx form) env)
|
||||
(and (form-sym? head) (not shadowed) (form-macro? ctx head))
|
||||
(analyze ctx (form-expand-1 ctx form) env)
|
||||
:else
|
||||
(ir/invoke (analyze ctx head env)
|
||||
(mapv #(analyze ctx % env) (rest items))))))))
|
||||
(invoke (analyze ctx head env)
|
||||
(mapv #(analyze ctx % env) (rest items))))))))
|
||||
|
||||
(defn analyze
|
||||
"Analyze form to IR in context ctx. The 2-arg arity starts with an empty env."
|
||||
([ctx form] (analyze ctx form (empty-env)))
|
||||
([ctx form env]
|
||||
(cond
|
||||
(h/literal? form) (ir/const form)
|
||||
(h/sym? form) (analyze-symbol ctx form env)
|
||||
(h/vector? form) (ir/vector-node (mapv #(analyze ctx % env) (h/vector-items form)))
|
||||
(h/map? form) (ir/map-node (mapv (fn [p] [(analyze ctx (first p) env)
|
||||
(analyze ctx (second p) env)])
|
||||
(h/map-pairs form)))
|
||||
(h/set? form) (uncompilable "set literal")
|
||||
(h/list? form) (analyze-list ctx form env)
|
||||
(form-literal? form) (const form)
|
||||
(form-sym? form) (analyze-symbol ctx form env)
|
||||
(form-vec? form) (vector-node (mapv #(analyze ctx % env) (form-vec-items form)))
|
||||
(form-map? form) (map-node (mapv (fn [p] [(analyze ctx (first p) env)
|
||||
(analyze ctx (second p) env)])
|
||||
(form-map-pairs form)))
|
||||
(form-set? form) (uncompilable "set literal")
|
||||
(form-list? form) (analyze-list ctx form env)
|
||||
:else (uncompilable "unsupported form"))))
|
||||
|
|
|
|||
|
|
@ -155,14 +155,29 @@
|
|||
|
||||
# --- pipeline wiring (the self-hosted compile path) ---
|
||||
|
||||
# Compile-load a jolt-core namespace via the bootstrap so it runs as native
|
||||
# bytecode. The analyzer uses unqualified referred names (jolt.host form-* + the
|
||||
# IR ctors), so the bootstrap's plain :var path compiles it. Stateful forms (the
|
||||
# ns/require) fall back to the interpreter. Source from the embedded stdlib map.
|
||||
(defn- compile-load [ctx ns-name]
|
||||
(def src (get (get (ctx :env) :embedded-sources @{}) ns-name))
|
||||
(when src
|
||||
(def saved (ctx-current-ns ctx))
|
||||
(ctx-set-current-ns ctx ns-name)
|
||||
(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))
|
||||
(when (not (nil? f))
|
||||
(def c (protect (comp/compile-ast f ctx)))
|
||||
(if (c 0) (comp/eval-compiled (c 1) ctx) (eval-form ctx @{} f))))
|
||||
(ctx-set-current-ns ctx saved)))
|
||||
|
||||
(defn- ensure-analyzer [ctx]
|
||||
# Load jolt.analyzer (and transitively jolt.ir) once; jolt.host is pre-installed
|
||||
# by host/install! so its require is a no-op. The analyzer runs INTERPRETED:
|
||||
# compiling it via the bootstrap needs qualified-ref compilation, which
|
||||
# regresses compile mode (the clojure.test shim breaks) — tracked in jolt-4xc.
|
||||
# Correctness is unaffected (218/218 conformance); speed is the open item.
|
||||
(when (= 0 (length ((ctx-find-ns ctx "jolt.analyzer") :mappings)))
|
||||
(eval-form ctx @{} (r/parse-string "(require '[jolt.analyzer])"))))
|
||||
(compile-load ctx "jolt.ir")
|
||||
(compile-load ctx "jolt.analyzer")))
|
||||
|
||||
(defn analyze-form
|
||||
"Run the portable Clojure analyzer (jolt.analyzer/analyze) on a reader form,
|
||||
|
|
|
|||
|
|
@ -810,15 +810,20 @@
|
|||
arities @{}
|
||||
defining-ns (ctx-current-ns ctx)]
|
||||
(var self nil)
|
||||
# The (single) variadic clause is dispatched separately: it handles
|
||||
# any arg count >= its fixed count. Storing it in `arities` by
|
||||
# fixed-count would collide with a same-fixed-count fixed clause and
|
||||
# only match that exact count.
|
||||
(var variadic-fn nil)
|
||||
(var variadic-min 0)
|
||||
(each pair pairs
|
||||
(let [args-form (in pair 0)
|
||||
body (tuple/slice pair 1)
|
||||
param-info (parse-params args-form)
|
||||
fixed-pats (param-info :fixed)
|
||||
rest-pat (param-info :rest)
|
||||
n-fixed (length fixed-pats)]
|
||||
(put arities n-fixed
|
||||
(fn [& fn-args]
|
||||
n-fixed (length fixed-pats)
|
||||
f (fn [& fn-args]
|
||||
(var fn-bindings @{})
|
||||
(table/setproto fn-bindings bindings)
|
||||
(var i 0)
|
||||
|
|
@ -836,12 +841,16 @@
|
|||
(each body-form body
|
||||
(set result (eval-form ctx fn-bindings body-form)))
|
||||
(ctx-set-current-ns ctx saved-ns)
|
||||
result))))
|
||||
result)]
|
||||
(if rest-pat
|
||||
(do (set variadic-fn f) (set variadic-min n-fixed))
|
||||
(put arities n-fixed f))))
|
||||
(set self (fn [& fn-args]
|
||||
(let [n (length fn-args)
|
||||
f (get arities n)]
|
||||
(if f
|
||||
(apply f fn-args)
|
||||
(cond
|
||||
f (apply f fn-args)
|
||||
(and variadic-fn (>= n variadic-min)) (apply variadic-fn fn-args)
|
||||
(error (string "Wrong number of args (" n ") passed to fn"))))))
|
||||
self)
|
||||
# Single-arity: (fn* [args] body...)
|
||||
|
|
|
|||
|
|
@ -114,13 +114,18 @@
|
|||
# can call them. Idempotent per context.
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
# Form predicates use `form-*` names (not list?/vector?/map?/set?/char?) so the
|
||||
# analyzer can refer them unqualified without the bootstrap's core-renames
|
||||
# intercepting them as the value-level predicates.
|
||||
(def- exports
|
||||
{"sym?" h-sym? "sym-name" h-sym-name "sym-ns" h-sym-ns
|
||||
"list?" h-list? "vector?" h-vector? "map?" h-map? "set?" h-set? "char?" h-char?
|
||||
"literal?" h-literal? "elements" h-elements "vector-items" h-vector-items
|
||||
"map-pairs" h-map-pairs "set-items" h-set-items
|
||||
"special?" h-special? "current-ns" h-current-ns "macro?" h-macro?
|
||||
"expand-1" h-expand-1 "resolve-global" h-resolve-global "intern!" h-intern!})
|
||||
{"form-sym?" h-sym? "form-sym-name" h-sym-name "form-sym-ns" h-sym-ns
|
||||
"form-list?" h-list? "form-vec?" h-vector? "form-map?" h-map?
|
||||
"form-set?" h-set? "form-char?" h-char? "form-literal?" h-literal?
|
||||
"form-elements" h-elements "form-vec-items" h-vector-items
|
||||
"form-map-pairs" h-map-pairs "form-set-items" h-set-items
|
||||
"form-special?" h-special? "compile-ns" h-current-ns "form-macro?" h-macro?
|
||||
"form-expand-1" h-expand-1 "resolve-global" h-resolve-global
|
||||
"host-intern!" h-intern!})
|
||||
|
||||
(defn install! [ctx]
|
||||
(def ns (ctx-find-ns ctx "jolt.host"))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue