diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 16cbca54..6fb99974 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -614,7 +614,7 @@ let make_test_env () = let island = Island { i_name = short_name; i_params = param_names; 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 ignore (Sx_types.env_bind eval_env name island); island diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 4196f50f..b0dfa3ce 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -128,6 +128,7 @@ and island = { i_body : value; i_closure : env; mutable i_file : string option; (** Source file path *) + mutable i_compiled : vm_closure option; (** Lazy JIT cache *) } and macro = { @@ -386,7 +387,7 @@ let make_island name params has_children body closure = Island { i_name = n; i_params = ps; i_has_children = hc; 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 = diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 29b3003e..31bd4ed8 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -20,6 +20,14 @@ type frame = { 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. *) type vm = { mutable stack : value array; @@ -27,6 +35,7 @@ type vm = { mutable frames : frame list; globals : (string, value) Hashtbl.t; (* live reference to kernel env *) 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 @@ -56,7 +65,7 @@ let is_jit_failed cl = cl.vm_code.vc_arity = -1 let _active_vm : vm option ref = ref None 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. *) 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)))) (* 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_call_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 () = - Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!" - !_vm_insn_count !_vm_call_count !_vm_cek_count + 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_comp_jit_count !_vm_comp_cek_count (** Push a VM closure frame onto the current VM — no new VM allocation. 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_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. Returns the result value, or raises VmSuspended if CEK suspends. Saves the suspended CEK state in vm.pending_cek for later resume. *) @@ -207,10 +270,66 @@ and vm_call vm f args = end else push vm (cek_call_or_suspend vm f (List args))) - | Component _ | Island _ -> - (* Components use keyword-arg parsing — CEK handles this, suspension-aware *) - incr _vm_cek_count; - push vm (cek_call_or_suspend vm f (List args)) + | Component c -> + let (kwargs, children) = parse_keyword_args c.c_params args in + (* Get or compile the component body *) + 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)) @@ -252,6 +371,9 @@ and run vm = | 4 (* OP_FALSE *) -> push vm (Bool false) | 5 (* OP_POP *) -> ignore (pop 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 ---- *) | 16 (* OP_LOCAL_GET *) -> @@ -336,6 +458,40 @@ and run vm = let v = pop vm in 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 ---- *) | 48 (* OP_CALL *) -> 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. *) let opcode_name = function | 1 -> "CONST" | 2 -> "NIL" | 3 -> "TRUE" | 4 -> "FALSE" - | 5 -> "POP" | 6 -> "DUP" + | 5 -> "POP" | 6 -> "DUP" | 7 -> "SWAP" | 16 -> "LOCAL_GET" | 17 -> "LOCAL_SET" | 18 -> "UPVALUE_GET" | 19 -> "UPVALUE_SET" | 20 -> "GLOBAL_GET" | 21 -> "GLOBAL_SET" | 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" | 51 -> "CLOSURE" | 52 -> "CALL_PRIM" | 64 -> "LIST" | 65 -> "DICT" @@ -724,7 +881,8 @@ let opcode_operand_size = function | 18 (* UPVALUE_GET *) | 19 (* UPVALUE_SET *) | 48 (* CALL *) | 49 (* TAIL_CALL *) | 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 *) | 52 (* CALL_PRIM *) -> 3 (* u16 + u8 *) | _ -> 0 (* no operand *) @@ -782,6 +940,7 @@ let trace_run src globals = | 4 -> push vm (Bool false) | 5 -> ignore (pop 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 let v = match Hashtbl.find_opt frame.local_cells slot with | 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 | 34 -> let offset = read_i16 frame in let v = pop vm in 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 let args = Array.init argc (fun _ -> pop vm) in let f = pop vm in diff --git a/lib/compiler.sx b/lib/compiler.sx index d40e018b..4c3881a1 100644 --- a/lib/compiler.sx +++ b/lib/compiler.sx @@ -303,6 +303,54 @@ (compile-letrec em args scope tail?) (= name "match") (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") (let () @@ -455,8 +503,8 @@ (args) (let ((first-arg (first args))) - (if (dict? first-arg) - ;; Variant 2: (let-match {:k v} expr body...) + (if + (dict? first-arg) (let ((pattern first-arg) (expr (nth args 1)) @@ -465,28 +513,36 @@ (bindings (list))) (append! bindings (list src-sym expr)) (for-each - (fn (k) - (append! bindings - (list (get pattern k) + (fn + (k) + (append! + bindings + (list + (get pattern k) (list (make-symbol "get") src-sym (str k))))) (keys pattern)) (cons bindings body)) - ;; Variant 1: (let-match name expr {:k v} body...) (let ((name-sym first-arg) (expr (nth args 1)) (pattern (nth args 2)) (body (slice args 3)) - (src-sym (if (= (str name-sym) "_") - (make-symbol "__lm_tmp") - name-sym)) + (src-sym + (if + (= (str name-sym) "_") + (make-symbol "__lm_tmp") + name-sym)) (bindings (list))) (append! bindings (list src-sym expr)) - (when (dict? pattern) + (when + (dict? pattern) (for-each - (fn (k) - (append! bindings - (list (get pattern k) + (fn + (k) + (append! + bindings + (list + (get pattern k) (list (make-symbol "get") src-sym (str k))))) (keys pattern))) (cons bindings body)))))) @@ -925,4 +981,122 @@ {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))))) ;; end define-library ;; 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))