Lib: Give access to js runtime value

hhugo · hhugo · commit a60db88b6905 · 2025-11-03T12:16:03.000+01:00
diff --git a/CHANGES.md b/CHANGES.md
@@ -7,6 +7,7 @@
 * Compiler/wasm: make the type of some Wasm primitives more precise (#2100)
 * Compiler: reference unboxing (#1958)
 * Runtime: improved handling of NaNs (#2110)
+* Lib: allow to reference values from the runtime (#2086)
 
 ## Bug fixes
 * Compiler: fix purity of comparison functions (again) (#2092)
diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml
@@ -1932,6 +1932,22 @@ let internal_primitives =
       in
       let l = List.map ~f:transl_prim_arg vl in
       JavaScript.invoke_fragment name l);
+  register "caml_jsoo_runtime" (fun _ l ->
+      match l with
+      | [ Pc (String name) ] when J.is_ident name ->
+          let* x =
+            register_import
+              ~import_module:"js"
+              ~name
+              (Global { mut = false; typ = JavaScript.anyref })
+          in
+          let* wrap =
+            register_import
+              ~name:"wrap"
+              (Fun { params = [ JavaScript.anyref ]; result = [ Type.value ] })
+          in
+          return (W.Call (wrap, [ GlobalGet x ]))
+      | _ -> failwith "Jsoo_runtime.Sys.external_ expects a string literal.");
   !l
 
 let externref = W.Ref { nullable = true; typ = Extern }
diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml
@@ -1547,6 +1547,17 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t
                    | Some s -> Printf.sprintf ", file %S" s)
                    pi.Parse_info.line
                    pi.Parse_info.col))
+        | Extern "caml_jsoo_runtime", [ Pc (String nm) ] when J.is_ident nm ->
+            let prim = Share.get_prim (runtime_fun ctx) nm ctx.Ctx.share in
+            return prim
+        | Extern "caml_jsoo_runtime", [ (Pc _ | Pv _) ] ->
+            failwith
+              (Printf.sprintf
+                 "%scaml_jsoo_runtime expects a string literal."
+                 (match (loc : J.location) with
+                 | Pi { name = Some name; col; line; _ } ->
+                     Printf.sprintf "%s:%d:%d: " name line col
+                 | Pi _ | N | U -> ""))
         | Extern "%js_array", l ->
             let* args = list_map (fun x -> access' ~ctx x) l in
             return (J.array args)
diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml
@@ -188,6 +188,11 @@ let specialize_instr opt_count ~target info i =
           incr opt_count;
           Let (x, Prim (Extern "%direct_int_mod", [ y; z ]))
       | _ -> i)
+  | Let (x, Prim (Extern "caml_jsoo_runtime", [ nm ])), _ -> (
+      match the_string_of info nm with
+      | Some nm when Javascript.is_ident nm ->
+          Let (x, Prim (Extern "caml_jsoo_runtime", [ Pc (String nm) ]))
+      | _ -> i)
   | _, _ -> i
 
 let skip_event cont (Event _ :: l | l) = cont l
diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output
@@ -14,6 +14,7 @@ caml_int64_or_native
 caml_int64_sub_native
 caml_int64_xor_native
 caml_int_as_pointer
+caml_jsoo_runtime
 caml_reset_afl_instrumentation
 debugger
 
diff --git a/compiler/tests-check-prim/main.5.4.output b/compiler/tests-check-prim/main.5.4.output
@@ -5,6 +5,7 @@ From main.bc:
 caml_assume_no_perform
 caml_continuation_use
 caml_int_as_pointer
+caml_jsoo_runtime
 caml_reset_afl_instrumentation
 debugger
 
diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output
@@ -14,6 +14,7 @@ caml_int64_or_native
 caml_int64_sub_native
 caml_int64_xor_native
 caml_int_as_pointer
+caml_jsoo_runtime
 caml_reset_afl_instrumentation
 caml_unix_map_file_bytecode
 debugger
diff --git a/compiler/tests-check-prim/unix-Unix.5.4.output b/compiler/tests-check-prim/unix-Unix.5.4.output
@@ -5,6 +5,7 @@ From unix.bc:
 caml_assume_no_perform
 caml_continuation_use
 caml_int_as_pointer
+caml_jsoo_runtime
 caml_reset_afl_instrumentation
 caml_unix_accept
 caml_unix_alarm
diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output
@@ -14,6 +14,7 @@ caml_int64_or_native
 caml_int64_sub_native
 caml_int64_xor_native
 caml_int_as_pointer
+caml_jsoo_runtime
 caml_reset_afl_instrumentation
 caml_unix_map_file_bytecode
 debugger
diff --git a/compiler/tests-check-prim/unix-Win32.5.4.output b/compiler/tests-check-prim/unix-Win32.5.4.output
@@ -0,0 +1,194 @@
+Missing
+-------
+
+From unix.bc:
+caml_assume_no_perform
+caml_continuation_use
+caml_int_as_pointer
+caml_jsoo_runtime
+caml_reset_afl_instrumentation
+caml_unix_accept
+caml_unix_bind
+caml_unix_clear_close_on_exec
+caml_unix_clear_nonblock
+caml_unix_connect
+caml_unix_create_process
+caml_unix_dup
+caml_unix_dup2
+caml_unix_environment
+caml_unix_execv
+caml_unix_execve
+caml_unix_execvp
+caml_unix_execvpe
+caml_unix_filedescr_of_channel
+caml_unix_getaddrinfo
+caml_unix_gethostbyaddr
+caml_unix_gethostbyname
+caml_unix_gethostname
+caml_unix_getnameinfo
+caml_unix_getpeername
+caml_unix_getpid
+caml_unix_getprotobyname
+caml_unix_getprotobynumber
+caml_unix_getservbyname
+caml_unix_getservbyport
+caml_unix_getsockname
+caml_unix_getsockopt
+caml_unix_listen
+caml_unix_lockf
+caml_unix_map_file_bytecode
+caml_unix_pipe
+caml_unix_putenv
+caml_unix_realpath
+caml_unix_recv
+caml_unix_recvfrom
+caml_unix_select
+caml_unix_send
+caml_unix_sendto
+caml_unix_set_close_on_exec
+caml_unix_set_nonblock
+caml_unix_setsockopt
+caml_unix_shutdown
+caml_unix_sleep
+caml_unix_socket
+caml_unix_socketpair
+caml_unix_string_of_inet_addr
+caml_unix_system
+caml_unix_terminate_process
+caml_unix_waitpid
+debugger
+
+Unused
+-------
+
+From +array.js:
+caml_check_bound
+
+From +bigarray.js:
+caml_ba_create_from (deprecated)
+caml_ba_init
+
+From +bigstring.js:
+caml_bigstring_blit_ba_to_ba
+caml_bigstring_blit_ba_to_bytes
+caml_bigstring_blit_bytes_to_ba
+caml_bigstring_blit_string_to_ba
+caml_bigstring_memcmp
+caml_hash_mix_bigstring
+
+From +effect.js:
+jsoo_effect_not_supported
+
+From +fs.js:
+caml_ba_map_file
+caml_ba_map_file_bytecode
+caml_fs_init
+jsoo_create_file
+jsoo_create_file_extern
+
+From +graphics.js:
+caml_gr_arc_aux
+caml_gr_blit_image
+caml_gr_clear_graph
+caml_gr_close_graph
+caml_gr_close_subwindow
+caml_gr_create_image
+caml_gr_current_x
+caml_gr_current_y
+caml_gr_display_mode
+caml_gr_doc_of_state
+caml_gr_draw_arc
+caml_gr_draw_char
+caml_gr_draw_image
+caml_gr_draw_rect
+caml_gr_draw_str
+caml_gr_draw_string
+caml_gr_dump_image
+caml_gr_fill_arc
+caml_gr_fill_poly
+caml_gr_fill_rect
+caml_gr_lineto
+caml_gr_make_image
+caml_gr_moveto
+caml_gr_open_graph
+caml_gr_open_subwindow
+caml_gr_plot
+caml_gr_point_color
+caml_gr_remember_mode
+caml_gr_resize_window
+caml_gr_set_color
+caml_gr_set_font
+caml_gr_set_line_width
+caml_gr_set_text_size
+caml_gr_set_window_title
+caml_gr_sigio_handler
+caml_gr_sigio_signal
+caml_gr_size_x
+caml_gr_size_y
+caml_gr_state
+caml_gr_state_create
+caml_gr_state_get
+caml_gr_state_init
+caml_gr_state_set
+caml_gr_synchronize
+caml_gr_text_size
+caml_gr_wait_event
+caml_gr_window_id
+
+From +hash.js:
+caml_hash_mix_int64
+
+From +ints.js:
+caml_div
+caml_mod
+
+From +jslib.js:
+caml_is_js
+caml_trampoline
+caml_trampoline_return
+caml_wrap_exception
+
+From +marshal.js:
+caml_marshal_constants
+
+From +mlBytes.js:
+caml_array_of_bytes (deprecated)
+caml_array_of_string (deprecated)
+caml_bytes_of_utf16_jsstring
+caml_new_string (deprecated)
+caml_string_concat
+caml_to_js_string (deprecated)
+
+From +runtime_events.js:
+caml_runtime_events_create_cursor
+caml_runtime_events_free_cursor
+caml_runtime_events_read_poll
+caml_runtime_events_user_resolve
+
+From +stdlib.js:
+caml_is_printable
+caml_maybe_print_stats
+
+From +sys.js:
+caml_fatal_uncaught_exception
+caml_format_exception
+caml_is_special_exception
+caml_set_static_env
+caml_sys_const_naked_pointers_checked
+
+From +toplevel.js:
+jsoo_get_runtime_aliases
+jsoo_toplevel_init_compile
+jsoo_toplevel_init_reloc
+
+From +unix.js:
+caml_strerror
+caml_unix_fchmod
+caml_unix_getegid
+caml_unix_geteuid
+caml_unix_getgid
+caml_unix_getpwnam
+caml_unix_getuid
+caml_unix_rewinddir
+unix_error_message
+
diff --git a/compiler/tests-jsoo/custom.js b/compiler/tests-jsoo/custom.js
@@ -0,0 +1,5 @@
+//Provides: process
+var process = "process";
+
+//Provides: obj
+var obj = { process: 42 };
diff --git a/compiler/tests-jsoo/custom.wat b/compiler/tests-jsoo/custom.wat
@@ -0,0 +1,7 @@
+;; This ensures that the referenced JavaScript values are linked in the
+;; runtime with separate compilation and is optimized away in case of
+;; whole program compilation.
+
+(global (export "_caml_js_delete") (import "js" "caml_js_delete") anyref)
+(global (export "_process") (import "js" "process") anyref)
+(global (export "_obj") (import "js" "obj") anyref)
diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune
@@ -48,6 +48,7 @@
    test_bigarray
    test_marshal_compressed
    test_parsing
+   test_custom
    calc_parser
    calc_lexer))
  (libraries unix compiler-libs.common js_of_ocaml-compiler)
