Some JavaScript interface optimizations

Avoid allocating an array to pass parameters by generating specific
JavaScript code for function and method calls.

compiler/bin-wasm_of_ocaml/compile.ml

@@ -162,7 +162,7 @@ let escape_string s =
   done;
   Buffer.contents b
 
-let build_js_runtime primitives (strings : string list) wasm_file output_file =
+let build_js_runtime primitives (strings, fragments) wasm_file output_file =
   let always_required_js, primitives =
     let l =
       StringSet.fold
@@ -200,6 +200,21 @@ let build_js_runtime primitives (strings : string list) wasm_file output_file =
                    strings))
          , Javascript.N )
        ]);
+  let fragment_buffer = Buffer.create 1024 in
+  let f = Pretty_print.to_buffer fragment_buffer in
+  Pretty_print.set_compact f (not (Config.Flag.pretty ()));
+  ignore
+    (Js_output.program
+       f
+       [ ( Javascript.Expression_statement
+             (EObj
+                (List.map
+                   ~f:(fun (nm, f) ->
+                     let id = Utf8_string.of_string_exn nm in
+                     Javascript.Property (PNI id, f))
+                   fragments))
+         , Javascript.N )
+       ]);
   let s = Wa_runtime.js_runtime in
   let rec find pat i =
     if String.equal (String.sub s ~pos:i ~len:(String.length pat)) pat
@@ -227,6 +242,8 @@ let build_js_runtime primitives (strings : string list) wasm_file output_file =
     ^ trim_semi (Buffer.contents b')
     ^ String.sub s ~pos:(j + 10) ~len:(k - j - 10)
     ^ trim_semi (Buffer.contents b'')
+    ^ ","
+    ^ trim_semi (Buffer.contents fragment_buffer)
     ^ String.sub s ~pos:(k + 7) ~len:(String.length s - k - 7))
 
 let run { Cmd_arg.common; profile; runtime_files; input_file; output_file; params } =

compiler/lib/driver.ml

@@ -615,13 +615,13 @@ let full ~target ~standalone ~wrap_with_fun ~profile ~linkall ~source_map d p =
   match target with
   | `JavaScript formatter ->
       let source_map = emit formatter r in
-      source_map, []
+      source_map, ([], [])
   | `Wasm ch ->
       let (p, live_vars), _, in_cps = r in
       None, Wa_generate.f ch ~live_vars ~in_cps p
 
 let full_no_source_map ~target ~standalone ~wrap_with_fun ~profile ~linkall d p =
-  let (_ : Source_map.t option * string list) =
+  let (_ : Source_map.t option * _) =
     full ~target ~standalone ~wrap_with_fun ~profile ~linkall ~source_map:None d p
   in
   ()

compiler/lib/driver.mli

@@ -29,7 +29,7 @@ val f :
   -> ?source_map:Source_map.t
   -> Parse_bytecode.Debug.t
   -> Code.program
-  -> Source_map.t option * string list
+  -> Source_map.t option * (string list * (string * Javascript.expression) list)
 
 val f' :
      ?standalone:bool

compiler/lib/specialize_js.ml

@@ -53,19 +53,19 @@ let specialize_instr ~target info i =
           Let (x, Prim (Extern prim, [ Pc (String s); z ]))
       | Some _ -> Let (x, Constant (Int (Regular, 0l)))
       | None -> i)
