Step 10d: bytecode expansion — close the CEK gap

Tier 1 — Component keyword dispatch on VM:
- Components/islands JIT-compile bodies via jit_compile_comp
- parse_keyword_args matches keyword names against component params
- Added i_compiled field to island type for JIT cache
- Component calls no longer fall back to CEK

Tier 2 — OP_SWAP (opcode 7):
- New stack swap operation for future HO loop compilation
- HO forms already efficient via NativeFn + VmClosure callbacks

Tier 3 — Exception handler stack:
- OP_PUSH_HANDLER (35), OP_POP_HANDLER (36), OP_RAISE (37)
- VM gains handler_stack with frame depth tracking
- Compiler handles guard and raise as bytecode
- Functions with exception handling no longer cause JIT failure

Tier 4 — Scope forms as bytecode:
- Compiler handles provide, context, peek, scope, provide!,
  bind, emit!, emitted via CALL_PRIM sequences
- Functions using reactive scope no longer trigger JIT failure

4 new opcodes (SWAP, PUSH_HANDLER, POP_HANDLER, RAISE) → 37 total.
2776/2776 tests pass, zero regressions.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
2026-04-05 13:19:25 +00:00
parent c4dd125210
commit 2cf4c73ab3
4 changed files with 373 additions and 25 deletions

View File

@@ -614,7 +614,7 @@ let make_test_env () =
let island = Island { let island = Island {
i_name = short_name; i_params = param_names; i_name = short_name; i_params = param_names;
i_has_children = has_children; i_has_children = has_children;
i_body = body; i_closure = eval_env; i_file = None; i_body = body; i_closure = eval_env; i_file = None; i_compiled = None;
} in } in
ignore (Sx_types.env_bind eval_env name island); ignore (Sx_types.env_bind eval_env name island);
island island

View File