@@ -66,6 +67,16 @@
  (modules test_float16 test_bigarray)
  (modes js wasm native))
 
+(test
+ (name test_custom)
+ (modules test_custom)
+ (libraries js_of_ocaml)
+ (js_of_ocaml
+  (javascript_files custom.js))
+ (wasm_of_ocaml
+  (javascript_files custom.js custom.wat))
+ (modes js wasm))
+
 (ocamlyacc calc_parser)
 
 (ocamllex calc_lexer)
diff --git a/compiler/tests-jsoo/test_custom.ml b/compiler/tests-jsoo/test_custom.ml
@@ -0,0 +1,8 @@
+open Js_of_ocaml
+
+let () =
+  let p : Js.js_string Js.t = Jsoo_runtime.Sys.external_ "process" in
+  let o : _ Js.t = Jsoo_runtime.Sys.external_ "obj" in
+  let del = Jsoo_runtime.Sys.external_ "caml_js_delete" in
+  ignore (Js.Unsafe.fun_call del [| o; Js.Unsafe.coerce (Js.string "process") |]);
+  print_endline (Js.to_string p)
diff --git a/lib/runtime/js_of_ocaml_runtime_stubs.c b/lib/runtime/js_of_ocaml_runtime_stubs.c
@@ -208,6 +208,10 @@ void caml_jsoo_flags_use_js_string () {
   caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_flags_use_js_string!");
 }
 
+void caml_jsoo_runtime () {
+  caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_runtime!");
+}
+
 void caml_jsstring_of_string () {
   caml_fatal_error("Unimplemented Javascript primitive caml_jsstring_of_string!");
 }
diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml
@@ -124,6 +124,8 @@ module Sys = struct
   external restore_channel : out_channel -> redirection -> unit
     = "caml_ml_channel_restore"
 
+  external external_ : string -> 'a = "caml_jsoo_runtime"
+
   module Config = struct
     external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string"
 
