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

Restore all OCaml + request-handler to working state (aa4c911)

Browse Source 
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-29 22:11:17 +00:00
parent 4e89b9a66b
commit a38b5a9b44
4 changed files with 106 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -713,13 +713,13 @@ let register_jit_hook env =
Sx_ref.jit_call_hook := Some (fun f args -> Sx_ref.jit_call_hook := Some (fun f args ->
match f with match f with
| Lambda l -> | Lambda l ->
let fn_name = match l.l_name with Some n -> n | None -> "?" in
(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) ->
(* Cached bytecode — run on VM, fall back to CEK on runtime error. (* Cached bytecode — run on VM, fall back to CEK on runtime error.
Log once per function name, then stay quiet. Don't disable. *) Log once per function name, then stay quiet. Don't disable. *)
(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 e -> with e ->
let fn_name = match l.l_name with Some n -> n | None -> "?" in
if not (Hashtbl.mem _jit_warned fn_name) then begin if not (Hashtbl.mem _jit_warned fn_name) then begin
Hashtbl.replace _jit_warned fn_name true; Hashtbl.replace _jit_warned fn_name true;
Printf.eprintf "[jit] %s runtime fallback to CEK: %s\n%!" fn_name (Printexc.to_string e) Printf.eprintf "[jit] %s runtime fallback to CEK: %s\n%!" fn_name (Printexc.to_string e)
@@ -727,8 +727,8 @@ let register_jit_hook env =
None) None)
| Some _ -> None (* compile failed or disabled — CEK handles *) | Some _ -> None (* compile failed or disabled — CEK handles *)
| None -> | None ->
let fn_name = match l.l_name with Some n -> n | None -> "?" in
if !_jit_compiling then None if !_jit_compiling then None
else if Hashtbl.mem _jit_warned fn_name then None
else begin else begin
_jit_compiling := true; _jit_compiling := true;
let t0 = Unix.gettimeofday () in let t0 = Unix.gettimeofday () in
@@ -743,7 +743,6 @@ let register_jit_hook env =
(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 e -> with e ->
Printf.eprintf "[jit] %s first-call fallback to CEK: %s\n%!" fn_name (Printexc.to_string e); Printf.eprintf "[jit] %s first-call fallback to CEK: %s\n%!" fn_name (Printexc.to_string e);
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
Hashtbl.replace _jit_warned fn_name true; Hashtbl.replace _jit_warned fn_name true;
None) None)
| None -> None | None -> None
@@ -1579,16 +1578,9 @@ let http_inject_shell_statics env static_dir sx_sxc =
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
Filename.dirname (Filename.dirname static_dir) in Filename.dirname (Filename.dirname static_dir) in
let templates_dir = project_dir ^ "/shared/sx/templates" in let templates_dir = project_dir ^ "/shared/sx/templates" in
(* Client libraries: all .sx files in templates/client-libs/ *) let client_libs = [
let client_libs_dir = templates_dir ^ "/client-libs" in templates_dir ^ "/cssx.sx";
let extra_libs = ] in
if Sys.file_exists client_libs_dir && Sys.is_directory client_libs_dir then
Array.to_list (Sys.readdir client_libs_dir)
|> List.filter (fun f -> Filename.check_suffix f ".sx")
|> List.sort String.compare
|> List.map (fun f -> client_libs_dir ^ "/" ^ f)
else [] in
let client_libs = (templates_dir ^ "/cssx.sx") :: extra_libs in
List.iter (fun path -> List.iter (fun path ->
if Sys.file_exists path then begin if Sys.file_exists path then begin
let src = In_channel.with_open_text path In_channel.input_all in let src = In_channel.with_open_text path In_channel.input_all in
@@ -1622,20 +1614,7 @@ let http_inject_shell_statics env static_dir sx_sxc =
(* Compute file hashes for cache busting *) (* Compute file hashes for cache busting *)
let sx_js_hash = file_hash (static_dir ^ "/scripts/sx-browser.js") in let sx_js_hash = file_hash (static_dir ^ "/scripts/sx-browser.js") in
let body_js_hash = file_hash (static_dir ^ "/scripts/body.js") in let body_js_hash = file_hash (static_dir ^ "/scripts/body.js") in
(* Include SX source file hashes so browser cache busts when .sx files change *) let wasm_hash = file_hash (static_dir ^ "/wasm/sx_browser.bc.wasm.js") in
let sx_dir = static_dir ^ "/wasm/sx" in
let sx_files_hash =
if Sys.file_exists sx_dir && Sys.is_directory sx_dir then
let entries = Sys.readdir sx_dir in
Array.sort String.compare entries;
let combined = Array.fold_left (fun acc f ->
if Filename.check_suffix f ".sx" then
acc ^ file_hash (sx_dir ^ "/" ^ f)
else acc
) "" entries in
String.sub (Digest.string combined |> Digest.to_hex) 0 12
else "" in
let wasm_hash = file_hash (static_dir ^ "/wasm/sx_browser.bc.wasm.js") ^ sx_files_hash in
(* Read CSS for inline injection *) (* Read CSS for inline injection *)
let tw_css = read_css_file (static_dir ^ "/styles/tw.css") in let tw_css = read_css_file (static_dir ^ "/styles/tw.css") in
let basics_css = read_css_file (static_dir ^ "/styles/basics.css") in let basics_css = read_css_file (static_dir ^ "/styles/basics.css") in
@@ -1695,7 +1674,16 @@ let http_inject_shell_statics env static_dir sx_sxc =
ignore (env_bind env "__shell-body-scripts" Nil); ignore (env_bind env "__shell-body-scripts" Nil);
ignore (env_bind env "__shell-inline-css" Nil); ignore (env_bind env "__shell-inline-css" Nil);
ignore (env_bind env "__shell-inline-head-js" Nil); ignore (env_bind env "__shell-inline-head-js" Nil);
ignore (env_bind env "__shell-init-sx" Nil); (* init-sx: trigger client-side render when sx-root is empty (SSR failed).
The boot code hydrates existing islands but doesn't do fresh render.
This script forces a render from page-sx after boot completes. *)
ignore (env_bind env "__shell-init-sx" (String
"document.addEventListener('sx:boot-done', function() { \
var root = document.getElementById('sx-root'); \
if (root && !root.innerHTML.trim() && typeof SX !== 'undefined' && SX.renderPage) { \
SX.renderPage(); \
} \
});"));
Printf.eprintf "[sx-http] Shell statics: defs=%d hash=%s css=%d js=%s wasm=%s\n%!" Printf.eprintf "[sx-http] Shell statics: defs=%d hash=%s css=%d js=%s wasm=%s\n%!"
(String.length component_defs) component_hash (String.length sx_css) sx_js_hash wasm_hash (String.length component_defs) component_hash (String.length sx_css) sx_js_hash wasm_hash
@@ -1801,9 +1789,7 @@ let http_setup_page_helpers env =
SxExpr (Printf.sprintf "(pre :class \"text-sm overflow-x-auto\" (code \"%s\"))" escaped) SxExpr (Printf.sprintf "(pre :class \"text-sm overflow-x-auto\" (code \"%s\"))" escaped)
| _ -> Nil); | _ -> Nil);
(* component-source — stub *) (* component-source — stub *)
bind "component-source" (fun _args -> String ""); bind "component-source" (fun _args -> String "")
(* handler-source — stub (returns empty, used by example pages) *)
bind "handler-source" (fun _args -> String "")
let http_mode port = let http_mode port =
let env = make_server_env () in let env = make_server_env () in
@@ -2022,9 +2008,7 @@ let http_mode port =
let is_ajax = List.exists (fun (k, _) -> k = "sx-request" || k = "hx-request") headers in let is_ajax = List.exists (fun (k, _) -> k = "sx-request" || k = "hx-request") headers in
match http_render_page env path headers with match http_render_page env path headers with
| Some html -> | Some html ->
let ct = if is_ajax then "text/sx; charset=utf-8" let resp = http_response ~content_type:"text/html; charset=utf-8" html in
else "text/html; charset=utf-8" in
let resp = http_response ~content_type:ct html in
if not is_ajax then Hashtbl.replace response_cache path resp; if not is_ajax then Hashtbl.replace response_cache path resp;
resp resp
| None -> http_response ~status:404 "<h1>Not Found</h1>" | None -> http_response ~status:404 "<h1>Not Found</h1>"

16
hosts/ocaml/lib/sx_render.ml
View File

@@ -280,10 +280,7 @@ and render_list_to_html head args env =
| _ -> | _ ->
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
do_render_to_html result env) do_render_to_html result env)
with Eval_error _ -> with Eval_error _ -> "")
(* Symbol not in env — might be a primitive; eval the full expression *)
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
do_render_to_html result env)
| _ -> | _ ->
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
do_render_to_html result env do_render_to_html result env
@@ -533,13 +530,10 @@ and render_list_buf buf head args env =
| _ -> | _ ->
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
render_to_buf buf result env) render_to_buf buf result env)
with Eval_error _ -> with Eval_error msg ->
(* Symbol not in env — might be a primitive; eval the full expression *) (* Unknown symbol/component — skip silently during SSR.
(try The client will render from page-sx. *)
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in Printf.eprintf "[ssr-skip] %s\n%!" msg)
render_to_buf buf result env
with Eval_error msg ->
Printf.eprintf "[ssr-skip] %s\n%!" msg))
| _ -> | _ ->
(try (try
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in

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

@@ -576,12 +576,14 @@ let jit_compile_lambda (l : lambda) globals =
let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in
let quoted = List [Symbol "quote"; fn_expr] in let quoted = List [Symbol "quote"; fn_expr] in
let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in
(* Inject closure bindings into globals so GLOBAL_GET can find them. (* If the lambda has closure-captured variables, merge them into globals
Only injects values not already present in globals (preserves so the VM can find them via GLOBAL_GET. The compiler doesn't know
existing defines). Mutable closure vars get stale snapshots here about the enclosing scope, so closure vars get compiled as globals. *)
but GLOBAL_SET writes back to vm_closure_env, and GLOBAL_GET
falls through to vm_closure_env if the global is stale. *)
let effective_globals = let effective_globals =
(* Use the LIVE globals table directly. Inject only truly local
closure bindings (not already in globals) into the live table.
This ensures GLOBAL_GET always sees the latest define values.
Previous approach copied globals, creating a stale snapshot. *)
let closure = l.l_closure in let closure = l.l_closure in
let count = ref 0 in let count = ref 0 in
let rec inject env = let rec inject env =
@@ -623,14 +625,16 @@ let jit_compile_lambda (l : lambda) globals =
as a NativeFn if it's callable (so the CEK can dispatch to it). *) as a NativeFn if it's callable (so the CEK can dispatch to it). *)
(try (try
let value = execute_module outer_code globals in let value = execute_module outer_code globals in
ignore (fn_name, value, bc); (* resolved — not a closure, CEK handles it *) Printf.eprintf "[jit] RESOLVED %s: %s (bc[0]=%d)\n%!"
fn_name (type_of value) (if Array.length bc > 0 then bc.(0) else -1);
(* If the resolved value is a NativeFn, we can't wrap it as a (* If the resolved value is a NativeFn, we can't wrap it as a
vm_closure — just let the CEK handle it directly. Return None vm_closure — just let the CEK handle it directly. Return None
so the lambda falls through to CEK, which will find the so the lambda falls through to CEK, which will find the
resolved value in the env on next lookup. *) resolved value in the env on next lookup. *)
None None
with _ -> with _ ->
ignore fn_name; (* non-closure, execution failed — CEK fallback *) Printf.eprintf "[jit] SKIP %s: non-closure execution failed (bc[0]=%d, len=%d)\n%!"
fn_name (if Array.length bc > 0 then bc.(0) else -1) (Array.length bc);
None) None)
end end
| _ -> | _ ->