-  | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), `JavaScript -> (
+  | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> (
       match the_def_of info a with
       | Some (Block (_, a, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in
           Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a))
       | _ -> i)
-  | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), `JavaScript -> (
+  | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> (
       match the_def_of info a with
       | Some (Block (_, a, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in
           Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a))
       | _ -> i)
-  | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), `JavaScript -> (
+  | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> (
       match the_string_of info m with
       | Some m when Javascript.is_ident m -> (
           match the_def_of info a with
@@ -80,7 +80,7 @@ let specialize_instr ~target info i =
                       :: Array.to_list a ) )
           | _ -> i)
       | _ -> i)
-  | Let (x, Prim (Extern "caml_js_new", [ c; a ])), `JavaScript -> (
+  | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> (
       match the_def_of info a with
       | Some (Block (_, a, _)) ->
           let a = Array.map a ~f:(fun x -> Pv x) in

compiler/lib/wasm/wa_code_generation.ml

@@ -36,6 +36,7 @@ type context =
   ; mutable init_code : W.instruction list
   ; mutable string_count : int
   ; mutable strings : string list
+  ; mutable fragments : Javascript.expression StringMap.t
   }
 
 let make_context () =
@@ -55,6 +56,7 @@ let make_context () =
   ; init_code = []
   ; string_count = 0
   ; strings = []
+  ; fragments = StringMap.empty
   }
 
 type var =
@@ -182,6 +184,12 @@ let register_string s st =
   context.strings <- s :: context.strings;
   n, st
 
+let register_fragment name f st =
+  let context = st.context in
+  if not (StringMap.mem name context.fragments)
+  then context.fragments <- StringMap.add name (f ()) context.fragments;
+  (), st
+
 let set_closure_env f env st =
   st.context.closure_envs <- Var.Map.add f env st.context.closure_envs;
   (), st

compiler/lib/wasm/wa_code_generation.mli

@@ -20,6 +20,7 @@ type context =
   ; mutable init_code : Wa_ast.instruction list
   ; mutable string_count : int
   ; mutable strings : string list
+  ; mutable fragments : Javascript.expression StringMap.t
   }
 
 val make_context : unit -> context
@@ -140,6 +141,8 @@ val init_code : context -> unit t
 
 val register_string : string -> int t
 
+val register_fragment : string -> (unit -> Javascript.expression) -> unit t
+
 val get_context : context t
 
 val set_closure_env : Code.Var.t -> Code.Var.t -> unit t

compiler/lib/wasm/wa_core_target.ml

@@ -620,6 +620,8 @@ module Math = struct
   let fmod f g = binary "fmod" f g
 end
 
+let internal_primitives = Hashtbl.create 0
+
 let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler =
   let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Value.value) in
   try_

compiler/lib/wasm/wa_gc_target.ml

@@ -1230,6 +1230,155 @@ module Math = struct
   let exp2 x = power (return (W.Const (F64 2.))) x
 end
 
