Chez Phase 1 (increment 3g): letfn + declare/def-no-init
Closes the last two non-host-interop prelude emit gaps. letfn now analyzes to a :let node flagged :letrec — the binding fns are bound into the env together before any spec is analyzed, so siblings and self resolve. The Chez back end lowers it to letrec*; the Janet back end punts it at emit (its sequential let* can't express the mutual recursion — same interpreter fallback as before, just decided at emit-ir instead of analyze). (def x) with no init (declare) analyzes to a :def with :no-init instead of punting. Chez reserves the var cell via declare-var! (which doesn't clobber an existing root — (do (def x 7) (def x) x) => 7); the Janet back end still punts to the interpreter, which interns a genuinely-unbound var. fallback-zero-test now checks emit-ir too, not just analyze-form, so the real compile-vs-interpret decision is what it asserts (letfn/def-no-init analyze but the Janet back end punts them). letfn stays in must-punt with an updated note. Prelude emit reach 342 -> 348/355 (40-lazy now 13/13); Chez subset 664 -> 672, 0 divergences; emit-test 110 -> 117. Full gate green.
This commit is contained in:
parent
930800f9a6
commit
0f7d2753a8
8 changed files with 119 additions and 31 deletions
|
|
@ -171,8 +171,12 @@
|
||||||
(def b (vv b))
|
(def b (vv b))
|
||||||
(string "(" (munge (get b 0)) " " (emit (get b 1)) ")"))
|
(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]
|
(defn- emit-let [node]
|
||||||
(string "(let* (" (string/join (map emit-binding (vv (get node :bindings))) " ") ") "
|
(def kw (if (get node :letrec) "letrec*" "let*"))
|
||||||
|
(string "(" kw " (" (string/join (map emit-binding (vv (get node :bindings))) " ") ") "
|
||||||
(emit (get node :body)) ")"))
|
(emit (get node :body)) ")"))
|
||||||
|
|
||||||
(defn- emit-loop [node]
|
(defn- emit-loop [node]
|
||||||
|
|
@ -362,8 +366,13 @@
|
||||||
:try (emit-try node)
|
:try (emit-try node)
|
||||||
:quote (emit-quoted (get node :form))
|
:quote (emit-quoted (get node :form))
|
||||||
:fn (emit-fn node)
|
:fn (emit-fn node)
|
||||||
:def (string "(def-var! " (string/format "%j" (get node :ns)) " "
|
# (def name) with no init (declare): reserve the var cell (declare-var!
|
||||||
(string/format "%j" (get node :name)) " " (emit (get node :init)) ")")
|
# doesn't clobber an existing root) so a forward reference resolves.
|
||||||
|
:def (if (get node :no-init)
|
||||||
|
(string "(declare-var! " (string/format "%j" (get node :ns)) " "
|
||||||
|
(string/format "%j" (get node :name)) ")")
|
||||||
|
(string "(def-var! " (string/format "%j" (get node :ns)) " "
|
||||||
|
(string/format "%j" (get node :name)) " " (emit (get node :init)) ")"))
|
||||||
(errorf "emit: unhandled op %p" (get node :op)))))
|
(errorf "emit: unhandled op %p" (get node :op)))))
|
||||||
|
|
||||||
# Wrap emitted top-level forms into a runnable Chez program: load the RT, then
|
# Wrap emitted top-level forms into a runnable Chez program: load the RT, then
|
||||||
|
|
|
||||||
|
|
@ -43,6 +43,10 @@
|
||||||
;; A var is a mutable cell keyed by "ns/name". A `:def` sets the root; a `:var`
|
;; A var is a mutable cell keyed by "ns/name". A `:def` sets the root; a `:var`
|
||||||
;; reference reads it at use time (late binding), so a forward/mutually-recursive
|
;; reference reads it at use time (late binding), so a forward/mutually-recursive
|
||||||
;; reference resolves to whatever the cell holds when the call actually runs.
|
;; reference resolves to whatever the cell holds when the call actually runs.
|
||||||
|
;; declare / (def name) with no init reserves a cell holding this placeholder
|
||||||
|
;; until the real def overwrites it (a forward reference resolves to the cell, and
|
||||||
|
;; correct code never reads it before the binding def runs).
|
||||||
|
(define jolt-unbound (string->symbol "#<jolt-unbound>"))
|
||||||
(define-record-type var-cell (fields ns name (mutable root)) (nongenerative var-cell-v1))
|
(define-record-type var-cell (fields ns name (mutable root)) (nongenerative var-cell-v1))
|
||||||
(define var-table (make-hashtable string-hash string=?))
|
(define var-table (make-hashtable string-hash string=?))
|
||||||
(define (jolt-var ns name)
|
(define (jolt-var ns name)
|
||||||
|
|
@ -53,6 +57,13 @@
|
||||||
c))))
|
c))))
|
||||||
(define (var-deref ns name) (var-cell-root (jolt-var ns name)))
|
(define (var-deref ns name) (var-cell-root (jolt-var ns name)))
|
||||||
(define (def-var! ns name v) (var-cell-root-set! (jolt-var ns name) v) v)
|
(define (def-var! ns name v) (var-cell-root-set! (jolt-var ns name) v) v)
|
||||||
|
;; declare / (def name) with no init: reserve the cell ONLY if absent. An
|
||||||
|
;; existing root is left intact — Clojure's (def x) with no init does not clobber
|
||||||
|
;; a prior binding (do (def x 7) (def x) x) => 7.
|
||||||
|
(define (declare-var! ns name)
|
||||||
|
(let ((k (string-append ns "/" name)))
|
||||||
|
(unless (hashtable-ref var-table k #f)
|
||||||
|
(hashtable-set! var-table k (make-var-cell ns name jolt-unbound)))))
|
||||||
|
|
||||||
;; --- jolt number printing ----------------------------------------------------
|
;; --- jolt number printing ----------------------------------------------------
|
||||||
;; jolt models every number as a Clojure double: integer-valued values print
|
;; jolt models every number as a Clojure double: integer-valued values print
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,7 @@
|
||||||
|
|
||||||
(def ^:private handled
|
(def ^:private handled
|
||||||
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"
|
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"
|
||||||
"syntax-quote" "var"})
|
"syntax-quote" "var" "letfn"})
|
||||||
|
|
||||||
(defn- uncompilable [why]
|
(defn- uncompilable [why]
|
||||||
(throw (str "jolt/uncompilable: " why)))
|
(throw (str "jolt/uncompilable: " why)))
|
||||||
|
|
@ -190,6 +190,27 @@
|
||||||
n)]
|
n)]
|
||||||
n)))
|
n)))
|
||||||
|
|
||||||
|
;; letfn: (letfn [(name [params] body*)...] body*). The named local fns are
|
||||||
|
;; MUTUALLY recursive, so bind every name into the env BEFORE analyzing any spec
|
||||||
|
;; — each spec then resolves its siblings (and itself) as locals. Emitted as a
|
||||||
|
;; :let flagged :letrec so the back ends know the bindings forward-reference each
|
||||||
|
;; other: Chez lowers it to `letrec*`; the Janet back end punts to the
|
||||||
|
;; interpreter (its shared mutable env already gives the letrec semantics that a
|
||||||
|
;; compiled sequential let* lacks — the reason letfn was uncompilable before).
|
||||||
|
(defn- analyze-letfn [ctx items env]
|
||||||
|
(let [specs (vec (form-vec-items (nth items 1)))
|
||||||
|
names (mapv #(form-sym-name (first (vec (form-elements %)))) specs)
|
||||||
|
env* (add-locals env names)
|
||||||
|
binds (mapv (fn [spec]
|
||||||
|
(let [cl (vec (form-elements spec))]
|
||||||
|
;; analyze as a named fn (items[1] = the name): self- and
|
||||||
|
;; sibling-calls resolve, the fn carries its own name.
|
||||||
|
[(form-sym-name (first cl))
|
||||||
|
(analyze-fn ctx (vec (cons (first cl) cl)) env*)]))
|
||||||
|
specs)]
|
||||||
|
{:op :let :letrec true :bindings binds
|
||||||
|
:body (analyze-seq ctx (drop 2 items) env*)}))
|
||||||
|
|
||||||
(defn- analyze-special [ctx op items env]
|
(defn- analyze-special [ctx op items env]
|
||||||
(case op
|
(case op
|
||||||
"quote" (quote-node (second items))
|
"quote" (quote-node (second items))
|
||||||
|
|
@ -210,20 +231,25 @@
|
||||||
;; the whole def (it unwraps the name and merges the meta).
|
;; the whole def (it unwraps the name and merges the meta).
|
||||||
(when-not (form-sym? name-sym)
|
(when-not (form-sym? name-sym)
|
||||||
(uncompilable "def name with map metadata"))
|
(uncompilable "def name with map metadata"))
|
||||||
;; (def name) with no init (declare) just interns — interpreter's job
|
(if (< (count items) 3)
|
||||||
(when (< (count items) 3)
|
;; (def name) with no init (declare): intern + reserve the cell so a
|
||||||
(uncompilable "def with no init"))
|
;; forward reference resolves. The back ends key on :no-init — Chez
|
||||||
(let [nm (form-sym-name name-sym)
|
;; def-var!s an unbound placeholder; the Janet back end punts to the
|
||||||
cur (compile-ns ctx)
|
;; interpreter, which interns a genuinely-unbound var.
|
||||||
;; (def name docstring value): docstring is form 2, value form 3.
|
(let [nm (form-sym-name name-sym) cur (compile-ns ctx)]
|
||||||
;; Matches the interpreter; without this the docstring was taken
|
(host-intern! ctx cur nm)
|
||||||
;; as the value and the real init dropped (jolt-6ym).
|
{:op :def :ns cur :name nm :no-init true})
|
||||||
has-doc (and (> (count items) 3) (string? (nth items 2)))
|
(let [nm (form-sym-name name-sym)
|
||||||
val-form (nth items (if has-doc 3 2))
|
cur (compile-ns ctx)
|
||||||
base-meta (or (form-sym-meta name-sym) {})
|
;; (def name docstring value): docstring is form 2, value form 3.
|
||||||
node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)]
|
;; Matches the interpreter; without this the docstring was taken
|
||||||
(host-intern! ctx cur nm)
|
;; as the value and the real init dropped (jolt-6ym).
|
||||||
(def-node cur nm (analyze ctx val-form env) node-meta)))
|
has-doc (and (> (count items) 3) (string? (nth items 2)))
|
||||||
|
val-form (nth items (if has-doc 3 2))
|
||||||
|
base-meta (or (form-sym-meta name-sym) {})
|
||||||
|
node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)]
|
||||||
|
(host-intern! ctx cur nm)
|
||||||
|
(def-node cur nm (analyze ctx val-form env) node-meta))))
|
||||||
"let*" (let [bvec (vec (form-vec-items (nth items 1)))
|
"let*" (let [bvec (vec (form-vec-items (nth items 1)))
|
||||||
r (analyze-bindings ctx bvec env)]
|
r (analyze-bindings ctx bvec env)]
|
||||||
(let-node (first r) (analyze-seq ctx (drop 2 items) (second r))))
|
(let-node (first r) (analyze-seq ctx (drop 2 items) (second r))))
|
||||||
|
|
@ -238,6 +264,7 @@
|
||||||
{:op :recur :recur-name rt
|
{:op :recur :recur-name rt
|
||||||
:args (mapv #(analyze ctx % env) (rest items))})
|
:args (mapv #(analyze ctx % env) (rest items))})
|
||||||
"try" (analyze-try ctx items env)
|
"try" (analyze-try ctx items env)
|
||||||
|
"letfn" (analyze-letfn ctx items env)
|
||||||
"fn*" (analyze-fn ctx items env)
|
"fn*" (analyze-fn ctx items env)
|
||||||
;; Lower the backtick to construction code (zero runtime cost), then analyze
|
;; Lower the backtick to construction code (zero runtime cost), then analyze
|
||||||
;; it — the macroexpand/compile-time step, per read -> macroexpand -> compile.
|
;; it — the macroexpand/compile-time step, per read -> macroexpand -> compile.
|
||||||
|
|
|
||||||
|
|
@ -179,6 +179,11 @@
|
||||||
(tuple/slice out))
|
(tuple/slice out))
|
||||||
|
|
||||||
(defn- emit-let [ctx node]
|
(defn- emit-let [ctx node]
|
||||||
|
# letfn lowers to a :let flagged :letrec (mutually-recursive bindings). A
|
||||||
|
# compiled sequential Janet let can't forward-ref a sibling, so punt to the
|
||||||
|
# interpreter (the deliberate uncompilable channel) — its shared mutable env
|
||||||
|
# gives the letrec semantics. The Chez back end compiles it directly (letrec*).
|
||||||
|
(when (node :letrec) (error "jolt/uncompilable: letfn"))
|
||||||
(def binds @[])
|
(def binds @[])
|
||||||
(each pair (vview (node :bindings))
|
(each pair (vview (node :bindings))
|
||||||
(def p (vview pair))
|
(def p (vview pair))
|
||||||
|
|
@ -740,7 +745,12 @@
|
||||||
:recur (emit-recur ctx node)
|
:recur (emit-recur ctx node)
|
||||||
:try (emit-try ctx node)
|
:try (emit-try ctx node)
|
||||||
:throw ['error (emit ctx (node :expr))]
|
:throw ['error (emit ctx (node :expr))]
|
||||||
:def (let [cell (cell-for ctx (node :ns) (node :name))
|
:def (do
|
||||||
|
# (def name) with no init (declare): no compiled value to install —
|
||||||
|
# punt to the interpreter, which interns a genuinely-unbound var
|
||||||
|
# (compiling it to nil would diverge: reading an unbound var throws).
|
||||||
|
(when (node :no-init) (error "jolt/uncompilable: def with no init"))
|
||||||
|
(let [cell (cell-for ctx (node :ns) (node :name))
|
||||||
meta (node :meta)
|
meta (node :meta)
|
||||||
setter (if (and meta (not (empty? meta))) (var-setter-meta cell meta) (var-setter cell))
|
setter (if (and meta (not (empty? meta))) (var-setter-meta cell meta) (var-setter cell))
|
||||||
_ (cgen-collect! ctx node)
|
_ (cgen-collect! ctx node)
|
||||||
|
|
@ -759,7 +769,7 @@
|
||||||
# redefined (jolt-wf4).
|
# redefined (jolt-wf4).
|
||||||
(let [init-form (emit ctx (node :init))]
|
(let [init-form (emit ctx (node :init))]
|
||||||
(when-let [ud (get (ctx :env) :unit-defs)] (put ud cell true))
|
(when-let [ud (get (ctx :env) :unit-defs)] (put ud cell true))
|
||||||
(tuple setter init-form)))))
|
(tuple setter init-form))))))
|
||||||
:let (emit-let ctx node)
|
:let (emit-let ctx node)
|
||||||
:fn (emit-fn ctx node)
|
:fn (emit-fn ctx node)
|
||||||
:invoke (emit-invoke ctx node)
|
:invoke (emit-invoke ctx node)
|
||||||
|
|
|
||||||
|
|
@ -48,13 +48,14 @@ compile-time signal) and are counted "out of subset", not as divergences.
|
||||||
|
|
||||||
JOLT_CHEZ_CORPUS=1 janet test/chez/run-corpus-chez.janet
|
JOLT_CHEZ_CORPUS=1 janet test/chez/run-corpus-chez.janet
|
||||||
|
|
||||||
Baseline after inc 3f (quoted literals): **664/664 compiled cases pass**, 0
|
Baseline after inc 3g (letfn + declare): **672/672 compiled cases pass**, 0
|
||||||
divergences; 1994/2658 out of subset (await clojure.core on Chez). Inc 3e
|
divergences; 1986/2658 out of subset (await clojure.core on Chez). Inc 3e
|
||||||
(throw/try + ex-info) was 632/632; inc 3f's quote support + a seq.ss fix (empty
|
(throw/try + ex-info) was 632/632; inc 3f's quote support + a seq.ss fix (empty
|
||||||
`map`/`filter` results are `()` not nil, matching Clojure) pulled 32 more corpus
|
`map`/`filter` results are `()` not nil, matching Clojure) reached 664/664; inc 3g
|
||||||
cases into the subset. `emit-fn` lowers multi-arity fns to a Scheme `case-lambda`
|
(letfn -> Scheme `letrec*`, declare/def-no-init -> a reserved var cell) pulled 8
|
||||||
and variadic fns to a rest-arg lambda (rest list coerced to a jolt seq, nil when
|
more corpus cases into the subset. `emit-fn` lowers multi-arity fns to a Scheme
|
||||||
empty).
|
`case-lambda` and variadic fns to a rest-arg lambda (rest list coerced to a jolt
|
||||||
|
seq, nil when empty).
|
||||||
|
|
||||||
## Phase 1 — clojure.core prelude emission (inc 3d, jolt-ocvi)
|
## Phase 1 — clojure.core prelude emission (inc 3d, jolt-ocvi)
|
||||||
The `-e`-capable jolt-chez path: emit the clojure.core tiers
|
The `-e`-capable jolt-chez path: emit the clojure.core tiers
|
||||||
|
|
|
||||||
|
|
@ -98,7 +98,7 @@
|
||||||
|
|
||||||
# Regression floor (raise it as new IR ops / RT shims land, like the suite
|
# Regression floor (raise it as new IR ops / RT shims land, like the suite
|
||||||
# baseline). Fails if prelude emit reach drops below the recorded baseline.
|
# baseline). Fails if prelude emit reach drops below the recorded baseline.
|
||||||
(def reach-floor 342)
|
(def reach-floor 348)
|
||||||
(when (< compiled reach-floor)
|
(when (< compiled reach-floor)
|
||||||
(printf "REGRESSION: prelude emit reach %d < floor %d" compiled reach-floor)
|
(printf "REGRESSION: prelude emit reach %d < floor %d" compiled reach-floor)
|
||||||
(os/exit 1))
|
(os/exit 1))
|
||||||
|
|
|
||||||
|
|
@ -259,6 +259,28 @@
|
||||||
(ok (string "quote: " src) (and (= code 0) (= out want))
|
(ok (string "quote: " src) (and (= code 0) (= out want))
|
||||||
(string "chez=" out " janet=" want " | " err))))
|
(string "chez=" out " janet=" want " | " err))))
|
||||||
|
|
||||||
|
# 3k) letfn + declare/def-no-init (inc 3g). letfn lowers to a Scheme `letrec*`
|
||||||
|
# (mutual recursion between the named local fns — a plain let* can't forward-
|
||||||
|
# ref a sibling). declare/(def x) with no init pre-creates the var cell so a
|
||||||
|
# forward reference resolves; the real def runs before any call.
|
||||||
|
(each src [# single local fn
|
||||||
|
"(letfn [(twice [x] (* x 2))] (twice 5))"
|
||||||
|
# self-recursion within a local fn
|
||||||
|
"(letfn [(fact [n] (if (zero? n) 1 (* n (fact (dec n)))))] (fact 5))"
|
||||||
|
# MUTUAL recursion — the letrec semantics a sequential let* lacks
|
||||||
|
"(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] (ev? 10))"
|
||||||
|
"(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] (od? 7))"
|
||||||
|
# local fn passed to a higher-order fn
|
||||||
|
"(letfn [(sq [x] (* x x))] (map sq [1 2 3]))"
|
||||||
|
# declare + forward reference (the canonical mutually-recursive top-level use)
|
||||||
|
"(declare is-ev) (defn is-od [n] (if (zero? n) false (is-ev (dec n)))) (defn is-ev [n] (if (zero? n) true (is-od (dec n)))) (is-ev 10)"
|
||||||
|
# declare then redefine: the real def overwrites the reserved cell
|
||||||
|
"(declare foo) (def foo 10) foo"]
|
||||||
|
(let [[code out err] (d/run-on-chez ctx src)
|
||||||
|
want (cli-oracle src)]
|
||||||
|
(ok (string "letfn/declare: " src) (and (= code 0) (= out want))
|
||||||
|
(string "chez=" out " janet=" want " | " err))))
|
||||||
|
|
||||||
# 3h) prelude mode (inc 3d): emitting clojure.core ITSELF, a core->core ref must
|
# 3h) prelude mode (inc 3d): emitting clojure.core ITSELF, a core->core ref must
|
||||||
# lower to a runtime var-deref instead of being rejected as "out of subset".
|
# lower to a runtime var-deref instead of being rejected as "out of subset".
|
||||||
# `frequencies` is a core fn but not a native-op, so it exercises the switch.
|
# `frequencies` is a core fn but not a native-op, so it exercises the switch.
|
||||||
|
|
|
||||||
|
|
@ -21,8 +21,13 @@
|
||||||
(def ctx (init-cached))
|
(def ctx (init-cached))
|
||||||
|
|
||||||
(defn- analyzes? [s]
|
(defn- analyzes? [s]
|
||||||
# true if the analyzer produced IR (compiled), false if it punted/uncompilable.
|
# true if the form COMPILES end to end (analyzer IR + back end emit), false if
|
||||||
(def r (protect (backend/analyze-form ctx (parse-string s))))
|
# it punts to the interpreter. Checks emit-ir too, not just analyze-form: letfn
|
||||||
|
# and (def x) with no init now ANALYZE to IR, but the Janet back end punts them
|
||||||
|
# at emit time (sequential let* can't express mutual recursion; an unbound var
|
||||||
|
# is not a compiled value) — so analyze-form alone would miss the real
|
||||||
|
# compile-vs-interpret decision that compile-and-eval makes.
|
||||||
|
(def r (protect (backend/emit-ir ctx (backend/analyze-form ctx (parse-string s)))))
|
||||||
(and (r 0) true))
|
(and (r 0) true))
|
||||||
|
|
||||||
# --- Must compile: pure, non-stateful value production. NONE may punt. ---
|
# --- Must compile: pure, non-stateful value production. NONE may punt. ---
|
||||||
|
|
@ -80,8 +85,11 @@
|
||||||
# defmacro — definitional host seam (the EXPANDERS are compiled;
|
# defmacro — definitional host seam (the EXPANDERS are compiled;
|
||||||
# see backend/recompile-macros!)
|
# see backend/recompile-macros!)
|
||||||
# set! — host var-cell mutation special
|
# set! — host var-cell mutation special
|
||||||
# letfn — needs letrec IR (sequential let* can't express mutual
|
# letfn — analyzes to a :letrec IR node now (inc 3g), but the Janet
|
||||||
# recursion); permanent-interpret unless the IR gains it
|
# back end still punts it at emit: its sequential let* can't
|
||||||
|
# express the mutual recursion. The Chez back end DOES
|
||||||
|
# compile it (letrec*). Janet stays interpret until emit-let
|
||||||
|
# gains a letrec lowering.
|
||||||
# eval — compile-and-run entry (also loader stateful-head?)
|
# eval — compile-and-run entry (also loader stateful-head?)
|
||||||
# . / new / Foo. / — thin host-interop heads the back end doesn't model
|
# . / new / Foo. / — thin host-interop heads the back end doesn't model
|
||||||
# .method
|
# .method
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue