diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index a06b0db..17bc9ee 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -435,7 +435,7 @@ and cek_call f args = (* reactive-shift-deref *) and reactive_shift_deref sig' env kont = - (let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil))) ((fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))))))))) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont)))))))) + (let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (NativeFn ("\206\187", fun _args -> (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((NativeFn ("\206\187", fun _args -> match _args with [d] -> (fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil)) d | _ -> Nil))) ((NativeFn ("\206\187", fun _args -> (fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))) ())))))))) ())) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((NativeFn ("\206\187", fun _args -> (fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil))) ()))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont)))))))) (* step-eval-call *) and step_eval_call head args env kont = diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index a8eb1a9..9695c5a 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -369,8 +369,12 @@ let notify_subscribers _s = Nil let flush_subscribers _s = Nil let dispose_computed _s = Nil -(* Island scope stubs — accept OCaml functions from transpiled code *) -let with_island_scope _register_fn body_fn = body_fn () +(* Island scope stubs — accept both bare OCaml fns and NativeFn values + from transpiled code (NativeFn wrapping for value-storable lambdas). *) +let with_island_scope _register_fn body_fn = + match body_fn with + | NativeFn (_, f) -> f [] + | _ -> Nil let register_in_scope _dispose_fn = Nil (* Component type annotation stub *) diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index 670596b..d6e865c 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -690,7 +690,9 @@ ;; fn/lambda ;; -------------------------------------------------------------------------- -(define ml-emit-fn +;; ml-emit-fn-bare: emit a plain OCaml function (fun params -> body). +;; Used by HO form inlining where a bare OCaml closure is needed. +(define ml-emit-fn-bare (fn (expr (set-vars :as list)) (let ((params (nth expr 1)) (body (rest (rest expr))) @@ -714,6 +716,25 @@ (ml-emit-do body all-set-vars)))) (str "(fun " params-str " -> " ref-decls body-str ")"))))))) +;; ml-emit-fn: emit an SX-compatible NativeFn value. +;; Wraps the OCaml closure so it can be stored as a value, passed to +;; signal-add-sub!, etc. The args pattern-match unpacks the value list. +(define ml-emit-fn + (fn (expr (set-vars :as list)) + (let ((params (nth expr 1)) + (param-strs (ml-collect-params params)) + (n (len param-strs)) + (bare (ml-emit-fn-bare expr set-vars))) + (if (= n 0) + ;; Zero-arg: NativeFn("λ", fun _args -> body) + (str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))") + ;; N-arg: NativeFn("λ", fun args -> match args with [a;b;...] -> body | _ -> Nil) + (let ((match-pat (str "[" (join "; " param-strs) "]")) + (call-args (join " " param-strs))) + (str "(NativeFn (\"\\206\\187\", fun _args -> match _args with " + match-pat " -> " bare " " call-args + " | _ -> Nil))")))))) + (define ml-collect-params (fn ((params :as list)) (ml-collect-params-loop params 0 (list)))) @@ -987,7 +1008,10 @@ (= (symbol-name (first val-expr)) "lambda")))) (is-recursive (ml-is-self-recursive? name val-expr))) (let ((rec-kw (if is-recursive "rec " "")) - (val-str (ml-expr-inner val-expr set-vars)) + ;; Recursive fns must be bare OCaml functions (called directly) + (val-str (if (and is-fn is-recursive) + (ml-emit-fn-bare val-expr set-vars) + (ml-expr-inner val-expr set-vars))) (rest-str (ml-emit-do-chain args (+ i 1) set-vars))) (str "(let " rec-kw ml-name " = " val-str " in " rest-str ")")))) ;; Non-define expression @@ -1031,12 +1055,12 @@ body-str))) (str "(" result-wrap " (" ocaml-fn " (fun " param-str " -> " wrapped-body ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))) - ;; Named function — direct call (all defines are OCaml fns) + ;; Named function — dispatch via cek_call (fn may be NativeFn value) (let ((fn-str (ml-expr-inner fn-arg set-vars))) (if needs-bool - (str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (" fn-str " _x))" + (str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (cek_call " fn-str " (List [_x])))" " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))") - (str "(" result-wrap " (" ocaml-fn " (fun _x -> " fn-str " _x)" + (str "(" result-wrap " (" ocaml-fn " (fun _x -> cek_call " fn-str " (List [_x]))" " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))))) (define ml-emit-ho-indexed @@ -1054,8 +1078,8 @@ (ml-emit-do body set-vars)))) (str "(List (List.mapi (fun " i-param " " v-param " -> let " i-param " = Number (float_of_int " i-param ") in " body-str ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))) - (str "(List (List.mapi (fun _i _x -> " (ml-expr-inner fn-arg set-vars) - " (Number (float_of_int _i)) _x) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))) + (str "(List (List.mapi (fun _i _x -> cek_call " (ml-expr-inner fn-arg set-vars) + " (List [Number (float_of_int _i); _x])) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))) (define ml-emit-reduce (fn ((args :as list) (set-vars :as list)) @@ -1077,8 +1101,8 @@ (str "_" raw-acc))))) (str "(List.fold_left (fun " acc-param " " x-param " -> " body-str ") " (ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))) - (str "(List.fold_left (fun _acc _x -> " (ml-expr-inner fn-arg set-vars) - " _acc _x) " (ml-expr-inner init-arg set-vars) + (str "(List.fold_left (fun _acc _x -> cek_call " (ml-expr-inner fn-arg set-vars) + " (List [_acc; _x])) " (ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))))) @@ -1100,8 +1124,8 @@ (ml-emit-do body set-vars)))) (str "(List.iter (fun " param-str " -> ignore (" body-str ")) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))) - (str "(List.iter (fun _x -> ignore (" (ml-expr-inner fn-arg set-vars) - " _x)) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))))) + (str "(List.iter (fun _x -> ignore (cek_call " (ml-expr-inner fn-arg set-vars) + " (List [_x]))) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))))) ;; -------------------------------------------------------------------------- @@ -1131,7 +1155,7 @@ (str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> " "let _r = Hashtbl.create (Hashtbl.length _tbl) in " "Hashtbl.iter (fun _k _v -> " - "Hashtbl.replace _r _k (" fn-str " (String _k) _v)) _tbl; " + "Hashtbl.replace _r _k (cek_call " fn-str " (List [String _k; _v]))) _tbl; " "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))))))