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

HS tests: SIGALRM + raise timeout for native OCaml loops

Browse Source 
The infinite loops in the HS parser are in transpiled native OCaml code,
not in the VM or CEK step loop. Neither step counters (in cek_step_loop,
cek_step, trampoline) nor VM instruction checks caught them because
the loops are in direct OCaml recursion.

Fix: SIGALRM handler raises Eval_error to break out of native loops.
Also sets step_limit flag to catch VM loops. Combined approach handles
both native OCaml recursion (alarm+raise) and VM bytecode (step check).

The alarm+raise can become unreliable after ~13 timeouts in a single
process, but handles the common case well. Reverts the fork-based
approach which lost inter-test state.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-14 11:57:33 +00:00
parent 3d7fffe4eb
commit e3eb46d0dc
3 changed files with 69 additions and 59 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -85,64 +85,46 @@ let make_test_env () =
with Eval_error msg -> List [Symbol "error"; String msg])
| _ -> Nil);
(* Two-phase try-call: first attempt runs in-process (fast, state-sharing).
If a test hangs (detected by SIGALRM), retry it in a fork for safe timeout. *)
let _test_timed_out = ref false in
Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ ->
_test_timed_out := true;
(* Set step_limit to trigger check in VM instruction loop *)
Sx_ref.step_limit := 1;
(* Also raise to break native OCaml loops (HS parser etc.) *)
raise (Eval_error "TIMEOUT: test exceeded 5s")));
bind "try-call" (fun args ->
match args with
| [thunk] ->
(* Fork-based timeout: child runs test, parent waits up to 5s *)
let r, w = Unix.pipe () in
let pid = Unix.fork () in
if pid = 0 then begin
(* Child process *)
Unix.close r;
let write_result s =
let _ = Unix.write_substring w s 0 (String.length s) in
Unix.close w; exit 0 in
(try
let result = eval_expr (List [thunk]) (Env env) in
ignore result;
write_result "OK:"
with
| Eval_error msg -> write_result ("ERR:" ^ msg)
| exn -> write_result ("EXN:" ^ Printexc.to_string exn))
end else begin
(* Parent process *)
Unix.close w;
(* Wait with timeout using select *)
let deadline = Unix.gettimeofday () +. 5.0 in
let rec wait_loop () =
let remaining = deadline -. Unix.gettimeofday () in
if remaining <= 0.0 then begin
Unix.kill pid Sys.sigkill;
ignore (Unix.waitpid [] pid);
Unix.close r;
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool false);
Hashtbl.replace d "error" (String "TIMEOUT: test exceeded 5s");
Dict d
end else begin
match Unix.select [r] [] [] (min remaining 0.1) with
| _ :: _, _, _ ->
let buf = Bytes.create 4096 in
let n = Unix.read r buf 0 4096 in
Unix.close r;
ignore (Unix.waitpid [] pid);
let msg = Bytes.sub_string buf 0 n in
if String.length msg >= 3 && String.sub msg 0 3 = "OK:" then begin
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool true);
Dict d
end else begin
let err = if String.length msg > 4 then String.sub msg 4 (String.length msg - 4) else msg in
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool false);
Hashtbl.replace d "error" (String err);
Dict d
end
| [], _, _ -> wait_loop ()
end
in
wait_loop ()
end
_test_timed_out := false;
Sx_ref.step_limit := 0;
Sx_ref.step_count := 0;
ignore (Unix.alarm 5);
(try
let result = eval_expr (List [thunk]) (Env env) in
ignore result;
ignore (Unix.alarm 0);
Sx_ref.step_limit := 0;
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool true);
Dict d
with
| Eval_error msg ->
ignore (Unix.alarm 0);
Sx_ref.step_limit := 0;
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool false);
Hashtbl.replace d "error" (String (if !_test_timed_out then "TIMEOUT: test exceeded 5s" else msg));
Dict d
| exn ->
ignore (Unix.alarm 0);
Sx_ref.step_limit := 0;
let d = Hashtbl.create 2 in
Hashtbl.replace d "ok" (Bool false);
Hashtbl.replace d "error" (String (Printexc.to_string exn));
Dict d)
| _ -> raise (Eval_error "try-call: expected 1 arg"));
bind "report-pass" (fun args ->
@@ -2138,6 +2120,8 @@ let run_spec_tests env test_files =
load_module "freeze.sx" lib_dir;
load_module "content.sx" lib_dir;
load_module "parser-combinators.sx" lib_dir;
load_module "graphql.sx" lib_dir;
load_module "graphql-exec.sx" lib_dir;
(* DOM module — provides dom-* wrappers around host-* primitives *)
let web_lib_dir = Filename.concat web_dir "lib" in
load_module "dom.sx" web_lib_dir;