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

VM aser-slot → sx-page-full: single-call page render, 0.55s warm

Browse Source 
Compiler fixes:
- Upvalue re-lookup returns own position (uv-index), not parent slot
- Spec: cek-call uses (make-env) not (dict) — OCaml Dict≠Env
- Bootstrap post-processes transpiler Dict→Env for cek_call

VM runtime fixes:
- compile_adapter evaluates constant defines (SPECIAL_FORM_NAMES etc.)
  via execute_module instead of wrapping as NativeFn closures
- Native primitives: map-indexed, some, every?
- Nil-safe HO forms: map/filter/for-each/some/every? accept nil as empty
- expand-components? set in kernel env (not just VM globals)
- unwrap_env diagnostic: reports actual type received

sx-page-full command:
- Single OCaml call: aser-slot body + render-to-html shell
- Eliminates two pipe round-trips (was: aser-slot→Python→shell render)
- Shell statics (component_defs, CSS, pages_sx) cached in Python,
  injected into kernel once, referenced by symbol in per-request command
- Large blobs use placeholder tokens — Python splices post-render,
  pipe transfers ~51KB instead of 2MB

Performance (warm):
- Server total: 0.55s (was ~2s)
- aser-slot VM: 0.3s, shell render: 0.01s, pipe: 0.06s
- kwargs computation: 0.000s (cached)

