From f9df794475b26278eac52f3db3c5365140f8a177 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sat, 6 Jun 2026 06:26:22 -0400 Subject: [PATCH] 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. --- jolt-core/jolt/analyzer.clj | 170 +++++++++++++++++--------- src/jolt/backend.janet | 36 +++++- test/integration/self-host-test.janet | 8 ++ 3 files changed, 153 insertions(+), 61 deletions(-) diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index 2761ae4..888a9dc 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -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")))) diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet index f6dab72..a385ad1 100644 --- a/src/jolt/backend.janet +++ b/src/jolt/backend.janet @@ -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) diff --git a/test/integration/self-host-test.janet b/test/integration/self-host-test.janet index 49f0e22..0d11c6e 100644 --- a/test/integration/self-host-test.janet +++ b/test/integration/self-host-test.janet @@ -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"))