152
web/request-handler.sx
View File

@@ -1,43 +1,15 @@
(define (define
sx-handle-request sx-url-to-expr
(fn
(path headers env)
(let
((is-ajax (or (has-key? headers "sx-request") (has-key? headers "hx-request")))
(path-expr (sx-parse-url path))
(page-ast (sx-eval-page path-expr env)))
(if
(nil? page-ast)
nil
(let
((nav-path (if (starts-with? path "/sx/") path (str "/sx" path))))
(if
is-ajax
(sx-render-ajax page-ast nav-path env)
(sx-render-full-page page-ast nav-path env)))))))
(define
sx-parse-url
(fn (fn
(path) (path)
(let (cond
((p (cond (or (= path "/") (= path "/sx/") (= path "/sx")) "home" (starts-with? path "/sx/") (substring path 4 (string-length path)) (starts-with? path "/") (substring path 1 (string-length path)) :else path))) (or (= path "/") (= path "/sx/") (= path "/sx"))
(let ((spaced (join " " (split p ".")))) spaced)))) "home"
(starts-with? path "/sx/")
(define (join " " (split (slice path 4 (len path)) "."))
sx-eval-page (starts-with? path "/")
(fn (join " " (split (slice path 1 (len path)) "."))
(path-expr env) :else path)))
(let
((exprs (sx-parse path-expr)))
(when
(not (empty? exprs))
(let
((expr (if (= (len exprs) 1) (first exprs) exprs))
(quoted (sx-auto-quote expr env)))
(let
((callable (if (symbol? quoted) (list quoted) quoted)))
(cek-try (fn () (eval-expr callable env)) (fn (err) nil))))))))
(define (define
sx-auto-quote sx-auto-quote
@@ -51,53 +23,73 @@
:else expr))) :else expr)))
(define (define
sx-render-ajax sx-eval-page
(fn (fn
(page-ast nav-path env) (path-expr env)
(let (cek-try
((wrapped (list (make-symbol "~layouts/doc") :path nav-path page-ast)) (fn
(aser-result (aser (list (make-symbol "quote") wrapped) env))) ()
(let
((body-exprs (sx-parse aser-result)))
(let (let
((body-expr (if (= (len body-exprs) 1) (first body-exprs) (cons (make-symbol "<>") body-exprs)))) ((exprs (sx-parse path-expr)))
(render-to-html body-expr env)))))) (when
(not (empty? exprs))
(let
((expr (if (= (len exprs) 1) (first exprs) exprs))
(quoted (sx-auto-quote expr env))
(callable (if (symbol? quoted) (list quoted) quoted)))
(eval-expr callable env)))))
(fn (err) nil))))
(define (define
sx-render-full-page sx-handle-request
(fn (fn
(page-ast nav-path env) (path headers env)
(let (let
((wrapped (list (make-symbol "~layouts/doc") :path nav-path page-ast)) ((is-ajax (or (has-key? headers "sx-request") (has-key? headers "hx-request")))
(full-ast (path-expr (sx-url-to-expr path))
(list (make-symbol "~shared:layout/app-body") :content wrapped))) (page-ast (sx-eval-page path-expr env)))
(let (if
((aser-result (aser (list (make-symbol "quote") full-ast) env))) (nil? page-ast)
nil
(let (let
((body-exprs (sx-parse aser-result))) ((nav-path (if (starts-with? path "/sx/") path (str "/sx" path))))
(let (cek-try
((body-expr (if (= (len body-exprs) 1) (first body-exprs) (cons (make-symbol "<>") body-exprs)))) (fn
(let ()
((body-html (render-to-html body-expr env)) (if
(page-source (serialize full-ast))) is-ajax
(~shared:shell/sx-page-shell (let
:title "SX" ((content (list (make-symbol "~layouts/doc") :path nav-path page-ast)))
:csrf "" (render-to-html content env))
:page-sx page-source (let
:body-html body-html ((wrapped (list (make-symbol "~layouts/doc") :path nav-path page-ast))
:component-defs __shell-component-defs (full-ast
:component-hash __shell-component-hash (list
:pages-sx __shell-pages-sx (make-symbol "~shared:layout/app-body")
:sx-css __shell-sx-css :content wrapped))
:sx-css-classes __shell-sx-css-classes (body-html (render-to-html full-ast env)))
:asset-url __shell-asset-url (render-to-html
:sx-js-hash __shell-sx-js-hash (list
:body-js-hash __shell-body-js-hash (make-symbol "~shared:shell/sx-page-shell")
:wasm-hash __shell-wasm-hash :title "SX"
:head-scripts __shell-head-scripts :csrf ""
:body-scripts __shell-body-scripts :page-sx (serialize full-ast)
:inline-css __shell-inline-css :body-html body-html
:inline-head-js __shell-inline-head-js :component-defs __shell-component-defs
:init-sx __shell-init-sx :component-hash __shell-component-hash
:use-wasm (= (or (env-get env "SX_USE_WASM") "") "1") :pages-sx __shell-pages-sx
:meta-html "")))))))) :sx-css __shell-sx-css
:sx-css-classes __shell-sx-css-classes
:asset-url __shell-asset-url
:sx-js-hash __shell-sx-js-hash
:body-js-hash __shell-body-js-hash
:wasm-hash __shell-wasm-hash
:head-scripts __shell-head-scripts
:body-scripts __shell-body-scripts
:inline-css __shell-inline-css
:inline-head-js __shell-inline-head-js
:init-sx __shell-init-sx
:use-wasm true
:meta-html "")
env))))
(fn (err) (str "<h1>Render error</h1><pre>" err "</pre>"))))))))