SX_STANDALONE mode for sx_docs dev (skips fragment fetches).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-20 11:06:04 +00:00
parent 8dd3eaa1d9
commit ae0e87fbf8
13 changed files with 477 additions and 149 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -697,38 +697,36 @@ let compile_adapter env =
(Array.length outer_code.Sx_vm.constants)
(if Array.length outer_code.Sx_vm.constants > 0 then
type_of outer_code.Sx_vm.constants.(0) else "empty");
(* The compiled define body is (fn ...) which compiles to
OP_CLOSURE + [upvalue descriptors] + OP_RETURN.
Extract the inner code object from constants[idx]. *)
let code =
let bc = outer_code.Sx_vm.bytecode in
if Array.length bc >= 4 && bc.(0) = 51 then begin
let idx = bc.(1) lor (bc.(2) lsl 8) in
let bc = outer_code.Sx_vm.bytecode in
if Array.length bc >= 4 && bc.(0) = 51 then begin
(* The compiled define body is (fn ...) which compiles to
OP_CLOSURE + [upvalue descriptors] + OP_RETURN.
Extract the inner code object from constants[idx]. *)
let idx = bc.(1) lor (bc.(2) lsl 8) in
let code =
if idx < Array.length outer_code.Sx_vm.constants then begin
let inner_val = outer_code.Sx_vm.constants.(idx) in
try Sx_vm.code_from_value inner_val
with e ->
Printf.eprintf "[vm] inner code_from_value failed for %s: %s\n%!"
name (Printexc.to_string e);
Printf.eprintf "[vm] inner val type: %s\n%!" (type_of inner_val);
(match inner_val with
| Dict d ->
Printf.eprintf "[vm] inner keys: %s\n%!"
(String.concat ", " (Hashtbl.fold (fun k _ acc -> k::acc) d []));
(match Hashtbl.find_opt d "bytecode" with
| Some v -> Printf.eprintf "[vm] bytecode type: %s\n%!" (type_of v)
| None -> Printf.eprintf "[vm] NO bytecode key\n%!")
| _ -> ());
raise e
end else outer_code
end else outer_code
in
let cl = { Sx_vm.code; upvalues = [||]; name = Some name;
env_ref = globals } in
Hashtbl.replace globals name
(NativeFn ("vm:" ^ name, fun args ->
Sx_vm.call_closure cl args globals));
incr compiled
in
let cl = { Sx_vm.code; upvalues = [||]; name = Some name;
env_ref = globals } in
Hashtbl.replace globals name
(NativeFn ("vm:" ^ name, fun args ->
Sx_vm.call_closure cl args globals));
incr compiled
end else begin
(* Not a lambda — constant expression (e.g. (list ...)).
Execute once and store the resulting value directly. *)
let value = Sx_vm.execute_module outer_code globals in
Hashtbl.replace globals name value;
Printf.eprintf "[vm] %s: constant (type=%s)\n%!" name (type_of value);
incr compiled
end
| _ -> () (* non-dict result — skip *)
with e ->
Printf.eprintf "[vm] FAIL adapter %s: %s\n%!" name (Printexc.to_string e))
@@ -861,11 +859,11 @@ let dispatch env cmd =
io_queue := [];
io_counter := 0;
let t0 = Unix.gettimeofday () in
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
ignore (env_bind env "expand-components?" expand_fn);
let result = match !vm_adapter_globals with
| Some globals ->
(* VM path: call compiled aser directly *)
Hashtbl.replace globals "expand-components?"
(NativeFn ("expand-components?", fun _args -> Bool true));
Hashtbl.replace globals "expand-components?" expand_fn;
let aser_fn = try Hashtbl.find globals "aser"
with Not_found -> raise (Eval_error "VM: aser not compiled") in
let r = match aser_fn with
@@ -875,15 +873,10 @@ let dispatch env cmd =
Hashtbl.remove globals "expand-components?";
r
| None ->
(* CEK fallback *)
ignore (env_bind env "expand-components?"
(NativeFn ("expand-components?", fun _args -> Bool true)));
let call = List [Symbol "aser";
List [Symbol "quote"; expr];
Env env] in
let r = Sx_ref.eval_expr call (Env env) in
Hashtbl.remove env.bindings "expand-components?";
r
Sx_ref.eval_expr call (Env env)
in
let t1 = Unix.gettimeofday () in
io_batch_mode := false;
@@ -911,6 +904,78 @@ let dispatch env cmd =
Hashtbl.remove env.bindings "expand-components?";
send_error (Printexc.to_string exn))
| List (Symbol "sx-page-full" :: String page_src :: shell_kwargs) ->
(* Full page render: aser-slot body + render-to-html shell in ONE call.
shell_kwargs are keyword pairs: :title "..." :csrf "..." etc.
These are passed directly to ~shared:shell/sx-page-shell. *)
(try
(* Phase 1: aser-slot the page body *)
let exprs = Sx_parser.parse_all page_src in
let expr = match exprs with
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs)
in
io_batch_mode := true;
io_queue := [];
io_counter := 0;
let t0 = Unix.gettimeofday () in
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
ignore (env_bind env "expand-components?" expand_fn);
let body_result = match !vm_adapter_globals with
| Some globals ->
Hashtbl.replace globals "expand-components?" expand_fn;
let aser_fn = try Hashtbl.find globals "aser"
with Not_found -> raise (Eval_error "VM: aser not compiled") in
let r = match aser_fn with
| NativeFn (_, fn) -> fn [expr; Env env]
| _ -> raise (Eval_error "VM: aser not a function")
in
Hashtbl.remove globals "expand-components?";
r
| None ->
let call = List [Symbol "aser";
List [Symbol "quote"; expr];
Env env] in
Sx_ref.eval_expr call (Env env)
in
let t1 = Unix.gettimeofday () in
io_batch_mode := false;
Hashtbl.remove env.bindings "expand-components?";
let body_str = match body_result with
| String s | SxExpr s -> s
| _ -> serialize_value body_result
in
let body_final = flush_batched_io body_str in
let t2 = Unix.gettimeofday () in
(* Phase 2: render shell with body + all kwargs.
Resolve symbol references (e.g. __shell-component-defs) to their
values from the env — these were pre-injected by the bridge. *)
let resolved_kwargs = List.map (fun v ->
match v with
| Symbol s ->
(try env_get env s
with _ -> try Sx_primitives.get_primitive s with _ -> v)
| _ -> v
) shell_kwargs in
let shell_args = Keyword "page-sx" :: String body_final :: resolved_kwargs in
let shell_call = List (Symbol "~shared:shell/sx-page-shell" :: shell_args) in
let html = Sx_render.render_to_html shell_call env in
let t3 = Unix.gettimeofday () in
Printf.eprintf "[sx-page-full] aser=%.3fs io=%.3fs shell=%.3fs total=%.3fs body=%d html=%d\n%!"
(t1 -. t0) (t2 -. t1) (t3 -. t2) (t3 -. t0)
(String.length body_final) (String.length html);
send_ok_string html
with
| Eval_error msg ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
send_error msg
| exn ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
send_error (Printexc.to_string exn))
| List [Symbol "render"; String src] ->
(try
let exprs = Sx_parser.parse_all src in

11
hosts/ocaml/bootstrap.py
View File

@@ -200,6 +200,17 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
return '\n'.join(fixed)
output = fix_mutable_reads(output)
# Fix cek_call: the spec passes (make-env) as the env arg to
# continue_with_call, but the transpiler evaluates it at transpile
# time (it's a primitive), producing Dict instead of Env.
# Fix cek_call: the spec passes (make-env) as the env arg to
# continue_with_call, but the transpiler evaluates make-env at
# transpile time (it's a primitive), producing Dict instead of Env.
output = output.replace(
"((Dict (Hashtbl.create 0))) (a) ((List []))",
"(Env (Sx_types.make_env ())) (a) ((List []))",
)
return output

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

@@ -618,20 +618,44 @@ let () =
match args with
| [f; (List items | ListRef { contents = items })] ->
List (List.map (fun x -> call_any f [x]) items)
| [_; Nil] -> List []
| _ -> raise (Eval_error "map: expected (fn list)"));
register "map-indexed" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
List (List.mapi (fun i x -> call_any f [Number (float_of_int i); x]) items)
| [_; Nil] -> List []
| _ -> raise (Eval_error "map-indexed: expected (fn list)"));
register "filter" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
List (List.filter (fun x -> sx_truthy (call_any f [x])) items)
| [_; Nil] -> List []
| _ -> raise (Eval_error "filter: expected (fn list)"));
register "for-each" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
List.iter (fun x -> ignore (call_any f [x])) items; Nil
| _ -> raise (Eval_error "for-each: expected (fn list)"));
| [_; Nil] -> Nil (* nil collection = no-op *)
| _ ->
let types = String.concat ", " (List.map (fun v -> type_of v) args) in
raise (Eval_error (Printf.sprintf "for-each: expected (fn list), got (%s) %d args" types (List.length args))));
register "reduce" (fun args ->
match args with
| [f; init; (List items | ListRef { contents = items })] ->
List.fold_left (fun acc x -> call_any f [acc; x]) init items
| _ -> raise (Eval_error "reduce: expected (fn init list)"));
register "some" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
(try List.find (fun x -> sx_truthy (call_any f [x])) items
with Not_found -> Bool false)
| [_; Nil] -> Bool false
| _ -> raise (Eval_error "some: expected (fn list)"));
register "every?" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
Bool (List.for_all (fun x -> sx_truthy (call_any f [x])) items)
| [_; Nil] -> Bool true
| _ -> raise (Eval_error "every?: expected (fn list)"));
()

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

