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

Fix transpiler append! emit for mutable globals + run_with_io error recovery

Browse Source 
The transpiler's append! emit path didn't check ml-is-mutable-global?,
so (append! *provide-batch-queue* sub) wrote to a dead local variable
instead of the global _ref. This caused the combined test suite hang —
fire-provide-subscribers was silently broken before the local-ref shadow
removal, and now correctly modifies the global batch queue.

Also adds run_with_io error-to-raise conversion (kont_has_handler guard)
so native Eval_errors can be caught by CEK guard/handler-bind when running
through the test runner's IO-aware step loop.

2798/2800 tests pass. 2 foreign-type-checking failures remain: guard can't
catch Eval_error from native fns called through cek_run_iterative (the
handler dispatch itself uses cek_call which re-enters cek_run_iterative,
creating an infinite loop). Fix requires spec-level change: make (error)
use CEK raise instead of host-error.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 18:59:38 +00:00
parent b61b437ccd
commit 7f772e0f23
3 changed files with 51 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1231,9 +1231,32 @@ let run_spec_tests env test_files =
let s = ref state in
let is_terminal st = match Sx_ref.cek_terminal_p st with Bool true -> true | _ -> false in
let is_suspended st = match Sx_runtime.get_val st (String "phase") with String "io-suspended" -> true | _ -> false in
(* Check if kont has any handler frames — pure structural scan *)
let kont_has_handler kont =
let k = ref kont in
let found = ref false in
while (match !k with List (_::_) -> true | _ -> false) && not !found do
(match !k with
| List (frame :: rest) ->
(match frame with
| CekFrame f when f.cf_type = "handler" -> found := true
| _ -> ());
k := List rest
| _ -> k := List [])
done;
!found in
let rec loop () =
while not (is_terminal !s) && not (is_suspended !s) do
s := Sx_ref.cek_step !s
(try s := Sx_ref.cek_step !s
with Eval_error msg ->
let kont = Sx_ref.cek_kont !s in
if kont_has_handler kont then
(* Convert to CEK-level raise so guard/handler-bind can catch it *)
let env = Sx_ref.cek_env !s in
s := Sx_ref.make_cek_value (String msg) env
(Sx_ref.kont_push (Sx_ref.make_raise_eval_frame env (Bool false)) kont)
else
raise (Eval_error msg))
done;
if is_suspended !s then begin
let request = Sx_runtime.get_val !s (String "request") in

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

@@ -622,7 +622,7 @@ and kont_extract_provides kont =
(* fire-provide-subscribers *)
and fire_provide_subscribers name =
(let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_ref; sub])))))) then (sx_append_b !_provide_batch_queue_ref sub) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil))
(let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_ref; sub])))))) then (_provide_batch_queue_ref := sx_append_b !_provide_batch_queue_ref sub; Nil) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil))
(* batch-begin! *)
and batch_begin_b () =
@@ -803,7 +803,7 @@ and step_sf_provide args env kont =
(* step-sf-context *)
and step_sf_context args env kont =
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (sx_append_b !_bind_tracking_ref name) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont))))
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (_bind_tracking_ref := sx_append_b !_bind_tracking_ref name; Nil) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont))))
(* step-sf-peek *)
and step_sf_peek args env kont =

40
hosts/ocaml/transpiler.sx
View File

@@ -834,30 +834,40 @@
(ml-emit-map-dict args set-vars)
(= op "append!")
(let
((target (nth args 0))
((target (symbol-name (nth expr 1)))
(item-expr (ml-expr-inner (nth args 1) set-vars)))
(if
(and
(= (type-of target) "symbol")
(some
(fn (v) (= v (ml-mangle (symbol-name target))))
set-vars))
(ml-is-mutable-global? target)
(let
((mangled (ml-mangle (symbol-name target))))
((mangled (ml-mangle target)))
(str
"("
mangled
" := sx_append_b !"
"ref := sx_append_b !"
mangled
" "
"ref "
item-expr
"; Nil)"))
(str
"(sx_append_b "
(ml-expr-inner target set-vars)
" "
item-expr
")")))
(if
(and
(= (type-of (nth expr 1)) "symbol")
(some (fn (v) (= v (ml-mangle target))) set-vars))
(let
((mangled (ml-mangle target)))
(str
"("
mangled
" := sx_append_b !"
mangled
" "
item-expr
"; Nil)"))
(str
"(sx_append_b "
(ml-expr-inner (nth expr 1) set-vars)
" "
item-expr
")"))))
(= op "dict-set!")
(str
"(sx_dict_set_b "