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:
@@ -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
|
||||||
|
|||||||
@@ -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 =
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
200
lib/compiler.sx
200
lib/compiler.sx
@@ -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))
|
||||||
|
|||||||
Reference in New Issue
Block a user