@@ -422,7 +422,7 @@ and step_sf_deref args env kont =
(* cek-call *)
and cek_call f args =
(let a = (if sx_truthy ((is_nil (args))) then (List []) else args) in (if sx_truthy ((is_nil (f))) then Nil else (if sx_truthy ((let _or = (is_lambda (f)) in if sx_truthy _or then _or else (is_callable (f)))) then (cek_run ((continue_with_call (f) (a) ((Dict (Hashtbl.create 0))) (a) ((List []))))) else Nil)))
(let a = (if sx_truthy ((is_nil (args))) then (List []) else args) in (if sx_truthy ((is_nil (f))) then Nil else (if sx_truthy ((let _or = (is_lambda (f)) in if sx_truthy _or then _or else (is_callable (f)))) then (cek_run ((continue_with_call (f) (a) ((make_env ())) (a) ((List []))))) else Nil)))
(* reactive-shift-deref *)
and reactive_shift_deref sig' env kont =

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

@@ -240,7 +240,7 @@ let type_of v = String (Sx_types.type_of v)
The transpiled CEK machine stores envs in dicts as Env values. *)
let unwrap_env = function
| Env e -> e
| _ -> raise (Eval_error "Expected env")
| v -> raise (Eval_error ("Expected env, got " ^ Sx_types.type_of v))
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)