diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml index 89dcc143..841bbfc0 100644 --- a/hosts/ocaml/bin/mcp_tree.ml +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -600,7 +600,8 @@ let rec handle_tool name args = let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in Filename.dirname spec_dir in - let cmd = Printf.sprintf "cd %s && node hosts/ocaml/browser/compile-modules.js shared/static/wasm 2>&1" project_dir in + (* Use compile-modules.js which now delegates to native OCaml *) + let cmd = Printf.sprintf "cd %s && node --input-type=commonjs hosts/ocaml/browser/compile-modules.js shared/static/wasm 2>&1" project_dir in let ic = Unix.open_process_in cmd in let lines = ref [] in (try while true do lines := input_line ic :: !lines done with End_of_file -> ()); diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 1edc9d9b..6eb6b972 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -578,6 +578,11 @@ let setup_type_constructors env = (* Already a value — return as-is *) v | _ -> raise (Eval_error "parse: expected string")); + (* Native bytecode compiler — bootstrapped from lib/compiler.sx *) + bind "compile" (fun args -> + match args with [expr] -> Sx_compiler.compile expr | _ -> Nil); + bind "compile-module" (fun args -> + match args with [exprs] -> Sx_compiler.compile_module exprs | _ -> Nil); bind "parse-int" (fun args -> match args with | [String s] -> (try Number (float_of_int (int_of_string s)) with _ -> Nil) diff --git a/hosts/ocaml/bootstrap_compiler.py b/hosts/ocaml/bootstrap_compiler.py new file mode 100644 index 00000000..d40928e0 --- /dev/null +++ b/hosts/ocaml/bootstrap_compiler.py @@ -0,0 +1,151 @@ +#!/usr/bin/env python3 +""" +Bootstrap the SX bytecode compiler to native OCaml. + +Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it compiler.sx, +and produces sx_compiler.ml — the bytecode compiler as native OCaml. + +Usage: + python3 hosts/ocaml/bootstrap_compiler.py +""" +from __future__ import annotations + +import os +import sys + +_HERE = os.path.dirname(os.path.abspath(__file__)) +_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..")) +sys.path.insert(0, _PROJECT) + +from shared.sx.parser import parse_all +from shared.sx.types import Symbol + + +def extract_defines(source: str) -> list[tuple[str, list]]: + """Parse .sx source, return list of (name, define-expr) for top-level defines.""" + exprs = parse_all(source) + defines = [] + for expr in exprs: + if isinstance(expr, list) and expr and isinstance(expr[0], Symbol): + if expr[0].name == "define": + name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1]) + defines.append((name, expr)) + return defines + + +PREAMBLE = """\ +(* sx_compiler.ml — Auto-generated from lib/compiler.sx *) +(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *) + +[@@@warning "-26-27"] + +open Sx_types +open Sx_runtime + +(* The compiler uses cek_call from the evaluator for runtime dispatch *) +let cek_call = Sx_ref.cek_call +let eval_expr = Sx_ref.eval_expr +let trampoline v = match v with + | Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env) + | other -> other + +(* Bindings for external functions the compiler calls. + Some shadow OCaml stdlib names — the SX versions operate on values. *) +let serialize v = String (Sx_types.inspect v) +let sx_parse v = match v with + | String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es) + | v -> v +let floor v = prim_call "floor" [v] +let abs v = prim_call "abs" [v] +let min a b = prim_call "min" [a; b] +let max a b = prim_call "max" [a; b] +let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v] + +(* skip_annotations: strips :keyword value pairs from a list (type annotations) *) +let rec skip_annotations items = + match items with + | List [] | Nil -> Nil + | List (Keyword _ :: _ :: rest) -> skip_annotations (List rest) + | ListRef { contents = [] } -> Nil + | ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest) + | List (first :: _) -> first + | ListRef { contents = first :: _ } -> first + | _ -> Nil + +(* compile_match: uses local recursion (letrec) that the transpiler can't handle. + Falls back to CEK evaluation at runtime. *) +let compile_match em args scope tail_p = + let fn = Sx_ref.eval_expr (Symbol "compile-match") (Env (Sx_types.make_env ())) in + ignore (Sx_ref.cek_call fn (List [em; args; scope; tail_p])) + +""" + + +def main(): + import tempfile + from shared.sx.ocaml_sync import OcamlSync + from shared.sx.parser import serialize + + # Load the transpiler into OCaml kernel + bridge = OcamlSync() + transpiler_path = os.path.join(_HERE, "transpiler.sx") + bridge.load(transpiler_path) + + # Read compiler.sx + compiler_path = os.path.join(_PROJECT, "lib", "compiler.sx") + with open(compiler_path) as f: + src = f.read() + defines = extract_defines(src) + + # Skip functions that use letrec/named-let (transpiler can't handle) + skip = {"compile-match"} + defines = [(n, e) for n, e in defines if n not in skip] + # Deduplicate (keep last definition) + seen = {} + for i, (n, e) in enumerate(defines): + seen[n] = i + defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i] + + print(f"Transpiling {len(defines)} defines from compiler.sx...", file=sys.stderr) + + # Build the defines list and known names for the transpiler + defines_list = [[name, expr] for name, expr in defines] + known_names = [name for name, _ in defines] + + # Serialize to temp file, load into kernel + defines_sx = serialize(defines_list) + known_sx = serialize(known_names) + with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp: + tmp.write(f"(define _defines '{defines_sx})\n") + tmp.write(f"(define _known_defines '{known_sx})\n") + tmp_path = tmp.name + try: + bridge.load(tmp_path) + finally: + os.unlink(tmp_path) + + # Call ml-translate-file — emits as single let rec block + result = bridge.eval("(ml-translate-file _defines)") + + bridge.stop() + + output = PREAMBLE + "\n(* === Transpiled from bytecode compiler === *)\n" + result + "\n" + + # Post-process: fix skip_annotations local NativeFn → use top-level + old = 'then (let skip_annotations = (NativeFn (' + if old in output: + idx = output.index(old) + end_marker = 'in (skip_annotations (rest_args)))' + end_idx = output.index(end_marker, idx) + output = output[:idx] + 'then (skip_annotations (rest_args))' + output[end_idx + len(end_marker):] + + # Write output + out_path = os.path.join(_HERE, "lib", "sx_compiler.ml") + with open(out_path, "w") as f: + f.write(output) + print(f"Wrote {len(output)} bytes to {out_path}", file=sys.stderr) + print(f" {len(defines)} functions transpiled", file=sys.stderr) + + +if __name__ == "__main__": + main() diff --git a/hosts/ocaml/lib/sx_compiler.ml b/hosts/ocaml/lib/sx_compiler.ml new file mode 100644 index 00000000..bcccdb78 --- /dev/null +++ b/hosts/ocaml/lib/sx_compiler.ml @@ -0,0 +1,212 @@ +(* sx_compiler.ml — Auto-generated from lib/compiler.sx *) +(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *) + +[@@@warning "-26-27"] + +open Sx_types +open Sx_runtime + +(* The compiler uses cek_call from the evaluator for runtime dispatch *) +let cek_call = Sx_ref.cek_call +let eval_expr = Sx_ref.eval_expr +let trampoline v = match v with + | Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env) + | other -> other + +(* Bindings for external functions the compiler calls. + Some shadow OCaml stdlib names — the SX versions operate on values. *) +let serialize v = String (Sx_types.inspect v) +let sx_parse v = match v with + | String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es) + | v -> v +let floor v = prim_call "floor" [v] +let abs v = prim_call "abs" [v] +let min a b = prim_call "min" [a; b] +let max a b = prim_call "max" [a; b] +let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v] +let init lst = prim_call "init" [lst] +let last lst = prim_call "last" [lst] + +(* skip_annotations: strips :keyword value pairs from a list (type annotations) *) +let rec skip_annotations items = + match items with + | List [] | Nil -> Nil + | List (Keyword _ :: _ :: rest) -> skip_annotations (List rest) + | ListRef { contents = [] } -> Nil + | ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest) + | List (first :: _) -> first + | ListRef { contents = first :: _ } -> first + | _ -> Nil + +(* compile_match: uses local recursion (letrec) that the transpiler can't handle. + Delegates to the SX-level compile-match via a ref set at init time. *) +let _compile_match_fn : (value -> value -> value -> value -> value) ref = + ref (fun _em _args _scope _tail_p -> Nil) +let compile_match em args scope tail_p = !_compile_match_fn em args scope tail_p + + +(* === Transpiled from bytecode compiler === *) +(* make-pool *) +let rec make_pool () = + (let _d = Hashtbl.create 2 in Hashtbl.replace _d "entries" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Hashtbl.replace _d "index" (let _d = Hashtbl.create 1 in Hashtbl.replace _d "_count" (Number 0.0); Dict _d); Dict _d) + +(* pool-add *) +and pool_add pool value = + (let () = ignore ((String "Add a value to the constant pool, return its index. Deduplicates.")) in (let key = (serialize (value)) in let idx_map = (get (pool) ((String "index"))) in (if sx_truthy ((prim_call "has-key?" [idx_map; key])) then (get (idx_map) (key)) else (let idx = (get (idx_map) ((String "_count"))) in (let () = ignore ((sx_dict_set_b idx_map key idx)) in (let () = ignore ((sx_dict_set_b idx_map (String "_count") (prim_call "+" [idx; (Number 1.0)]))) in (let () = ignore ((sx_append_b (get (pool) ((String "entries"))) value)) in idx))))))) + +(* make-scope *) +and make_scope parent = + (let _d = Hashtbl.create 5 in Hashtbl.replace _d "next-slot" (Number 0.0); Hashtbl.replace _d "upvalues" (List []); Hashtbl.replace _d "locals" (List []); Hashtbl.replace _d "parent" parent; Hashtbl.replace _d "is-function" (Bool false); Dict _d) + +(* scope-define-local *) +and scope_define_local scope name = + (let () = ignore ((String "Add a local variable, return its slot index.\n Idempotent: if name already has a slot, return it.")) in (let existing = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list (get (scope) ((String "locals")))))))) in (if sx_truthy (existing) then (get (existing) ((String "slot"))) else (let slot = (get (scope) ((String "next-slot"))) in (let () = ignore ((sx_append_b (get (scope) ((String "locals"))) (let _d = Hashtbl.create 3 in Hashtbl.replace _d "mutable" (Bool false); Hashtbl.replace _d "slot" slot; Hashtbl.replace _d "name" name; Dict _d))) in (let () = ignore ((sx_dict_set_b scope (String "next-slot") (prim_call "+" [slot; (Number 1.0)]))) in slot)))))) + +(* scope-resolve *) +and scope_resolve scope name = + (let () = ignore ((String "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection.")) in (if sx_truthy ((is_nil (scope))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let locals = (get (scope) ((String "locals"))) in let found = (Bool (List.exists (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))) in (if sx_truthy (found) then (let local = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))))) in (CekFrame { cf_type = "local"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let upvals = (get (scope) ((String "upvalues"))) in let uv_found = (Bool (List.exists (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))) in (if sx_truthy (uv_found) then (let uv = (first ((List (List.filter (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let parent = (get (scope) ((String "parent"))) in (if sx_truthy ((is_nil (parent))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let parent_result = (scope_resolve (parent) (name)) in (if sx_truthy ((prim_call "=" [(get (parent_result) ((String "type"))); (String "global")])) then parent_result else (if sx_truthy ((get (scope) ((String "is-function")))) then (let uv_idx = (len ((get (scope) ((String "upvalues"))))) in (let () = ignore ((sx_append_b (get (scope) ((String "upvalues"))) (let _d = Hashtbl.create 4 in Hashtbl.replace _d "index" (get (parent_result) ((String "index"))); Hashtbl.replace _d "is-local" (prim_call "=" [(get (parent_result) ((String "type"))); (String "local")]); Hashtbl.replace _d "uv-index" uv_idx; Hashtbl.replace _d "name" name; Dict _d))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }))) else parent_result))))))))))) + +(* make-emitter *) +and make_emitter () = + (let _d = Hashtbl.create 2 in Hashtbl.replace _d "pool" (make_pool ()); Hashtbl.replace _d "bytecode" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Dict _d) + +(* emit-byte *) +and emit_byte em byte = + (sx_append_b (get (em) ((String "bytecode"))) byte) + +(* emit-u16 *) +and emit_u16 em value = + (let () = ignore ((emit_byte (em) ((prim_call "mod" [value; (Number 256.0)])))) in (emit_byte (em) ((prim_call "mod" [(floor ((prim_call "/" [value; (Number 256.0)]))); (Number 256.0)])))) + +(* emit-i16 *) +and emit_i16 em value = + (let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in (emit_u16 (em) (v))) + +(* emit-op *) +and emit_op em opcode = + (emit_byte (em) (opcode)) + +(* emit-const *) +and emit_const em value = + (let idx = (pool_add ((get (em) ((String "pool")))) (value)) in (let () = ignore ((emit_op (em) ((Number 1.0)))) in (emit_u16 (em) (idx)))) + +(* current-offset *) +and current_offset em = + (len ((get (em) ((String "bytecode"))))) + +(* patch-i16 *) +and patch_i16 em offset value = + (let () = ignore ((String "Patch a previously emitted i16 at the given bytecode offset.")) in (let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in let bc = (get (em) ((String "bytecode"))) in (let () = ignore ((set_nth_b (bc) (offset) ((prim_call "mod" [v; (Number 256.0)])))) in (set_nth_b (bc) ((prim_call "+" [offset; (Number 1.0)])) ((prim_call "mod" [(floor ((prim_call "/" [v; (Number 256.0)]))); (Number 256.0)])))))) + +(* compile-expr *) +and compile_expr em expr scope tail_p = + (let () = ignore ((String "Compile an expression. tail? indicates tail position for TCO.")) in (if sx_truthy ((is_nil (expr))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "number")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "string")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "boolean")])) then (emit_op (em) ((if sx_truthy (expr) then (Number 3.0) else (Number 4.0)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "keyword")])) then (emit_const (em) ((keyword_name (expr)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "symbol")])) then (compile_symbol (em) ((symbol_name (expr))) (scope)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])) then (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (compile_list (em) (expr) (scope) (tail_p))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "dict")])) then (compile_dict (em) (expr) (scope)) else (emit_const (em) (expr))))))))))) + +(* compile-symbol *) +and compile_symbol em name scope = + (let resolved = (scope_resolve (scope) (name)) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 16.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 18.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (idx))))))) + +(* compile-dict *) +and compile_dict em expr scope = + (let ks = (prim_call "keys" [expr]) in let count = (len (ks)) in (let () = ignore ((List.iter (fun k -> ignore ((let () = ignore ((emit_const (em) (k))) in (compile_expr (em) ((get (expr) (k))) (scope) ((Bool false)))))) (sx_to_list ks); Nil)) in (let () = ignore ((emit_op (em) ((Number 65.0)))) in (emit_u16 (em) (count))))) + +(* compile-list *) +and compile_list em expr scope tail_p = + (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])))))) then (compile_call (em) (head) (args) (scope) (tail_p)) else (let name = (symbol_name (head)) in (if sx_truthy ((prim_call "=" [name; (String "if")])) then (compile_if (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (compile_when (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (compile_and (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (compile_or (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then (compile_define (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (compile_set (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (compile_quote (em) (args)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (compile_cond (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (compile_case (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (compile_thread (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (compile_defmacro (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defstyle")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defhandler")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defpage")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defquery")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defaction")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defrelation")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "deftype")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defeffect")])) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (compile_quasiquote (em) ((first (args))) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (compile_letrec (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "match")])) then (compile_match (em) (args) (scope) (tail_p)) else (compile_call (em) (head) (args) (scope) (tail_p)))))))))))))))))))))))))))))))))))) + +(* compile-if *) +and compile_if em args scope tail_p = + (let test = (first (args)) in let then_expr = (nth (args) ((Number 1.0))) in let else_expr = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (nth (args) ((Number 2.0))) else Nil) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let else_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (then_expr) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (else_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [else_jump; (Number 2.0)])])))) in (let () = ignore ((if sx_truthy ((is_nil (else_expr))) then (emit_op (em) ((Number 2.0))) else (compile_expr (em) (else_expr) (scope) (tail_p)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))) + +(* compile-when *) +and compile_when em args scope tail_p = + (let test = (first (args)) in let body = (rest (args)) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_begin (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip_jump; (Number 2.0)])])))) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))) + +(* compile-and *) +and compile_and em args scope tail_p = + (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 3.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_and (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))))))))))) + +(* compile-or *) +and compile_or em args scope tail_p = + (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 4.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 34.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_or (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))))))))))) + +(* compile-begin *) +and compile_begin em exprs scope tail_p = + (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (exprs)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent"))))))))))) then (List.iter (fun expr -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (expr)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (expr)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (expr)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (expr)))); (String "define")]))))) then (let name_expr = (nth (expr) ((Number 1.0))) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in (scope_define_local (scope) (name))) else Nil))) (sx_to_list exprs); Nil) else Nil)) in (if sx_truthy ((empty_p (exprs))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (exprs)); (Number 1.0)])) then (compile_expr (em) ((first (exprs))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_begin (em) ((rest (exprs))) (scope) (tail_p))))))) + +(* compile-let *) +and compile_let em args scope tail_p = + (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (first (binding)) else (make_symbol ((first (binding))))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil)) in (let lambda_expr = (prim_call "concat" [(List [(make_symbol ((String "fn"))); !params]); body]) in let letrec_bindings = (List [(List [(make_symbol (loop_name)); lambda_expr])]) in let call_expr = (cons ((make_symbol (loop_name))) (!inits)) in (compile_letrec (em) ((List [letrec_bindings; call_expr])) (scope) (tail_p))))) else (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((List.iter (fun binding -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in let value = (nth (binding) ((Number 1.0))) in let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((compile_expr (em) (value) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list bindings); Nil)) in (compile_begin (em) (body) (let_scope) (tail_p)))))) + +(* compile-letrec *) +and compile_letrec em args scope tail_p = + (let () = ignore ((String "Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n so mutually recursive functions can reference each other.")) in (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((let slots = (List (List.map (fun binding -> (let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (let () = ignore ((emit_byte (em) (slot))) in slot)))))) (sx_to_list bindings))) in (List.iter (fun pair -> ignore ((let binding = (first (pair)) in let slot = (nth (pair) ((Number 1.0))) in (let () = ignore ((compile_expr (em) ((nth (binding) ((Number 1.0)))) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list (List (List.map (fun i -> (List [(nth (bindings) (i)); (nth (slots) (i))])) (sx_to_list (prim_call "range" [(Number 0.0); (len (bindings))]))))); Nil))) in (compile_begin (em) (body) (let_scope) (tail_p)))))) + +(* compile-lambda *) +and compile_lambda em args scope = + (let params = (first (args)) in let body = (rest (args)) in let fn_scope = (make_scope (scope)) in let fn_em = (make_emitter ()) in (let () = ignore ((sx_dict_set_b fn_scope (String "is-function") (Bool true))) in (let () = ignore ((List.iter (fun p -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (if sx_truthy ((let _and = (list_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (p)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (p)))); (String "symbol")])))) then (symbol_name ((first (p)))) else p)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((prim_call "=" [name; (String "&key")]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [name; (String "&rest")]))))))) then (scope_define_local (fn_scope) (name)) else Nil)))) (sx_to_list params); Nil)) in (let () = ignore ((compile_begin (fn_em) (body) (fn_scope) ((Bool true)))) in (let () = ignore ((emit_op (fn_em) ((Number 50.0)))) in (let upvals = (get (fn_scope) ((String "upvalues"))) in let code = (let _d = Hashtbl.create 4 in Hashtbl.replace _d "upvalue-count" (len (upvals)); Hashtbl.replace _d "arity" (len ((get (fn_scope) ((String "locals"))))); Hashtbl.replace _d "constants" (get ((get (fn_em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (fn_em) ((String "bytecode"))); Dict _d) in let code_idx = (pool_add ((get (em) ((String "pool")))) (code)) in (let () = ignore ((emit_op (em) ((Number 51.0)))) in (let () = ignore ((emit_u16 (em) (code_idx))) in (List.iter (fun uv -> ignore ((let () = ignore ((emit_byte (em) ((if sx_truthy ((get (uv) ((String "is-local")))) then (Number 1.0) else (Number 0.0))))) in (emit_byte (em) ((get (uv) ((String "index")))))))) (sx_to_list upvals); Nil))))))))) + +(* compile-define *) +and compile_define em args scope = + (let name_expr = (first (args)) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in let value = (let rest_args = (rest (args)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (rest_args)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]))) then (skip_annotations (rest_args)) else (first (rest_args)))) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent")))))))))) then (let slot = (scope_define_local (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))) else (let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 128.0)))) in (emit_u16 (em) (name_idx))))))) + +(* compile-set *) +and compile_set em args scope = + (let name = (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (symbol_name ((first (args)))) else (first (args))) in let value = (nth (args) ((Number 1.0))) in let resolved = (scope_resolve (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 19.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 21.0)))) in (emit_u16 (em) (idx)))))))) + +(* compile-quote *) +and compile_quote em args = + (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (emit_const (em) ((first (args))))) + +(* compile-cond *) +and compile_cond em args scope tail_p = + (let () = ignore ((String "Compile (cond test1 body1 test2 body2 ... :else fallback).")) in (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (emit_op (em) ((Number 2.0))) else (let test = (first (args)) in let body = (nth (args) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (prim_call "slice" [args; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (compile_expr (em) (body) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_cond (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))))) + +(* compile-case *) +and compile_case em args scope tail_p = + (let () = ignore ((String "Compile (case expr val1 body1 val2 body2 ... :else fallback).")) in (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let clauses = (rest (args)) in (compile_case_clauses (em) (clauses) (scope) (tail_p))))) + +(* compile-case-clauses *) +and compile_case_clauses em clauses scope tail_p = + (if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (emit_op (em) ((Number 2.0)))) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (clauses)); (Number 2.0)])) then (prim_call "slice" [clauses; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_expr (em) (body) (scope) (tail_p))) else (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "="))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) ((Number 2.0))))))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_case_clauses (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))))))) + +(* compile-thread *) +and compile_thread em args scope tail_p = + (let () = ignore ((String "Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls.")) in (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let val_expr = (first (args)) in let forms = (rest (args)) in (compile_thread_step (em) (val_expr) (forms) (scope) (tail_p)))))) + +(* compile-thread-step *) +and compile_thread_step em val_expr forms scope tail_p = + (if sx_truthy ((empty_p (forms))) then (compile_expr (em) (val_expr) (scope) (tail_p)) else (let form = (first (forms)) in let rest_forms = (rest (forms)) in let is_tail = (let _and = tail_p in if not (sx_truthy _and) then _and else (empty_p (rest_forms))) in (let call_expr = (if sx_truthy ((list_p (form))) then (prim_call "concat" [(List [(first (form)); val_expr]); (rest (form))]) else (List [form; val_expr])) in (if sx_truthy ((empty_p (rest_forms))) then (compile_expr (em) (call_expr) (scope) (is_tail)) else (let () = ignore ((compile_expr (em) (call_expr) (scope) ((Bool false)))) in (compile_thread_step (em) (call_expr) (rest_forms) (scope) (tail_p))))))) + +(* compile-defcomp *) +and compile_defcomp em args scope = + (let () = ignore ((String "Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defcomp"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defcomp")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0))))))) + +(* compile-defmacro *) +and compile_defmacro em args scope = + (let () = ignore ((String "Compile defmacro — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defmacro"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defmacro")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0))))))) + +(* compile-quasiquote *) +and compile_quasiquote em expr scope = + (let () = ignore ((String "Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation.")) in (compile_qq_expr (em) (expr) (scope))) + +(* compile-qq-expr *) +and compile_qq_expr em expr scope = + (let () = ignore ((String "Compile a quasiquote sub-expression.")) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])))))) then (emit_const (em) (expr)) else (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (let head = (first (expr)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (compile_expr (em) ((nth (expr) ((Number 1.0)))) (scope) ((Bool false))) else (compile_qq_list (em) (expr) (scope))))))) + +(* compile-qq-list *) +and compile_qq_list em items scope = + (let () = ignore ((String "Compile a quasiquote list. Handles splice-unquote by building\n segments and concatenating them.")) in (let has_splice = (Bool (List.exists (fun item -> sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")])))))) (sx_to_list items))) in (if sx_truthy ((Bool (not (sx_truthy (has_splice))))) then (let () = ignore ((List.iter (fun item -> ignore ((compile_qq_expr (em) (item) (scope)))) (sx_to_list items); Nil)) in (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((len (items)))))) else (let segment_count = ref ((Number 0.0)) in let pending = ref ((Number 0.0)) in (let () = ignore ((List.iter (fun item -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (let () = ignore ((segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil)) in (pending := (Number 0.0); Nil)))) else Nil)) in (let () = ignore ((compile_expr (em) ((nth (item) ((Number 1.0)))) (scope) ((Bool false)))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else (let () = ignore ((compile_qq_expr (em) (item) (scope))) in (pending := (prim_call "+" [!pending; (Number 1.0)]); Nil))))) (sx_to_list items); Nil)) in (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else Nil)) in (if sx_truthy ((prim_call ">" [!segment_count; (Number 1.0)])) then (let concat_idx = (pool_add ((get (em) ((String "pool")))) ((String "concat"))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (concat_idx))) in (emit_byte (em) (!segment_count))))) else Nil))))))) + +(* compile-call *) +and compile_call em head args scope tail_p = + (let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args)))))))))) + +(* compile *) +and compile expr = + (let () = ignore ((String "Compile a single SX expression to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d))))) + +(* compile-module *) +and compile_module exprs = + (let () = ignore ((String "Compile a list of top-level expressions to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((List.iter (fun expr -> ignore ((let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (emit_op (em) ((Number 5.0)))))) (sx_to_list (init (exprs))); Nil)) in (let () = ignore ((compile_expr (em) ((last (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d)))))) + diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index 796a62e0..4e18b027 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -455,3 +455,6 @@ let strip_prefix s prefix = (* debug_log — no-op in production, used by CEK evaluator for component warnings *) let debug_log _ _ = Nil +(* mutable_list — mutable list for bytecode compiler pool entries *) +let mutable_list () = ListRef (ref []) +