compiler.lua

-- compiler.lua : compile KLambda forms to Lua source, then load().
-- Strategy: statement-based codegen.  `ctail` emits statements ending in a
-- `return` (or native if/elseif), so function bodies use real Lua control flow
-- and real tail calls (LuaJIT does proper TCO).  `cexpr` emits a Lua expression,
-- wrapping control forms in an IIFE only when used in value (non-tail) position.

local R = require("runtime")
local cons, is_cons, NIL = R.cons, R.is_cons, R.NIL
local is_symbol = R.is_symbol

local C = {}

-- list helpers over runtime cons
local function car(x) return x[1] end
local function cdr(x) return x[2] end
local function to_array(lst)
  local a = {}
  while is_cons(lst) do a[#a+1] = lst[1]; lst = lst[2] end
  return a
end
local function len(lst)
  local n = 0; while is_cons(lst) do n = n + 1; lst = lst[2] end; return n
end

-- ------------------------------------------------------------------
-- arity registry shared with runtime via the env table passed to load()
-- ------------------------------------------------------------------
C.ARITY = {}    -- function-name -> arity (known defuns + primitives)

-- ------------------------------------------------------------------
-- Lua string literal escaping
-- ------------------------------------------------------------------
local function qstr(s)
  return string.format("%q", s)
end

-- compile-time gensym for Lua locals
local gsn = 0
local function gen(prefix) gsn = gsn + 1; return (prefix or "t") .. gsn end

-- ------------------------------------------------------------------
-- Compilation context (module-global; we never compile in parallel).
--
-- For a single `defun` body, we hoist every `(freeze ...)` closure to a flat
-- list at the top of the impl function. Reason: KLambda emitted by the Shen
-- Prolog compiler (e.g. einsteins-riddle, t-star) chains 60+ continuation
-- closures inside argument positions; naive codegen would nest 60+ Lua
-- `function() ... end` bodies, which LuaJIT's parser rejects with "chunk has
-- too many syntax levels".
--
-- The trick:
--   * Each freeze body is compiled with its free variables abstracted as
--     parameters: `kbody[N] = function(cap1, cap2, ...) return BODY end`.
--     These bodies are emitted as a flat sequence inside the impl function.
--   * At each freeze occurrence, we emit `BIND(kbody[N], cap1, cap2, ...)` --
--     a plain call, no nested `function` literal at the use site. BIND is a
--     runtime helper that snapshots the captures and returns a 0-arity thunk.
--
-- This decouples freeze definitions from the surrounding `let` block scope,
-- so we don't need per-defun forward declarations of every let-var (which
-- would blow Lua's per-function 200-local limit on the larger t-star defun).
-- ------------------------------------------------------------------
local CTX  -- nil outside a defun compile; otherwise a fresh table per defun.

-- Self-tail-call -> loop lowering state. Non-nil only while compiling a defun
-- body whose direct tail self-calls may be lowered to a loop continue:
--   { name = <defun name>, arity = N, lnames = {param locals}, used = bool }
-- When a tail-position call (NAME a1..aN) matches name+exact arity, ctail
-- emits `p1, ..., pN = e1, ..., eN; goto tco` instead of a tail call, and
-- cdefun wraps the body in `while true do ... ::tco:: end`. Lua's multiple
-- assignment evaluates every RHS before assigning, so (f Y X)-style swaps are
-- handled without explicit temps (and we add zero locals toward the 200-local
-- limit). MUST be cleared while compiling any body that is hoisted into a
-- separate Lua function (KC bodies, the no-CTX IIFE fallback) — a `goto`
-- there would cross a function boundary and fail to parse.
local SELF

-- Factoriser failure-continuations (S37+):
--   (let G (freeze E) ... (thaw G) ...)
-- Lowered when G is only thawed and never escapes (Astra/port-performance.md).
-- Unique thaw: compile E at the thaw site (delayed eval, no BIND).
-- Several tail thaws: one shared ::fail:: + goto (LuaJIT; PUC 5.1 keeps BIND).
-- Nested KC/IIFE functions see only `inline` records (goto cannot cross).
local CONT = {}

-- The lowering emits `goto`/labels, which PUC Lua 5.1 cannot parse (goto is
-- 5.2+/LuaJIT). Feature-detect once; without it every defun simply keeps the
-- proper-tail-call form (correctness identical -- this is a perf-only lever).
local HAS_GOTO = (loadstring or load)("do goto tco ::tco:: end") ~= nil

-- Tail recursion modulo cons (see TRMC above try_self_tail). SHEN_TRMC=off
-- keeps ordinary codegen, for A/B measurement; C.TRMC is read per defun, so
-- an in-process A/B (bench/list_builders_ab.lua) can flip it too.
C.TRMC = os.getenv("SHEN_TRMC") ~= "off"

local function new_ctx()
  -- cbodies: hoisted bodies (both `freeze` bodies and value-position control
  --          forms), emitted into a single `KC` table at *chunk* scope (built
  --          once at load). Each is a constant function abstracting its free
  --          vars as params, so it never captures an impl-local as an upvalue
  --          (which would force a per-call FNEW). freeze use sites wrap KC[i]
  --          with BIND (snapshotting captures into a thunk); control forms just
  --          call KC[i] directly.
  return { cbodies = {} }
end

-- Collect the free variables of a form: KL names that appear as symbols in
-- the form, are bound in the outer `env`, and are NOT shadowed by inner
-- `let` / `lambda` bindings of the same name.
local function collect_free(form, env, bound, acc)
  if not is_cons(form) then
    if is_symbol(form) and env[form.name] and not bound[form.name] then
      acc[form.name] = true
    end
    return
  end
  local head = form[1]
  if is_symbol(head) and not env[head.name] then
    local op = head.name
    if op == "let" then
      local var = car(cdr(form)).name
      local val = car(cdr(cdr(form)))
      local body = car(cdr(cdr(cdr(form))))
      collect_free(val, env, bound, acc)
      local nb = {}; for k in pairs(bound) do nb[k] = true end; nb[var] = true
      collect_free(body, env, nb, acc)
      return
    elseif op == "lambda" then
      local var = car(cdr(form)).name
      local body = car(cdr(cdr(form)))
      local nb = {}; for k in pairs(bound) do nb[k] = true end; nb[var] = true
      collect_free(body, env, nb, acc)
      return
    end
  end
  local cur = form
  while is_cons(cur) do
    collect_free(cur[1], env, bound, acc)
    cur = cur[2]
  end
end


-- Loop-lowering safety scan: a lowered function's param locals MUTATE on each
-- iteration, so anything that captures a param BY REFERENCE and can outlive
-- the iteration would observe iteration N+1's values from a closure created in
-- iteration N. The only such construct in this codegen is `lambda` -> MKFUN,
-- whose Lua function literal captures impl locals as upvalues. Everything else
-- is immune:
--   * freeze       -> BIND(KC[i], caps...) snapshots capture VALUES at creation
--   * value-position control forms -> KC[i](caps...) called immediately
--   * trap-error / do-IIFE inline closures execute synchronously, before any
--     further mutation of the params
--   * let-locals are declared INSIDE the `while` block, so Lua closes upvalues
--     over them at each iteration's end (fresh per iteration)
-- So: refuse lowering iff some lambda in the body (outside freeze bodies) has
-- a param among its free variables. `env` is the param env (name -> truthy),
-- `bound` tracks shadowing let/lambda binders, mirroring collect_free.
local function lambda_captures_param(form, env, bound)
  if not is_cons(form) then return false end
  local head = form[1]
  if is_symbol(head) and not env[head.name] then
    local op = head.name
    if op == "freeze" then
      return false
    elseif op == "lambda" then
      -- collect_free over the whole lambda form sees through nested binders,
      -- so a hit at any depth inside this lambda is caught here.
      local fv = {}
      collect_free(form, env, bound, fv)
      return next(fv) ~= nil
    elseif op == "let" then
      local var = car(cdr(form)).name
      local val = car(cdr(cdr(form)))
      local body = car(cdr(cdr(cdr(form))))
      if lambda_captures_param(val, env, bound) then return true end
      local nb = {}; for k in pairs(bound) do nb[k] = true end; nb[var] = true
      return lambda_captures_param(body, env, nb)
    end
  end
  local cur = form
  while is_cons(cur) do
    if lambda_captures_param(cur[1], env, bound) then return true end
    cur = cur[2]
  end
  return false
end

-- Pure-tail-recursion scan: lowering only pays when the function becomes a
-- REAL loop, with no residual recursion left inside the loop body. A mixed
-- function (tak/ackermann shape: the tail self-call's arguments themselves
-- recurse, or another branch recurses non-tail) REGRESSES under lowering --
-- LuaJIT traces a self-tail-call chain well, but a loop whose body re-enters
-- the same function through non-tail calls keeps side-exiting the loop trace
-- (measured: tak(24,16,8) 2.1x slower when mixed-lowered). So: eligible iff
-- EVERY occurrence of the function's own name in the body is the head of a
-- direct call in TAIL position with the exact declared arity, and the
-- arguments of those calls are self-free. Any other occurrence -- bare-symbol
-- reference (value/partial application), wrong arity, a call in an argument,
-- inside lambda/freeze/trap-error or any non-tail position -- refuses
-- lowering, keeping today's codegen for the whole function. A let/lambda
-- binder that rebinds the name also refuses (the name would sometimes be a
-- variable; conservative). The tail-position map below mirrors ctail exactly:
-- if/cond results, let body, do-last, and/or second arg, type's expr.
local function contains_name(form, name)
  if is_symbol(form) then return form.name == name end
  local cur = form
  while is_cons(cur) do
    if contains_name(cur[1], name) then return true end
    cur = cur[2]
  end
  return false
end

-- `st` (optional) enables the tail-recursion-modulo-cons extension: a
-- (cons H (NAME a1..aN)) in tail position, H and the ai self-free and exact
-- arity, is accepted too and recorded as st.cons = true (see TRMC below).
local function pure_tail_self(form, name, arity, tailpos, st)
  if not is_cons(form) then
    -- a bare self-reference (value / partial application) is residual
    return not (is_symbol(form) and form.name == name)
  end
  local head = form[1]
  if is_symbol(head) then
    local op = head.name
    if st and tailpos and op == "cons" and name ~= "cons" then
      local rest = cdr(form)
      if is_cons(rest) and is_cons(cdr(rest)) and cdr(cdr(rest)) == NIL then
        local h, call = car(rest), car(cdr(rest))
        if is_cons(call) and is_symbol(car(call)) and car(call).name == name
           and not contains_name(h, name) then
          local args = to_array(cdr(call))
          if #args ~= arity then return false end
          for i = 1, #args do
            if contains_name(args[i], name) then return false end
          end
          st.cons = true
          return true
        end
      end
    end
    -- (shen.f-error NAME): the fall-through clause of every non-exhaustive
    -- `define`. NAME is data (the name printed in the error), never a call,
    -- so it is not residual recursion. Exempted for TRMC only; the plain
    -- loop lowering keeps refusing it (measured regression, see
    -- doc/PERF-URDR-RESULTS.md "Tried / not shipped").
    if st and op == "shen.f-error" then
      local rest = cdr(form)
      if is_cons(rest) and cdr(rest) == NIL and is_symbol(car(rest))
         and car(rest).name == name then
        return true
      end
    end
    if op == name then
      -- direct self-call: lowerable iff in tail position with exact arity and
      -- self-free arguments (arguments are evaluated in non-tail position)
      local args = to_array(cdr(form))
      if not tailpos or #args ~= arity then return false end
      for i = 1, #args do
        if contains_name(args[i], name) then return false end
      end
      return true
    elseif op == "if" then
      local rest = cdr(form)
      if contains_name(car(rest), name) then return false end -- test: non-tail
      local cur = cdr(rest)
      while is_cons(cur) do
        if not pure_tail_self(cur[1], name, arity, tailpos, st) then return false end
        cur = cur[2]
      end
      return true
    elseif op == "cond" then
      local cur = cdr(form)
      while is_cons(cur) do
        local cl = cur[1]
        if contains_name(car(cl), name) then return false end  -- test: non-tail
        if not pure_tail_self(car(cdr(cl)), name, arity, tailpos, st) then return false end
        cur = cur[2]
      end
      return true
    elseif op == "let" then
      local var  = car(cdr(form))
      local val  = car(cdr(cdr(form)))
      local body = car(cdr(cdr(cdr(form))))
      if is_symbol(var) and var.name == name then return false end -- rebinds it
      if contains_name(val, name) then return false end            -- val: non-tail
      return pure_tail_self(body, name, arity, tailpos, st)
    elseif op == "do" then
      local forms = to_array(cdr(form))
      for i = 1, #forms - 1 do
        if contains_name(forms[i], name) then return false end     -- non-tail
      end
      return #forms == 0 or pure_tail_self(forms[#forms], name, arity, tailpos, st)
    elseif op == "and" or op == "or" then
      local a = car(cdr(form)); local b = car(cdr(cdr(form)))
      if contains_name(a, name) then return false end              -- a: non-tail
      return pure_tail_self(b, name, arity, tailpos, st)
    elseif op == "type" then
      return pure_tail_self(car(cdr(form)), name, arity, tailpos, st)  -- ctail: tail
    elseif op == "lambda" or op == "freeze" or op == "trap-error" then
      -- separate function bodies / pcall closure: any self-ref is residual
      return not contains_name(cdr(form), name)
    end
  end
  -- generic call (or computed head): everything here is non-tail
  return not contains_name(form, name)
end

-- environment: maps KL var name -> Lua local name. Implemented as a linked
-- table of scopes for cheap shadowing.
local function extend(env, kname, lname)
  local e = {}; for k,v in pairs(env) do e[k]=v end; e[kname]=lname; return e
end

local cexpr, ctail  -- forward

-- a symbol used as a *value* (self-evaluating) -> intern at runtime
local function symlit(name) return 'S(' .. qstr(name) .. ')' end

-- A call (NAME a1..an) whose callee arity is unknown at compile time -- in
-- practice a forward reference to a function defined later in the same file,
-- since each toplevel `define` is compiled on its own. The generic form,
-- APP(S(name), ...), interns the name, takes APP's symbol slow path and
-- re-dispatches through a vararg call on every execution; a hot Shen helper
-- written above its callees ran ~50x slower than the same call to an
-- already-defined function (issue #66: tla.shen's hash, 2.3 us per 5-step
-- reduce). CALLn looks up F[name] at call time, calls it directly when its
-- runtime arity is n (or unrecorded, APP's own "assume exact" rule), and
-- otherwise falls back to exactly the old APP(S(name), ...) path -- so
-- partial / over-application, redefinition and "not a function" errors are
-- unchanged. Fixed arity, no varargs: LuaJIT traces it.
local MAX_CALLN = 8
local function unknown_call(name, argstr, n)
  if n <= MAX_CALLN then
    if n == 0 then return "CALL0(" .. qstr(name) .. ")" end
    return "CALL" .. n .. "(" .. qstr(name) .. ", " .. argstr .. ")"
  end
  if n == 0 then return "APP(" .. symlit(name) .. ")" end
  return "APP(" .. symlit(name) .. ", " .. argstr .. ")"
end
C.MAX_CALLN = MAX_CALLN

-- ------------------------------------------------------------------
-- atom / literal compilation
-- ------------------------------------------------------------------
local function catom(form, env)
  local t = type(form)
  if t == "number" then
    return string.format("%.17g", form):gsub("%.0$","")  -- numeric literal
  elseif t == "boolean" then
    return form and "true" or "false"
  elseif t == "string" then
    return qstr(form)
  elseif form == NIL then
    return "NIL"
  elseif is_symbol(form) then
    local lname = env[form.name]
    if lname then return lname end       -- bound variable
    return symlit(form.name)             -- self-evaluating symbol
  else
    error("catom: cannot compile " .. tostring(form))
  end
end

-- numeric literal needs care: keep integers exact
-- mtoint: PUC 5.3+ %d-format guard (string.format("%d", n) errors there for
-- an integral float outside int64 range). nil under LuaJIT/5.1.
--
-- TWO63: the %d path is only sound for integral values that fit in an int64.
-- LuaJIT/5.1 have no mtoint to fall back on, and there string.format("%d", n)
-- SATURATES instead of erroring -- 1e300 renders as 9223372036854775807, so
-- the literal was destroyed in the generated source, before evaluation:
-- (> 1e300 1e100) compiled to APP(S(">"), 9223372036854775807, ...) => false.
-- Range-check up front on every host; anything outside int64 falls through to
-- the round-tripping %.17g form that catom already uses for the same job.
-- Non-finite values (+-inf, NaN) fail the comparisons and take that same
-- fall-through path they took before -- unchanged, deliberately out of scope.
local mtoint = math.tointeger
local TWO63 = 9223372036854775808.0   -- 2^63, exact as a double
local function cnum(n)
  if n == math.floor(n) and n > -TWO63 and n < TWO63 then
    if mtoint then
      local i = mtoint(n)
      if i then return string.format("%d", i) end
      return string.format("%.17g", n)
    end
    return string.format("%d", n)
  end
  return string.format("%.17g", n)
end

-- ------------------------------------------------------------------
-- application
-- ------------------------------------------------------------------
local function ftab_ref(name)
  return 'F[' .. qstr(name) .. ']'
end

-- Direct `impl(...)` for self-calls and per-entry `local fN = F["name"]`
-- for other known-arity callees. Lookup happens once per invocation of
-- `impl`, not per inner call; redefinition between top-level calls is
-- still seen. Nested KC/IIFE bodies keep F["name"] (those locals are not
-- in scope). Self-calls use `impl` so recursion does not hash F at all.
local IN_IMPL = false
local DEFUN_NAME = nil
local FREF_LIST = {}
local FREF_MAP = {}
local function callee_ref(name)
  if not IN_IMPL then return ftab_ref(name) end
  if DEFUN_NAME and name == DEFUN_NAME then return "impl" end
  local ln = FREF_MAP[name]
  if ln then return ln end
  ln = "f" .. (#FREF_LIST + 1)
  FREF_LIST[#FREF_LIST + 1] = { name = name, ln = ln }
  FREF_MAP[name] = ln
  return ln
end

-- 2-arg numeric primitives that get inlined to an ENV fast-path helper
-- (see ENV.ADD/.../EQ in prims.lua and the call site in ccall). Track 1.1/1.2.
local ARITH2 = {
  ["+"]="ADD", ["-"]="SUB", ["*"]="MUL", ["/"]="DIV",
  [">"]="GT", ["<"]="LT", [">="]="GE", ["<="]="LE", ["="]="EQ",
}

-- Let-floating: rewrite (F a1...aN (let X V B)) -> (let X V (F a1...aN B)).
-- This collapses right-recursive let chains in continuation-passing code
-- (e.g. the Prolog backend generates many (let X (newpv A) (shen.gc A NEXT))
-- forms inside einsteins-riddle), which would otherwise compile to deeply
-- nested IIFEs that exceed Lua's chunk syntax-level limit.
--
-- This is sound when the let's value form V has no side effect that depends
-- on evaluating a1...aN first. We restrict to the LAST argument and require
-- preceding args to be atoms/unbound symbols (pure variable / literal refs)
-- so the visible evaluation order is preserved.
local function arg_pure(form, env)
  if not is_cons(form) then return true end
  return false
end
-- Recognised special forms that must NOT be treated as ordinary calls when
-- recursing for deep let-floating.
local SPECIAL_HEADS = {
  ["if"]=true, ["cond"]=true, ["let"]=true, ["do"]=true,
  ["trap-error"]=true, ["and"]=true, ["or"]=true,
  ["lambda"]=true, ["freeze"]=true, ["defun"]=true, ["type"]=true,
}
local function try_let_float(form, env)
  -- Never treat a binder / control form as if it were an ordinary call.
  -- In particular (lambda V BODY) and (freeze BODY) must NOT have their body
  -- floated out, because that would move the body's enclosed lets to an outer
  -- scope where the binder's variable (V) is no longer in scope when the body
  -- references it. (Concrete bug: defprolog `mapit` source has
  -- `(lambda Z112 (lambda Z113 (let W114 ... (let W115 (lambda ... Z113 ...) ...))))`
  -- where the inner lambda body's freeze references Z113. Floating the let
  -- out of `(lambda Z113 ...)` strands that Z113 reference outside its binder
  -- and the compiler emits `S("Z113")` (a self-evaluating symbol) instead of
  -- the captured Lua local -- causing mapit to silently produce false.)
  local head = car(form)
  if is_symbol(head) and not env[head.name] and SPECIAL_HEADS[head.name] then
    return nil
  end
  local args_node = cdr(form)
  if args_node == NIL then return nil end
  -- find the last cons cell of the arg list
  local prev_chain = {}
  local cur = args_node
  while cdr(cur) ~= NIL do
    prev_chain[#prev_chain+1] = car(cur)
    cur = cdr(cur)
  end
  local last = car(cur)
  -- preceding args must be pure (atoms / unbound symbols) so floating preserves
  -- the visible evaluation order.
  for i=1,#prev_chain do
    if not arg_pure(prev_chain[i], env) then return nil end
  end
  local x, val, new_last
  if is_cons(last) and is_symbol(car(last)) and car(last).name == "let"
     and not env["let"] then
    x   = car(cdr(last))
    val = car(cdr(cdr(last)))
    new_last = car(cdr(cdr(cdr(last))))
  elseif is_cons(last) and is_symbol(car(last))
         and not env[car(last).name]
         and not SPECIAL_HEADS[car(last).name] then
    -- Recurse: try to float a let out of the last arg's own last-arg chain.
    -- This collapses (F1 _ (F2 _ (let X V B))) into (let X V (F1 _ (F2 _ B))).
    local inner = try_let_float(last, env)
    if not (inner and is_cons(inner) and is_symbol(car(inner))
            and car(inner).name == "let") then
      return nil
    end
    x   = car(cdr(inner))
    val = car(cdr(cdr(inner)))
    new_last = car(cdr(cdr(cdr(inner))))
  else
    return nil
  end
  -- rebuild (F prev... new_last)
  local new_args = cons(new_last, NIL)
  for i=#prev_chain,1,-1 do new_args = cons(prev_chain[i], new_args) end
  local new_call = cons(car(form), new_args)
  return cons(R.intern("let"), cons(x, cons(val, cons(new_call, NIL))))
end

-- ------------------------------------------------------------------
-- hd/tl accessor-chain hoisting (pattern-match support).
--
-- The KL that Shen's pattern compiler emits for a rule over a nested literal
-- structure re-derives the full accessor path at EVERY test and in every
-- result position: (= 97 (hd (hd (hd (hd (tl X)))))), then the same spine one
-- step deeper for the next test, and so on. Compiled naively that is O(n^2)
-- generated code, and a single deep chain alone can exceed LuaJIT's parser
-- nesting budget ("chunk has too many syntax levels"). So at STATEMENT points
-- inside ctail (if/and/or tests, let values, `return <call>`) we bind each
-- hd/tl step to a Lua local ONCE and let later chains extend from the cached
-- prefix: `local p1 = F["tl"](a1); local p2 = F["hd"](p1); ...`.
--
-- Safety rules (all enforced below):
--   * Only chains of non-shadowed `hd`/`tl` applications rooted (transitively)
--     at an env-bound variable participate. Each step still calls through
--     F["hd"]/F["tl"], exactly as the inline form did.
--   * Hoisting happens only while HOIST.pure holds: everything the statement
--     expression evaluates BEFORE the chain is effect-free (atoms, other
--     hoisted chains, cons construction, cons?/=/not). The first subexpression
--     that could observably error or side-effect clears the flag, and later
--     chains stay inline -- so visible evaluation order never changes.
--     Hoisted chains are emitted in compile order = left-to-right evaluation
--     order, so order AMONG chains is preserved too.
--   * HOIST is nil (and the cache reset) inside anything compiled as a
--     separate or deferred Lua function -- lambda/freeze bodies, KC bodies,
--     trap-error closures, do-IIFEs -- so a chain is never evaluated earlier
--     (or less conditionally) than its source position.
--   * CCACHE is block-scoped: a branch nested inside `if ... then ... end`
--     caches into a child scope that is discarded on exit, so a cached local
--     is only ever referenced from code it dominates.
--   * Caching does change the NUMBER of F["hd"]/F["tl"] calls executed (each
--     step runs once per match attempt instead of once per test). hd/tl are
--     pure structural reads of immutable cons cells, so results -- including
--     failure behavior -- are identical; this is the same class of tradeoff
--     as the ARITH2/cons inline fast paths above.
--   * Locals are the scarce resource (200/function). After CSE_MAX_LOCALS
--     hoisted locals in one function we spill further steps into a scratch
--     table PT (cf. try_flatten_call_chain), declared at function top only
--     when actually used; contexts that cannot declare PT simply stop
--     hoisting and keep today's inline chains.
-- ------------------------------------------------------------------
local CSE_MAX_LOCALS = 100
local CCACHE = {}   -- chain key -> Lua local/slot name, block-scoped via __index
local HOIST = nil   -- nil, or { out = {stmt strings}, pure = bool } at a flush site
local FNL = { np = 0, npt = 0, pt = false, can_pt = false }  -- per-Lua-function

local function new_fnl(can_pt)
  return { np = 0, npt = 0, pt = false, can_pt = can_pt }
end

local function child_cache()
  return setmetatable({}, { __index = CCACHE })
end

-- Canonical key for a pure accessor chain, or nil if `form` is not one.
-- Returns key, depth. Depth 0 = bare bound variable.
local function chain_key(form, env)
  if is_symbol(form) then
    local ln = env[form.name]
    if ln then return ln, 0 end
    return nil
  end
  if not is_cons(form) then return nil end
  local h = form[1]
  if not (is_symbol(h) and (h.name == "hd" or h.name == "tl") and not env[h.name]) then
    return nil
  end
  local rest = form[2]
  if not (is_cons(rest) and rest[2] == NIL) then return nil end
  local k, d = chain_key(rest[1], env)
  if not k then return nil end
  return (h.name == "hd" and "h" or "t") .. k, d + 1
end

-- Bind one computed step to a fresh local (or PT slot past the local budget).
-- Returns the reference string, or nil if no slot is available.
local function chain_slot(expr)
  if FNL.np < CSE_MAX_LOCALS then
    FNL.np = FNL.np + 1
    local ln = gen("p")
    HOIST.out[#HOIST.out+1] = "local " .. ln .. " = " .. expr .. "; "
    return ln
  end
  if not FNL.can_pt then return nil end
  FNL.pt = true
  FNL.npt = FNL.npt + 1
  local slot = "PT[" .. FNL.npt .. "]"
  HOIST.out[#HOIST.out+1] = slot .. " = " .. expr .. "; "
  return slot
end

local function chain_materialize(form, env)
  if is_symbol(form) then return env[form.name] end
  local key = chain_key(form, env)
  local hit = CCACHE[key]
  if hit then return hit end
  local inner = chain_materialize(form[2][1], env)
  -- HD/TL helpers (see ccall): same is_cons check as F["hd"]/F["tl"], but a
  -- direct ENV lookup rather than an F-table hash at every pattern step.
  local expr = (form[1].name == "hd" and "HD(" or "TL(") .. inner .. ")"
  local name = chain_slot(expr)
  if not name then return expr end   -- slot budget exhausted: stay inline
  CCACHE[key] = name
  return name
end

local function try_chain(form, env)
  if not (HOIST and HOIST.pure) then return nil end
  -- exact-arity F["hd"]/F["tl"] emission below must match what ccall would
  -- have emitted; bail if someone redefined them with a different arity
  if C.ARITY["hd"] ~= 1 or C.ARITY["tl"] ~= 1 then return nil end
  local key, depth = chain_key(form, env)
  if not key or depth == 0 then return nil end
  local hit = CCACHE[key]
  if hit then return hit end
  if depth < 2 then return nil end   -- single step: not worth a local
  return chain_materialize(form, env)
end

-- Heads whose exact-arity application can neither side-effect nor raise, so
-- evaluating a later hoisted chain ahead of them is unobservable. Everything
-- else (user calls, arithmetic that can type-error, control-form KC calls,
-- APP dispatch, un-hoisted hd/tl) clears HOIST.pure.
local PURE_HEADS = {
  ["cons?"]=true, ["="]=true, ["cons"]=true, ["not"]=true,
  ["empty?"]=true, ["number?"]=true, ["string?"]=true, ["boolean?"]=true,
}

-- Compile `form` as the value expression of a statement being emitted NOW,
-- with chain hoisting enabled. Returns prefix statements and the expression.
local function cstmt_expr(form, env)
  local saved = HOIST
  HOIST = { out = {}, pure = true }
  local e = cexpr(form, env)
  local pre = table.concat(HOIST.out)
  HOIST = saved
  return pre, e
end

-- Flatten a deep right-spine call chain (F1 ... (F2 ... (F3 ... INNER)))
-- into a sequence of local assignments. Without this, the chained
-- shen.gc(A, shen.gc(A, shen.gc(A, ...))) calls produced by the Shen Prolog
-- compiler hit Lua's expression-complexity limit (~200 nested calls).
-- Only valid in statement (tail) position because we emit `local` bindings.
local function try_flatten_call_chain(form, env)
  -- Chain-CSE handles pure hd/tl accessor spines (see block above): it
  -- budgets locals and spills to PT, whereas a frame here costs one `local c`
  -- unconditionally -- a ~300-step pattern path would blow the 200-local
  -- limit. So never treat a pure chain as frames: stop the walk there and
  -- let it compile as this chain's (or the enclosing call's) value.
  local chain_ok = C.ARITY["hd"] == 1 and C.ARITY["tl"] == 1
  -- Walk into the last-arg chain, building a list of call frames.
  local frames = {}   -- each: { head_form, prev_args_array }
  local cur = form
  while is_cons(cur) and is_symbol(car(cur)) and not env[car(cur).name]
        and not SPECIAL_HEADS[car(cur).name]
        and not (chain_ok and chain_key(cur, env)) do
    local args_node = cdr(cur)
    if args_node == NIL then break end
    local prev = {}
    local c = args_node
    while cdr(c) ~= NIL do prev[#prev+1] = car(c); c = cdr(c) end
    frames[#frames+1] = { car(cur), prev }
    cur = car(c)
  end
  if #frames < 16 then return nil end   -- not deep enough to flatten
  local stmts = {}

  -- EVALUATION ORDER. Shen evaluates operands left to right -- shen-go,
  -- shen-cl and shen-rust all do -- but this lowering builds the chain from
  -- the INSIDE OUT, so anything emitted at a call site runs after everything
  -- emitted for the frames nested inside it. Left-to-right therefore means:
  -- every non-last argument of every frame must be evaluated HERE, outermost
  -- frame first, before the innermost value; the call sites below then only
  -- reference the results.
  --
  -- Only arguments that can actually be observed need that treatment.
  -- `arg_pure` args are atoms / unbound symbols / already-bound Lua locals:
  -- no effects, and nothing in a straight-line chain can change them, so they
  -- stay INLINE at the call site. That matters -- the chains this lowering
  -- exists for (the Prolog compiler's shen.gc(A, shen.gc(A, ...)) CPS spines)
  -- have nothing but variable refs in those positions, so they keep exactly
  -- the code they had before.
  --
  -- The hoisted values go into one scratch TABLE rather than into `local`s.
  -- Locals are the scarce resource here: Lua allows 200 per function and the
  -- chain already spends one per frame, so hoisting into locals would halve
  -- the depth this lowering can handle. The table is emitted only when some
  -- argument actually needs it.
  local nhoist = 0
  for i=1,#frames do
    local prevs = frames[i][2]
    for j=1,#prevs do
      if not arg_pure(prevs[j], env) then nhoist = nhoist + 1 end
    end
  end
  local pre = {}   -- pre[i][j] = Lua expression string for frame i's arg j
  if nhoist > 0 then
    local tname = gen("t")
    stmts[#stmts+1] = "local " .. tname .. " = {};"
    local k = 0
    for i=1,#frames do
      local prevs = frames[i][2]
      local strs = {}
      for j=1,#prevs do
        if arg_pure(prevs[j], env) then
          strs[j] = cexpr(prevs[j], env)
        else
          k = k + 1
          local slot = tname .. "[" .. k .. "]"
          stmts[#stmts+1] = slot .. " = " .. cexpr(prevs[j], env) .. ";"
          strs[j] = slot
        end
      end
      pre[i] = strs
    end
  else
    for i=1,#frames do
      local prevs = frames[i][2]
      local strs = {}
      for j=1,#prevs do strs[j] = cexpr(prevs[j], env) end
      pre[i] = strs
    end
  end

  -- innermost value next
  -- If the innermost form is a (do A1 A2 ... AN), emit A1..A_{N-1} as
  -- statement-level side-effects (block-scoped `do local _ = A end`, no
  -- closure) and use AN as the value expression. This avoids wrapping the
  -- whole innermost in a single IIFE that would capture every flattened
  -- local as an upvalue (Lua caps at 60 upvalues per function).
  local val_form = cur
  if is_cons(cur) and is_symbol(cur[1]) and not env["do"]
     and cur[1].name == "do" then
    local do_args = to_array(cdr(cur))
    for i=1,#do_args-1 do
      stmts[#stmts+1] = "do local _ = " .. cexpr(do_args[i], env) .. " end"
    end
    val_form = do_args[#do_args]
  end
  -- The innermost value is compiled at a statement position of its own, so
  -- give it a chain-hoist flush site: a pure hd/tl spine terminating the
  -- frame chain (where the walk above stopped) then binds its steps to
  -- budgeted locals instead of one giant nested expression. Runtime order is
  -- unchanged: these prefix statements run after the hoisted frame args
  -- above, exactly where the inner value was evaluated before.
  local inner_name = gen("c")
  local saved_h = HOIST
  HOIST = { out = {}, pure = true }
  local innerc = cexpr(val_form, env)
  for i = 1, #HOIST.out do stmts[#stmts+1] = HOIST.out[i] end
  HOIST = saved_h
  stmts[#stmts+1] = "local " .. inner_name .. " = " .. innerc .. ";"
  -- build each call up to but not including the outermost
  for i=#frames, 2, -1 do
    local frame = frames[i]
    local hname = frame[1].name
    local prev_strs = pre[i]
    local arg_list
    if #prev_strs == 0 then arg_list = inner_name
    else arg_list = table.concat(prev_strs, ", ") .. ", " .. inner_name end
    local next_name = gen("c")
    -- use ccall semantics via a single-shot synthetic form
    local synth = cons(frame[1], NIL)
    -- prepend prev args + inner placeholder. Build a synthetic AST node so
    -- we can reuse ccall for arity-correct dispatch.
    -- We don't actually need the AST; emit a direct F[...] call using ARITY.
    local ar = C.ARITY[hname]
    local call_str
    if ar and #prev_strs + 1 == ar then
      call_str = callee_ref(hname) .. "(" .. arg_list .. ")"
    else
      -- fall back to APP for mismatched arity; late-bound for unknown
      call_str = ar and ("APP(" .. symlit(hname) .. ", " .. arg_list .. ")")
                 or unknown_call(hname, arg_list, #prev_strs + 1)
    end
    stmts[#stmts+1] = "local " .. next_name .. " = " .. call_str .. ";"
    inner_name = next_name
  end
  -- outermost: emit as return statement
  local frame = frames[1]
  local hname = frame[1].name
  local prev_strs = pre[1]
  local arg_list
  if #prev_strs == 0 then arg_list = inner_name
  else arg_list = table.concat(prev_strs, ", ") .. ", " .. inner_name end
  local ar = C.ARITY[hname]
  local call_str
  if ar and #prev_strs + 1 == ar then
    call_str = callee_ref(hname) .. "(" .. arg_list .. ")"
  else
    call_str = ar and ("APP(" .. symlit(hname) .. ", " .. arg_list .. ")")
               or unknown_call(hname, arg_list, #prev_strs + 1)
  end
  stmts[#stmts+1] = "return " .. call_str
  return table.concat(stmts, " ")
end


-- Curried call chains ((((fn f) a1) a2) ... an). Shen 42 translates a call
-- as this chain whenever f's arity is unknown at TRANSLATION time -- which
-- is every call into a library that the same file `load`s, even inside
-- `define`s, because the kernel reads the whole outer file before the
-- nested load has run. Compiled literally that is n nested APPs and n-1
-- partial-application closures per call (~2.5 us for a 4-argument call).
--
-- Emitted instead:  CURn(fn(S"f"), a1, ..., an). Lua evaluates the
-- arguments left to right, so (fn f) still runs -- and still raises for an
-- undefined f -- before a1. When the function's runtime arity is n, every
-- intermediate application of the original was a side-effect-free partial,
-- so the direct call g(a1..an) is exactly equivalent. Otherwise CURn
-- replays the original nested APPs on the already-evaluated arguments;
-- that fallback can only reorder effects if an intermediate application
-- runs code AND a later argument has effects. So the rewrite applies only
-- when a2..an are atoms or local variables, whose evaluation order is
-- unobservable. Even a known compile-time arity can change after a
-- redefinition: evaluating effectful operands eagerly would break the
-- fallback's ordering and error short-circuiting. Every level must apply
-- exactly one argument (the kernel's curried form); a multi-argument level
-- ((fn f) a b) is left to APP, whose dispatch differs from nesting for a
-- function with no recorded arity.
local function order_free(form, env)
  if is_cons(form) then return false end
  return true   -- number/string/boolean/(), symbol literal or local variable
end

local function curried_call(form, env)
  local args = {}
  local cur = form
  while is_cons(cur) and is_cons(car(cur)) do
    local rest = cdr(cur)
    if not (is_cons(rest) and cdr(rest) == NIL) then return nil end
    table.insert(args, 1, car(rest))
    cur = car(cur)
  end
  -- cur must be (fn SYM): `fn` not rebound, SYM a symbol literal
  if not (is_cons(cur) and is_symbol(car(cur)) and car(cur).name == "fn"
          and not env["fn"]) then
    return nil
  end
  local rest = cdr(cur)
  if not (is_cons(rest) and cdr(rest) == NIL) then return nil end
  local sym = car(rest)
  if not (is_symbol(sym) and not env[sym.name]) then return nil end
  local n = #args
  if n < 1 or n > MAX_CALLN then return nil end
  for i = 2, n do
    if not order_free(args[i], env) then return nil end
  end
  local fnref = callee_ref("fn")
  local cargs = {}
  for i = 1, n do cargs[i] = cexpr(args[i], env) end
  return "CUR" .. n .. "(" .. fnref .. "(" .. symlit(sym.name) .. "), "
         .. table.concat(cargs, ", ") .. ")"
end

-- compile a call (F a1..an) in expression position
local function ccall(form, env)
  local head = car(form)
  local args = to_array(cdr(form))
  local cargs = {}
  for i=1,#args do cargs[i] = cexpr(args[i], env) end
  local argstr = table.concat(cargs, ", ")
  -- Chain-hoist purity: this application runs after its args; anything the
  -- statement evaluates after it may no longer be hoisted ahead of it unless
  -- the head is known effect-free and non-raising.
  if HOIST and HOIST.pure then
    if not (is_symbol(head) and not env[head.name] and PURE_HEADS[head.name]) then
      HOIST.pure = false
    end
  end

  if is_symbol(head) and not env[head.name] then
    local name = head.name
    local ar = C.ARITY[name]
    if ar ~= nil then
      if #args == ar then
        -- Track 1.1/1.2: inline 2-arg numeric prims to ENV fast-paths (ADD,
        -- SUB, ..., EQ) instead of an F-table hash lookup. The helpers guard on
        -- type(number) and fall back to F[name], preserving KL semantics + late
        -- binding. Only when the head isn't a locally-bound var (checked above).
        -- Equality specialization (shen-scheme emit-equality-check). When one
        -- operand is a compile-time atom — (), a boolean/number/string
        -- literal, or an unbound (self-evaluating) symbol — KL `=` is Lua
        -- identity/`==` (interned symbols, interned strings, unique NIL).
        -- Avoids the EQ helper entirely at the pattern-match sites the kernel
        -- emits as `(= () X)` / `(= true X)` / `(= foo X)`.
        if name == "=" and ar == 2 then
          local function atom_lit(form)
            if form == NIL then return true end
            local t = type(form)
            if t == "number" or t == "boolean" or t == "string" then return true end
            return is_symbol(form) and not env[form.name]
          end
          if atom_lit(args[1]) or atom_lit(args[2]) then
            return "(" .. cargs[1] .. ")==(" .. cargs[2] .. ")"
          end
        end
        local helper = ARITH2[name]
        if helper and ar == 2 then
          return helper .. "(" .. argstr .. ")"
        end
        -- Inline exact-arity (cons A B) as a bare table+metatable construction
        -- (ENV.CMT is the runtime Cons metatable). Rationale: cons is the
        -- single hottest call in list-heavy workloads (urdr's software
        -- SHA-256: bits are cons lists), and routing it through the F["cons"]
        -- wrapper proto makes that tiny function a JIT trace hotspot in its
        -- own right — on LuaJIT it ends up blacklisted (repeated aborts of
        -- traces rooted in it), after which EVERY caller's trace that reaches
        -- it aborts too ("blacklisted at prims.lua"), demoting whole suites to
        -- the interpreter. Emitted inline there is no proto to blacklist, and
        -- hot traces can sink the allocation. Same late-binding tradeoff as
        -- the ARITH2 fast paths above: a runtime redefinition of `cons` is
        -- not seen by already-compiled exact-arity call sites.
        if name == "cons" and ar == 2 then
          return "setmetatable({" .. argstr .. "}, CMT)"
        end
        -- Unary KLambda ops that map onto a Lua test / operator (shen-scheme
        -- unary-op-mapping). `not` matches the kernel `(if V false true)` —
        -- Lua truthiness, no boolean guard. `hd`/`tl`/`thaw` go through ENV
        -- helpers that keep the primitive's error / thunk paths.
        if name == "empty?" and ar == 1 then
          return "(" .. argstr .. ")==NIL"
        end
        if name == "cons?" and ar == 1 then
          return "getmetatable(" .. argstr .. ")==CMT"
        end
        if name == "number?" and ar == 1 then
          return "type(" .. argstr .. ")==\"number\""
        end
        if name == "string?" and ar == 1 then
          return "type(" .. argstr .. ")==\"string\""
        end
        if name == "boolean?" and ar == 1 then
          return "type(" .. argstr .. ")==\"boolean\""
        end
        if name == "not" and ar == 1 then
          return "not (" .. argstr .. ")"
        end
        if name == "hd" and ar == 1 then
          return "HD(" .. argstr .. ")"
        end
        if name == "tl" and ar == 1 then
          return "TL(" .. argstr .. ")"
        end
        if name == "thaw" and ar == 1 then
          return "THAW(" .. argstr .. ")"
        end
        -- `(intern "foo")` is a compile-time intern (shen-scheme: quote).
        -- "true"/"false" follow the intern primitive's boolean mapping.
        if name == "intern" and ar == 1 and type(args[1]) == "string" then
          local s = args[1]
          if s == "true" then return "true" end
          if s == "false" then return "false" end
          return symlit(s)
        end
        -- (value LIT): direct GLOBALS access (shen-scheme static globals).
        -- Unbound still errors via the primitive fallback. `set` is NOT
        -- inlined: boot.lua's fasl recorder wraps F["set"] to capture
        -- expansion-time globals, and a SET_S that wrote GLOBALS directly
        -- would silently drop those records (stdlib image ≠ uncached boot).
        if name == "value" and ar == 1 and is_symbol(args[1]) and not env[args[1].name] then
          return "VALUE_S(" .. qstr(args[1].name) .. ")"
        end
        -- String / vector primitives that map onto Lua ops (fallback helpers
        -- preserve KL error messages on the slow path).
        if name == "cn" and ar == 2 then return "CN(" .. argstr .. ")" end
        if name == "@s" and ar == 2 then return "CN(" .. argstr .. ")" end
        if name == "pos" and ar == 2 then return "POS(" .. argstr .. ")" end
        if name == "tlstr" and ar == 1 then return "TLSTR(" .. argstr .. ")" end
        if name == "string->n" and ar == 1 then return "STRN(" .. argstr .. ")" end
        if name == "n->string" and ar == 1 then return "NSTR(" .. argstr .. ")" end
        if name == "hdstr" and ar == 1 then return "POS(" .. argstr .. ", 0)" end
        if name == "shen.hds=?" and ar == 2 then return "HDS_EQ(" .. argstr .. ")" end
        if name == "shen.comb" and ar == 2 then return "COMB(" .. argstr .. ")" end
        if name == "shen.in->" and ar == 1 then return "HD(" .. argstr .. ")" end
        if name == "shen.<-out" and ar == 1 then return "HD(TL(" .. argstr .. "))" end
        if name == "shen.ccons?" and ar == 1 then return "CCONS_Q(" .. argstr .. ")" end
        if name == "<-address" and ar == 2 then return "ADDR(" .. argstr .. ")" end
        if name == "address->" and ar == 3 then return "ADSET(" .. argstr .. ")" end
        if name == "absvector?" and ar == 1 then
          return "getmetatable(" .. argstr .. ")==VMT"
        end
        return callee_ref(name) .. "(" .. argstr .. ")"
      else
        -- Arity mismatch at compile time: route through APP so dispatch uses
        -- the *current* runtime arity (FA[F[name]]) rather than the value of
        -- C.ARITY[name] captured at compile time. This matters whenever a
        -- function's arity changes between when a call site is compiled and
        -- when it executes -- e.g. when a later (define ...) redefines a
        -- function with a new arity (binary.shen redefines `complement` after
        -- tableauprolog.shen used it as a 6-arg Prolog predicate), or when
        -- Shen's `shen.update-lambdatable` evaluates a curry wrapper for the
        -- new arity *before* the new defun has been installed (depth.shen
        -- redefining `depth` from 3 to 4 args). Baking the stale arity into
        -- PARTIAL / over-app expressions would silently produce wrong-arity
        -- residual closures.
        if #args == 0 then return "APP(" .. symlit(name) .. ")" end
        return "APP(" .. symlit(name) .. ", " .. argstr .. ")"
      end
    else
      -- unknown arity (typically a forward reference: a function defined
      -- later in the same file) -> late-bound fixed-arity dispatch
      return unknown_call(name, argstr, #args)
    end
  else
    local cur = curried_call(form, env)
    if cur then return cur end
    -- head is a bound variable or a compound expression -> generic apply
    local hv = cexpr(head, env)
    if #args == 0 then return "APP(" .. hv .. ")" end
    return "APP(" .. hv .. ", " .. argstr .. ")"
  end
end

-- Tail recursion modulo cons (#58). A function whose self-calls are all in
-- tail position OR are the cdr of a tail-position (cons H (self ...)) -- the
-- `[X | (f Xs)]` list-builder shape -- compiles its body as
--     TSTEP(m, a1..an)
-- and installs  impl(a1..an) = return TSTEP(false, a1..an).
-- With m false (the first call), every tail position behaves exactly as in
-- ordinary codegen, and a (cons H (self args)) site tail-calls
-- TLOOP(H, args). TLOOP allocates the first cell and iterates TSTEP(true, ..):
-- with m true a cons site returns TRMC_C (append a cell holding H, go on
-- with args), a plain self-call returns TRMC_T (go on with args), and any
-- other value is the list's tail, linked into the last cell before TLOOP
-- returns the head. The cells are fresh and unreachable from anything else until TLOOP
-- returns, so filling their cdrs in place is unobservable -- the argument
-- prims.lua's native append / shen.reverse-help already rely on.
--
-- One Lua frame per output element becomes a loop LuaJIT can trace (the
-- `[X | (f ...)]` shape otherwise aborts with "register coalescing too
-- complex" / down-recursion), and deep builders no longer consume stack.
-- Stack behaviour is otherwise unchanged: until a cell exists, base-case
-- tail calls are real tail calls (so mutual tail recursion through a
-- builder's base case stays constant-space), and once cells exist the
-- original was already non-tail. No goto: works on every host.
--
-- The building-mode handoff is ONE return value (the marker); the new cell's
-- car and the next arguments travel in chunk-level upvalues TH, T1..Tn,
-- stored after every sub-expression has been evaluated and read by TLOOP
-- immediately after TSTEP returns, so nothing can run in between. TLOOP
-- clears the handoff slots before the next step, so neither a normal return
-- nor an error keeps heads/arguments reachable through the installed function.
-- Returning them as multiple results instead made LuaJIT abort traces that
-- returned through TSTEP ("NYI: register coalescing too complex").
local function trmc_site(h, cargs, marker)
  local vals, slots = {}, {}
  if h then vals[1] = h; slots[1] = "TH" end
  for i = 1, #cargs do vals[#vals + 1] = cargs[i]; slots[#slots + 1] = "T" .. i end
  local names = {}
  for i = 1, #vals do names[i] = gen("r") end
  local nl = table.concat(names, ", ")
  local direct
  if marker == "TRMC_C" then
    direct = "TLOOP(" .. nl .. ")"
  else
    direct = "TSTEP(false" .. (#names > 0 and (", " .. nl) or "") .. ")"
  end
  local bind, store = "", ""
  if #names > 0 then
    bind = "local " .. nl .. " = " .. table.concat(vals, ", ") .. "; "
    store = table.concat(slots, ", ") .. " = " .. nl .. "; "
  end
  return "do " .. bind .. "if " .. SELF.mode .. " then " .. store .. "return "
         .. marker .. " end return " .. direct .. " end"
end

-- (cons H (self args)) in tail position of a TRMC body -> trmc_site.
local function try_trmc_cons(form, env)
  if not (SELF and SELF.trmc) then return nil end
  local head = car(form)
  if not (is_symbol(head) and head.name == "cons" and not env["cons"]) then return nil end
  local rest = cdr(form)
  if not (is_cons(rest) and is_cons(cdr(rest)) and cdr(cdr(rest)) == NIL) then return nil end
  local call = car(cdr(rest))
  if not (is_cons(call) and is_symbol(car(call)) and car(call).name == SELF.name
          and not env[SELF.name]) then
    return nil
  end
  local args = to_array(cdr(call))
  if #args ~= SELF.arity then return nil end
  SELF.used = true
  -- KL evaluates cons's arguments left to right: H, then the call's args.
  local hc = cexpr(car(rest), env)
  local cargs = {}
  for i = 1, #args do cargs[i] = cexpr(args[i], env) end
  return trmc_site(hc, cargs, "TRMC_C")
end

-- Tail-position DIRECT self-call with exact declared arity -> loop continue.
-- Returns the replacement statement string, or nil if this form is not a
-- lowerable self-call. Anything that doesn't match (calls through APP /
-- partials / variables, arity mismatches, shadowed name) keeps ordinary
-- codegen and still works: the loop only replaces the tail self-call; the
-- function value installed in F is unchanged.
local function try_self_tail(form, env)
  if not SELF then return nil end
  local head = car(form)
  if not (is_symbol(head) and not env[head.name] and head.name == SELF.name) then
    return nil
  end
  local args = to_array(cdr(form))
  if #args ~= SELF.arity then return nil end
  SELF.used = true
  if SELF.trmc then
    -- TRMC step body: a plain tail self-call continues the builder loop
    -- (building) or is an ordinary tail call of the step (not building).
    local cargs = {}
    for i = 1, #args do cargs[i] = cexpr(args[i], env) end
    return trmc_site(nil, cargs, "TRMC_T")
  end
  if #args == 0 then return "goto tco" end
  local cargs = {}
  for i = 1, #args do cargs[i] = cexpr(args[i], env) end
  return table.concat(SELF.lnames, ", ") .. " = "
         .. table.concat(cargs, ", ") .. "; goto tco"
end

-- detect a long (cons A (cons B ... TAIL)) spine and flatten it into a single
-- MKLIST({...}, tail) call, to avoid Lua's expression-nesting depth limit.
local function cons_chain(form)
  local elems = {}
  local cur = form
  while is_cons(cur) and is_symbol(car(cur)) and car(cur).name == "cons"
        and is_cons(cdr(cur)) and is_cons(cdr(cdr(cur))) and cdr(cdr(cdr(cur))) == NIL do
    elems[#elems+1] = car(cdr(cur))
    cur = car(cdr(cdr(cur)))
  end
  return elems, cur  -- elems (in order), final tail form
end

-- ------------------------------------------------------------------
-- constant folding of pure-data (cons ...) trees.
-- A form is constant data if it is an atom, a non-shadowed symbol, or
-- (cons A B) where A and B are constant data.  Such trees (quoted lists,
-- the giant kernel arity table, test-banner rcons forms) are built once at
-- compile time and referenced via the KDATA side table — this avoids Lua's
-- ~200-level expression-nesting parser limit and shrinks generated code.
-- KL cons cells are immutable, so sharing the constant is safe.
-- ------------------------------------------------------------------
C.KDATA = {}

-- When set, literal hoisting goes through the self-contained MKTREE
-- blueprint instead of the KDATA side table. Chunks compiled this way are
-- relocatable — no baked-in KDATA indices — which is what boot.lua's fasl
-- recorder needs to make cached user-program chunks replayable in sessions
-- whose KDATA population differs (e.g. nested loads, skipped typechecks).
C.NO_KDATA = false

-- Original spine-only const hoisting (kept for backward behavior on explicit (cons ...) forms).
local function const_count(form, env)
  local t = type(form)
  if t=="number" or t=="string" or t=="boolean" then return 1 end
  if form == NIL then return 1 end
  if is_symbol(form) then
    if env[form.name] then return nil end
    return 1
  end
  if is_cons(form) and is_symbol(car(form)) and car(form).name=="cons"
     and not env["cons"]
     and is_cons(cdr(form)) and is_cons(cdr(cdr(form))) and cdr(cdr(cdr(form)))==NIL then
    local a = const_count(car(cdr(form)), env); if not a then return nil end
    local b = const_count(car(cdr(cdr(form))), env); if not b then return nil end
    return a + b + 1
  end
  return nil
end
local function const_build(form)
  if is_cons(form) then
    return cons(const_build(car(cdr(form))), const_build(car(cdr(cdr(form)))))
  end
  return form
end
local function try_const(form, env)
  if C.NO_KDATA then return nil end
  if not (is_cons(form) and is_symbol(car(form)) and car(form).name=="cons") then return nil end
  local n = const_count(form, env)
  if n and n >= 24 then
    local v = const_build(form)
    local idx = #C.KDATA + 1
    C.KDATA[idx] = v
    return "KDATA[" .. idx .. "]"
  end
  return nil
end

-- General literal data hoisting for (cons ...) trees used as arguments
-- (e.g. embedded source forms passed to shen.record-kl in 42 stlib, giant
-- arity tables, etc.). A form is "literal data" only if it self-evaluates:
-- atoms / unbound symbols / NIL, or a `(cons L R)` call whose subtrees are
-- literal data. Crucially this MUST NOT match other calls like `(set ...)`,
-- `(shen.record-kl ...)`, or `(lambda ...)` — those have side effects /
-- semantics and cannot be replaced by their AST as a constant.
local function is_lit(form, env)
  local t = type(form)
  if t=="number" or t=="string" or t=="boolean" then return true end
  if form == NIL then return true end
  if is_symbol(form) then return not env[form.name] end
  if is_cons(form) then
    -- Only a (cons L R) call counts as data construction.
    -- The cons cell representing this call has shape:
    --   cons(cons-sym, cons(L, cons(R, NIL)))
    local head = form[1]
    if not (is_symbol(head) and head.name == "cons" and not env["cons"]) then
      return false
    end
    local rest = form[2]
    if not is_cons(rest) then return false end
    local rest2 = rest[2]
    if not is_cons(rest2) then return false end
    if rest2[2] ~= NIL then return false end
    return is_lit(rest[1], env) and is_lit(rest2[1], env)
  end
  return false
end
local function lit_count(form)
  if not is_cons(form) then return 1 end
  -- count cons-call nodes via the L and R arguments only
  local rest = form[2]
  return 1 + lit_count(rest[1]) + lit_count(rest[2][1])
end
-- Build the runtime cons tree value from a (cons L R) form recursively.
local function lit_build(form)
  if not is_cons(form) then return form end
  local rest = form[2]
  return cons(lit_build(rest[1]), lit_build(rest[2][1]))
end
local function try_lit_const(form, env)
  if C.NO_KDATA then return nil end
  if not is_cons(form) then return nil end
  if not is_lit(form, env) then return nil end
  local n = lit_count(form)
  if n >= 24 then
    local idx = #C.KDATA + 1
    C.KDATA[idx] = lit_build(form)
    return "KDATA[" .. idx .. "]"
  end
  return nil
end

-- ------------------------------------------------------------------
-- Deep cons-tree compilation.
--
-- A KLambda expression like `(cons A (cons B (cons (cons ...) ...)))` compiles
-- naively into deeply-nested `F["cons"](_, F["cons"](_, F["cons"](_, _)))`
-- expressions. Lua's parser refuses to compile expressions nested past about
-- 200 levels, so the 42 stlib's giant `shen.record-kl <name> <source-tree>`
-- calls (some have tree depth ~216 and ~7000 cons cells) blow up at load.
--
-- The fix: emit deep cons-trees through a flat blueprint array consumed by
-- the runtime helper `MKTREE`. The blueprint contains:
--   * `'v', <leaf-value-expr>` for each leaf (atom, unbound symbol,
--     literal cons subtree hoisted via KDATA, or non-cons-call subexpr like
--     `(protect Var)`), and
--   * `'c'` to pop the top two stack entries and replace them with a cons cell.
-- The whole expression becomes a single shallow call to MKTREE.
-- ------------------------------------------------------------------
local function count_cons_nodes(form)
  if not is_cons(form) then return 0 end
  if not (is_symbol(form[1]) and form[1].name == "cons") then return 0 end
  local rest = form[2]
  if not (is_cons(rest) and is_cons(rest[2]) and rest[2][2] == NIL) then return 0 end
  return 1 + count_cons_nodes(rest[1]) + count_cons_nodes(rest[2][1])
end

local function compile_cons_tree(form, env)
  local ops = {}
  local function visit(f)
    if is_cons(f) then
      -- prefer hoisting fully-literal subtrees as KDATA (one stack push)
      local hoisted = try_lit_const(f, env)
      if hoisted then
        ops[#ops+1] = "'v', " .. hoisted
        return
      end
      -- (cons L R) call: recurse into both halves, then emit 'c'
      if is_symbol(f[1]) and f[1].name == "cons" and not env["cons"] then
        local rest = f[2]
        if is_cons(rest) and is_cons(rest[2]) and rest[2][2] == NIL then
          visit(rest[1])
          visit(rest[2][1])
          ops[#ops+1] = "'c'"
          return
        end
      end
    end
    -- arbitrary leaf expression (constant, symbol, or non-cons call like `(protect V)`)
    ops[#ops+1] = "'v', " .. cexpr(f, env)
  end
  visit(form)
  return "MKTREE({" .. table.concat(ops, ", ") .. "})"
end

-- ------------------------------------------------------------------
-- trap-error peephole (shen-scheme emit-trap-error-optimize).
-- (trap-error (value X) (lambda E H)) and the same for <-vector / <-address,
-- when E is unused in H, become a non-throwing lookup. pcall is a LuaJIT
-- trace barrier; the kernel uses this pattern for unbound globals and empty
-- property-vector buckets.
-- ------------------------------------------------------------------
local function mentions_name(form, name, shadowed)
  if not is_cons(form) then
    return is_symbol(form) and form.name == name and not shadowed[name]
  end
  local head = form[1]
  if is_symbol(head) then
    local op = head.name
    if op == "let" and not shadowed["let"] then
      local var = car(cdr(form))
      local val = car(cdr(cdr(form)))
      local body = car(cdr(cdr(cdr(form))))
      if mentions_name(val, name, shadowed) then return true end
      local nb = {}; for k,v in pairs(shadowed) do nb[k] = v end
      if is_symbol(var) then nb[var.name] = true end
      return mentions_name(body, name, nb)
    elseif op == "lambda" and not shadowed["lambda"] then
      local var = car(cdr(form))
      local body = car(cdr(cdr(form)))
      local nb = {}; for k,v in pairs(shadowed) do nb[k] = v end
      if is_symbol(var) then nb[var.name] = true end
      return mentions_name(body, name, nb)
    end
  end
  local cur = form
  while is_cons(cur) do
    if mentions_name(cur[1], name, shadowed) then return true end
    cur = cur[2]
  end
  return false
end

local function const_lua(form, env)
  if form == NIL then return "NIL" end
  local t = type(form)
  if t == "number" then return cnum(form) end
  if t == "boolean" then return form and "true" or "false" end
  if t == "string" then return qstr(form) end
  if is_symbol(form) and not env[form.name] then return symlit(form.name) end
  return nil
end

local function try_trap_opt(form, env)
  if not (is_cons(form) and is_symbol(form[1]) and form[1].name == "trap-error"
          and not env["trap-error"]) then
    return nil
  end
  local expr = car(cdr(form))
  local handler = car(cdr(cdr(form)))
  if not (is_cons(handler) and is_symbol(handler[1]) and handler[1].name == "lambda"
          and not env["lambda"]) then
    return nil
  end
  local var = car(cdr(handler))
  local body = car(cdr(cdr(handler)))
  if not is_symbol(var) then return nil end
  if mentions_name(body, var.name, {}) then return nil end
  if not is_cons(expr) then return nil end
  local eh = expr[1]
  if not (is_symbol(eh) and not env[eh.name]) then return nil end
  local default = const_lua(body, env)
  if not default then
    default = "function() return " .. cexpr(body, env) .. " end"
  end
  -- Operands must not raise (shen-scheme note; bifrost trap-error-operand-raises).
  -- Variables and literals are safe; (<-vector (simple-error "boom") 1) is not.
  local function safe_op(form)
    if form == NIL then return true end
    local t = type(form)
    if t == "number" or t == "boolean" or t == "string" then return true end
    return is_symbol(form)
  end
  if eh.name == "value" then
    local x = car(cdr(expr))
    if not safe_op(x) then return nil end
    if is_symbol(x) and not env[x.name] then
      return "VALUE_OR_S(" .. qstr(x.name) .. ", " .. default .. ")"
    end
    return "VALUE_OR(" .. cexpr(x, env) .. ", " .. default .. ")"
  elseif eh.name == "<-vector" then
    local v = car(cdr(expr))
    local n = car(cdr(cdr(expr)))
    if not (safe_op(v) and safe_op(n)) then return nil end
    return "VEC_OR(" .. cexpr(v, env) .. ", " .. cexpr(n, env) .. ", " .. default .. ")"
  elseif eh.name == "<-address" then
    local v = car(cdr(expr))
    local n = car(cdr(cdr(expr)))
    if not (safe_op(v) and safe_op(n)) then return nil end
    return "ADDR_OR(" .. cexpr(v, env) .. ", " .. cexpr(n, env) .. ", " .. default .. ")"
  elseif eh.name == "get" then
    local x = car(cdr(expr))
    local y = car(cdr(cdr(expr)))
    local z = car(cdr(cdr(cdr(expr))))
    if not (safe_op(x) and safe_op(y) and safe_op(z)) then return nil end
    return "GET_OR(" .. cexpr(x, env) .. ", " .. cexpr(y, env) .. ", "
           .. cexpr(z, env) .. ", " .. default .. ")"
  end
  return nil
end

-- ------------------------------------------------------------------
-- freeze-let failure continuations (see CONT).
-- ------------------------------------------------------------------
local function analyze_cont(form, cname, env, tailpos)
  if not is_cons(form) then
    if is_symbol(form) and form.name == cname then
      return true, 0, 1, 0
    end
    return false, 0, 0, 0
  end
  local head = car(form)
  if is_symbol(head) and not env[head.name] then
    local op = head.name
    if op == "thaw" then
      local args = to_array(cdr(form))
      if #args == 1 and is_symbol(args[1]) and args[1].name == cname then
        if tailpos then return false, 1, 0, 0 end
        return false, 1, 0, 1
      end
    elseif op == "let" then
      local var = car(cdr(form))
      local val = car(cdr(cdr(form)))
      local body = car(cdr(cdr(cdr(form))))
      local e1, t1, o1, n1 = analyze_cont(val, cname, env, false)
      if is_symbol(var) and var.name == cname then
        return e1, t1, o1, n1
      end
      local e2, t2, o2, n2 = analyze_cont(body, cname, env, tailpos)
      return e1 or e2, t1 + t2, o1 + o2, n1 + n2
    elseif op == "lambda" then
      local var = car(cdr(form))
      local body = car(cdr(cdr(form)))
      if is_symbol(var) and var.name == cname then return false, 0, 0, 0 end
      local e, t, o, n = analyze_cont(body, cname, env, false)
      if t > 0 or o > 0 then return true, t, o, n end
      return e, t, o, n
    elseif op == "freeze" then
      local body = car(cdr(form))
      local e, t, o, n = analyze_cont(body, cname, env, false)
      if t > 0 or o > 0 then return true, t, o, n end
      return e, t, o, n
    elseif op == "trap-error" then
      local e1, t1, o1, n1 = analyze_cont(car(cdr(form)), cname, env, false)
      local e2, t2, o2, n2 = analyze_cont(car(cdr(cdr(form))), cname, env, false)
      if t1 + t2 > 0 or o1 + o2 > 0 then return true, t1 + t2, o1 + o2, n1 + n2 end
      return e1 or e2, t1 + t2, o1 + o2, n1 + n2
    elseif op == "if" then
      local test = car(cdr(form))
      local th = car(cdr(cdr(form)))
      local rest = cdr(cdr(cdr(form)))
      local el = is_cons(rest) and car(rest) or nil
      local e, t, o, n = analyze_cont(test, cname, env, false)
      local e2, t2, o2, n2 = analyze_cont(th, cname, env, tailpos)
      e, t, o, n = e or e2, t + t2, o + o2, n + n2
      if el then
        local e3, t3, o3, n3 = analyze_cont(el, cname, env, tailpos)
        e, t, o, n = e or e3, t + t3, o + o3, n + n3
      end
      return e, t, o, n
    elseif op == "cond" then
      local e, t, o, n = false, 0, 0, 0
      local cur = cdr(form)
      while is_cons(cur) do
        local cl = cur[1]
        local e1, t1, o1, n1 = analyze_cont(car(cl), cname, env, false)
        local e2, t2, o2, n2 = analyze_cont(car(cdr(cl)), cname, env, tailpos)
        e, t, o, n = e or e1 or e2, t + t1 + t2, o + o1 + o2, n + n1 + n2
        cur = cur[2]
      end
      return e, t, o, n
    elseif op == "do" then
      local forms = to_array(cdr(form))
      local e, t, o, n = false, 0, 0, 0
      for i = 1, #forms do
        local e1, t1, o1, n1 = analyze_cont(forms[i], cname, env, tailpos and i == #forms)
        e, t, o, n = e or e1, t + t1, o + o1, n + n1
      end
      return e, t, o, n
    elseif op == "and" or op == "or" then
      local a = car(cdr(form)); local b = car(cdr(cdr(form)))
      local e1, t1, o1, n1 = analyze_cont(a, cname, env, false)
      local e2, t2, o2, n2 = analyze_cont(b, cname, env, tailpos)
      return e1 or e2, t1 + t2, o1 + o2, n1 + n2
    elseif op == "type" then
      return analyze_cont(car(cdr(form)), cname, env, tailpos)
    end
  end
  if is_symbol(head) and head.name == cname then
    return true, 0, 1, 0
  end
  local e, t, o, n = false, 0, 0, 0
  local cur = form
  while is_cons(cur) do
    local e1, t1, o1, n1 = analyze_cont(cur[1], cname, env, false)
    e, t, o, n = e or e1, t + t1, o + o1, n + n1
    cur = cur[2]
  end
  return e, t, o, n
end

local function lookup_cont(name)
  for i = #CONT, 1, -1 do
    if CONT[i].name == name then return CONT[i] end
  end
end

local function snapshot_env(eform, env)
  if not SELF then return env, "" end
  local fv = {}
  collect_free(eform, env, {}, fv)
  local newenv = {}; for k, v in pairs(env) do newenv[k] = v end
  local stmts = {}
  local params = {}
  for i = 1, #SELF.lnames do params[SELF.lnames[i]] = true end
  for kname in pairs(fv) do
    local ln = env[kname]
    if type(ln) == "string" and params[ln] then
      local cap = gen("c")
      stmts[#stmts + 1] = "local " .. cap .. " = " .. ln .. ";"
      newenv[kname] = cap
    end
  end
  return newenv, table.concat(stmts, " ")
end

local function try_cont_thaw(form, env, tail)
  if not is_cons(form) then return nil end
  local h = form[1]
  if not (is_symbol(h) and h.name == "thaw" and not env["thaw"]) then return nil end
  local rest = form[2]
  if not (is_cons(rest) and rest[2] == NIL and is_symbol(rest[1])) then return nil end
  local rec = lookup_cont(rest[1].name)
  if not rec then return nil end
  if rec.kind == "inline" then
    if tail then return ctail(rec.expr, rec.env) end
    return cexpr(rec.expr, rec.env)
  end
  if rec.kind == "goto" and tail then
    return "goto " .. rec.label
  end
  return nil
end

local function try_lower_freeze_let(var, val, body, env)
  -- SHEN_FREEZE_CONT=off keeps BIND/THAW (A/B for load/compile benches).
  if os.getenv("SHEN_FREEZE_CONT") == "off" then return nil end
  if not is_symbol(var) then return nil end
  if not (is_cons(val) and is_symbol(val[1]) and val[1].name == "freeze"
          and not env["freeze"]) then
    return nil
  end
  local eform = car(cdr(val))
  local escapes, nthaw, nother, nontail = analyze_cont(body, var.name, env, true)
  if escapes or nother > 0 or nthaw == 0 then return nil end
  local freeze_env, snap = snapshot_env(eform, env)
  if nthaw == 1 then
    CONT[#CONT + 1] = { name = var.name, kind = "inline", expr = eform, env = freeze_env }
    local s = ctail(body, env)
    CONT[#CONT] = nil
    return (snap ~= "" and (snap .. " ") or "") .. s
  end
  if nontail > 0 or not HAS_GOTO then return nil end
  local rec = {
    name = var.name, kind = "goto", expr = eform, env = freeze_env,
    label = gen("fail"),
  }
  CONT[#CONT + 1] = rec
  local body_s = ctail(body, env)
  CONT[#CONT] = nil
  -- Inner `do` so a `return` in the body is the last statement of its block;
  -- `goto fail` still reaches the label after (same idiom as ::tco::).
  return (snap ~= "" and (snap .. " ") or "")
         .. "do " .. body_s .. " end ::" .. rec.label .. ":: "
         .. ctail(eform, freeze_env)
end

local function push_inline_cont()
  local saved = CONT
  local f = {}
  for i = 1, #CONT do
    if CONT[i].kind == "inline" then f[#f + 1] = CONT[i] end
  end
  CONT = f
  return saved
end

-- ------------------------------------------------------------------
-- cexpr : value position (returns a Lua expression string)
-- ------------------------------------------------------------------
function cexpr(form, env)
  if not is_cons(form) then
    if type(form)=="number" then return cnum(form) end
    return catom(form, env)
  end
  local head = car(form)
  -- Pattern-match accessor chains: reuse / bind hd-tl steps as locals when a
  -- statement-point hoist buffer is active (see the CSE block above ccall).
  if HOIST then
    local cn = try_chain(form, env)
    if cn then return cn end
  end
  if is_symbol(head) and head.name == "cons" and not env["cons"] then
    local k = try_const(form, env)
    if k then return k end
    -- If this is a deep cons-tree (would blow Lua's expression-nesting limit
    -- when compiled as nested F["cons"] calls), emit via the flat MKTREE
    -- blueprint instead. 60 nodes is well below the parser limit and gives
    -- the inline path a chance for moderately-sized forms.
    if count_cons_nodes(form) >= 60 then
      return compile_cons_tree(form, env)
    end
    local elems, tail = cons_chain(form)
    if #elems >= 16 then
      local parts = {}
      for i=1,#elems do parts[i] = cexpr(elems[i], env) end
      return "MKLIST({" .. table.concat(parts, ", ") .. "}, " .. cexpr(tail, env) .. ")"
    end
  end
  -- General large literal data (catches embedded source trees in stlib etc.)
  local k = try_lit_const(form, env)
  if k then return k end
  if is_symbol(head) and not env[head.name] then
    local op = head.name
    if op == "trap-error" then
      local opt = try_trap_opt(form, env)
      if opt then
        if HOIST then HOIST.pure = false end
        return opt
      end
    end
    if op == "if" or op == "cond" or op == "let" or op == "do"
       or op == "trap-error" or op == "and" or op == "or" then
      -- Control form in value position. The obvious codegen wraps the tail
      -- compilation in an IIFE `(function() ... end)()`, but that closure
      -- captures every in-scope local it references (6-9 upvalues in the
      -- typechecker) and is re-allocated on EVERY evaluation -- measured at
      -- ~1490 bytes/inference, 64% of all typechecker allocation.
      --
      -- Instead, hoist the body to a *constant* function that takes its free
      -- variables as parameters (same KB-table mechanism as `freeze`), and
      -- call it. A nested function with no upvalues is created once at chunk
      -- load, not per evaluation, so this allocates nothing per call. Compile
      -- the body FIRST so any nested freezes/control-forms claim lower KB
      -- indices before we take ours.
      if CTX then
        local fv = {}
        collect_free(form, env, {}, fv)
        local lnames = {}
        for kname in pairs(fv) do lnames[#lnames+1] = env[kname] end
        table.sort(lnames)
        local params = table.concat(lnames, ", ")
        -- Compile the body FIRST so nested freezes/control-forms claim their KC
        -- indices before we take ours. The body references only its param free
        -- vars, globals, and KC (a load-time upvalue) -- never an impl local --
        -- so this stays a constant function with no per-call FNEW.
        -- Clear SELF: this body becomes a SEPARATE Lua function (KC[i]), so a
        -- self-call in here is not in impl's tail position and a `goto tco`
        -- would illegally cross the function boundary. Likewise reset the
        -- chain-hoist state: KC[i] has its own local budget, and locals cached
        -- in the enclosing function are not in scope here.
        local saved_self = SELF
        local saved_h, saved_cc, saved_fnl = HOIST, CCACHE, FNL
        local saved_cont = push_inline_cont()
        local saved_impl = IN_IMPL
        SELF = nil; HOIST = nil; CCACHE = {}; FNL = new_fnl(true); IN_IMPL = false
        local body_stmts = ctail(form, env)
        if FNL.pt then body_stmts = "local PT = {}; " .. body_stmts end
        SELF = saved_self; HOIST = saved_h; CCACHE = saved_cc; FNL = saved_fnl
        CONT = saved_cont; IN_IMPL = saved_impl
        local idx = #CTX.cbodies + 1
        CTX.cbodies[idx] = "function(" .. params .. ") " .. body_stmts .. " end"
        -- The KC call itself may raise or side-effect: later siblings in the
        -- enclosing statement must not hoist chains ahead of it.
        if HOIST then HOIST.pure = false end
        return "KC[" .. idx .. "](" .. params .. ")"
      end
      -- No per-defun context (top-level eval chunk): fall back to the IIFE.
      -- (Clear SELF here too: the IIFE is a separate function.)
      local saved_self = SELF
      local saved_h, saved_cc, saved_fnl = HOIST, CCACHE, FNL
      local saved_cont = push_inline_cont()
      local saved_impl = IN_IMPL
      SELF = nil; HOIST = nil; CCACHE = {}; FNL = new_fnl(true); IN_IMPL = false
      local body_stmts = ctail(form, env)
      if FNL.pt then body_stmts = "local PT = {}; " .. body_stmts end
      SELF = saved_self; HOIST = saved_h; CCACHE = saved_cc; FNL = saved_fnl
      CONT = saved_cont; IN_IMPL = saved_impl
      if HOIST then HOIST.pure = false end
      return "(function() " .. body_stmts .. " end)()"
    end
    -- For ordinary calls, opportunistically let-float a trailing let argument
    -- so that nested continuation-passing chains compile flat.
    local floated = try_let_float(form, env)
    if floated then return cexpr(floated, env) end
    if op == "lambda" then
      local v = car(cdr(form))
      local body = car(cdr(cdr(form)))
      local ln = gen("v")
      local e2 = extend(env, v.name, ln)
      -- Deferred body: nothing inside may be hoisted to the creation site.
      -- Not impl-scope: `fN` locals live in impl, not this nested function.
      local saved_h, saved_impl = HOIST, IN_IMPL
      HOIST = nil; IN_IMPL = false
      local bodyc = cexpr(body, e2)
      HOIST = saved_h; IN_IMPL = saved_impl
      return "MKFUN(1, function(" .. ln .. ") return " .. bodyc .. " end)"
    elseif op == "freeze" then
      local body = car(cdr(form))
      if CTX then
        -- Hoist the freeze body to the chunk-scope KC table (a constant function
        -- built once at load), abstracting its free vars as params; BIND snapshots
        -- the current captures into a thunk at the use site. Putting the body in
        -- KC rather than a per-impl-call table means the function literal is
        -- created ONCE, not on every call to the enclosing defun -- which in the
        -- recursive typechecker was a major per-inference allocation source.
        local fv = {}
        collect_free(body, env, {}, fv)
        local lnames = {}
        for kname in pairs(fv) do lnames[#lnames+1] = env[kname] end
        table.sort(lnames)  -- stable order for caller / body
        -- Deferred body: nothing inside may be hoisted to the creation site.
        local saved_h, saved_impl = HOIST, IN_IMPL
        HOIST = nil; IN_IMPL = false
        local body_str = cexpr(body, env)
        HOIST = saved_h; IN_IMPL = saved_impl
        local idx = #CTX.cbodies + 1
        CTX.cbodies[idx] = "function(" .. table.concat(lnames, ", ") .. ") return "
                           .. body_str .. " end"
        local call_args = (#lnames == 0) and "" or (", " .. table.concat(lnames, ", "))
        return "BIND(KC[" .. idx .. "]" .. call_args .. ")"
      end
      local saved_h, saved_impl = HOIST, IN_IMPL
      HOIST = nil; IN_IMPL = false
      local bodyc = cexpr(body, env)
      HOIST = saved_h; IN_IMPL = saved_impl
      return "MKFUN(0, function() return " .. bodyc .. " end)"
    elseif op == "defun" then
      error("defun in expression position")
    elseif op == "type" then
      -- (type EXPR TYPE) : types erased at KL boundary -> just the expr
      return cexpr(car(cdr(form)), env)
    else
      local ct = try_cont_thaw(form, env, false)
      if ct then return ct end
      return ccall(form, env)
    end
  else
    local ct = try_cont_thaw(form, env, false)
    if ct then return ct end
    return ccall(form, env)
  end
end

-- ------------------------------------------------------------------
-- Statement-nesting depth ctail will emit for `form`, used to pick which
-- branch of an `if` gets nested inside the guard block (the other is emitted
-- FLAT after it -- see the if case in ctail below). Kernel pattern-match code
-- chains one (if TEST ...) per pattern element down the then-spine (and one
-- (and ...) per test inside the KC'd guard), so nesting the shallower branch
-- keeps total statement depth roughly the pattern's TREE depth instead of its
-- element COUNT -- which is what used to blow LuaJIT's ~200 "syntax levels".
-- This is only a heuristic for choosing the flat branch; either choice is
-- semantically identical.
-- ------------------------------------------------------------------
local function ctail_depth(form, env)
  if not is_cons(form) then return 0 end
  local h = form[1]
  if not (is_symbol(h) and not env[h.name]) then return 0 end
  local op = h.name
  if op == "if" then
    local th = car(cdr(cdr(form)))
    local rest = cdr(cdr(cdr(form)))
    local el = is_cons(rest) and car(rest) or nil
    local dt = ctail_depth(th, env)
    local de = el and ctail_depth(el, env) or 0
    if de <= dt then
      return math.max(dt, 1 + de)   -- else nested, then flat
    end
    return math.max(de, 1 + dt)     -- then nested, else flat
  elseif op == "and" or op == "or" then
    local b = cdr(cdr(form))
    return is_cons(b) and ctail_depth(car(b), env) or 0
  elseif op == "let" then
    local b = cdr(cdr(cdr(form)))
    return is_cons(b) and ctail_depth(car(b), env) or 0
  elseif op == "do" then
    local forms = to_array(cdr(form))
    if #forms == 0 then return 0 end
    return ctail_depth(forms[#forms], env)
  elseif op == "cond" then
    local m = 0
    local cur = cdr(form)
    while is_cons(cur) do
      local d = ctail_depth(car(cdr(cur[1])), env)
      if d > m then m = d end
      cur = cur[2]
    end
    return 1 + m
  elseif op == "type" then
    return ctail_depth(car(cdr(form)), env)
  end
  return 0
end

-- ------------------------------------------------------------------
-- ctail : tail position (emits statements; control-flow returns)
-- ------------------------------------------------------------------
function ctail(form, env)
  if not is_cons(form) then
    return "return " .. (type(form)=="number" and cnum(form) or catom(form, env))
  end
  local head = car(form)
  if is_symbol(head) and not env[head.name] then
    local op = head.name
    if op == "if" then
      local test = car(cdr(form))
      local th   = car(cdr(cdr(form)))
      local rest = cdr(cdr(cdr(form)))
      local el   = is_cons(rest) and car(rest) or nil -- may be missing
      -- FLAT emission: nest only the shallower branch inside the guard block
      -- and emit the deeper branch as a plain statement sequence AFTER it.
      -- Every ctail-compiled branch ends in a control transfer (return / goto
      -- tco), so control reaches the flat branch exactly when the nested one
      -- was not taken -- semantics identical to the old fully-nested
      -- `if ... then ... else ... end`, but a then-spine of N pattern tests
      -- now costs O(1) nesting instead of N (LuaJIT parser rejects ~200).
      local pre, testc = cstmt_expr(test, env)
      local dt = ctail_depth(th, env)
      local de = el and ctail_depth(el, env) or 0
      if de <= dt then
        -- nest else, flatten then (guard inverted; `not` exactly flips Lua
        -- truthiness, which is what the old `if (test)` dispatched on)
        local saved_cc = CCACHE
        CCACHE = child_cache()
        local els = el and ctail(el, env) or "return false"
        CCACHE = saved_cc
        return pre .. "if not (" .. testc .. ") then " .. els .. " end "
               .. ctail(th, env)
      else
        -- nest then, flatten else
        local saved_cc = CCACHE
        CCACHE = child_cache()
        local ths = ctail(th, env)
        CCACHE = saved_cc
        return pre .. "if (" .. testc .. ") then " .. ths .. " end "
               .. ctail(el, env)
      end
    elseif op == "cond" then
      -- (cond (test res) ... )
      local clauses = to_array(cdr(form))
      local parts = {}
      for i=1,#clauses do
        local cl = clauses[i]
        local test = car(cl)
        local res  = car(cdr(cl))
        -- each result sits inside its own then-block: block-scope its chain cache
        local saved_cc = CCACHE
        CCACHE = child_cache()
        local resc = ctail(res, env)
        CCACHE = saved_cc
        if i == 1 then
          parts[#parts+1] = "if (" .. cexpr(test, env) .. ") then " .. resc
        else
          parts[#parts+1] = " elseif (" .. cexpr(test, env) .. ") then " .. resc
        end
      end
      parts[#parts+1] = " else return ERR(\"cond failure\") end"
      return table.concat(parts)
    elseif op == "let" then
      local v   = car(cdr(form))
      local val = car(cdr(cdr(form)))
      local body= car(cdr(cdr(cdr(form))))
      local lowered = try_lower_freeze_let(v, val, body, env)
      if lowered then return lowered end
      local ln = gen("v")
      local pre, valc = cstmt_expr(val, env)
      local e2 = extend(env, v.name, ln)
      return pre .. "local " .. ln .. " = " .. valc .. "; " .. ctail(body, e2)
    elseif op == "do" then
      local forms = to_array(cdr(form))
      local s = {}
      for i=1,#forms-1 do
        local es = cexpr(forms[i], env)
        -- Turn intermediate do values into a statement with a block-scoped
        -- throwaway local. Valid Lua for any expression (var, call, etc.),
        -- and the local dies at `end`, so giant do-chains (42's
        -- stlib.initialise-*, shen.initialise-lambda-forms) still add no
        -- locals toward the 200-local limit. This used to be an IIFE,
        -- `(function() return E end)();`, which allocated a closure (FNEW)
        -- on every execution -- and FNEW is NYI in the LuaJIT trace
        -- compiler, so any loop running a `do` aborted its trace (#66).
        s[#s+1] = "do local _ = " .. es .. " end"
      end
      s[#s+1] = ctail(forms[#forms], env)
      return table.concat(s, " ")
    elseif op == "and" then
      -- FLAT emission (see the `if` case): the kernel's pattern-match guards
      -- are right-nested (and t1 (and t2 ...)) chains; nesting the second arg
      -- inside `then` cost one syntax level per test. The early-exit form is
      -- semantically identical and costs O(1) nesting per link.
      local a = car(cdr(form)); local b = car(cdr(cdr(form)))
      local pre, ac = cstmt_expr(a, env)
      return pre .. "if not (" .. ac .. ") then return false end " .. ctail(b, env)
    elseif op == "or" then
      local a = car(cdr(form)); local b = car(cdr(cdr(form)))
      local pre, ac = cstmt_expr(a, env)
      return pre .. "if (" .. ac .. ") then return true end " .. ctail(b, env)
    elseif op == "trap-error" then
      local opt = try_trap_opt(form, env)
      if opt then return "return " .. opt end
      local expr = car(cdr(form))
      local handler = car(cdr(cdr(form)))
      -- (trap-error E H): if E raises a Shen exception, apply H to it.
      local hc = cexpr(handler, env)
      return "local ok,res = pcall(function() return " .. cexpr(expr, env)
             .. " end); if ok then return res else return APP(" .. hc .. ", TOEXCN(res)) end"
    elseif op == "type" then
      return ctail(car(cdr(form)), env)
    elseif op == "lambda" or op == "freeze" then
      return "return " .. cexpr(form, env)
    else
      local ct = try_cont_thaw(form, env, true)
      if ct then return ct end
      local floated = try_let_float(form, env)
      if floated then return ctail(floated, env) end
      -- try_flatten_call_chain BEFORE try_self_tail: a >=16-deep last-arg
      -- chain must still flatten (parser nesting limit); it then keeps an
      -- ordinary tail call for the outer frame, which is always correct.
      -- EXCEPT for pure hd/tl accessor chains: flatten spends one Lua local
      -- per frame (a ~300-step pattern path would blow the 200-local limit),
      -- while the chain-CSE flush site below both budgets its locals (PT
      -- spill) and caches the steps for reuse by sibling branches.
      if not (chain_key(form, env)
              and C.ARITY["hd"] == 1 and C.ARITY["tl"] == 1) then
        local flat = try_flatten_call_chain(form, env)
        if flat then return flat end
      end
      -- Both the self-tail assignment's RHS list and an ordinary tail call's
      -- arguments evaluate left-to-right at this statement point, so give
      -- them a chain-hoist flush site too (deep accessor chains in recursive
      -- rule bodies would otherwise still nest past the parser limit).
      local saved_h = HOIST
      HOIST = { out = {}, pure = true }
      local selfjump = try_trmc_cons(form, env) or try_self_tail(form, env)
      if selfjump then
        local pre = table.concat(HOIST.out)
        HOIST = saved_h
        return pre .. selfjump
      end
      local callc = ccall(form, env)
      local pre = table.concat(HOIST.out)
      HOIST = saved_h
      return pre .. "return " .. callc
    end
  else
    local floated = try_let_float(form, env)
    if floated then return ctail(floated, env) end
    local flat = try_flatten_call_chain(form, env)
    if flat then return flat end
    local saved_h = HOIST
    HOIST = { out = {}, pure = true }
    local callc = ccall(form, env)
    local pre = table.concat(HOIST.out)
    HOIST = saved_h
    return pre .. "return " .. callc
  end
end

-- ------------------------------------------------------------------
-- top-level form compilation
-- ------------------------------------------------------------------
-- compile (defun NAME (PARAMS) BODY) -> Lua source registering into F-table.
local function cdefun(form)
  local name = car(cdr(form)).name
  local params = to_array(car(cdr(cdr(form))))
  local body = car(cdr(cdr(cdr(form))))
  local env = {}
  local lnames = {}
  for i=1,#params do
    local ln = gen("a")
    env[params[i].name] = ln
    lnames[i] = ln
  end
  C.ARITY[name] = #params
  local saved = CTX
  CTX = new_ctx()
  -- fresh chain-hoist state for the impl function (see CSE block above ccall)
  local saved_fnl, saved_cc = FNL, CCACHE
  FNL = new_fnl(true)
  CCACHE = {}
  -- Self-tail-call -> loop lowering. Eligible unless:
  --   * the function is not PURELY tail-recursive -- some self-reference is a
  --     non-tail call, a partial application, or sits in a tail self-call's
  --     own arguments (see pure_tail_self: mixed lowering measurably regresses
  --     LuaJIT tracing, tak 2.1x), or
  --   * some lambda in the body closes over a param (its MKFUN upvalue would
  --     alias the mutating loop local; see lambda_captures_param), or
  --   * the name is an inlined 2-arg arithmetic prim (a self-call today
  --     compiles to the ADD/SUB/... numeric fast path, NOT a recursive call;
  --     lowering would change that pre-existing behavior).
  -- Semantics note: a lowered tail self-call no longer re-reads F[name] each
  -- iteration, so a mid-recursion redefinition of the function (or a track/
  -- step wrapper installed around F[name]) is not observed by an already-
  -- running loop. Non-tail self-calls and APP/partial calls are unaffected.
  local saved_self = SELF
  local trmc_st = { cons = false }
  if HAS_GOTO and not ARITH2[name] and pure_tail_self(body, name, #params, true)
     and not lambda_captures_param(body, env, {}) then
    SELF = { name = name, arity = #params, lnames = lnames, used = false }
  elseif C.TRMC and not ARITH2[name] and name ~= "cons"
     and pure_tail_self(body, name, #params, true, trmc_st) and trmc_st.cons then
    -- TRMC step body: its params never mutate (each TSTEP call is a fresh
    -- frame), so lambda_captures_param does not apply.
    SELF = { name = name, arity = #params, lnames = lnames, used = false,
             trmc = true, mode = gen("m") }
  else
    SELF = nil
  end
  local trmc = SELF ~= nil and SELF.trmc
  local saved_cont = CONT
  CONT = {}
  local saved_in, saved_dn = IN_IMPL, DEFUN_NAME
  local saved_fl, saved_fm = FREF_LIST, FREF_MAP
  IN_IMPL, DEFUN_NAME, FREF_LIST, FREF_MAP = true, name, {}, {}
  local body_src = ctail(body, env)
  local fref_decls = {}
  for i, r in ipairs(FREF_LIST) do
    fref_decls[i] = "local " .. r.ln .. " = F[" .. qstr(r.name) .. "];"
  end
  local lowered = SELF ~= nil and SELF.used and not trmc
  local trmc_used = trmc and SELF.used
  local trmc_mode = trmc and SELF.mode
  SELF = saved_self
  CONT = saved_cont
  IN_IMPL, DEFUN_NAME, FREF_LIST, FREF_MAP = saved_in, saved_dn, saved_fl, saved_fm
  if lowered then
    -- `while true` (not a bare backward goto) so LuaJIT emits a real LOOP
    -- bytecode -- the natural trace anchor. ::tco:: sits at the end of the
    -- block ("continue" idiom): every `goto tco` re-enters the loop with the
    -- params already reassigned; all other paths `return` out. let-locals are
    -- declared inside the block, so closures over them are closed at each
    -- iteration boundary (fresh per iteration).
    -- The extra inner `do ... end` is required by Lua's grammar: the flat
    -- statement sequences ctail now emits can legitimately end in a bare
    -- `return`, and `return` must be the LAST statement of its block -- the
    -- ::tco:: label may not follow it directly. Closing the inner block first
    -- keeps every return legal; `goto tco` still reaches the label (jumping
    -- to a label at the end of an enclosing block is the sanctioned
    -- "continue" idiom).
    body_src = "while true do do " .. body_src .. " end ::tco:: end"
  end
  -- chain-hoist spill table (only when the local budget was exceeded);
  -- declared outside the tco loop: every PT slot is written before it is read
  -- on every path of every iteration, so one table per call suffices.
  if FNL.pt then body_src = "local PT = {}; " .. body_src end
  if #fref_decls > 0 then body_src = table.concat(fref_decls, " ") .. " " .. body_src end
  FNL = saved_fnl
  CCACHE = saved_cc
  -- Hoisted (freeze ...) bodies AND value-position control-form bodies both go
  -- into a single chunk-scope KC table, built ONCE at load -- NOT inside impl.
  -- Each KC entry is a constant function abstracting its free vars as params
  -- (BIND snapshots a freeze's captures at the use site; a control form is just
  -- called). Because the table and its function literals are created once rather
  -- than on every impl call, the recursive typechecker no longer re-allocates a
  -- freeze-body table per inference. The BIND(KC[i],...) / KC[i](...) use sites
  -- stay flat, so deep CPS chains still compile under Lua's syntax-level limit.
  --
  -- We MUST forward-declare `local KC` and assign on a separate line so a KC
  -- body that references KC[j] (a nested hoist) captures KC as an upvalue.
  local kc_init = ""
  if #CTX.cbodies > 0 then
    local parts = { "local KC; KC = {" }
    for i, b in ipairs(CTX.cbodies) do
      parts[#parts+1] = "[" .. i .. "] = " .. b .. (i == #CTX.cbodies and "" or ",")
    end
    parts[#parts+1] = "};"
    kc_init = table.concat(parts, " ") .. " "
  end
  CTX = saved
  local plist = table.concat(lnames, ", ")
  local src
  if trmc_used then
    local cm = #lnames > 0 and ", " or ""
    local tl = {}
    for i = 1, #lnames do tl[i] = "T" .. i end
    local tlist = table.concat(tl, ", ")
    src = "do " .. kc_init
      .. "local impl, TSTEP, TLOOP, TH" .. cm .. tlist .. "; "
      .. "TSTEP = function(" .. trmc_mode .. cm .. plist .. ") " .. body_src .. " end; "
      .. "TLOOP = function(h" .. cm .. plist .. ") "
      ..   "local head = setmetatable({h, NIL}, CMT); local last = head; "
      ..   "while true do "
      ..     "local k = TSTEP(true" .. cm .. plist .. "); "
      ..     "if k == TRMC_C then local c = setmetatable({TH, NIL}, CMT); last[2] = c; last = c; "
      ..     "elseif k ~= TRMC_T then last[2] = k; return head end "
      ..     (#lnames > 0 and (plist .. " = " .. tlist .. "; ") or "")
      ..     "TH" .. cm .. tlist .. " = nil; "
      ..   "end "
      .. "end; "
      .. "impl = function(" .. plist .. ") return TSTEP(false" .. cm .. plist .. ") end; "
      .. "F[" .. qstr(name) .. "] = impl; FA[impl] = " .. #params .. " end"
  else
    src = "do " .. kc_init
            .. "local function impl(" .. plist .. ") "
            .. body_src .. " end "
            .. "F[" .. qstr(name) .. "] = impl; FA[impl] = " .. #params .. " end"
  end
  return src
end
C.cdefun = cdefun

-- Pre-scan a list of forms to register arities of all defuns (so mutual /
-- forward references compile as direct exact-arity calls).
function C.prescan(forms)
  for _,f in ipairs(forms) do
    if is_cons(f) and is_symbol(car(f)) and car(f).name == "defun" then
      local name = car(cdr(f)).name
      local params = car(cdr(cdr(f)))
      C.ARITY[name] = len(params)
    end
  end
end

-- expose expression compiler + a returning-chunk helper for eval
C.cexpr = cexpr
C.ctail = ctail
function C.compile_expr_chunk(form)
  return "return (" .. cexpr(form, {}) .. ")"
end

-- compile any top-level form to a Lua statement string
function C.compile_top(form)
  if is_cons(form) and is_symbol(car(form)) and car(form).name == "defun" then
    return cdefun(form)
  else
    -- a top-level expression: evaluate for side effects. Wrapped in do..end
    -- so a whole kernel file can be concatenated into ONE chunk (boot.lua's
    -- bytecode cache) without accumulating `local _` slots toward Lua's
    -- 200-locals-per-scope limit.
    return "do local _ = " .. cexpr(form, {}) .. "; end"
  end
end

return C