@@ -128,6 +128,7 @@ and island = {
i_body : value; i_body : value;
i_closure : env; i_closure : env;
mutable i_file : string option; (** Source file path *) mutable i_file : string option; (** Source file path *)
mutable i_compiled : vm_closure option; (** Lazy JIT cache *)
} }
and macro = { and macro = {
@@ -386,7 +387,7 @@ let make_island name params has_children body closure =
Island { Island {
i_name = n; i_params = ps; i_has_children = hc; i_name = n; i_params = ps; i_has_children = hc;
i_body = body; i_closure = unwrap_env_val closure; i_body = body; i_closure = unwrap_env_val closure;
i_file = None; i_file = None; i_compiled = None;
} }
let make_macro params rest_param body closure name = let make_macro params rest_param body closure name =

View File

@@ -20,6 +20,14 @@ type frame = {
local_cells : (int, vm_upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *) local_cells : (int, vm_upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *)
} }
(** Exception handler entry on the handler stack. *)
type handler_entry = {
h_catch_ip : int; (* IP to jump to when exception is raised *)
h_frame_depth : int; (* number of frames when handler was pushed *)
h_sp : int; (* stack pointer when handler was pushed *)
h_frame : frame; (* the frame that pushed the handler *)
}
(** VM state. *) (** VM state. *)
type vm = { type vm = {
mutable stack : value array; mutable stack : value array;
@@ -27,6 +35,7 @@ type vm = {
mutable frames : frame list; mutable frames : frame list;
globals : (string, value) Hashtbl.t; (* live reference to kernel env *) globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
mutable pending_cek : value option; (* suspended CEK state from Component/Lambda call *) mutable pending_cek : value option; (* suspended CEK state from Component/Lambda call *)
mutable handler_stack : handler_entry list; (* exception handler stack *)
} }
(** Raised when OP_PERFORM is executed. Carries the IO request dict (** Raised when OP_PERFORM is executed. Carries the IO request dict
@@ -56,7 +65,7 @@ let is_jit_failed cl = cl.vm_code.vc_arity = -1
let _active_vm : vm option ref = ref None let _active_vm : vm option ref = ref None
let create globals = let create globals =
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals; pending_cek = None } { stack = Array.make 4096 Nil; sp = 0; frames = []; globals; pending_cek = None; handler_stack = [] }
(** Stack ops — inlined for speed. *) (** Stack ops — inlined for speed. *)
let push vm v = let push vm v =
@@ -95,13 +104,34 @@ let closure_to_value cl =
fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args)))) fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args))))
(* Placeholder — actual calls go through vm_call below *) (* Placeholder — actual calls go through vm_call below *)
(** Parse keyword args from an evaluated args list.
The compiler converts :keyword to its string name, so we need the
component's param list to identify which strings are keyword names.
Returns (kwargs_hashtbl, children_list). *)
let parse_keyword_args params args =
let param_set = Hashtbl.create (List.length params) in
List.iter (fun p -> Hashtbl.replace param_set p true) params;
let kwargs = Hashtbl.create 8 in
let children = ref [] in
let rec go = function
| (String k | Keyword k) :: v :: rest when Hashtbl.mem param_set k ->
Hashtbl.replace kwargs k v; go rest
| v :: rest -> children := v :: !children; go rest
| [] -> ()
in
go args;
(kwargs, List.rev !children)
let _vm_comp_jit_count = ref 0
let _vm_comp_cek_count = ref 0
let _vm_insn_count = ref 0 let _vm_insn_count = ref 0
let _vm_call_count = ref 0 let _vm_call_count = ref 0
let _vm_cek_count = ref 0 let _vm_cek_count = ref 0
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0 let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0;
_vm_comp_jit_count := 0; _vm_comp_cek_count := 0
let vm_report_counters () = let vm_report_counters () =
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!" Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d comp_jit=%d comp_cek=%d\n%!"
!_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_comp_jit_count !_vm_comp_cek_count
(** Push a VM closure frame onto the current VM — no new VM allocation. (** Push a VM closure frame onto the current VM — no new VM allocation.
This is the fast path for intra-VM closure calls. *) This is the fast path for intra-VM closure calls. *)
@@ -137,6 +167,39 @@ let code_from_value v =
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||]; | _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None } vc_bytecode_list = None; vc_constants_list = None }
(** JIT-compile a component or island body.
Wraps body as (fn (param1 param2 ... [children]) body) and compiles.
Returns Some vm_closure on success, None on failure. *)
let jit_compile_comp ~name ~params ~has_children ~body ~closure globals =
try
let _compile_fn = try Hashtbl.find globals "compile"
with Not_found -> raise (Eval_error "JIT: compiler not loaded") in
let param_names = params @ (if has_children then ["children"] else []) in
let param_syms = List (List.map (fun s -> Symbol s) param_names) in
let fn_expr = List [Symbol "fn"; param_syms; body] in
let quoted = List [Symbol "quote"; fn_expr] in
let compile_env = Sx_types.env_extend (Sx_types.make_env ()) in
Hashtbl.iter (fun k v -> Hashtbl.replace compile_env.bindings (Sx_types.intern k) v) globals;
let result = Sx_ref.eval_expr (List [Symbol "compile"; quoted]) (Env compile_env) in
(match result with
| Dict d when Hashtbl.mem d "bytecode" ->
let outer_code = code_from_value result in
let bc = outer_code.vc_bytecode in
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
let idx = bc.(1) lor (bc.(2) lsl 8) in
if idx < Array.length outer_code.vc_constants then
let inner_val = outer_code.vc_constants.(idx) in
let code = code_from_value inner_val in
Some { vm_code = code; vm_upvalues = [||];
vm_name = Some name; vm_env_ref = globals;
vm_closure_env = Some closure }
else None
end else None
| _ -> None)
with e ->
Printf.eprintf "[jit-comp] FAIL %s: %s\n%!" name (Printexc.to_string e);
None
(** Call an SX value via CEK, detecting suspension instead of erroring. (** Call an SX value via CEK, detecting suspension instead of erroring.
Returns the result value, or raises VmSuspended if CEK suspends. Returns the result value, or raises VmSuspended if CEK suspends.
Saves the suspended CEK state in vm.pending_cek for later resume. *) Saves the suspended CEK state in vm.pending_cek for later resume. *)
@@ -207,10 +270,66 @@ and vm_call vm f args =
end end
else else
push vm (cek_call_or_suspend vm f (List args))) push vm (cek_call_or_suspend vm f (List args)))
| Component _ | Island _ -> | Component c ->
(* Components use keyword-arg parsing — CEK handles this, suspension-aware *) let (kwargs, children) = parse_keyword_args c.c_params args in
incr _vm_cek_count; (* Get or compile the component body *)
push vm (cek_call_or_suspend vm f (List args)) let compiled = match c.c_compiled with
| Some cl when not (is_jit_failed cl) -> Some cl
| Some _ -> None
| None ->
c.c_compiled <- Some jit_failed_sentinel;
let result = jit_compile_comp ~name:c.c_name ~params:c.c_params
~has_children:c.c_has_children ~body:c.c_body
~closure:c.c_closure vm.globals in
(match result with Some cl -> c.c_compiled <- Some cl | None -> ());
result
in
(match compiled with
| Some cl ->
incr _vm_comp_jit_count;
(* Build positional args: keyword params in order, then children *)
let call_args = List.map (fun p ->
match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil
) c.c_params in
let call_args = if c.c_has_children
then call_args @ [List children]
else call_args in
(try push vm (call_closure cl call_args cl.vm_env_ref)
with _ ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| None ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| Island i ->
let (kwargs, children) = parse_keyword_args i.i_params args in
let compiled = match i.i_compiled with
| Some cl when not (is_jit_failed cl) -> Some cl
| Some _ -> None
| None ->
i.i_compiled <- Some jit_failed_sentinel;
let result = jit_compile_comp ~name:i.i_name ~params:i.i_params
~has_children:i.i_has_children ~body:i.i_body
~closure:i.i_closure vm.globals in
(match result with Some cl -> i.i_compiled <- Some cl | None -> ());
result
in
(match compiled with
| Some cl ->
incr _vm_comp_jit_count;
let call_args = List.map (fun p ->
match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil
) i.i_params in
let call_args = if i.i_has_children
then call_args @ [List children]
else call_args in
(try push vm (call_closure cl call_args cl.vm_env_ref)
with _ ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| None ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| _ -> | _ ->
raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f)) raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f))
@@ -252,6 +371,9 @@ and run vm =
| 4 (* OP_FALSE *) -> push vm (Bool false) | 4 (* OP_FALSE *) -> push vm (Bool false)
| 5 (* OP_POP *) -> ignore (pop vm) | 5 (* OP_POP *) -> ignore (pop vm)
| 6 (* OP_DUP *) -> push vm (peek vm) | 6 (* OP_DUP *) -> push vm (peek vm)
| 7 (* OP_SWAP *) ->
let a = pop vm in let b = pop vm in
push vm a; push vm b
(* ---- Variable access ---- *) (* ---- Variable access ---- *)
| 16 (* OP_LOCAL_GET *) -> | 16 (* OP_LOCAL_GET *) ->
@@ -336,6 +458,40 @@ and run vm =
let v = pop vm in let v = pop vm in
if sx_truthy v then frame.ip <- frame.ip + offset if sx_truthy v then frame.ip <- frame.ip + offset
(* ---- Exception handling ---- *)
| 35 (* OP_PUSH_HANDLER *) ->
let catch_offset = read_i16 frame in
let entry = {
h_catch_ip = frame.ip + catch_offset;
h_frame_depth = List.length vm.frames;
h_sp = vm.sp;
h_frame = frame;
} in
vm.handler_stack <- entry :: vm.handler_stack
| 36 (* OP_POP_HANDLER *) ->
(match vm.handler_stack with
| _ :: rest -> vm.handler_stack <- rest
| [] -> ())
| 37 (* OP_RAISE *) ->
let exn_val = pop vm in
(match vm.handler_stack with
| entry :: rest ->
vm.handler_stack <- rest;
(* Unwind frames to the handler's depth *)
while List.length vm.frames > entry.h_frame_depth do
match vm.frames with
| _ :: fs -> vm.frames <- fs
| [] -> ()
done;
(* Restore stack pointer and jump to catch *)
vm.sp <- entry.h_sp;
entry.h_frame.ip <- entry.h_catch_ip;
push vm exn_val
| [] ->
(* No handler — raise OCaml exception for CEK to catch *)
raise (Eval_error (Printf.sprintf "Unhandled exception: %s"
(Sx_runtime.value_to_str exn_val))))
(* ---- Function calls ---- *) (* ---- Function calls ---- *)
| 48 (* OP_CALL *) -> | 48 (* OP_CALL *) ->
let argc = read_u8 frame in let argc = read_u8 frame in
@@ -699,11 +855,12 @@ let () = _vm_call_closure_ref := (fun cl args -> call_closure cl args cl.vm_env_
(** Map opcode integer to human-readable name. *) (** Map opcode integer to human-readable name. *)
let opcode_name = function let opcode_name = function
| 1 -> "CONST" | 2 -> "NIL" | 3 -> "TRUE" | 4 -> "FALSE" | 1 -> "CONST" | 2 -> "NIL" | 3 -> "TRUE" | 4 -> "FALSE"
| 5 -> "POP" | 6 -> "DUP" | 5 -> "POP" | 6 -> "DUP" | 7 -> "SWAP"
| 16 -> "LOCAL_GET" | 17 -> "LOCAL_SET" | 16 -> "LOCAL_GET" | 17 -> "LOCAL_SET"
| 18 -> "UPVALUE_GET" | 19 -> "UPVALUE_SET" | 18 -> "UPVALUE_GET" | 19 -> "UPVALUE_SET"
| 20 -> "GLOBAL_GET" | 21 -> "GLOBAL_SET" | 20 -> "GLOBAL_GET" | 21 -> "GLOBAL_SET"
| 32 -> "JUMP" | 33 -> "JUMP_IF_FALSE" | 34 -> "JUMP_IF_TRUE" | 32 -> "JUMP" | 33 -> "JUMP_IF_FALSE" | 34 -> "JUMP_IF_TRUE"
| 35 -> "PUSH_HANDLER" | 36 -> "POP_HANDLER" | 37 -> "RAISE"
| 48 -> "CALL" | 49 -> "TAIL_CALL" | 50 -> "RETURN" | 48 -> "CALL" | 49 -> "TAIL_CALL" | 50 -> "RETURN"
| 51 -> "CLOSURE" | 52 -> "CALL_PRIM" | 51 -> "CLOSURE" | 52 -> "CALL_PRIM"
| 64 -> "LIST" | 65 -> "DICT" | 64 -> "LIST" | 65 -> "DICT"
@@ -724,7 +881,8 @@ let opcode_operand_size = function
| 18 (* UPVALUE_GET *) | 19 (* UPVALUE_SET *) | 18 (* UPVALUE_GET *) | 19 (* UPVALUE_SET *)
| 48 (* CALL *) | 49 (* TAIL_CALL *) | 48 (* CALL *) | 49 (* TAIL_CALL *)
| 144 (* STR_CONCAT *) -> 1 (* u8 *) | 144 (* STR_CONCAT *) -> 1 (* u8 *)
| 32 (* JUMP *) | 33 (* JUMP_IF_FALSE *) | 34 (* JUMP_IF_TRUE *) -> 2 (* i16 *) | 32 (* JUMP *) | 33 (* JUMP_IF_FALSE *) | 34 (* JUMP_IF_TRUE *)
| 35 (* PUSH_HANDLER *) -> 2 (* i16 *)
| 51 (* CLOSURE *) -> 2 (* u16 for constant index; upvalue descriptors follow dynamically *) | 51 (* CLOSURE *) -> 2 (* u16 for constant index; upvalue descriptors follow dynamically *)
| 52 (* CALL_PRIM *) -> 3 (* u16 + u8 *) | 52 (* CALL_PRIM *) -> 3 (* u16 + u8 *)
| _ -> 0 (* no operand *) | _ -> 0 (* no operand *)
@@ -782,6 +940,7 @@ let trace_run src globals =
| 4 -> push vm (Bool false) | 4 -> push vm (Bool false)
| 5 -> ignore (pop vm) | 5 -> ignore (pop vm)
| 6 -> push vm (peek vm) | 6 -> push vm (peek vm)
| 7 -> let a = pop vm in let b = pop vm in push vm a; push vm b
| 16 -> let slot = read_u8 frame in | 16 -> let slot = read_u8 frame in
let v = match Hashtbl.find_opt frame.local_cells slot with let v = match Hashtbl.find_opt frame.local_cells slot with
| Some cell -> cell.uv_value | Some cell -> cell.uv_value
@@ -809,6 +968,20 @@ let trace_run src globals =
if not (sx_truthy v) then frame.ip <- frame.ip + offset if not (sx_truthy v) then frame.ip <- frame.ip + offset
| 34 -> let offset = read_i16 frame in let v = pop vm in | 34 -> let offset = read_i16 frame in let v = pop vm in
if sx_truthy v then frame.ip <- frame.ip + offset if sx_truthy v then frame.ip <- frame.ip + offset
| 35 -> let catch_offset = read_i16 frame in
vm.handler_stack <- { h_catch_ip = frame.ip + catch_offset;
h_frame_depth = List.length vm.frames; h_sp = vm.sp;
h_frame = frame } :: vm.handler_stack
| 36 -> (match vm.handler_stack with _ :: r -> vm.handler_stack <- r | [] -> ())
| 37 -> let exn_val = pop vm in
(match vm.handler_stack with
| entry :: rest ->
vm.handler_stack <- rest;
while List.length vm.frames > entry.h_frame_depth do
match vm.frames with _ :: fs -> vm.frames <- fs | [] -> () done;
vm.sp <- entry.h_sp; entry.h_frame.ip <- entry.h_catch_ip;
push vm exn_val
| [] -> vm.frames <- [])
| 48 -> let argc = read_u8 frame in | 48 -> let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in let args = Array.init argc (fun _ -> pop vm) in
let f = pop vm in let f = pop vm in

View File

@@ -303,6 +303,54 @@
(compile-letrec em args scope tail?) (compile-letrec em args scope tail?)
(= name "match") (= name "match")
(compile-match em args scope tail?) (compile-match em args scope tail?)
(= name "guard")
(compile-guard em args scope tail?)
(= name "raise")
(do
(compile-expr em (first args) scope false)
(emit-op em 37))
(= name "scope")
(compile-scope em args scope tail?)
(= name "provide")
(compile-provide em args scope tail?)
(= name "context")
(do
(emit-const em (keyword-name (first args)))
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "context"))
(emit-byte em 1))
(= name "peek")
(do
(emit-const em (keyword-name (first args)))
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-peek"))
(emit-byte em 1))
(= name "provide!")
(do
(emit-const em (keyword-name (first args)))
(compile-expr em (nth args 1) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "provide-set!"))
(emit-byte em 2))
(= name "bind")
(do
(compile-expr em (first args) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "bind"))
(emit-byte em 1))
(= name "emit!")
(do
(emit-const em (keyword-name (first args)))
(compile-expr em (nth args 1) scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-emit!"))
(emit-byte em 2))
(= name "emitted")
(do
(emit-const em (keyword-name (first args)))
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-emitted"))
(emit-byte em 1))
(= name "perform") (= name "perform")
(let (let
() ()
@@ -455,8 +503,8 @@
(args) (args)
(let (let
((first-arg (first args))) ((first-arg (first args)))
(if (dict? first-arg) (if
;; Variant 2: (let-match {:k v} expr body...) (dict? first-arg)
(let (let
((pattern first-arg) ((pattern first-arg)
(expr (nth args 1)) (expr (nth args 1))
@@ -465,28 +513,36 @@
(bindings (list))) (bindings (list)))
(append! bindings (list src-sym expr)) (append! bindings (list src-sym expr))
(for-each (for-each
(fn (k) (fn
(append! bindings (k)
(list (get pattern k) (append!
bindings
(list
(get pattern k)
(list (make-symbol "get") src-sym (str k))))) (list (make-symbol "get") src-sym (str k)))))
(keys pattern)) (keys pattern))
(cons bindings body)) (cons bindings body))
;; Variant 1: (let-match name expr {:k v} body...)
(let (let
((name-sym first-arg) ((name-sym first-arg)
(expr (nth args 1)) (expr (nth args 1))
(pattern (nth args 2)) (pattern (nth args 2))
(body (slice args 3)) (body (slice args 3))
(src-sym (if (= (str name-sym) "_") (src-sym
(make-symbol "__lm_tmp") (if
name-sym)) (= (str name-sym) "_")
(make-symbol "__lm_tmp")
name-sym))
(bindings (list))) (bindings (list)))
(append! bindings (list src-sym expr)) (append! bindings (list src-sym expr))
(when (dict? pattern) (when
(dict? pattern)
(for-each (for-each
(fn (k) (fn
(append! bindings (k)
(list (get pattern k) (append!
bindings
(list
(get pattern k)
(list (make-symbol "get") src-sym (str k))))) (list (make-symbol "get") src-sym (str k)))))
(keys pattern))) (keys pattern)))
(cons bindings body)))))) (cons bindings body))))))
@@ -925,4 +981,122 @@
{:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library
;; Re-export to global namespace for backward compatibility ;; Re-export to global namespace for backward compatibility
(define
compile-provide
(fn
(em args scope tail?)
(let
((name (keyword-name (first args)))
(val-expr (nth args 1))
(body (slice args 2))
(name-idx (pool-add (get em "pool") name)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if (empty? body) (emit-op em 2) (compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))
(define
compile-scope
(fn
(em args scope tail?)
(let
((first-arg (first args))
(name
(if
(= (type-of first-arg) "keyword")
(keyword-name first-arg)
(symbol-name first-arg)))
(rest-args (rest args))
(name-idx (pool-add (get em "pool") name)))
(if
(and
(>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(let
((val-expr (nth rest-args 1)) (body (slice rest-args 2)))
(emit-op em 1)
(emit-u16 em name-idx)
(compile-expr em val-expr scope false)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))
(let
((body rest-args))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 2)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-push!"))
(emit-byte em 2)
(emit-op em 5)
(if
(empty? body)
(emit-op em 2)
(compile-begin em body scope false))
(emit-op em 1)
(emit-u16 em name-idx)
(emit-op em 52)
(emit-u16 em (pool-add (get em "pool") "scope-pop!"))
(emit-byte em 1)
(emit-op em 5))))))
(define
compile-guard-clauses
(fn
(em clauses scope var-slot tail?)
(if
(empty? clauses)
(do (emit-op em 16) (emit-byte em var-slot) (emit-op em 37))
(let
((clause (first clauses))
(rest-clauses (rest clauses))
(test (first clause))
(body (rest clause)))
(if
(or
(and
(= (type-of test) "keyword")
(= (keyword-name test) "else"))
(= test true))
(compile-begin em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33)
(let
((skip (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32)
(let
((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-guard-clauses em rest-clauses scope var-slot tail?)
(patch-i16
em
end-jump
(- (current-offset em) (+ end-jump 2)))))))))))
(import (sx compiler)) (import (sx compiler))