self-host: compile loop/recur, recur-in-fn, and try
Analyzer threads an env (locals + recur target) instead of a bare locals set, and compiles loop*/recur, recur directly in a fixed-arity fn (each arity's name is its recur target -> self-call), and try/catch/finally (-> Janet try + defer). recur into a variadic arity isn't a recur target, so it falls back to the interpreter rather than miscompiling the rest seq. Still 218/218 conformance via the pipeline, now with these forms compiling natively instead of interpreting.
This commit is contained in:
Yogthos
parent
5624e99eb6
commit
f9df794475
3 changed files with 153 additions and 61 deletions
|
|
@ -6,63 +6,117 @@
|
|||
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)."
|
||||
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]))
|
||||
|
||||
(declare analyze analyze-fn)
|
||||
(declare analyze analyze-fn analyze-try)
|
||||
|
||||
;; Special forms the analyzer compiles itself. Anything else with a special head
|
||||
;; (ns, deftype, defmacro, …) is left to the interpreter via uncompilable.
|
||||
;; 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*" "throw"})
|
||||
#{"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]
|
||||
(swap! gensym-counter inc)
|
||||
(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 locals]
|
||||
(let [v (mapv #(analyze ctx % locals) forms)
|
||||
[ctx forms env]
|
||||
(let [v (mapv #(analyze ctx % env) forms)
|
||||
n (count v)]
|
||||
(cond
|
||||
(zero? n) (ir/const nil)
|
||||
(= 1 n) (first v)
|
||||
:else (ir/do-node (subvec v 0 (dec n)) (peek v)))))
|
||||
|
||||
(defn- analyze-special [ctx op items locals]
|
||||
(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]
|
||||
(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)
|
||||
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) locals)
|
||||
(analyze ctx (nth items 2) locals)
|
||||
"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) locals)
|
||||
(analyze ctx (nth items 3) env)
|
||||
(ir/const nil)))
|
||||
"do" (analyze-seq ctx (rest items) locals)
|
||||
"throw" (ir/throw-node (analyze ctx (nth items 1) locals))
|
||||
"do" (analyze-seq ctx (rest items) env)
|
||||
"throw" (ir/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) locals)))
|
||||
(ir/def-node cur nm (analyze ctx (nth items 2) env)))
|
||||
"let*" (let [bvec (vec (h/vector-items (nth items 1)))
|
||||
locals* (atom locals)
|
||||
pairs (loop [i 0 acc []]
|
||||
(if (< i (count bvec))
|
||||
(let [bsym (nth bvec i)
|
||||
_ (when-not (h/sym? bsym)
|
||||
(uncompilable "destructuring let binding"))
|
||||
nm (h/sym-name bsym)
|
||||
init (analyze ctx (nth bvec (inc i)) @locals*)]
|
||||
(swap! locals* conj nm)
|
||||
(recur (+ i 2) (conj acc [nm init])))
|
||||
acc))]
|
||||
(ir/let-node pairs (analyze-seq ctx (drop 2 items) @locals*)))
|
||||
"fn*" (analyze-fn ctx items locals)
|
||||
[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)))
|
||||
rname (gen-name "loop")
|
||||
[pairs env*] (analyze-bindings ctx bvec env)
|
||||
env** (with-recur env* rname)]
|
||||
{:op :loop :recur-name rname :bindings pairs
|
||||
:body (analyze-seq ctx (drop 2 items) env**)})
|
||||
"recur" (let [rt (:recur env)]
|
||||
(when-not rt (uncompilable "recur outside loop/fn"))
|
||||
{:op :recur :recur-name rt
|
||||
:args (mapv #(analyze ctx % env) (rest items))})
|
||||
"try" (analyze-try ctx items env)
|
||||
"fn*" (analyze-fn ctx items env)
|
||||
(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))]
|
||||
(cond
|
||||
(= hname "catch")
|
||||
(let [cl (vec (h/elements c))]
|
||||
(reset! catch-sym (h/sym-name (nth cl 2)))
|
||||
(reset! catch-body (drop 3 cl)))
|
||||
(= hname "finally")
|
||||
(reset! finally-body (rest (vec (h/elements c))))
|
||||
:else (swap! body conj c))))
|
||||
{:op :try
|
||||
:body (analyze-seq ctx @body env)
|
||||
:catch-sym @catch-sym
|
||||
:catch-body (when @catch-body
|
||||
(analyze-seq ctx @catch-body (add-locals env [@catch-sym])))
|
||||
:finally (when @finally-body (analyze-seq ctx @finally-body env))}))
|
||||
|
||||
(defn- parse-params [pvec]
|
||||
"Plain-symbol params only; & rest. Destructuring -> uncompilable."
|
||||
(loop [i 0 fixed [] rest-name nil]
|
||||
(if (< i (count pvec))
|
||||
(let [p (nth pvec i)]
|
||||
|
|
@ -74,37 +128,37 @@
|
|||
(recur (inc i) (conj fixed (h/sym-name p)) rest-name)))
|
||||
{:fixed fixed :rest rest-name})))
|
||||
|
||||
(defn- analyze-arity [ctx pvec body locals fn-name]
|
||||
(defn- analyze-arity [ctx pvec body env fn-name]
|
||||
(let [{:keys [fixed rest]} (parse-params (vec (h/vector-items pvec)))
|
||||
locals* (cond-> (reduce conj locals fixed)
|
||||
rest (conj rest)
|
||||
fn-name (conj fn-name))]
|
||||
{:params fixed :rest rest :body (analyze-seq ctx body locals*)}))
|
||||
;; 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))
|
||||
env* (-> (add-locals env names) (with-recur rname))]
|
||||
{:params fixed :rest rest :recur-name rname
|
||||
:body (analyze-seq ctx body env*)}))
|
||||
|
||||
(defn- analyze-fn [ctx items locals]
|
||||
;; (fn* name? params body...) | (fn* name? ([params] body...) ...)
|
||||
(defn- analyze-fn [ctx items env]
|
||||
(let [named (h/sym? (nth items 1))
|
||||
fn-name (when named (h/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) locals fn-name)])
|
||||
(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) locals fn-name)))
|
||||
(analyze-arity ctx (first cl) (rest cl) env fn-name)))
|
||||
rest-items))
|
||||
:else (uncompilable "fn: bad params"))))
|
||||
|
||||
(defn- analyze-symbol [ctx form locals]
|
||||
(defn- analyze-symbol [ctx form env]
|
||||
(let [nm (h/sym-name form) ns (h/sym-ns form)]
|
||||
(cond
|
||||
;; local (only unqualified)
|
||||
(and (nil? ns) (contains? locals nm)) (ir/local nm)
|
||||
;; qualified: must resolve to a var, else interpret (handles janet/…,
|
||||
;; Math/…, and any host interop the back end doesn't model).
|
||||
(and (nil? ns) (local? env nm)) (ir/local nm)
|
||||
ns (let [r (h/resolve-global ctx form)]
|
||||
(if (= :var (:kind r))
|
||||
(ir/var-ref (:ns r) (:name r))
|
||||
|
|
@ -113,41 +167,37 @@
|
|||
(case (:kind r)
|
||||
:var (ir/var-ref (:ns r) (:name r))
|
||||
:host (ir/host-ref (:name r))
|
||||
;; unresolved: forward reference in the current ns (resolved at call time)
|
||||
(ir/var-ref (h/current-ns ctx) nm))))))
|
||||
|
||||
(defn- analyze-list [ctx form locals]
|
||||
(defn- analyze-list [ctx form env]
|
||||
(let [items (vec (h/elements form))]
|
||||
(if (zero? (count items))
|
||||
(ir/quote-node form)
|
||||
(let [head (first items)
|
||||
hname (when (and (h/sym? head) (nil? (h/sym-ns head))) (h/sym-name head))
|
||||
shadowed (and hname (contains? locals hname))]
|
||||
shadowed (and hname (local? env hname))]
|
||||
(cond
|
||||
(and hname (not shadowed) (contains? handled hname))
|
||||
(analyze-special ctx hname items locals)
|
||||
;; A special form the analyzer doesn't compile -> interpreter.
|
||||
(analyze-special ctx hname items env)
|
||||
(and hname (not shadowed) (h/special? hname))
|
||||
(uncompilable (str "special form " hname))
|
||||
(and (h/sym? head) (not shadowed) (h/macro? ctx head))
|
||||
(analyze ctx (h/expand-1 ctx form) locals)
|
||||
(analyze ctx (h/expand-1 ctx form) env)
|
||||
:else
|
||||
(ir/invoke (analyze ctx head locals)
|
||||
(mapv #(analyze ctx % locals) (rest items))))))))
|
||||
(ir/invoke (analyze ctx head env)
|
||||
(mapv #(analyze ctx % env) (rest items))))))))
|
||||
|
||||
(defn analyze
|
||||
"Analyze form to IR in context ctx with the given set of local names in scope."
|
||||
([ctx form] (analyze ctx form #{}))
|
||||
([ctx form locals]
|
||||
"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 locals)
|
||||
(h/vector? form) (ir/vector-node (mapv #(analyze ctx % locals) (h/vector-items form)))
|
||||
(h/map? form) (ir/map-node (mapv (fn [p] [(analyze ctx (first p) locals)
|
||||
(analyze ctx (second p) locals)])
|
||||
(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 locals)
|
||||
;; Anything else (tagged literals like #"regex"/#inst, unknown shapes) is
|
||||
;; host-specific or not a value the back end can embed — interpret it.
|
||||
(h/list? form) (analyze-list ctx form env)
|
||||
:else (uncompilable "unsupported form"))))
|
||||
|
|
|
|||
|
|
@ -49,11 +49,42 @@
|
|||
(array/push binds (emit ctx (in p 1))))
|
||||
['let (tuple/slice binds) (emit ctx (node :body))])
|
||||
|
||||
# A named Janet fn whose name is the arity's recur target, so recur is a
|
||||
# self-call (Janet tail-calls it).
|
||||
(defn- emit-arity-fn [ctx ar]
|
||||
(def ps @[])
|
||||
(each pn (vview (ar :params)) (array/push ps (symbol pn)))
|
||||
(when (ar :rest) (array/push ps '&) (array/push ps (symbol (ar :rest))))
|
||||
['fn (tuple/slice ps) (emit ctx (ar :body))])
|
||||
(if (ar :recur-name)
|
||||
['fn (symbol (ar :recur-name)) (tuple/slice ps) (emit ctx (ar :body))]
|
||||
['fn (tuple/slice ps) (emit ctx (ar :body))]))
|
||||
|
||||
(defn- emit-loop [ctx node]
|
||||
(def L (symbol (node :recur-name)))
|
||||
(def params @[])
|
||||
(def inits @[])
|
||||
(each pair (vview (node :bindings))
|
||||
(def p (vview pair))
|
||||
(array/push params (symbol (in p 0)))
|
||||
(array/push inits (emit ctx (in p 1))))
|
||||
['do
|
||||
['var L nil]
|
||||
['set L ['fn (tuple/slice params) (emit ctx (node :body))]]
|
||||
(tuple/slice (array/concat @[L] inits))])
|
||||
|
||||
(defn- emit-recur [ctx node]
|
||||
(tuple/slice (array/concat @[(symbol (node :recur-name))]
|
||||
(map |(emit ctx $) (vview (node :args))))))
|
||||
|
||||
(defn- emit-try [ctx node]
|
||||
(def core
|
||||
(if (node :catch-sym)
|
||||
['try (emit ctx (node :body))
|
||||
[[(symbol (node :catch-sym))] (emit ctx (node :catch-body))]]
|
||||
(emit ctx (node :body))))
|
||||
(if (node :finally)
|
||||
['defer (emit ctx (node :finally)) core]
|
||||
core))
|
||||
|
||||
(defn- emit-fn [ctx node]
|
||||
(def arities (vview (node :arities)))
|
||||
|
|
@ -104,6 +135,9 @@
|
|||
:var (tuple (var-getter (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)
|
||||
:recur (emit-recur ctx node)
|
||||
:try (emit-try ctx node)
|
||||
:throw ['error (emit ctx (node :expr))]
|
||||
:def (tuple (var-setter (cell-for ctx (node :ns) (node :name))) (emit ctx (node :init)))
|
||||
:let (emit-let ctx node)
|
||||
|
|
|
|||
|
|
@ -42,6 +42,14 @@
|
|||
(assert (= 7 (ce ctx "(arity 3 4)")) "multi-arity 2")
|
||||
(assert (= 15 (ce ctx "(arity 1 2 3 4 5)")) "multi-arity variadic")
|
||||
|
||||
# loop / recur
|
||||
(assert (= 15 (ce ctx "(loop [i 0 acc 0] (if (< i 6) (recur (inc i) (+ acc i)) acc))")) "loop/recur")
|
||||
# recur directly in a fixed-arity fn
|
||||
(assert (= 15 (ce ctx "((fn [n acc] (if (zero? n) acc (recur (dec n) (+ acc n)))) 5 0)")) "recur in fn")
|
||||
# try / catch / finally
|
||||
(assert (= "caught" (ce ctx "(try (throw 42) (catch Exception e \"caught\"))")) "try/catch")
|
||||
(assert (= 7 (ce ctx "(try 7 (finally 0))")) "try/finally")
|
||||
|
||||
# higher-order + nesting
|
||||
(assert (= 15 (ce ctx "(reduce + (map inc [0 1 2 3 4]))")) "reduce+map"))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue