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

Transpiler: emit NativeFn for SX lambdas, bare OCaml for HO inlines

Browse Source 
SX lambdas ((fn (x) body)) now transpile to NativeFn values that can
be stored as SX values — passed to signal-add-sub!, stored in dicts,
used as reactive subscribers. Previously emitted as bare OCaml closures
which couldn't be stored in the SX value type system.

ml-emit-fn → NativeFn("λ", fun args -> match args with [...] -> body)
ml-emit-fn-bare → (fun params -> body) — used by HO inliners and
  recursive let bindings (let rec) which call themselves directly.

HO forms (map, filter, reduce, for-each, map-indexed, map-dict) use
cek_call for non-inline function arguments, bare OCaml lambdas for
inline (fn ...) arguments.

Runtime: with_island_scope accepts NativeFn values (pattern match on
value type) since transpiled lambdas are now NativeFn-wrapped.

Unblocks WASM reactive signals — the bootstrap FIXUPS that manually
wrapped reactive_shift_deref's subscriber as NativeFn are no longer
needed when merging to the wasm branch.

1314/1314 JS tests, 4/4 Playwright isomorphic tests.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-24 10:28:28 +00:00
parent 89543e0152
commit efb2d92b99
3 changed files with 43 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
hosts/ocaml/transpiler.sx
View File

@@ -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\"))"))))))