+module JavaScript = struct
+  let anyref = W.Ref { nullable = true; typ = Any }
+
+  let invoke_fragment name args =
+    let* f =
+      register_import
+        ~import_module:"fragments"
+        ~name
+        (Fun { params = List.map ~f:(fun _ -> anyref) args; result = [ anyref ] })
+    in
+    let* wrap =
+      register_import ~name:"wrap" (Fun { params = [ anyref ]; result = [ Type.value ] })
+    in
+    let* unwrap =
+      register_import
+        ~name:"unwrap"
+        (Fun { params = [ Type.value ]; result = [ anyref ] })
+    in
+    let* args =
+      expression_list
+        (fun e ->
+          let* e = e in
+          return (W.Call (unwrap, [ e ])))
+        args
+    in
+    return (W.Call (wrap, [ Call (f, args) ]))
+end
+
+let internal_primitives = Hashtbl.create 100
+
+let () =
+  let register name f = Hashtbl.add internal_primitives name f in
+  let module J = Javascript in
+  register "%caml_js_opt_call" (fun transl_prim_arg l ->
+      let arity = List.length l - 2 in
+      let name = Printf.sprintf "call_%d" arity in
+      let* () =
+        register_fragment name (fun () ->
+            let f = Utf8_string.of_string_exn "f" in
+            let o = Utf8_string.of_string_exn "o" in
+            let params =
+              List.init ~len:arity ~f:(fun i ->
+                  Utf8_string.of_string_exn (Printf.sprintf "x%d" i))
+            in
+            EArrow
+              ( J.fun_
+                  (List.map ~f:J.ident (f :: params))
+                  [ ( Return_statement
+                        (Some
+                           (J.call
+                              (J.dot
+                                 (EVar (J.ident f))
+                                 (Utf8_string.of_string_exn "call"))
+                              (List.map ~f:(fun x -> J.EVar (J.ident x)) (o :: params))
+                              N))
+                    , N )
+                  ]
+                  N
+              , AUnknown ))
+      in
+      let l = List.map ~f:transl_prim_arg l in
+      JavaScript.invoke_fragment name l);
+  register "%caml_js_opt_fun_call" (fun transl_prim_arg l ->
+      let arity = List.length l - 1 in
+      let name = Printf.sprintf "fun_call_%d" arity in
+      let* () =
+        register_fragment name (fun () ->
+            let f = Utf8_string.of_string_exn "f" in
+            let params =
+              List.init ~len:arity ~f:(fun i ->
+                  Utf8_string.of_string_exn (Printf.sprintf "x%d" i))
+            in
+            EArrow
+              ( J.fun_
+                  (List.map ~f:J.ident (f :: params))
+                  [ ( Return_statement
+                        (Some
+                           (J.call
+                              (EVar (J.ident f))
+                              (List.map ~f:(fun x -> J.EVar (J.ident x)) params)
+                              N))
+                    , N )
+                  ]
+                  N
+              , AUnknown ))
+      in
+      let l = List.map ~f:transl_prim_arg l in
+      JavaScript.invoke_fragment name l);
+  register "%caml_js_opt_meth_call" (fun transl_prim_arg l ->
+      match l with
+      | o :: Code.Pc (NativeString (Utf meth)) :: args ->
+          let arity = List.length args in
+          let name =
+            let (Utf8 name) = meth in
+            Printf.sprintf "meth_call_%d_%s" arity name
+          in
+          let* () =
+            register_fragment name (fun () ->
+                let o = Utf8_string.of_string_exn "o" in
+                let params =
+                  List.init ~len:arity ~f:(fun i ->
+                      Utf8_string.of_string_exn (Printf.sprintf "x%d" i))
+                in
+                EArrow
+                  ( J.fun_
+                      (List.map ~f:J.ident (o :: params))
+                      [ ( Return_statement
+                            (Some
+                               (J.call
+                                  (J.dot (EVar (J.ident o)) meth)
+                                  (List.map ~f:(fun x -> J.EVar (J.ident x)) params)
+                                  N))
+                        , N )
+                      ]
+                      N
+                  , AUnknown ))
+          in
+          let o = transl_prim_arg o in
+          let args = List.map ~f:transl_prim_arg args in
+          JavaScript.invoke_fragment name (o :: args)
+      | _ -> assert false);
+  register "%caml_js_opt_new" (fun transl_prim_arg l ->
+      let arity = List.length l - 1 in
+      let name = Printf.sprintf "new_%d" arity in
+      let* () =
+        register_fragment name (fun () ->
+            let c = Utf8_string.of_string_exn "c" in
+            let params =
+              List.init ~len:arity ~f:(fun i ->
+                  Utf8_string.of_string_exn (Printf.sprintf "x%d" i))
+            in
+            EArrow
+              ( J.fun_
+                  (List.map ~f:J.ident (c :: params))
+                  [ ( Return_statement
+                        (Some
+                           (ENew
+                              ( EVar (J.ident c)
+                              , Some
+                                  (List.map ~f:(fun x -> J.Arg (EVar (J.ident x))) params)
+                              )))
+                    , N )
+                  ]
+                  N
+              , AUnknown ))
+      in
+      let l = List.map ~f:transl_prim_arg l in
+      JavaScript.invoke_fragment name l)
+
 let externref = W.Ref { nullable = true; typ = Extern }
 
 let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler =