coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

Refactor MCP tree server: dispatch table, caching, validation, subprocess cleanup

Browse Source 
Break up the 1735-line handle_tool match into 45 individual handler functions
with hashtable-based dispatch. Add mtime-based file parse caching (AST + CST),
consolidated run_command helper replacing 9 bare open_process_in patterns,
require_file/require_dir input validation, and pagination (limit/offset) for
sx_find_across, sx_comp_list, sx_comp_usage. Also includes pending VM changes:
rest-arity support, hyperscript parser, compiler/transpiler updates.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-08 10:12:57 +00:00
parent 4d1079aa5e
commit 387a6cb49e
19 changed files with 1353 additions and 966 deletions
Download Patch File Download Diff File Expand all files Collapse all files

540
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -400,19 +400,40 @@ let call_sx fn_name args =
let fn = env_get e fn_name in let fn = env_get e fn_name in
Sx_ref.cek_call fn (List args) Sx_ref.cek_call fn (List args)
(* File parse cache — avoids re-parsing unchanged files *)
let _parse_cache : (string, float * value) Hashtbl.t = Hashtbl.create 32
let _parse_cst_cache : (string, float * value * Sx_parser.cst_file) Hashtbl.t = Hashtbl.create 32
let _max_cache_entries = 64
let cache_invalidate path =
Hashtbl.remove _parse_cache path;
Hashtbl.remove _parse_cst_cache path
let parse_file path = let parse_file path =
let src = In_channel.with_open_text path In_channel.input_all in let mtime = (Unix.stat path).Unix.st_mtime in
let exprs = Sx_parser.parse_all src in match Hashtbl.find_opt _parse_cache path with
List exprs | Some (cached_mtime, ast) when cached_mtime = mtime -> ast
| _ ->
if Hashtbl.length _parse_cache > _max_cache_entries then Hashtbl.clear _parse_cache;
let src = In_channel.with_open_text path In_channel.input_all in
let ast = List (Sx_parser.parse_all src) in
Hashtbl.replace _parse_cache path (mtime, ast);
ast
(* CST-based round-tripping — replaces comment_map machinery. (* CST-based round-tripping — replaces comment_map machinery.
Parse file as CST for lossless writes, project to AST for tree-tools. *) Parse file as CST for lossless writes, project to AST for tree-tools. *)
(* Parse file → (AST for tree-tools, CST for writing back) *) (* Parse file → (AST for tree-tools, CST for writing back) *)
let parse_file_cst path = let parse_file_cst path =
let cst = Sx_parser.parse_file_cst path in let mtime = (Unix.stat path).Unix.st_mtime in
let ast = List (List.map Sx_cst.cst_to_ast cst.nodes) in match Hashtbl.find_opt _parse_cst_cache path with
(ast, cst) | Some (cached_mtime, ast, cst) when cached_mtime = mtime -> (ast, cst)
| _ ->
if Hashtbl.length _parse_cst_cache > _max_cache_entries then Hashtbl.clear _parse_cst_cache;
let cst = Sx_parser.parse_file_cst path in
let ast = List (List.map Sx_cst.cst_to_ast cst.nodes) in
Hashtbl.replace _parse_cst_cache path (mtime, ast, cst);
(ast, cst)
(* Extract comment text from CST trivia for display in summarise/read_tree *) (* Extract comment text from CST trivia for display in summarise/read_tree *)
let extract_cst_comments (cst : Sx_parser.cst_file) = let extract_cst_comments (cst : Sx_parser.cst_file) =
@@ -637,6 +658,7 @@ let write_edit_cst file (cst : Sx_parser.cst_file) result =
) new_items in ) new_items in
let source = Sx_cst.cst_file_to_source new_cst_nodes cst.trailing_trivia in let source = Sx_cst.cst_file_to_source new_cst_nodes cst.trailing_trivia in
Out_channel.with_open_text file (fun oc -> output_string oc source); Out_channel.with_open_text file (fun oc -> output_string oc source);
cache_invalidate file;
text_result (Printf.sprintf "OK — wrote %d bytes to %s" (String.length source) file) text_result (Printf.sprintf "OK — wrote %d bytes to %s" (String.length source) file)
| None -> | None ->
let err = match Hashtbl.find_opt d "error" with let err = match Hashtbl.find_opt d "error" with
@@ -645,15 +667,56 @@ let write_edit_cst file (cst : Sx_parser.cst_file) result =
error_result ("Error: " ^ err)) error_result ("Error: " ^ err))
| _ -> error_result "Unexpected result type" | _ -> error_result "Unexpected result type"
(* ------------------------------------------------------------------ *)
(* Infrastructure helpers *)
(* ------------------------------------------------------------------ *)
let run_command cmd =
let ic = Unix.open_process_in cmd in
let buf = Buffer.create 4096 in
(try while true do
if Buffer.length buf > 0 then Buffer.add_char buf '\n';
Buffer.add_string buf (input_line ic)
done with End_of_file -> ());
let status = Unix.close_process_in ic in
let code = match status with Unix.WEXITED n -> n | _ -> 1 in
(code, Buffer.contents buf)
let require_file args key =
let open Yojson.Safe.Util in
let path = args |> member key |> to_string in
if not (Sys.file_exists path) then
raise (Invalid_argument (Printf.sprintf "File not found: %s" path));
path
let require_dir args key =
let open Yojson.Safe.Util in
let path = args |> member key |> to_string in
if not (Sys.file_exists path) then
raise (Invalid_argument (Printf.sprintf "Directory not found: %s" path))
else if not (Sys.is_directory path) then
raise (Invalid_argument (Printf.sprintf "Not a directory: %s" path));
path
let project_dir () =
try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
(* ------------------------------------------------------------------ *)
(* Tool dispatch table *)
(* ------------------------------------------------------------------ *)
let tool_handlers : (string, Yojson.Safe.t -> Yojson.Safe.t) Hashtbl.t = Hashtbl.create 64
let register name f = Hashtbl.replace tool_handlers name f
(* ------------------------------------------------------------------ *) (* ------------------------------------------------------------------ *)
(* Tool handlers *) (* Tool handlers *)
(* ------------------------------------------------------------------ *) (* ------------------------------------------------------------------ *)
let handle_tool name args = let handle_sx_read_tree args =
let open Yojson.Safe.Util in let open Yojson.Safe.Util in
match name with let file = require_file args "file" in
| "sx_read_tree" ->
let file = args |> member "file" |> to_string in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let focus = args |> member "focus" |> to_string_option in let focus = args |> member "focus" |> to_string_option in
let max_depth = to_int_safe (args |> member "max_depth") in let max_depth = to_int_safe (args |> member "max_depth") in
@@ -679,24 +742,28 @@ let handle_tool name args =
let summary = value_to_string (call_sx "summarise" [tree; Number 2.0]) in let summary = value_to_string (call_sx "summarise" [tree; Number 2.0]) in
text_result (inject_cst_comments (Printf.sprintf ";; File has %d lines — showing depth-2 summary. Use max_depth, max_lines, or focus to control output.\n%s" line_count summary) (extract_cst_comments cst))) text_result (inject_cst_comments (Printf.sprintf ";; File has %d lines — showing depth-2 summary. Use max_depth, max_lines, or focus to control output.\n%s" line_count summary) (extract_cst_comments cst)))
| "sx_summarise" -> let handle_sx_summarise args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let depth = to_int_or ~default:2 (args |> member "depth") in let depth = to_int_or ~default:2 (args |> member "depth") in
text_result (inject_cst_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) (extract_cst_comments cst)) text_result (inject_cst_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) (extract_cst_comments cst))
| "sx_read_subtree" -> let handle_sx_read_subtree args =
let tree = parse_file (args |> member "file" |> to_string) in let open Yojson.Safe.Util in
let tree = parse_file (require_file args "file") in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
text_result (value_to_string (call_sx "read-subtree" [tree; path])) text_result (value_to_string (call_sx "read-subtree" [tree; path]))
| "sx_get_context" -> let handle_sx_get_context args =
let tree = parse_file (args |> member "file" |> to_string) in let open Yojson.Safe.Util in
let tree = parse_file (require_file args "file") in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
text_result (value_to_string (call_sx "get-context" [tree; path])) text_result (value_to_string (call_sx "get-context" [tree; path]))
| "sx_find_all" -> let handle_sx_find_all args =
let tree = parse_file (args |> member "file" |> to_string) in let open Yojson.Safe.Util in
let tree = parse_file (require_file args "file") in
let pattern = args |> member "pattern" |> to_string in let pattern = args |> member "pattern" |> to_string in
let results = call_sx "find-all" [tree; String pattern] in let results = call_sx "find-all" [tree; String pattern] in
let lines = match results with let lines = match results with
@@ -711,8 +778,9 @@ let handle_tool name args =
in in
text_result (String.concat "\n" lines) text_result (String.concat "\n" lines)
| "sx_get_siblings" -> let handle_sx_get_siblings args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
let output = value_to_string (call_sx "get-siblings" [tree; path]) in let output = value_to_string (call_sx "get-siblings" [tree; path]) in
@@ -722,40 +790,44 @@ let handle_tool name args =
| _ -> false in | _ -> false in
text_result (if is_top_level then inject_cst_comments output (extract_cst_comments cst) else output) text_result (if is_top_level then inject_cst_comments output (extract_cst_comments cst) else output)
| "sx_validate" -> let handle_sx_validate args =
let tree = parse_file (args |> member "file" |> to_string) in let tree = parse_file (require_file args "file") in
text_result (value_to_string (call_sx "validate" [tree])) text_result (value_to_string (call_sx "validate" [tree]))
| "sx_replace_node" -> let handle_sx_replace_node args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
let src = args |> member "new_source" |> to_string in let src = args |> member "new_source" |> to_string in
write_edit_cst file cst (call_sx "replace-node" [tree; path; String src]) write_edit_cst file cst (call_sx "replace-node" [tree; path; String src])
| "sx_insert_child" -> let handle_sx_insert_child args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
let index = to_int_or ~default:0 (args |> member "index") in let index = to_int_or ~default:0 (args |> member "index") in
let src = args |> member "new_source" |> to_string in let src = args |> member "new_source" |> to_string in
write_edit_cst file cst (call_sx "insert-child" [tree; path; Number (float_of_int index); String src]) write_edit_cst file cst (call_sx "insert-child" [tree; path; Number (float_of_int index); String src])
| "sx_delete_node" -> let handle_sx_delete_node args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
write_edit_cst file cst (call_sx "delete-node" [tree; path]) write_edit_cst file cst (call_sx "delete-node" [tree; path])
| "sx_wrap_node" -> let handle_sx_wrap_node args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let path = resolve_path tree (args |> member "path" |> to_string) in let path = resolve_path tree (args |> member "path" |> to_string) in
let wrapper = args |> member "wrapper" |> to_string in let wrapper = args |> member "wrapper" |> to_string in
write_edit_cst file cst (call_sx "wrap-node" [tree; path; String wrapper]) write_edit_cst file cst (call_sx "wrap-node" [tree; path; String wrapper])
| "sx_format_check" -> let handle_sx_format_check args =
let file = args |> member "file" |> to_string in let file = require_file args "file" in
let tree = parse_file file in let tree = parse_file file in
let warnings = call_sx "lint-file" [tree] in let warnings = call_sx "lint-file" [tree] in
(match warnings with (match warnings with
@@ -764,7 +836,8 @@ let handle_tool name args =
text_result (String.concat "\n" (List.map value_to_string items)) text_result (String.concat "\n" (List.map value_to_string items))
| _ -> text_result (value_to_string warnings)) | _ -> text_result (value_to_string warnings))
| "sx_macroexpand" -> let handle_sx_macroexpand args =
let open Yojson.Safe.Util in
let file = args |> member "file" |> to_string_option in let file = args |> member "file" |> to_string_option in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
(* Create a fresh env with file definitions loaded *) (* Create a fresh env with file definitions loaded *)
@@ -781,39 +854,30 @@ let handle_tool name args =
) Nil exprs in ) Nil exprs in
text_result (Sx_types.inspect result) text_result (Sx_types.inspect result)
| "sx_build" -> let handle_sx_build args =
let open Yojson.Safe.Util in
let target = args |> member "target" |> to_string_option |> Option.value ~default:"js" in let target = args |> member "target" |> to_string_option |> Option.value ~default:"js" in
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let cmd = match target with let cmd = match target with
| "ocaml" -> | "ocaml" ->
let abs_project = if Filename.is_relative project_dir then Sys.getcwd () ^ "/" ^ project_dir else project_dir in let abs_project = if Filename.is_relative pd then Sys.getcwd () ^ "/" ^ pd else pd in
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune build 2>&1 && cp _build/default/browser/sx_browser.bc.wasm.js %s/shared/static/wasm/sx_browser.bc.wasm.js && cp _build/default/browser/sx_browser.bc.js %s/shared/static/wasm/sx_browser.bc.js && cp -r _build/default/browser/sx_browser.bc.wasm.assets %s/shared/static/wasm/" abs_project abs_project abs_project abs_project Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune build 2>&1 && cp _build/default/browser/sx_browser.bc.wasm.js %s/shared/static/wasm/sx_browser.bc.wasm.js && cp _build/default/browser/sx_browser.bc.js %s/shared/static/wasm/sx_browser.bc.js && cp -r _build/default/browser/sx_browser.bc.wasm.assets %s/shared/static/wasm/" abs_project abs_project abs_project abs_project
| "wasm" -> | "wasm" ->
let abs_project = if Filename.is_relative project_dir then Sys.getcwd () ^ "/" ^ project_dir else project_dir in let abs_project = if Filename.is_relative pd then Sys.getcwd () ^ "/" ^ pd else pd in
Printf.sprintf "cd %s && bash hosts/ocaml/browser/build-all.sh 2>&1" abs_project Printf.sprintf "cd %s && bash hosts/ocaml/browser/build-all.sh 2>&1" abs_project
| "js" | _ -> | "js" | _ ->
let extra = if full then " --extensions continuations --spec-modules types" else "" in let extra = if full then " --extensions continuations --spec-modules types" else "" in
Printf.sprintf "cd %s && python3 hosts/javascript/cli.py%s --output shared/static/scripts/sx-browser.js 2>&1" project_dir extra Printf.sprintf "cd %s && python3 hosts/javascript/cli.py%s --output shared/static/scripts/sx-browser.js 2>&1" pd extra
in in
let ic = Unix.open_process_in cmd in let (code, output) = run_command cmd in
let lines = ref [] in if code = 0 then text_result (Printf.sprintf "OK — %s build succeeded\n%s" target (String.trim output))
(try while true do lines := input_line ic :: !lines done with End_of_file -> ()); else error_result (Printf.sprintf "%s build failed:\n%s" target output)
let status = Unix.close_process_in ic in
let output = String.concat "\n" (List.rev !lines) in
(match status with
| Unix.WEXITED 0 -> text_result (Printf.sprintf "OK — %s build succeeded\n%s" target (String.trim output))
| _ -> error_result (Printf.sprintf "%s build failed:\n%s" target output))
| "sx_build_bytecode" -> let handle_sx_build_bytecode _args =
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> ignore _args;
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in let pd = project_dir () in
Filename.dirname spec_dir let sx_dir = pd ^ "/shared/static/wasm/sx" in
in
let sx_dir = project_dir ^ "/shared/static/wasm/sx" in
let files = [ let files = [
"render.sx"; "core-signals.sx"; "signals.sx"; "deps.sx"; "router.sx"; "render.sx"; "core-signals.sx"; "signals.sx"; "deps.sx"; "router.sx";
"page-helpers.sx"; "freeze.sx"; "bytecode.sx"; "compiler.sx"; "vm.sx"; "page-helpers.sx"; "freeze.sx"; "bytecode.sx"; "compiler.sx"; "vm.sx";
@@ -905,35 +969,29 @@ let handle_tool name args =
else else
text_result (Printf.sprintf "Bytecode compilation partial\n%s" summary) text_result (Printf.sprintf "Bytecode compilation partial\n%s" summary)
| "sx_test" -> let handle_sx_test args =
let open Yojson.Safe.Util in
let host = args |> member "host" |> to_string_option |> Option.value ~default:"js" in let host = args |> member "host" |> to_string_option |> Option.value ~default:"js" in
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
(* Walk up from spec dir to find project root *)
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let timeout = to_int_or ~default:300 (args |> member "timeout") in let timeout = to_int_or ~default:300 (args |> member "timeout") in
let cmd = match host with let cmd = match host with
| "ocaml" -> | "ocaml" ->
(* Use pre-built binary directly — avoids dune rebuild delay. (* Use pre-built binary directly — avoids dune rebuild delay.
Falls back to dune exec if the binary doesn't exist. *) Falls back to dune exec if the binary doesn't exist. *)
let exe = Printf.sprintf "%s/hosts/ocaml/_build/default/bin/run_tests.exe" project_dir in let exe = Printf.sprintf "%s/hosts/ocaml/_build/default/bin/run_tests.exe" pd in
if Sys.file_exists exe then if Sys.file_exists exe then
Printf.sprintf "cd %s/hosts/ocaml && timeout %d %s%s 2>&1" Printf.sprintf "cd %s/hosts/ocaml && timeout %d %s%s 2>&1"
project_dir timeout exe (if full then " --full" else "") pd timeout exe (if full then " --full" else "")
else else
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && timeout %d dune exec bin/run_tests.exe%s 2>&1" Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && timeout %d dune exec bin/run_tests.exe%s 2>&1"
project_dir timeout (if full then " -- --full" else "") pd timeout (if full then " -- --full" else "")
| "js" | _ -> | "js" | _ ->
Printf.sprintf "cd %s && timeout %d node hosts/javascript/run_tests.js%s 2>&1" Printf.sprintf "cd %s && timeout %d node hosts/javascript/run_tests.js%s 2>&1"
project_dir timeout (if full then " --full" else "") pd timeout (if full then " --full" else "")
in in
let ic = Unix.open_process_in cmd in let (_code, output) = run_command cmd in
let lines = ref [] in let all_lines = String.split_on_char '\n' output in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let all_lines = List.rev !lines in
(* Extract summary and failures *) (* Extract summary and failures *)
let fails = List.filter (fun l -> let t = String.trim l in let fails = List.filter (fun l -> let t = String.trim l in
String.length t > 5 && String.sub t 0 4 = "FAIL") all_lines in String.length t > 5 && String.sub t 0 4 = "FAIL") all_lines in
@@ -948,7 +1006,8 @@ let handle_tool name args =
in in
text_result result text_result result
| "sx_pretty_print" -> let handle_sx_pretty_print args =
let open Yojson.Safe.Util in
let file = args |> member "file" |> to_string in let file = args |> member "file" |> to_string in
let cst = Sx_parser.parse_file_cst file in let cst = Sx_parser.parse_file_cst file in
(* Reformat each node's code while preserving trivia (comments, spacing) *) (* Reformat each node's code while preserving trivia (comments, spacing) *)
@@ -971,24 +1030,20 @@ let handle_tool name args =
) cst.nodes in ) cst.nodes in
let source = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in let source = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in
Out_channel.with_open_text file (fun oc -> output_string oc source); Out_channel.with_open_text file (fun oc -> output_string oc source);
cache_invalidate file;
text_result (Printf.sprintf "OK — reformatted %s (%d bytes, %d forms)" file (String.length source) (List.length cst.nodes)) text_result (Printf.sprintf "OK — reformatted %s (%d bytes, %d forms)" file (String.length source) (List.length cst.nodes))
| "sx_changed" -> let handle_sx_changed args =
let open Yojson.Safe.Util in
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" pd base_ref in
Filename.dirname spec_dir let (_code, output) = run_command cmd in
in let changed = if output = "" then [] else String.split_on_char '\n' output in
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
let ic = Unix.open_process_in cmd in
let files = ref [] in
(try while true do files := input_line ic :: !files done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let changed = List.rev !files in
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref) if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
else begin else begin
let lines = List.map (fun rel -> let lines = List.map (fun rel ->
let full = Filename.concat project_dir rel in let full = Filename.concat pd rel in
try try
let tree = parse_file full in let tree = parse_file full in
let summary = value_to_string (call_sx "summarise" [tree; Number 1.0]) in let summary = value_to_string (call_sx "summarise" [tree; Number 1.0]) in
@@ -998,29 +1053,20 @@ let handle_tool name args =
text_result (String.concat "\n\n" lines) text_result (String.concat "\n\n" lines)
end end
| "sx_diff_branch" -> let handle_sx_diff_branch args =
let open Yojson.Safe.Util in
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" pd base_ref in
Filename.dirname spec_dir let (_code, output) = run_command cmd in
in let changed = if output = "" then [] else String.split_on_char '\n' output in
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
let ic = Unix.open_process_in cmd in
let files = ref [] in
(try while true do files := input_line ic :: !files done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let changed = List.rev !files in
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref) if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
else begin else begin
let lines = List.filter_map (fun rel -> let lines = List.filter_map (fun rel ->
let full = Filename.concat project_dir rel in let full = Filename.concat pd rel in
(* Get the base version via git show *) (* Get the base version via git show *)
let base_cmd = Printf.sprintf "cd %s && git show %s:%s 2>/dev/null" project_dir base_ref rel in let base_cmd = Printf.sprintf "cd %s && git show %s:%s 2>/dev/null" pd base_ref rel in
let ic2 = Unix.open_process_in base_cmd in let (_base_code, base_src) = run_command base_cmd in
let base_lines = ref [] in
(try while true do base_lines := input_line ic2 :: !base_lines done with End_of_file -> ());
ignore (Unix.close_process_in ic2);
let base_src = String.concat "\n" (List.rev !base_lines) in
try try
let tree_b = parse_file full in let tree_b = parse_file full in
if base_src = "" then if base_src = "" then
@@ -1038,13 +1084,11 @@ let handle_tool name args =
else text_result (String.concat "\n\n" lines) else text_result (String.concat "\n\n" lines)
end end
| "sx_blame" -> let handle_sx_blame args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let path_str_arg = args |> member "path" |> to_string_option in let path_str_arg = args |> member "path" |> to_string_option in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
(* Get the node's source span by parsing and finding line numbers *) (* Get the node's source span by parsing and finding line numbers *)
let tree = parse_file file in let tree = parse_file file in
let target_src = match path_str_arg with let target_src = match path_str_arg with
@@ -1055,7 +1099,7 @@ let handle_tool name args =
else Some (Sx_types.inspect node) else Some (Sx_types.inspect node)
| None -> None | None -> None
in in
let rel_file = relative_path ~base:project_dir file in let rel_file = relative_path ~base:pd file in
let cmd = match target_src with let cmd = match target_src with
| Some src -> | Some src ->
(* Find the line range containing this source fragment *) (* Find the line range containing this source fragment *)
@@ -1064,18 +1108,15 @@ let handle_tool name args =
if c = '(' || c = ')' || c = '[' || c = ']' || c = '.' || c = '*' || c = '+' || c = '?' || c = '{' || c = '}' || c = '\\' || c = '|' || c = '^' || c = '$' if c = '(' || c = ')' || c = '[' || c = ']' || c = '.' || c = '*' || c = '+' || c = '?' || c = '{' || c = '}' || c = '\\' || c = '|' || c = '^' || c = '$'
then Printf.sprintf "\\%c" c else String.make 1 c then Printf.sprintf "\\%c" c else String.make 1 c
) (String.to_seq first_line))) in ) (String.to_seq first_line))) in
Printf.sprintf "cd %s && git blame -L '/%s/,+10' -- %s 2>/dev/null || git blame -- %s 2>/dev/null | head -20" project_dir escaped rel_file rel_file Printf.sprintf "cd %s && git blame -L '/%s/,+10' -- %s 2>/dev/null || git blame -- %s 2>/dev/null | head -20" pd escaped rel_file rel_file
| None -> | None ->
Printf.sprintf "cd %s && git blame -- %s 2>/dev/null | head -30" project_dir rel_file Printf.sprintf "cd %s && git blame -- %s 2>/dev/null | head -30" pd rel_file
in in
let ic = Unix.open_process_in cmd in let (_code, output) = run_command cmd in
let lines = ref [] in text_result output
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
text_result (String.concat "\n" (List.rev !lines))
| "sx_doc_gen" -> let handle_sx_doc_gen args =
let dir = args |> member "dir" |> to_string in let dir = require_dir args "dir" in
let files = glob_sx_files dir in let files = glob_sx_files dir in
let strip_comment_prefix text = let strip_comment_prefix text =
let lines = String.split_on_char '\n' text in let lines = String.split_on_char '\n' text in
@@ -1152,7 +1193,8 @@ let handle_tool name args =
if all_docs = [] then text_result "(no components found)" if all_docs = [] then text_result "(no components found)"
else text_result (String.concat "\n" all_docs) else text_result (String.concat "\n" all_docs)
| "sx_nav" -> let handle_sx_nav args =
let open Yojson.Safe.Util in
let mode = (try args |> member "mode" |> to_string with _ -> "list") in let mode = (try args |> member "mode" |> to_string with _ -> "list") in
let section_filter = (try Some (args |> member "section" |> to_string) with _ -> None) in let section_filter = (try Some (args |> member "section" |> to_string) with _ -> None) in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
@@ -1278,18 +1320,21 @@ let handle_tool name args =
(* Component file *) (* Component file *)
let src = Printf.sprintf ";;; %s\n\n(defcomp %s ()\n (~docs/page :title \"%s\"\n (~docs/section :title \"Overview\" :id \"overview\"\n (p \"TODO\"))))\n" title comp title in let src = Printf.sprintf ";;; %s\n\n(defcomp %s ()\n (~docs/page :title \"%s\"\n (~docs/section :title \"Overview\" :id \"overview\"\n (p \"TODO\"))))\n" title comp title in
Out_channel.with_open_text file (fun oc -> output_string oc src); Out_channel.with_open_text file (fun oc -> output_string oc src);
cache_invalidate file;
(* Page function *) (* Page function *)
let pf = sx_dir ^ "/page-functions.sx" in let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in let ps = In_channel.with_open_text pf In_channel.input_all in
Out_channel.with_open_text pf (fun oc -> Out_channel.with_open_text pf (fun oc ->
output_string oc ps; output_string oc ps;
Printf.fprintf oc "\n(define %s (make-page-fn \"%s\" \"~%s/%s/\" nil \"-content\"))\n" slug comp sec slug); Printf.fprintf oc "\n(define %s (make-page-fn \"%s\" \"~%s/%s/\" nil \"-content\"))\n" slug comp sec slug);
cache_invalidate pf;
(* Nav entry *) (* Nav entry *)
let nf = sx_dir ^ "/nav-data.sx" in let nf = sx_dir ^ "/nav-data.sx" in
let ns = In_channel.with_open_text nf In_channel.input_all in let ns = In_channel.with_open_text nf In_channel.input_all in
Out_channel.with_open_text nf (fun oc -> Out_channel.with_open_text nf (fun oc ->
output_string oc ns; output_string oc ns;
Printf.fprintf oc "\n(define %s-nav-items\n (list (dict :label \"%s\" :href \"%s\")))\n" slug title href); Printf.fprintf oc "\n(define %s-nav-items\n (list (dict :label \"%s\" :href \"%s\")))\n" slug title href);
cache_invalidate nf;
text_result (Printf.sprintf "Created:\n File: %s\n Component: %s\n Page fn: %s\n Nav href: %s" file comp slug href) text_result (Printf.sprintf "Created:\n File: %s\n Component: %s\n Page fn: %s\n Nav href: %s" file comp slug href)
end end
end end
@@ -1328,6 +1373,7 @@ let handle_tool name args =
let ns2 = remove_define_block ns nav_items_name in let ns2 = remove_define_block ns nav_items_name in
if ns2 <> ns then begin if ns2 <> ns then begin
Out_channel.with_open_text nf (fun oc -> output_string oc ns2); Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
cache_invalidate nf;
log (Printf.sprintf "nav-data.sx: removed define %s" nav_items_name) log (Printf.sprintf "nav-data.sx: removed define %s" nav_items_name)
end; end;
(* 2. Remove from nav-tree.sx — find the dict block with matching href *) (* 2. Remove from nav-tree.sx — find the dict block with matching href *)
@@ -1362,14 +1408,17 @@ let handle_tool name args =
log (Printf.sprintf "nav-tree.sx: removed entry for %s" slug); log (Printf.sprintf "nav-tree.sx: removed entry for %s" slug);
String.sub ts 0 !start ^ String.sub ts !e (String.length ts - !e) String.sub ts 0 !start ^ String.sub ts !e (String.length ts - !e)
in in
if ts2 <> ts then if ts2 <> ts then begin
Out_channel.with_open_text tf (fun oc -> output_string oc ts2); Out_channel.with_open_text tf (fun oc -> output_string oc ts2);
cache_invalidate tf
end;
(* 3. Remove from page-functions.sx *) (* 3. Remove from page-functions.sx *)
let pf = sx_dir ^ "/page-functions.sx" in let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in let ps = In_channel.with_open_text pf In_channel.input_all in
let ps2 = remove_define_block ps slug in let ps2 = remove_define_block ps slug in
if ps2 <> ps then begin if ps2 <> ps then begin
Out_channel.with_open_text pf (fun oc -> output_string oc ps2); Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
cache_invalidate pf;
log (Printf.sprintf "page-functions.sx: removed define %s" slug) log (Printf.sprintf "page-functions.sx: removed define %s" slug)
end; end;
text_result (Printf.sprintf "Deleted %s:\n%s" slug (Buffer.contents changes)) text_result (Printf.sprintf "Deleted %s:\n%s" slug (Buffer.contents changes))
@@ -1394,6 +1443,7 @@ let handle_tool name args =
let ns2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ns in let ns2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ns in
if ns2 <> ns then begin if ns2 <> ns then begin
Out_channel.with_open_text nf (fun oc -> output_string oc ns2); Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
cache_invalidate nf;
log (Printf.sprintf "nav-data.sx: rewrote hrefs %s → %s" from_sec to_sec) log (Printf.sprintf "nav-data.sx: rewrote hrefs %s → %s" from_sec to_sec)
end; end;
(* 2. Move entry in nav-tree.sx: extract block from source, rewrite hrefs, insert into target *) (* 2. Move entry in nav-tree.sx: extract block from source, rewrite hrefs, insert into target *)
@@ -1466,6 +1516,7 @@ let handle_tool name args =
result)) result))
in in
Out_channel.with_open_text tf (fun oc -> output_string oc ts3); Out_channel.with_open_text tf (fun oc -> output_string oc ts3);
cache_invalidate tf;
(* 3. Rewrite page-functions.sx component prefix if needed *) (* 3. Rewrite page-functions.sx component prefix if needed *)
let pf = sx_dir ^ "/page-functions.sx" in let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in let ps = In_channel.with_open_text pf In_channel.input_all in
@@ -1474,17 +1525,16 @@ let handle_tool name args =
let ps2 = Str.global_replace (Str.regexp_string old_comp_prefix) new_comp_prefix ps in let ps2 = Str.global_replace (Str.regexp_string old_comp_prefix) new_comp_prefix ps in
if ps2 <> ps then begin if ps2 <> ps then begin
Out_channel.with_open_text pf (fun oc -> output_string oc ps2); Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
cache_invalidate pf;
log (Printf.sprintf "page-functions.sx: rewrote %s → %s" old_comp_prefix new_comp_prefix) log (Printf.sprintf "page-functions.sx: rewrote %s → %s" old_comp_prefix new_comp_prefix)
end; end;
text_result (Printf.sprintf "Moved %s: %s → %s\n%s" slug from_sec to_sec (Buffer.contents changes)) text_result (Printf.sprintf "Moved %s: %s → %s\n%s" slug from_sec to_sec (Buffer.contents changes))
end end
| m -> error_result (Printf.sprintf "unknown mode: %s (list, check, add, move, delete)" m)) | m -> error_result (Printf.sprintf "unknown mode: %s (list, check, add, move, delete)" m))
| "sx_playwright" -> let handle_sx_playwright args =
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let open Yojson.Safe.Util in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in let pd = project_dir () in
Filename.dirname spec_dir
in
let spec = args |> member "spec" |> to_string_option in let spec = args |> member "spec" |> to_string_option in
let mode = args |> member "mode" |> to_string_option in let mode = args |> member "mode" |> to_string_option in
let url = args |> member "url" |> to_string_option in let url = args |> member "url" |> to_string_option in
@@ -1502,12 +1552,9 @@ let handle_tool name args =
if not use_inspector then begin if not use_inspector then begin
(* Original spec runner *) (* Original spec runner *)
let spec_arg = match spec with Some s -> " " ^ s | None -> "" in let spec_arg = match spec with Some s -> " " ^ s | None -> "" in
let cmd = Printf.sprintf "cd %s/tests/playwright && npx playwright test%s --reporter=line 2>&1" project_dir spec_arg in let cmd = Printf.sprintf "cd %s/tests/playwright && npx playwright test%s --reporter=line 2>&1" pd spec_arg in
let ic = Unix.open_process_in cmd in let (_code, output) = run_command cmd in
let lines = ref [] in let all_lines = String.split_on_char '\n' output in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let all_lines = List.rev !lines in
(* Count passed/failed/skipped from the summary line *) (* Count passed/failed/skipped from the summary line *)
let summary = List.find_opt (fun l -> let summary = List.find_opt (fun l ->
try let _ = Str.search_forward (Str.regexp "passed\\|failed") l 0 in true try let _ = Str.search_forward (Str.regexp "passed\\|failed") l 0 in true
@@ -1560,12 +1607,8 @@ let handle_tool name args =
let args_json = Yojson.Basic.to_string inspector_args in let args_json = Yojson.Basic.to_string inspector_args in
(* Single-quote shell wrapping — escape any literal single quotes in JSON *) (* Single-quote shell wrapping — escape any literal single quotes in JSON *)
let shell_safe = String.concat "'\\''" (String.split_on_char '\'' args_json) in let shell_safe = String.concat "'\\''" (String.split_on_char '\'' args_json) in
let cmd = Printf.sprintf "cd %s && node tests/playwright/sx-inspect.js '%s' 2>&1" project_dir shell_safe in let cmd = Printf.sprintf "cd %s && node tests/playwright/sx-inspect.js '%s' 2>&1" pd shell_safe in
let ic = Unix.open_process_in cmd in let (_code, raw) = run_command cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let raw = String.concat "\n" (List.rev !lines) in
(* Try to parse as JSON and format nicely *) (* Try to parse as JSON and format nicely *)
try try
let json = Yojson.Basic.from_string raw in let json = Yojson.Basic.from_string raw in
@@ -1575,7 +1618,8 @@ let handle_tool name args =
text_result raw text_result raw
end end
| "sx_harness_eval" -> let handle_sx_harness_eval args =
let open Yojson.Safe.Util in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
let mock_str = args |> member "mock" |> to_string_option in let mock_str = args |> member "mock" |> to_string_option in
let file = args |> member "file" |> to_string_option in let file = args |> member "file" |> to_string_option in
@@ -1637,8 +1681,9 @@ let handle_tool name args =
in in
text_result (Printf.sprintf "Result: %s%s%s" (Sx_types.inspect result) log_str warn_str) text_result (Printf.sprintf "Result: %s%s%s" (Sx_types.inspect result) log_str warn_str)
| "sx_write_file" -> let handle_sx_write_file args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let source = args |> member "source" |> to_string in let source = args |> member "source" |> to_string in
(* Validate by parsing as CST — preserves comments and formatting *) (* Validate by parsing as CST — preserves comments and formatting *)
(try (try
@@ -1665,12 +1710,14 @@ let handle_tool name args =
) cst.nodes in ) cst.nodes in
let output = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in let output = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in
Out_channel.with_open_text file (fun oc -> output_string oc output); Out_channel.with_open_text file (fun oc -> output_string oc output);
cache_invalidate file;
text_result (Printf.sprintf "OK — wrote %d bytes (%d top-level forms) to %s" (String.length output) (List.length cst.nodes) file) text_result (Printf.sprintf "OK — wrote %d bytes (%d top-level forms) to %s" (String.length output) (List.length cst.nodes) file)
end end
with e -> error_result (Printf.sprintf "Parse error — file not written: %s" (Printexc.to_string e))) with e -> error_result (Printf.sprintf "Parse error — file not written: %s" (Printexc.to_string e)))
| "sx_rename_symbol" -> let handle_sx_rename_symbol args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let old_name = args |> member "old_name" |> to_string in let old_name = args |> member "old_name" |> to_string in
let new_name = args |> member "new_name" |> to_string in let new_name = args |> member "new_name" |> to_string in
@@ -1684,8 +1731,9 @@ let handle_tool name args =
text_result (Printf.sprintf "Renamed %s occurrences of '%s' → '%s' in %s" count_str old_name new_name file) text_result (Printf.sprintf "Renamed %s occurrences of '%s' → '%s' in %s" count_str old_name new_name file)
| other -> other) | other -> other)
| "sx_replace_by_pattern" -> let handle_sx_replace_by_pattern args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let pattern = args |> member "pattern" |> to_string in let pattern = args |> member "pattern" |> to_string in
let src = args |> member "new_source" |> to_string in let src = args |> member "new_source" |> to_string in
@@ -1695,16 +1743,18 @@ let handle_tool name args =
else else
write_edit_cst file cst (call_sx "replace-by-pattern" [tree; String pattern; String src]) write_edit_cst file cst (call_sx "replace-by-pattern" [tree; String pattern; String src])
| "sx_insert_near" -> let handle_sx_insert_near args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let tree, cst = parse_file_cst file in let tree, cst = parse_file_cst file in
let pattern = args |> member "pattern" |> to_string in let pattern = args |> member "pattern" |> to_string in
let position = args |> member "position" |> to_string_option |> Option.value ~default:"after" in let position = args |> member "position" |> to_string_option |> Option.value ~default:"after" in
let src = args |> member "new_source" |> to_string in let src = args |> member "new_source" |> to_string in
write_edit_cst file cst (call_sx "insert-near-pattern" [tree; String pattern; String position; String src]) write_edit_cst file cst (call_sx "insert-near-pattern" [tree; String pattern; String position; String src])
| "sx_rename_across" -> let handle_sx_rename_across args =
let dir = args |> member "dir" |> to_string in let open Yojson.Safe.Util in
let dir = require_dir args "dir" in
let old_name = args |> member "old_name" |> to_string in let old_name = args |> member "old_name" |> to_string in
let new_name = args |> member "new_name" |> to_string in let new_name = args |> member "new_name" |> to_string in
let dry_run = args |> member "dry_run" |> to_bool_option |> Option.value ~default:false in let dry_run = args |> member "dry_run" |> to_bool_option |> Option.value ~default:false in
@@ -1730,8 +1780,11 @@ let handle_tool name args =
if results = [] then text_result (Printf.sprintf "No occurrences of '%s' found" old_name) if results = [] then text_result (Printf.sprintf "No occurrences of '%s' found" old_name)
else text_result (String.concat "\n" results) else text_result (String.concat "\n" results)
| "sx_comp_list" -> let handle_sx_comp_list args =
let dir = args |> member "dir" |> to_string in let open Yojson.Safe.Util in
let dir = require_dir args "dir" in
let limit = to_int_or ~default:200 (args |> member "limit") in
let offset = to_int_or ~default:0 (args |> member "offset") in
let files = glob_sx_files dir in let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path -> let all_lines = List.concat_map (fun path ->
let rel = relative_path ~base:dir path in let rel = relative_path ~base:dir path in
@@ -1754,10 +1807,16 @@ let handle_tool name args =
with _ -> [] with _ -> []
) files in ) files in
if all_lines = [] then text_result "(no definitions found)" if all_lines = [] then text_result "(no definitions found)"
else text_result (Printf.sprintf "%-10s %-40s %-50s %s\n%s" "TYPE" "NAME" "FILE" "PARAMS" (String.concat "\n" all_lines)) else
let total = List.length all_lines in
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
text_result (Printf.sprintf "%-10s %-40s %-50s %s (showing %d-%d of %d)\n%s" "TYPE" "NAME" "FILE" "PARAMS" offset (offset + List.length page) total (String.concat "\n" page))
| "sx_find_across" -> let handle_sx_find_across args =
let dir = args |> member "dir" |> to_string in let open Yojson.Safe.Util in
let dir = require_dir args "dir" in
let limit = to_int_or ~default:200 (args |> member "limit") in
let offset = to_int_or ~default:0 (args |> member "offset") in
let pattern = args |> member "pattern" |> to_string in let pattern = args |> member "pattern" |> to_string in
let files = glob_sx_files dir in let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path -> let all_lines = List.concat_map (fun path ->
@@ -1777,17 +1836,23 @@ let handle_tool name args =
with _ -> [] with _ -> []
) files in ) files in
if all_lines = [] then text_result "(no matches)" if all_lines = [] then text_result "(no matches)"
else text_result (String.concat "\n" all_lines) else
let total = List.length all_lines in
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
text_result (Printf.sprintf "(showing %d-%d of %d)\n%s" offset (offset + List.length page) total (String.concat "\n" page))
| "sx_diff" -> let handle_sx_diff args =
let file_a = args |> member "file_a" |> to_string in let file_a = require_file args "file_a" in
let file_b = args |> member "file_b" |> to_string in let file_b = require_file args "file_b" in
let tree_a = parse_file file_a in let tree_a = parse_file file_a in
let tree_b = parse_file file_b in let tree_b = parse_file file_b in
text_result (value_to_string (call_sx "tree-diff" [tree_a; tree_b])) text_result (value_to_string (call_sx "tree-diff" [tree_a; tree_b]))
| "sx_comp_usage" -> let handle_sx_comp_usage args =
let dir = args |> member "dir" |> to_string in let open Yojson.Safe.Util in
let dir = require_dir args "dir" in
let limit = to_int_or ~default:200 (args |> member "limit") in
let offset = to_int_or ~default:0 (args |> member "offset") in
let name = args |> member "name" |> to_string in let name = args |> member "name" |> to_string in
let files = glob_sx_files dir in let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path -> let all_lines = List.concat_map (fun path ->
@@ -1807,9 +1872,13 @@ let handle_tool name args =
with _ -> [] with _ -> []
) files in ) files in
if all_lines = [] then text_result "(no usages found)" if all_lines = [] then text_result "(no usages found)"
else text_result (String.concat "\n" all_lines) else
let total = List.length all_lines in
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
text_result (Printf.sprintf "(showing %d-%d of %d)\n%s" offset (offset + List.length page) total (String.concat "\n" page))
| "sx_eval" -> let handle_sx_eval args =
let open Yojson.Safe.Util in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
let exprs = Sx_parser.parse_all expr_str in let exprs = Sx_parser.parse_all expr_str in
let e = !env in let e = !env in
@@ -1818,7 +1887,8 @@ let handle_tool name args =
) Nil exprs in ) Nil exprs in
text_result (Sx_runtime.value_to_str result) text_result (Sx_runtime.value_to_str result)
| "sx_guard" -> let handle_sx_guard args =
let open Yojson.Safe.Util in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
let file = try Some (args |> member "file" |> to_string) with _ -> None in let file = try Some (args |> member "file" |> to_string) with _ -> None in
let e = !env in let e = !env in
@@ -1843,7 +1913,8 @@ let handle_tool name args =
String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in
text_result (Sx_runtime.value_to_str !result ^ cond_lines) text_result (Sx_runtime.value_to_str !result ^ cond_lines)
| "sx_render_trace" -> let handle_sx_render_trace args =
let open Yojson.Safe.Util in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
let file = try Some (args |> member "file" |> to_string) with _ -> None in let file = try Some (args |> member "file" |> to_string) with _ -> None in
let e = !env in let e = !env in
@@ -1872,7 +1943,8 @@ let handle_tool name args =
Buffer.add_string trace (Printf.sprintf "← %s\n" result_str); Buffer.add_string trace (Printf.sprintf "← %s\n" result_str);
text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace)) text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace))
| "sx_trace" -> let handle_sx_trace args =
let open Yojson.Safe.Util in
let expr_str = args |> member "expr" |> to_string in let expr_str = args |> member "expr" |> to_string in
let max_steps = to_int_or ~default:200 (args |> member "max_steps") in let max_steps = to_int_or ~default:200 (args |> member "max_steps") in
let file = try Some (args |> member "file" |> to_string) with _ -> None in let file = try Some (args |> member "file" |> to_string) with _ -> None in
@@ -1986,8 +2058,9 @@ let handle_tool name args =
text_result (Printf.sprintf "Result: %s\n\nTrace (%d steps):\n%s" text_result (Printf.sprintf "Result: %s\n\nTrace (%d steps):\n%s"
final_val !step_count (Buffer.contents steps)) final_val !step_count (Buffer.contents steps))
| "sx_deps" -> let handle_sx_deps args =
let file = args |> member "file" |> to_string in let open Yojson.Safe.Util in
let file = require_file args "file" in
let name = try Some (args |> member "name" |> to_string) with _ -> None in let name = try Some (args |> member "name" |> to_string) with _ -> None in
let dir = try args |> member "dir" |> to_string with _ -> let dir = try args |> member "dir" |> to_string with _ ->
try Sys.getenv "SX_PROJECT_DIR" with Not_found -> try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
@@ -2073,7 +2146,8 @@ let handle_tool name args =
text_result (Printf.sprintf "%s\n%d symbols referenced:\n%s%s" text_result (Printf.sprintf "%s\n%d symbols referenced:\n%s%s"
header (List.length sym_names) (String.concat "\n" lines) use_str) header (List.length sym_names) (String.concat "\n" lines) use_str)
| "sx_build_manifest" -> let handle_sx_build_manifest args =
let open Yojson.Safe.Util in
let target = (try args |> member "target" |> to_string with _ -> "js") in let target = (try args |> member "target" |> to_string with _ -> "js") in
(match target with (match target with
| "ocaml" -> | "ocaml" ->
@@ -2122,18 +2196,14 @@ let handle_tool name args =
) ["native"; "lambda"; "macro"; "component"; "island"; "value"]; ) ["native"; "lambda"; "macro"; "component"; "island"; "value"];
text_result (Buffer.contents sections) text_result (Buffer.contents sections)
| _ -> | _ ->
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
try Sys.getenv "PWD" with Not_found -> "." in
let cmd = Printf.sprintf "cd %s && python3 hosts/javascript/manifest.py 2>&1" let cmd = Printf.sprintf "cd %s && python3 hosts/javascript/manifest.py 2>&1"
(Filename.quote project_dir) in (Filename.quote pd) in
let ic = Unix.open_process_in cmd in let (_code, output) = run_command cmd in
let buf = Buffer.create 4096 in text_result output)
(try while true do Buffer.add_string buf (input_line ic ^ "\n") done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
text_result (Buffer.contents buf))
| "sx_explain" -> let handle_sx_explain args =
let open Yojson.Safe.Util in
let form_name = args |> member "name" |> to_string in let form_name = args |> member "name" |> to_string in
let e = !env in let e = !env in
let result = try let result = try
@@ -2184,22 +2254,21 @@ let handle_tool name args =
(* Server inspection tools *) (* Server inspection tools *)
(* ================================================================== *) (* ================================================================== *)
| "sx_load_check" -> let handle_sx_load_check _args =
ignore _args;
(* Load all .sx files the HTTP server would load, report errors *) (* Load all .sx files the HTTP server would load, report errors *)
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in let spec_base = pd ^ "/spec" in
Filename.dirname spec_dir in let lib_base = pd ^ "/lib" in
let spec_base = project_dir ^ "/spec" in let web_base = pd ^ "/web" in
let lib_base = project_dir ^ "/lib" in let shared_sx = pd ^ "/shared/sx/templates" in
let web_base = project_dir ^ "/web" in
let shared_sx = project_dir ^ "/shared/sx/templates" in
let sx_sx = let sx_sx =
let dp = project_dir ^ "/sx" in let dp = pd ^ "/sx" in
let dv = project_dir ^ "/sx/sx" in let dv = pd ^ "/sx/sx" in
if Sys.file_exists (dp ^ "/page-functions.sx") then dp else dv in if Sys.file_exists (dp ^ "/page-functions.sx") then dp else dv in
let sx_sxc = let sx_sxc =
let dp = project_dir ^ "/sxc" in let dp = pd ^ "/sxc" in
let dv = project_dir ^ "/sx/sxc" in let dv = pd ^ "/sx/sxc" in
if Sys.file_exists dp then dp else dv in if Sys.file_exists dp then dp else dv in
let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx"; let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx";
"harness.sx"; "eval-rules.sx"; "vm-inline.sx"] in "harness.sx"; "eval-rules.sx"; "vm-inline.sx"] in
@@ -2255,7 +2324,8 @@ let handle_tool name args =
else else
text_result (Printf.sprintf "%d files OK, %d errors:\n%s" !ok_count !err_count (Buffer.contents errors)) text_result (Printf.sprintf "%d files OK, %d errors:\n%s" !ok_count !err_count (Buffer.contents errors))
| "sx_env" -> let handle_sx_env args =
let open Yojson.Safe.Util in
(* Query running server for defined symbols *) (* Query running server for defined symbols *)
let pattern = args |> member "pattern" |> to_string_option |> Option.value ~default:"*" in let pattern = args |> member "pattern" |> to_string_option |> Option.value ~default:"*" in
let type_filter = args |> member "type" |> to_string_option in let type_filter = args |> member "type" |> to_string_option in
@@ -2281,7 +2351,8 @@ let handle_tool name args =
let lines = List.map (fun (name, tp) -> Printf.sprintf " %-40s %s" name tp) sorted in let lines = List.map (fun (name, tp) -> Printf.sprintf " %-40s %s" name tp) sorted in
text_result (Printf.sprintf "%d matches:\n%s" (List.length sorted) (String.concat "\n" lines)) text_result (Printf.sprintf "%d matches:\n%s" (List.length sorted) (String.concat "\n" lines))
| "sx_handler_list" -> let handle_sx_handler_list _args =
ignore _args;
(* List all registered defhandler forms *) (* List all registered defhandler forms *)
let e = !env in let e = !env in
let handlers = ref [] in let handlers = ref [] in
@@ -2310,14 +2381,13 @@ let handle_tool name args =
else else
text_result (Printf.sprintf "%d handlers:\n%s" (List.length sorted) (String.concat "\n" lines)) text_result (Printf.sprintf "%d handlers:\n%s" (List.length sorted) (String.concat "\n" lines))
| "sx_page_list" -> let handle_sx_page_list _args =
ignore _args;
(* List all page functions by scanning page-functions.sx *) (* List all page functions by scanning page-functions.sx *)
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let pd = project_dir () in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir in
let pf_path = let pf_path =
let dp = project_dir ^ "/sx/page-functions.sx" in let dp = pd ^ "/sx/page-functions.sx" in
let dv = project_dir ^ "/sx/sx/page-functions.sx" in let dv = pd ^ "/sx/sx/page-functions.sx" in
if Sys.file_exists dp then dp else dv in if Sys.file_exists dp then dp else dv in
if not (Sys.file_exists pf_path) then if not (Sys.file_exists pf_path) then
error_result "page-functions.sx not found" error_result "page-functions.sx not found"
@@ -2337,7 +2407,8 @@ let handle_tool name args =
error_result (Printf.sprintf "Parse error: %s" (Printexc.to_string e)) error_result (Printf.sprintf "Parse error: %s" (Printexc.to_string e))
end end
| "sx_request" -> let handle_sx_request args =
let open Yojson.Safe.Util in
(* Simulate HTTP request to running server *) (* Simulate HTTP request to running server *)
let url = args |> member "url" |> to_string in let url = args |> member "url" |> to_string in
let method_ = args |> member "method" |> to_string_option |> Option.value ~default:"GET" in let method_ = args |> member "method" |> to_string_option |> Option.value ~default:"GET" in
@@ -2383,7 +2454,62 @@ let handle_tool name args =
with e -> with e ->
error_result (Printf.sprintf "Connection failed (server running on port %d?): %s" port (Printexc.to_string e))) error_result (Printf.sprintf "Connection failed (server running on port %d?): %s" port (Printexc.to_string e)))
| _ -> error_result ("Unknown tool: " ^ name) let handle_tool name args =
match Hashtbl.find_opt tool_handlers name with
| Some handler ->
(try handler args
with Invalid_argument msg -> error_result msg
| e -> error_result ("Error: " ^ Printexc.to_string e))
| None -> error_result ("Unknown tool: " ^ name)
let () =
register "sx_read_tree" handle_sx_read_tree;
register "sx_summarise" handle_sx_summarise;
register "sx_read_subtree" handle_sx_read_subtree;
register "sx_get_context" handle_sx_get_context;
register "sx_find_all" handle_sx_find_all;
register "sx_get_siblings" handle_sx_get_siblings;
register "sx_validate" handle_sx_validate;
register "sx_replace_node" handle_sx_replace_node;
register "sx_insert_child" handle_sx_insert_child;
register "sx_delete_node" handle_sx_delete_node;
register "sx_wrap_node" handle_sx_wrap_node;
register "sx_format_check" handle_sx_format_check;
register "sx_macroexpand" handle_sx_macroexpand;
register "sx_build" handle_sx_build;
register "sx_build_bytecode" handle_sx_build_bytecode;
register "sx_test" handle_sx_test;
register "sx_pretty_print" handle_sx_pretty_print;
register "sx_changed" handle_sx_changed;
register "sx_diff_branch" handle_sx_diff_branch;
register "sx_blame" handle_sx_blame;
register "sx_doc_gen" handle_sx_doc_gen;
register "sx_nav" handle_sx_nav;
register "sx_playwright" handle_sx_playwright;
register "sx_harness_eval" handle_sx_harness_eval;
register "sx_write_file" handle_sx_write_file;
register "sx_rename_symbol" handle_sx_rename_symbol;
register "sx_replace_by_pattern" handle_sx_replace_by_pattern;
register "sx_insert_near" handle_sx_insert_near;
register "sx_rename_across" handle_sx_rename_across;
register "sx_comp_list" handle_sx_comp_list;
register "sx_find_across" handle_sx_find_across;
register "sx_diff" handle_sx_diff;
register "sx_comp_usage" handle_sx_comp_usage;
register "sx_eval" handle_sx_eval;
register "sx_guard" handle_sx_guard;
register "sx_render_trace" handle_sx_render_trace;
register "sx_trace" handle_sx_trace;
register "sx_deps" handle_sx_deps;
register "sx_build_manifest" handle_sx_build_manifest;
register "sx_explain" handle_sx_explain;
register "sx_load_check" handle_sx_load_check;
register "sx_env" handle_sx_env;
register "sx_handler_list" handle_sx_handler_list;
register "sx_page_list" handle_sx_page_list;
register "sx_request" handle_sx_request;
()
(* ------------------------------------------------------------------ *) (* ------------------------------------------------------------------ *)
(* MCP tool definitions *) (* MCP tool definitions *)
@@ -2465,12 +2591,18 @@ let tool_definitions = `List [
("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to search for definitions (default: project root)")])] ["file"]; ("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to search for definitions (default: project root)")])] ["file"];
tool "sx_build_manifest" "Show build manifest: which modules, primitives, adapters, and exports are included in a JS or OCaml build." tool "sx_build_manifest" "Show build manifest: which modules, primitives, adapters, and exports are included in a JS or OCaml build."
[("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default) or \"ocaml\"")])] []; [("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default) or \"ocaml\"")])] [];
tool "sx_find_across" "Search for a pattern across all .sx files under a directory. Returns file paths, tree paths, and summaries." tool "sx_find_across" "Search for a pattern across all .sx files under a directory. Returns file paths, tree paths, and summaries. Paginated (default 200 results)."
[dir_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")])] ["dir"; "pattern"]; [dir_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")]);
tool "sx_comp_list" "List all definitions (defcomp, defisland, defmacro, defpage, define) across .sx files in a directory." ("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
[dir_prop] ["dir"]; ("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["dir"; "pattern"];
tool "sx_comp_usage" "Find all uses of a component or symbol name across .sx files in a directory." tool "sx_comp_list" "List all definitions (defcomp, defisland, defmacro, defpage, define) across .sx files in a directory. Paginated (default 200 results)."
[dir_prop; ("name", `Assoc [("type", `String "string"); ("description", `String "Component or symbol name to search for")])] ["dir"; "name"]; [dir_prop;
("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["dir"];
tool "sx_comp_usage" "Find all uses of a component or symbol name across .sx files in a directory. Paginated (default 200 results)."
[dir_prop; ("name", `Assoc [("type", `String "string"); ("description", `String "Component or symbol name to search for")]);
("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["dir"; "name"];
tool "sx_diff" "Structural diff between two .sx files. Reports ADDED, REMOVED, CHANGED nodes with paths." tool "sx_diff" "Structural diff between two .sx files. Reports ADDED, REMOVED, CHANGED nodes with paths."
[("file_a", `Assoc [("type", `String "string"); ("description", `String "Path to first .sx file")]); [("file_a", `Assoc [("type", `String "string"); ("description", `String "Path to first .sx file")]);
("file_b", `Assoc [("type", `String "string"); ("description", `String "Path to second .sx file")])] ["file_a"; "file_b"]; ("file_b", `Assoc [("type", `String "string"); ("description", `String "Path to second .sx file")])] ["file_a"; "file_b"];

43
hosts/ocaml/bin/run_tests.ml
View File

@@ -1132,6 +1132,9 @@ let run_foundation_tests () =
(* Spec test runner *) (* Spec test runner *)
(* ====================================================================== *) (* ====================================================================== *)
(* Called after module loading to sync JIT globals with env *)
let _jit_refresh_globals : (unit -> unit) ref = ref (fun () -> ())
let run_spec_tests env test_files = let run_spec_tests env test_files =
(* Find project root: walk up from cwd until we find spec/tests *) (* Find project root: walk up from cwd until we find spec/tests *)
let rec find_root dir = let rec find_root dir =
@@ -1303,6 +1306,19 @@ let run_spec_tests env test_files =
load_module "bytecode.sx" lib_dir; load_module "bytecode.sx" lib_dir;
load_module "compiler.sx" lib_dir; load_module "compiler.sx" lib_dir;
load_module "vm.sx" lib_dir; load_module "vm.sx" lib_dir;
(* Rebind vm-execute-module and code-from-value to native OCaml implementations.
The SX versions from vm.sx run bytecode step-by-step in the interpreter —
far too slow for the test suite. Native versions use the compiled OCaml VM. *)
(* Rebind vm-execute-module to use the native OCaml VM directly.
The SX version from vm.sx runs bytecode step-by-step in the interpreter.
code-from-value stays as the SX version — it produces dicts that
vm-execute-module converts to native vm_code internally. *)
ignore (Sx_types.env_bind env "vm-execute-module" (NativeFn ("vm-execute-module", fun args ->
match args with
| [code; Dict globals] ->
let c = Sx_vm.code_from_value code in
Sx_vm.execute_module c globals
| _ -> Nil)));
load_module "signals.sx" spec_dir; (* core reactive primitives *) load_module "signals.sx" spec_dir; (* core reactive primitives *)
load_module "signals.sx" web_dir; (* web extensions *) load_module "signals.sx" web_dir; (* web extensions *)
load_module "freeze.sx" lib_dir; load_module "freeze.sx" lib_dir;
@@ -1432,6 +1448,10 @@ let run_spec_tests env test_files =
) test_files ) test_files
in in
(* Refresh JIT globals after all modules loaded — vm-execute-module,
code-from-value, and other late-bound functions must be visible. *)
!_jit_refresh_globals ();
List.iter (fun path -> List.iter (fun path ->
if Sys.file_exists path then begin if Sys.file_exists path then begin
let name = Filename.basename path in let name = Filename.basename path in
@@ -1479,6 +1499,11 @@ let () =
match e.Sx_types.parent with Some p -> env_to_globals p | None -> () match e.Sx_types.parent with Some p -> env_to_globals p | None -> ()
in in
env_to_globals env; env_to_globals env;
(* Seed VM globals with native primitives — CALL_PRIM resolves from globals *)
Hashtbl.iter (fun name fn ->
Hashtbl.replace globals name (NativeFn (name, fn))
) Sx_primitives.primitives;
_jit_refresh_globals := (fun () -> env_to_globals env);
(try (try
let compiler_path = if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx" let compiler_path = if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
else "../../lib/compiler.sx" in else "../../lib/compiler.sx" in
@@ -1493,8 +1518,16 @@ let () =
| Lambda l -> | Lambda l ->
(match l.l_compiled with (match l.l_compiled with
| Some cl when not (Sx_vm.is_jit_failed cl) -> | Some cl when not (Sx_vm.is_jit_failed cl) ->
(* VmSuspended = IO perform, Eval_error "VM undefined" = missing
special form. Both fall back to CEK safely — mark as failed
so we don't retry. *)
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) (try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
with _ -> None) with
| Sx_vm.VmSuspended _ ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel; None
| Eval_error msg when String.length msg > 14
&& String.sub msg 0 14 = "VM undefined: " ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel; None)
| Some _ -> None | Some _ -> None
| None -> | None ->
if l.l_name = None then None if l.l_name = None then None
@@ -1502,7 +1535,13 @@ let () =
l.l_compiled <- Some Sx_vm.jit_failed_sentinel; l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
match Sx_vm.jit_compile_lambda l globals with match Sx_vm.jit_compile_lambda l globals with
| Some cl -> l.l_compiled <- Some cl; | Some cl -> l.l_compiled <- Some cl;
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with _ -> None) (try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
with
| Sx_vm.VmSuspended _ ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel; None
| Eval_error msg when String.length msg > 14
&& String.sub msg 0 14 = "VM undefined: " ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel; None)
| None -> None | None -> None
end) end)
| _ -> None); | _ -> None);

38
hosts/ocaml/bin/sx_server.ml
View File

@@ -936,8 +936,8 @@ let register_jit_hook env =
| Lambda l -> | Lambda l ->
(match l.l_compiled with (match l.l_compiled with
| Some cl when not (Sx_vm.is_jit_failed cl) -> | Some cl when not (Sx_vm.is_jit_failed cl) ->
(* Skip during compilation — compiled helpers loop on complex ASTs. (* Skip during CEK-based compilation — helpers are called inside
Normal execution uses bytecode (fast). *) the VM when compile has bytecode, no need for the hook. *)
if !(Sx_vm._jit_compiling) then None if !(Sx_vm._jit_compiling) then None
else else
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) (try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
@@ -954,7 +954,6 @@ let register_jit_hook env =
None) None)
| Some _ -> None | Some _ -> None
| None -> | None ->
(* Only block NEW compilations during _jit_compiling, not execution *)
let fn_name = match l.l_name with Some n -> n | None -> "?" in let fn_name = match l.l_name with Some n -> n | None -> "?" in
if !(Sx_vm._jit_compiling) then None if !(Sx_vm._jit_compiling) then None
else if Hashtbl.mem _jit_warned fn_name then None else if Hashtbl.mem _jit_warned fn_name then None
@@ -1185,9 +1184,12 @@ let rec dispatch env cmd =
register_jit_hook env; register_jit_hook env;
let t0 = Unix.gettimeofday () in let t0 = Unix.gettimeofday () in
let count = ref 0 in let count = ref 0 in
(* Pre-compile helpers, NOT "compile" itself (loops on complex ASTs) *) (* Pre-compile compiler helpers AND compile itself.
When compile has bytecode, jit_compile_lambda calls it directly via
the VM — all helper calls happen inside the same VM execution with
no per-call overhead. This is 10-100x faster than CEK dispatch. *)
let compiler_names = [ let compiler_names = [
"compile-module"; "compile-expr"; "compile-symbol"; "compile"; "compile-module"; "compile-expr"; "compile-symbol";
"compile-dict"; "compile-list"; "compile-if"; "compile-when"; "compile-dict"; "compile-list"; "compile-if"; "compile-when";
"compile-and"; "compile-or"; "compile-begin"; "compile-let"; "compile-and"; "compile-or"; "compile-begin"; "compile-let";
"compile-letrec"; "compile-lambda"; "compile-define"; "compile-set"; "compile-letrec"; "compile-lambda"; "compile-define"; "compile-set";
@@ -1209,15 +1211,16 @@ let rec dispatch env cmd =
| None -> ()) | None -> ())
| _ -> () | _ -> ()
) compiler_names; ) compiler_names;
(* Mark "compile" as jit-failed — loops on complex ASTs as bytecode *)
(try match Hashtbl.find_opt env.bindings (Sx_types.intern "compile") with
| Some (Lambda l) -> l.l_compiled <- Some Sx_vm.jit_failed_sentinel
| _ -> ()
with _ -> ());
let dt = Unix.gettimeofday () -. t0 in let dt = Unix.gettimeofday () -. t0 in
Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs (lazy JIT active for all)\n%!" !count dt; Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs (lazy JIT active for all)\n%!" !count dt;
send_ok () send_ok ()
| List [Symbol "jit-reset-name"; String name] ->
(* Reset a function's JIT state back to uncompiled *)
(match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
| Some (Lambda l) -> l.l_compiled <- None; send_ok_raw (Printf.sprintf "reset %s" name)
| _ -> send_ok_raw (Printf.sprintf "not-found %s" name))
| List [Symbol "set-request-cookies"; Dict cookies] -> | List [Symbol "set-request-cookies"; Dict cookies] ->
(* Set request cookies for get-cookie primitive. (* Set request cookies for get-cookie primitive.
Called by Python bridge before each page render. *) Called by Python bridge before each page render. *)
@@ -2670,12 +2673,11 @@ let http_mode port =
| _ -> raise (Eval_error "component-source: expected (name)")); | _ -> raise (Eval_error "component-source: expected (name)"));
let jt0 = Unix.gettimeofday () in let jt0 = Unix.gettimeofday () in
let count = ref 0 in let count = ref 0 in
(* Pre-compile compiler HELPERS but NOT "compile" itself. (* Pre-compile the entire compiler — compile + helpers.
"compile" runs via CEK (correct for all AST sizes). jit_compile_lambda calls compile directly via the VM when it has
Its internal calls to compile-expr/emit-byte/etc use bytecode (fast). bytecode, so all helper calls happen in one VM execution. *)
Pre-compiling "compile" causes it to loop on complex nested forms. *)
let compiler_names = [ let compiler_names = [
"compile-module"; "compile-expr"; "compile-symbol"; "compile"; "compile-module"; "compile-expr"; "compile-symbol";
"compile-dict"; "compile-list"; "compile-if"; "compile-when"; "compile-dict"; "compile-list"; "compile-if"; "compile-when";
"compile-and"; "compile-or"; "compile-begin"; "compile-let"; "compile-and"; "compile-or"; "compile-begin"; "compile-let";
"compile-letrec"; "compile-lambda"; "compile-define"; "compile-set"; "compile-letrec"; "compile-lambda"; "compile-define"; "compile-set";
@@ -2699,12 +2701,6 @@ let http_mode port =
| _ -> () | _ -> ()
with _ -> () with _ -> ()
) compiler_names; ) compiler_names;
(* Mark "compile" as jit-failed — its compiled bytecode loops on complex
ASTs. It runs via CEK (correct), while its helpers run as bytecode (fast). *)
(try match env_get env "compile" with
| Lambda l -> l.l_compiled <- Some Sx_vm.jit_failed_sentinel
| _ -> ()
with _ -> ());
let jt1 = Unix.gettimeofday () in let jt1 = Unix.gettimeofday () in
Printf.eprintf "[sx-http] JIT pre-compiled %d compiler fns in %.3fs\n%!" !count (jt1 -. jt0); Printf.eprintf "[sx-http] JIT pre-compiled %d compiler fns in %.3fs\n%!" !count (jt1 -. jt0);
(* Re-bind native primitives that stdlib.sx may have overwritten with (* Re-bind native primitives that stdlib.sx may have overwritten with

3
hosts/ocaml/bootstrap_vm.py
View File

@@ -257,6 +257,7 @@ let closure_code cl = let c = unwrap_closure cl in
Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode))); Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants)); Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity)); Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
Hashtbl.replace d "vc-rest-arity" (Number (float_of_int c.vm_code.vc_rest_arity));
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals)); Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
Dict d Dict d
@@ -376,7 +377,7 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *) (* --- JIT sentinel --- *)
let _jit_failed_sentinel = { let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||]; vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }; vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
} }

14
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -941,7 +941,19 @@ let () =
| [f; Nil] -> call f [] | [f; Nil] -> call f []
| _ -> raise (Eval_error "apply: function and list")); | _ -> raise (Eval_error "apply: function and list"));
register "identical?" (fun args -> register "identical?" (fun args ->
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args")); match args with
| [a; b] ->
(* Physical identity for reference types, structural for values.
Numbers/strings/booleans from different constant pools must
compare equal when their values match. *)
let identical = match a, b with
| Number x, Number y -> x = y
| String x, String y -> x = y (* String.equal *)
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| _ -> a == b (* reference identity for dicts, lists, etc. *)
in Bool identical
| _ -> raise (Eval_error "identical?: 2 args"));
register "make-spread" (fun args -> register "make-spread" (fun args ->
match args with match args with
| [Dict d] -> | [Dict d] ->

2
hosts/ocaml/lib/sx_ref.ml
View File

@@ -895,7 +895,7 @@ and step_continue state =
(* continue-with-call *) (* continue-with-call *)
and continue_with_call f args env raw_args kont = and continue_with_call f args env raw_args kont =
(if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (let result' = (sx_apply_cek f args) in (if sx_truthy ((Bool (is_eval_error result'))) then (make_cek_value ((get (result') ((String "message")))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_value (result') (env) (kont)))) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))))) (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (let result' = (sx_apply_cek f args) in (if sx_truthy ((Bool (is_eval_error result'))) then (make_cek_value ((get (result') ((String "message")))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_value (result') (env) (kont)))) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((jit_skip_p (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))])))))))))))
(* sf-case-step-loop *) (* sf-case-step-loop *)
and sf_case_step_loop match_val clauses env kont = and sf_case_step_loop match_val clauses env kont =

22
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -186,6 +186,7 @@ let get_val container key =
Hashtbl.replace d "vc-bytecode" (List bc); Hashtbl.replace d "vc-bytecode" (List bc);
Hashtbl.replace d "vc-constants" (List consts); Hashtbl.replace d "vc-constants" (List consts);
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity)); Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
Hashtbl.replace d "vc-rest-arity" (Number (float_of_int c.vc_rest_arity));
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals)); Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
Dict d Dict d
| "vm-upvalues" -> | "vm-upvalues" ->
@@ -496,13 +497,28 @@ let _jit_hit = ref 0
let _jit_miss = ref 0 let _jit_miss = ref 0
let _jit_skip = ref 0 let _jit_skip = ref 0
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0 let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
(* Sentinel value for "JIT skipped — fall back to CEK".
Must be distinguishable from any legitimate return value including Nil.
We use a unique tagged dict that is_jit_skip can identify. *)
let _jit_skip_sentinel =
let d = Hashtbl.create 1 in
Hashtbl.replace d "__jit_skip" (Bool true);
Dict d
let is_jit_skip v = match v with
| Dict d -> Hashtbl.mem d "__jit_skip"
| _ -> false
(* Platform function for the spec: (jit-skip? v) → transpiles to jit_skip_p *)
let jit_skip_p v = Bool (is_jit_skip v)
let jit_try_call f args = let jit_try_call f args =
match !_jit_try_call_fn with match !_jit_try_call_fn with
| None -> incr _jit_skip; Nil | None -> incr _jit_skip; _jit_skip_sentinel
| Some hook -> | Some hook ->
match f with match f with
| Lambda l when l.l_name <> None -> | Lambda l when l.l_name <> None ->
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; Nil) (match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
| _ -> incr _jit_skip; Nil | _ -> incr _jit_skip; _jit_skip_sentinel

1
hosts/ocaml/lib/sx_types.ml
View File

@@ -178,6 +178,7 @@ and parameter = {
(** Compiled function body — bytecode + constant pool. *) (** Compiled function body — bytecode + constant pool. *)
and vm_code = { and vm_code = {
vc_arity : int; vc_arity : int;
vc_rest_arity : int; (** -1 = no &rest; >= 0 = number of positional params before &rest *)
vc_locals : int; vc_locals : int;
vc_bytecode : int array; vc_bytecode : int array;
vc_constants : value array; vc_constants : value array;

45
hosts/ocaml/lib/sx_vm.ml
View File

@@ -50,7 +50,7 @@ let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option)
(** Sentinel closure indicating JIT compilation was attempted and failed. (** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *) Prevents retrying compilation on every call. *)
let jit_failed_sentinel = { let jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||]; vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }; vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
} }
@@ -142,34 +142,61 @@ let _jit_compiling = ref false
This is the fast path for intra-VM closure calls. *) This is the fast path for intra-VM closure calls. *)
let push_closure_frame vm cl args = let push_closure_frame vm cl args =
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
List.iter (fun a -> push vm a) args; let rest_arity = cl.vm_code.vc_rest_arity in
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done; if rest_arity >= 0 then begin
(* &rest function: push positional args, collect remainder into a list.
For (fn (a b &rest c) body) with rest_arity=2:
slots: 0=a, 1=b, 2=c (the rest list) *)
let nargs = List.length args in
let rec push_args i = function
| [] ->
for _ = i to rest_arity - 1 do push vm Nil done;
push vm (List [])
| a :: remaining ->
if i < rest_arity then (push vm a; push_args (i + 1) remaining)
else push vm (List (a :: remaining))
in
push_args 0 args;
let used = (if nargs > rest_arity then rest_arity + 1 else nargs + 1) in
for _ = used to cl.vm_code.vc_locals - 1 do push vm Nil done
end else begin
List.iter (fun a -> push vm a) args;
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done
end;
vm.frames <- frame :: vm.frames vm.frames <- frame :: vm.frames
(** Convert compiler output (SX dict) to a vm_code object. *) (** Convert compiler output (SX dict) to a vm_code object. *)
let code_from_value v = let code_from_value v =
match v with match v with
| Dict d -> | Dict d ->
let bc_list = match Hashtbl.find_opt d "bytecode" with (* Accept both compiler output keys (bytecode/constants/arity) and
SX vm-code keys (vc-bytecode/vc-constants/vc-arity) *)
let find2 k1 k2 = match Hashtbl.find_opt d k1 with
| Some _ as r -> r | None -> Hashtbl.find_opt d k2 in
let bc_list = match find2 "bytecode" "vc-bytecode" with
| Some (List l | ListRef { contents = l }) -> | Some (List l | ListRef { contents = l }) ->
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l) Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
| _ -> [||] | _ -> [||]
in in
let entries = match Hashtbl.find_opt d "constants" with let entries = match find2 "constants" "vc-constants" with
| Some (List l | ListRef { contents = l }) -> Array.of_list l | Some (List l | ListRef { contents = l }) -> Array.of_list l
| _ -> [||] | _ -> [||]
in in
let constants = Array.map (fun entry -> let constants = Array.map (fun entry ->
match entry with match entry with
| Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *) | Dict ed when Hashtbl.mem ed "bytecode" || Hashtbl.mem ed "vc-bytecode" -> entry
| _ -> entry | _ -> entry
) entries in ) entries in
let arity = match Hashtbl.find_opt d "arity" with let arity = match find2 "arity" "vc-arity" with
| Some (Number n) -> int_of_float n | _ -> 0 | Some (Number n) -> int_of_float n | _ -> 0
in in
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants; let rest_arity = match find2 "rest-arity" "vc-rest-arity" with
| Some (Number n) -> int_of_float n | _ -> -1
in
{ vc_arity = arity; vc_rest_arity = rest_arity; vc_locals = arity + 16;
vc_bytecode = bc_list; vc_constants = constants;
vc_bytecode_list = None; vc_constants_list = None } vc_bytecode_list = None; vc_constants_list = None }
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||]; | _ -> { vc_arity = 0; vc_rest_arity = -1; 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. (** JIT-compile a component or island body.

2
hosts/ocaml/lib/sx_vm_ref.ml
View File

@@ -292,7 +292,7 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *) (* --- JIT sentinel --- *)
let _jit_failed_sentinel = { let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||]; vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }; vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
} }

2
hosts/ocaml/sx_vm_ref.ml
View File

@@ -287,7 +287,7 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *) (* --- JIT sentinel --- *)
let _jit_failed_sentinel = { let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||]; vm_code = { vc_arity = -1; vc_rest_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }; vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
} }

3
hosts/ocaml/transpiler.sx
View File

@@ -269,7 +269,8 @@
"try-catch" "try-catch"
"set-render-active!" "set-render-active!"
"scope-emitted" "scope-emitted"
"jit-try-call")) "jit-try-call"
"jit-skip?"))
(define (define
ml-is-known-name? ml-is-known-name?

49
lib/compiler.sx
View File

@@ -640,29 +640,38 @@
(fn-scope (make-scope scope)) (fn-scope (make-scope scope))
(fn-em (make-emitter))) (fn-em (make-emitter)))
(dict-set! fn-scope "is-function" true) (dict-set! fn-scope "is-function" true)
(for-each
(fn
(p)
(let
((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p)))
(when
(and (not (= name "&key")) (not (= name "&rest")))
(scope-define-local fn-scope name))))
params)
(compile-begin fn-em body fn-scope true)
(emit-op fn-em 50)
(let (let
((upvals (get fn-scope "upvalues")) ((rest-pos -1) (rest-name nil))
(code {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")})
(code-idx (pool-add (get em "pool") code)))
(emit-op em 51)
(emit-u16 em code-idx)
(for-each (for-each
(fn (fn
(uv) (p)
(emit-byte em (if (get uv "is-local") 1 0)) (let
(emit-byte em (get uv "index"))) ((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p)))
upvals))))) (cond
(= name "&rest")
(set! rest-pos (len (get fn-scope "locals")))
(= name "&key")
nil
:else (do
(when
(and (> rest-pos -1) (nil? rest-name))
(set! rest-name name))
(scope-define-local fn-scope name)))))
params)
(compile-begin fn-em body fn-scope true)
(emit-op fn-em 50)
(let
((upvals (get fn-scope "upvalues"))
(code (if (> rest-pos -1) {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :rest-arity rest-pos :bytecode (get fn-em "bytecode")} {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")}))
(code-idx (pool-add (get em "pool") code)))
(emit-op em 51)
(emit-u16 em code-idx)
(for-each
(fn
(uv)
(emit-byte em (if (get uv "is-local") 1 0))
(emit-byte em (get uv "index")))
upvals))))))
(define (define
compile-define compile-define
(fn (fn

493
lib/hyperscript/parser.sx
View File

@@ -512,267 +512,266 @@
(define (define
parse-go-cmd parse-go-cmd
(fn () (match-kw "to") (list (quote go) (parse-expr)))) (fn () (match-kw "to") (list (quote go) (parse-expr))))
(do (define
(define parse-arith
parse-arith (fn
(fn (left)
(left) (let
(let ((typ (tp-type)) (val (tp-val)))
((typ (tp-type)) (val (tp-val)))
(if
(and
(= typ "op")
(or
(= val "+")
(= val "-")
(= val "*")
(= val "/")
(= val "%")))
(do
(adv!)
(let
((op (cond ((= val "+") (quote +)) ((= val "-") (quote -)) ((= val "*") (quote *)) ((= val "/") (quote /)) ((= val "%") (make-symbol "%")))))
(let
((right (let ((a (parse-atom))) (if (nil? a) a (parse-poss a)))))
(parse-arith (list op left right)))))
left))))
(define
parse-the-expr
(fn
()
(let
((typ (tp-type)) (val (tp-val)))
(if
(or (= typ "ident") (= typ "keyword"))
(do
(adv!)
(if
(match-kw "of")
(list (make-symbol ".") (parse-expr) val)
(cond
((= val "result") (list (quote it)))
((= val "first") (parse-pos-kw (quote first)))
((= val "last") (parse-pos-kw (quote last)))
((= val "closest") (parse-trav (quote closest)))
((= val "next") (parse-trav (quote next)))
((= val "previous") (parse-trav (quote previous)))
(true (list (quote ref) val)))))
(parse-atom)))))
(define
parse-array-lit
(fn
()
(define
al-collect
(fn
(acc)
(if
(or (= (tp-type) "bracket-close") (at-end?))
(do (if (= (tp-type) "bracket-close") (adv!) nil) acc)
(let
((elem (parse-expr)))
(if (= (tp-type) "comma") (adv!) nil)
(al-collect (append acc (list elem)))))))
(cons (quote array) (al-collect (list)))))
(define
parse-return-cmd
(fn
()
(if (if
(or (and
(at-end?) (= typ "op")
(and (or
(= (tp-type) "keyword") (= val "+")
(or (= val "-")
(= (tp-val) "end") (= val "*")
(= (tp-val) "then") (= val "/")
(= (tp-val) "else")))) (= val "%")))
(list (quote return) nil) (do
(list (quote return) (parse-expr))))) (adv!)
(define parse-throw-cmd (fn () (list (quote throw) (parse-expr)))) (let
(define ((op (cond ((= val "+") (quote +)) ((= val "-") (quote -)) ((= val "*") (quote *)) ((= val "/") (quote /)) ((= val "%") (make-symbol "%")))))
parse-append-cmd (let
(fn ((right (let ((a (parse-atom))) (if (nil? a) a (parse-poss a)))))
() (parse-arith (list op left right)))))
(let left))))
((value (parse-expr))) (define
(expect-kw! "to") parse-the-expr
(let (fn
((target (parse-expr))) ()
(list (quote append!) value target))))) (let
(define ((typ (tp-type)) (val (tp-val)))
parse-tell-cmd (if
(fn (or (= typ "ident") (= typ "keyword"))
() (do
(adv!)
(if
(match-kw "of")
(list (make-symbol ".") (parse-expr) val)
(cond
((= val "result") (list (quote it)))
((= val "first") (parse-pos-kw (quote first)))
((= val "last") (parse-pos-kw (quote last)))
((= val "closest") (parse-trav (quote closest)))
((= val "next") (parse-trav (quote next)))
((= val "previous") (parse-trav (quote previous)))
(true (list (quote ref) val)))))
(parse-atom)))))
(define
parse-array-lit
(fn
()
(define
al-collect
(fn
(acc)
(if
(or (= (tp-type) "bracket-close") (at-end?))
(do (if (= (tp-type) "bracket-close") (adv!) nil) acc)
(let
((elem (parse-expr)))
(if (= (tp-type) "comma") (adv!) nil)
(al-collect (append acc (list elem)))))))
(cons (quote array) (al-collect (list)))))
(define
parse-return-cmd
(fn
()
(if
(or
(at-end?)
(and
(= (tp-type) "keyword")
(or
(= (tp-val) "end")
(= (tp-val) "then")
(= (tp-val) "else"))))
(list (quote return) nil)
(list (quote return) (parse-expr)))))
(define parse-throw-cmd (fn () (list (quote throw) (parse-expr))))
(define
parse-append-cmd
(fn
()
(let
((value (parse-expr)))
(expect-kw! "to")
(let (let
((target (parse-expr))) ((target (parse-expr)))
(list (quote append!) value target)))))
(define
parse-tell-cmd
(fn
()
(let
((target (parse-expr)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote tell) target body)))))
(define
parse-for-cmd
(fn
()
(let
((var-name (tp-val)))
(adv!)
(expect-kw! "in")
(let
((collection (parse-expr)))
(let (let
((body (parse-cmd-list))) ((idx (if (match-kw "index") (let ((iname (tp-val))) (adv!) iname) nil)))
(match-kw "end")
(list (quote tell) target body)))))
(define
parse-for-cmd
(fn
()
(let
((var-name (tp-val)))
(adv!)
(expect-kw! "in")
(let
((collection (parse-expr)))
(let
((idx (if (match-kw "index") (let ((iname (tp-val))) (adv!) iname) nil)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(if
idx
(list (quote for) var-name collection body :index idx)
(list (quote for) var-name collection body))))))))
(define
parse-make-cmd
(fn
()
(if (= (tp-val) "a") (adv!) nil)
(let
((type-name (tp-val)))
(adv!)
(let
((called (if (match-kw "called") (let ((n (tp-val))) (adv!) n) nil)))
(if
called
(list (quote make) type-name called)
(list (quote make) type-name))))))
(define
parse-install-cmd
(fn
()
(let
((name (tp-val)))
(adv!)
(if
(= (tp-type) "paren-open")
(let
((args (parse-call-args)))
(cons (quote install) (cons name args)))
(list (quote install) name)))))
(define
parse-measure-cmd
(fn
()
(let
((tgt (parse-expr)))
(list (quote measure) (if (nil? tgt) (list (quote me)) tgt)))))
(define
parse-param-list
(fn () (if (= (tp-type) "paren-open") (parse-call-args) (list))))
(define
parse-feat-body
(fn
()
(define
fb-collect
(fn
(acc)
(if
(or
(at-end?)
(and (= (tp-type) "keyword") (= (tp-val) "end")))
acc
(let
((feat (parse-feat)))
(if
(nil? feat)
acc
(fb-collect (append acc (list feat))))))))
(fb-collect (list))))
(define
parse-def-feat
(fn
()
(let
((name (tp-val)))
(adv!)
(let
((params (parse-param-list)))
(let (let
((body (parse-cmd-list))) ((body (parse-cmd-list)))
(match-kw "end") (match-kw "end")
(list (quote def) name params body)))))) (if
(define idx
parse-behavior-feat (list (quote for) var-name collection body :index idx)
(fn (list (quote for) var-name collection body))))))))
() (define
parse-make-cmd
(fn
()
(if (= (tp-val) "a") (adv!) nil)
(let
((type-name (tp-val)))
(adv!)
(let (let
((name (tp-val))) ((called (if (match-kw "called") (let ((n (tp-val))) (adv!) n) nil)))
(adv!) (if
called
(list (quote make) type-name called)
(list (quote make) type-name))))))
(define
parse-install-cmd
(fn
()
(let
((name (tp-val)))
(adv!)
(if
(= (tp-type) "paren-open")
(let (let
((params (parse-param-list))) ((args (parse-call-args)))
(cons (quote install) (cons name args)))
(list (quote install) name)))))
(define
parse-measure-cmd
(fn
()
(let
((tgt (parse-expr)))
(list (quote measure) (if (nil? tgt) (list (quote me)) tgt)))))
(define
parse-param-list
(fn () (if (= (tp-type) "paren-open") (parse-call-args) (list))))
(define
parse-feat-body
(fn
()
(define
fb-collect
(fn
(acc)
(if
(or
(at-end?)
(and (= (tp-type) "keyword") (= (tp-val) "end")))
acc
(let (let
((body (parse-feat-body))) ((feat (parse-feat)))
(match-kw "end") (if
(list (quote behavior) name params body)))))) (nil? feat)
(define acc
parse-render-kwargs (fb-collect (append acc (list feat))))))))
(fn (fb-collect (list))))
() (define
parse-def-feat
(fn
()
(let
((name (tp-val)))
(adv!)
(let
((params (parse-param-list)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote def) name params body))))))
(define
parse-behavior-feat
(fn
()
(let
((name (tp-val)))
(adv!)
(let
((params (parse-param-list)))
(let
((body (parse-feat-body)))
(match-kw "end")
(list (quote behavior) name params body))))))
(define
parse-render-kwargs
(fn
()
(define
collect-kw
(fn
(acc)
(if
(= (tp-type) "local")
(let
((key (tp-val)))
(adv!)
(let
((val (parse-expr)))
(collect-kw (append acc (list key val)))))
acc)))
(collect-kw (list))))
(define
parse-render-cmd
(fn
()
(let
((comp (cond ((= (tp-type) "component") (let ((name (tp-val))) (adv!) name)) ((= (tp-type) "paren-open") (do (adv!) (let ((expr (parse-expr))) (if (= (tp-type) "paren-close") (adv!) nil) expr))) (true (let ((name (tp-val))) (adv!) name)))))
(let
((kwargs (parse-render-kwargs)))
(let
((pos (cond ((match-kw "into") "into") ((match-kw "before") "before") ((match-kw "after") "after") (true nil))))
(let
((target (if pos (parse-expr) nil)))
(if
pos
(list (quote render) comp kwargs pos target)
(list (quote render) comp kwargs))))))))
(define
collect-sx-source
(fn
()
(let
((start-pos (get (tp) "pos")))
(adv!)
(define (define
collect-kw skip-to-close
(fn (fn
(acc) (depth)
(if (cond
(= (tp-type) "local") ((at-end?) start-pos)
(let ((= (tp-type) "paren-open")
((key (tp-val))) (do (adv!) (skip-to-close (+ depth 1))))
(adv!) ((= (tp-type) "paren-close")
(let
((val (parse-expr)))
(collect-kw (append acc (list key val)))))
acc)))
(collect-kw (list))))
(define
parse-render-cmd
(fn
()
(let
((comp (cond ((= (tp-type) "component") (let ((name (tp-val))) (adv!) name)) ((= (tp-type) "paren-open") (do (adv!) (let ((expr (parse-expr))) (if (= (tp-type) "paren-close") (adv!) nil) expr))) (true (let ((name (tp-val))) (adv!) name)))))
(let
((kwargs (parse-render-kwargs)))
(let
((pos (cond ((match-kw "into") "into") ((match-kw "before") "before") ((match-kw "after") "after") (true nil))))
(let
((target (if pos (parse-expr) nil)))
(if (if
pos (= depth 0)
(list (quote render) comp kwargs pos target) (let
(list (quote render) comp kwargs)))))))) ((end-pos (+ (get (tp) "pos") 1)))
(define (adv!)
collect-sx-source end-pos)
(fn (do (adv!) (skip-to-close (- depth 1)))))
() (true (do (adv!) (skip-to-close depth))))))
(let (let
((start-pos (get (tp) "pos"))) ((end-pos (skip-to-close 0)))
(adv!) (substring src start-pos end-pos)))))
(define
skip-to-close
(fn
(depth)
(cond
((at-end?) start-pos)
((= (tp-type) "paren-open")
(do (adv!) (skip-to-close (+ depth 1))))
((= (tp-type) "paren-close")
(if
(= depth 0)
(let
((end-pos (+ (get (tp) "pos") 1)))
(adv!)
end-pos)
(do (adv!) (skip-to-close (- depth 1)))))
(true (do (adv!) (skip-to-close depth))))))
(let
((end-pos (skip-to-close 0)))
(substring src start-pos end-pos))))))
(define (define
parse-cmd parse-cmd
(fn (fn

21
lib/vm.sx
View File

@@ -137,18 +137,21 @@
code-from-value code-from-value
(fn (fn
(v) (v)
"Convert a compiler output dict to a vm-code object." "Convert a compiler output dict to a vm-code dict. Idempotent — if v\n already has vm-code keys (vc-bytecode), returns as-is."
(if (if
(not (dict? v)) (not (dict? v))
(make-vm-code 0 16 (list) (list)) (make-vm-code 0 16 (list) (list))
(let (if
((bc-raw (get v "bytecode")) (has-key? v "vc-bytecode")
(bc (if (nil? bc-raw) (list) bc-raw)) v
(consts-raw (get v "constants")) (let
(consts (if (nil? consts-raw) (list) consts-raw)) ((bc-raw (get v "bytecode"))
(arity-raw (get v "arity")) (bc (if (nil? bc-raw) (list) bc-raw))
(arity (if (nil? arity-raw) 0 arity-raw))) (consts-raw (get v "constants"))
(make-vm-code arity (+ arity 16) bc consts))))) (consts (if (nil? consts-raw) (list) consts-raw))
(arity-raw (get v "arity"))
(arity (if (nil? arity-raw) 0 arity-raw)))
(make-vm-code arity (+ arity 16) bc consts))))))
(define vm-closure? (fn (v) (and (dict? v) (has-key? v "vm-code")))) (define vm-closure? (fn (v) (and (dict? v) (has-key? v "vm-code"))))
(define *active-vm* nil) (define *active-vm* nil)
(define *jit-compile-fn* nil) (define *jit-compile-fn* nil)

1030
shared/static/wasm/sx_browser.bc.js
View File

File diff suppressed because one or more lines are too long

2
shared/static/wasm/sx_browser.bc.wasm.js
View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create}; blake2_js_for_wasm_create: blake2_js_for_wasm_create};
} }
(globalThis)) (globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-1549dd9c",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-cb04d103",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var ({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-6b144ffc",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-e3e65d76",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

2
spec/evaluator.sx
View File

@@ -4280,7 +4280,7 @@
(let (let
((jit-result (jit-try-call f args))) ((jit-result (jit-try-call f args)))
(cond (cond
(nil? jit-result) (jit-skip? jit-result)
(make-cek-state (lambda-body f) local kont) (make-cek-state (lambda-body f) local kont)
(and (dict? jit-result) (get jit-result "__vm_suspended")) (and (dict? jit-result) (get jit-result "__vm_suspended"))
(make-cek-suspended (make-cek-suspended

7
sx/sx/handlers/hyperscript-api.sx
View File

@@ -1,5 +1,4 @@
;; _hyperscript playground API handler ;; _hyperscript playground API handler
;; Compiles hyperscript source and returns the AST + SX output as HTML
(defhandler (defhandler
hs-compile hs-compile
@@ -14,7 +13,7 @@
(~tw :tokens "text-sm text-gray-400 italic") (~tw :tokens "text-sm text-gray-400 italic")
"Enter some hyperscript and click Compile.") "Enter some hyperscript and click Compile.")
(let (let
((ast (hs-compile source)) (sx (hs-to-sx-from-source source))) ((compiled (hs-to-sx-from-source source)))
(div (div
(~tw :tokens "space-y-4") (~tw :tokens "space-y-4")
(div (div
@@ -25,7 +24,7 @@
(pre (pre
(~tw (~tw
:tokens "bg-gray-900 text-green-400 p-4 rounded-lg text-sm overflow-x-auto whitespace-pre-wrap font-mono") :tokens "bg-gray-900 text-green-400 p-4 rounded-lg text-sm overflow-x-auto whitespace-pre-wrap font-mono")
(sx-serialize sx))) (sx-serialize compiled)))
(div (div
(h4 (h4
(~tw (~tw
@@ -34,4 +33,4 @@
(pre (pre
(~tw (~tw
:tokens "bg-gray-900 text-amber-400 p-4 rounded-lg text-sm overflow-x-auto whitespace-pre-wrap font-mono") :tokens "bg-gray-900 text-amber-400 p-4 rounded-lg text-sm overflow-x-auto whitespace-pre-wrap font-mono")
(sx-serialize ast))))))) (sx-serialize (hs-compile source))))))))