Wasm_of_ocaml: more efficient definition of constant Javascript strings

CHANGES.md

@@ -19,6 +19,7 @@
 * Runtime/wasm: support jsoo_env and keep track of backtrace status (#1881)
 * Runtime/wasm: support unmarshaling compressed data (#1898)
 * Runtime/wasm: make resuming a continuation more efficient in Wasm (#1892)
+* Runtime/wasm: use imported string constants for JavaScript strings (#2022)
 * Compiler: improve performance of Javascript linking
 * Compiler: remove empty blocks (#1934)
 * Ppx: explicitly disallow polymorphic method (#1897)

compiler/bin-wasm_of_ocaml/compile.ml

@@ -484,7 +484,7 @@ let run
             then Some (Filename.temp_file unit_name ".wasm.map")
             else None)
          @@ fun opt_input_sourcemap ->
-         let strings, fragments =
+         let fragments =
            output
              code
              ~wat_file:
@@ -500,7 +500,7 @@ let run
            ~input_file
            ~output_file:tmp_wasm_file
            ();
-         { Link.unit_name; unit_info; strings; fragments }
+         { Link.unit_name; unit_info; fragments }
        in
        cont unit_data unit_name tmp_wasm_file opt_tmp_map_file
      in

compiler/lib-wasm/code_generation.ml

@@ -53,9 +53,6 @@ type context =
   ; mutable dummy_funs : Var.t IntMap.t
   ; mutable cps_dummy_funs : Var.t IntMap.t
   ; mutable init_code : W.instruction list
-  ; mutable string_count : int
-  ; mutable strings : string list
-  ; mutable string_index : int StringMap.t
   ; mutable fragments : Javascript.expression StringMap.t
   ; mutable globalized_variables : Var.Set.t
   ; value_type : W.value_type
@@ -78,9 +75,6 @@ let make_context ~value_type =
   ; dummy_funs = IntMap.empty
   ; cps_dummy_funs = IntMap.empty
   ; init_code = []
-  ; string_count = 0
-  ; strings = []
-  ; string_index = StringMap.empty
   ; fragments = StringMap.empty
   ; globalized_variables = Var.Set.empty
   ; value_type
@@ -254,16 +248,6 @@ let register_init_code code st =
   st.context.init_code <- st'.instrs @ st.context.init_code;
   (), st
 
-let register_string s st =
-  let context = st.context in
-  try StringMap.find s context.string_index, st
-  with Not_found ->
-    let n = context.string_count in
-    context.string_count <- 1 + context.string_count;
-    context.strings <- s :: context.strings;
-    context.string_index <- StringMap.add s n context.string_index;
-    n, st
-
 let register_fragment name f st =
   let context = st.context in
   if not (StringMap.mem name context.fragments)
@@ -476,7 +460,8 @@ let rec is_smi e =
   | Br_on_cast_fail _
   | Br_on_null _
   | Try _
-  | ExternConvertAny _ -> false
+  | ExternConvertAny _
+  | AnyConvertExtern _ -> false
   | BinOp ((F32 _ | F64 _), _, _) | RefTest _ | RefEq _ -> true
   | IfExpr (_, _, ift, iff) -> is_smi ift && is_smi iff
 

compiler/lib-wasm/code_generation.mli

@@ -37,9 +37,6 @@ type context =
   ; mutable dummy_funs : Code.Var.t Stdlib.IntMap.t
   ; mutable cps_dummy_funs : Code.Var.t Stdlib.IntMap.t
   ; mutable init_code : Wasm_ast.instruction list
-  ; mutable string_count : int
-  ; mutable strings : string list
-  ; mutable string_index : int StringMap.t
   ; mutable fragments : Javascript.expression StringMap.t
   ; mutable globalized_variables : Code.Var.Set.t
   ; value_type : Wasm_ast.value_type
@@ -178,8 +175,6 @@ val register_init_code : unit t -> unit t
 
 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

compiler/lib-wasm/gc_target.ml

@@ -514,7 +514,8 @@ module Value = struct
     | StructGet (_, _, _, e')
     | RefCast (_, e')
     | RefTest (_, e')
-    | ExternConvertAny e' -> effect_free e'
+    | ExternConvertAny e'
+    | AnyConvertExtern e' -> effect_free e'
     | BinOp (_, e1, e2)
     | ArrayNew (_, e1, e2)
     | ArrayNewData (_, _, e1, e2)
@@ -912,20 +913,12 @@ module Constant = struct
     let* () = register_global name { mut = false; typ = Type.value } c in
     return (W.GlobalGet name)
 
-  let str_js_utf8 s =
+  let byte_string s =
     let b = Buffer.create (String.length s) in
     String.iter s ~f:(function
-      | '\\' -> Buffer.add_string b "\\\\"
-      | c -> Buffer.add_char b c);
-    Buffer.contents b
-
-  let str_js_byte s =
-    let b = Buffer.create (String.length s) in
-    String.iter s ~f:(function
-      | '\\' -> Buffer.add_string b "\\\\"
       | '\128' .. '\255' as c ->
-          Buffer.add_string b "\\x";
-          Buffer.add_char_hex b c
+          Buffer.add_char b (Char.chr (0xC2 lor (Char.code c lsr 6)));
+          Buffer.add_char b (Char.chr (0x80 lor (Char.code c land 0x3F)))
       | c -> Buffer.add_char b c);
     Buffer.contents b
 
@@ -989,22 +982,18 @@ module Constant = struct
     | NativeString s ->
         let s =
           match s with
-          | Utf (Utf8 s) -> str_js_utf8 s
-          | Byte s -> str_js_byte s
+          | Utf (Utf8 s) -> s
+          | Byte s -> byte_string s
         in
-        let* i = register_string s in
         let* x =
-          let* name = unit_name in
           register_import
-            ~import_module:
-              (match name with
-              | None -> "strings"
-              | Some name -> name ^ ".strings")
-            ~name:(string_of_int i)
-            (Global { mut = false; typ = Ref { nullable = false; typ = Any } })
+            ~import_module:"str"
+            ~name:s
+            (Global { mut = false; typ = Ref { nullable = false; typ = Extern } })
         in
         let* ty = Type.js_type in
-        return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet x ]))
+        return
+          (Const_named ("str_" ^ s), W.StructNew (ty, [ AnyConvertExtern (GlobalGet x) ]))
     | String s ->
         let* ty = Type.string_type in
         if String.length s >= string_length_threshold

compiler/lib-wasm/generate.ml

@@ -1217,12 +1217,7 @@ module Generate (Target : Target_sig.S) = struct
     in
     global_context.init_code <- [];
     global_context.other_fields <- List.rev_append functions global_context.other_fields;
-    let js_code =
-      List.rev global_context.strings, StringMap.bindings global_context.fragments
-    in
-    global_context.string_count <- 0;
-    global_context.strings <- [];
-    global_context.string_index <- StringMap.empty;
+    let js_code = StringMap.bindings global_context.fragments in
     global_context.fragments <- StringMap.empty;
     toplevel_name, js_code
 

compiler/lib-wasm/generate.mli

@@ -27,7 +27,7 @@ val f :
   -> live_vars:int array
   -> in_cps:Effects.in_cps
   -> deadcode_sentinal:Code.Var.t
-  -> Wasm_ast.var * (string list * (string * Javascript.expression) list)
+  -> Wasm_ast.var * (string * Javascript.expression) list
 
 val add_start_function : context:Code_generation.context -> Wasm_ast.var -> unit
 

compiler/lib-wasm/initialize_locals.ml

@@ -47,8 +47,9 @@ let rec scan_expression ctx e =
   | RefTest (_, e')
   | Br_on_cast (_, _, _, e')
   | Br_on_cast_fail (_, _, _, e')
-  | Br_on_null (_, e') -> scan_expression ctx e'
-  | ExternConvertAny e' -> scan_expression ctx e'
+  | Br_on_null (_, e')
+  | ExternConvertAny e'
+  | AnyConvertExtern e' -> scan_expression ctx e'
   | BinOp (_, e', e'')
   | ArrayNew (_, e', e'')
   | ArrayNewData (_, _, e', e'')

compiler/lib-wasm/link.ml

@@ -314,22 +314,17 @@ let trim_semi s =
 type unit_data =
   { unit_name : string
   ; unit_info : Unit_info.t
-  ; strings : string list
   ; fragments : (string * Javascript.expression) list
   }
 
 let info_to_sexp ~predefined_exceptions ~build_info ~unit_data =
   let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in
   let units =
     List.map
-      ~f:(fun { unit_name; unit_info; strings; fragments } ->
+      ~f:(fun { unit_name; unit_info; fragments } ->
         Sexp.List
           (Unit_info.to_sexp unit_info
           |> add "name" false [ Atom unit_name ]
-          |> add
-               "strings"
-               (List.is_empty strings)
-               (List.map ~f:(fun s -> Sexp.Atom s) strings)
           |> add
                "fragments"
                (List.is_empty fragments)
@@ -366,9 +361,6 @@ let info_from_sexp info =
            let unit_name =
              u |> member "name" |> Option.value ~default:[] |> single string
            in
-           let strings =
-             u |> member "strings" |> Option.value ~default:[] |> List.map ~f:string
-           in
            let fragments =
              u
              |> member "fragments"
@@ -383,7 +375,7 @@ let info_from_sexp info =
                                   , let lex = Parse_js.Lexer.of_string (to_string e) in
                                     Parse_js.parse_expr lex ))*)
            in
-           { unit_name; unit_info; strings; fragments })
+           { unit_name; unit_info; fragments })
   in
   build_info, predefined_exceptions, unit_data
 
@@ -444,28 +436,13 @@ let build_runtime_arguments
   let generated_js =
     List.concat
     @@ List.map
-         ~f:(fun (unit_name, (strings, fragments)) ->
+         ~f:(fun (unit_name, fragments) ->
            let name s =
              match unit_name with
              | None -> s
              | Some nm -> nm ^ "." ^ s
            in
-           let strings =
-             if List.is_empty strings
-             then []
-             else
-               [ ( name "strings"
-                 , Javascript.EArr
-                     (List.map
-                        ~f:(fun s ->
-                          Javascript.Element (EStr (Utf8_string.of_string_exn s)))
-                        strings) )
-               ]
-           in
-           let fragments =
-             if List.is_empty fragments then [] else [ name "fragments", obj fragments ]
-           in
-           strings @ fragments)
+           if List.is_empty fragments then [] else [ name "fragments", obj fragments ])
          generated_js
   in
   let generated_js =
@@ -821,8 +798,8 @@ let link ~output_file ~linkall ~enable_source_maps ~files =
   let generated_js =
     List.concat
     @@ List.map files ~f:(fun (_, (_, units)) ->
-           List.map units ~f:(fun { unit_name; strings; fragments; _ } ->
-               Some unit_name, (strings, fragments)))
+           List.map units ~f:(fun { unit_name; fragments; _ } ->
+               Some unit_name, fragments))
   in
   let runtime_args =
     let js =

compiler/lib-wasm/link.mli

@@ -38,7 +38,6 @@ end
 type unit_data =
   { unit_name : string
   ; unit_info : Unit_info.t
-  ; strings : string list
   ; fragments : (string * Javascript.expression) list
   }
 
@@ -55,8 +54,7 @@ val build_runtime_arguments :
   -> separate_compilation:bool
   -> missing_primitives:string list
   -> wasm_dir:string
-  -> generated_js:
-       (string option * (string list * (string * Javascript.expression) list)) list
+  -> generated_js:(string option * (string * Javascript.expression) list) list
   -> unit
   -> Javascript.expression
 

compiler/lib-wasm/wasm_ast.ml

@@ -171,6 +171,7 @@ type expression =
   | IfExpr of value_type * expression * expression * expression
   | Try of func_type * instruction list * (var * int * value_type) list
   | ExternConvertAny of expression
+  | AnyConvertExtern of expression
 
 and instruction =
   | Drop of expression

compiler/lib-wasm/wasm_output.ml

@@ -702,6 +702,11 @@ end = struct
         output_expression st ch e';
         output_byte ch 0xFB;
         output_byte ch 0x1B
+    | AnyConvertExtern e' ->
+        Feature.require gc;
+        output_expression st ch e';
+        output_byte ch 0xFB;
+        output_byte ch 0x1A
 
   and output_instruction st ch i =
     match i with
@@ -918,8 +923,9 @@ end = struct
     | RefTest (_, e')
     | Br_on_cast (_, _, _, e')
     | Br_on_cast_fail (_, _, _, e')
-    | Br_on_null (_, e') -> expr_function_references e' set
-    | ExternConvertAny e' -> expr_function_references e' set
+    | Br_on_null (_, e')
+    | ExternConvertAny e'
+    | AnyConvertExtern e' -> expr_function_references e' set
     | BinOp (_, e', e'')
     | ArrayNew (_, e', e'')
     | ArrayNewData (_, _, e', e'')

compiler/lib-wasm/wat_output.ml

@@ -147,6 +147,16 @@ let rec format_sexp f s =
       Format.pp_print_string f ";;";
       Format.pp_print_string f s
 
+let escape_string s =
+  let b = Buffer.create (String.length s + 2) in
+  for i = 0 to String.length s - 1 do
+    let c = s.[i] in
+    if Char.(c >= ' ' && c <= '~' && c <> '"' && c <> '\\')
+    then Buffer.add_char b c
+    else Printf.bprintf b "\\%02x" (Char.code c)
+  done;
+  Buffer.contents b
+
 let index tbl x = Atom ("$" ^ Code.Var.Hashtbl.find tbl x)
 
 let heap_type st (ty : heap_type) =
@@ -215,7 +225,7 @@ let str_type st typ =
 
 let block_type = func_type
 
-let quoted_name name = Atom ("\"" ^ name ^ "\"")
+let quoted_name name = Atom ("\"" ^ escape_string name ^ "\"")
 
 let export name =
   match name with
@@ -481,6 +491,7 @@ let expression_or_instructions ctx st in_function =
                       catches))
         ]
     | ExternConvertAny e' -> [ List (Atom "extern.convert_any" :: expression e') ]
+    | AnyConvertExtern e' -> [ List (Atom "any.convert_extern" :: expression e') ]
   and instruction i =
     match i with
     | Drop e -> [ List (Atom "drop" :: expression e) ]
@@ -612,16 +623,6 @@ let import st f =
           ]
       ]
 
-let escape_string s =
-  let b = Buffer.create (String.length s + 2) in
-  for i = 0 to String.length s - 1 do
-    let c = s.[i] in
-    if Char.(c >= ' ' && c <= '~' && c <> '"' && c <> '\\')
-    then Buffer.add_char b c
-    else Printf.bprintf b "\\%02x" (Char.code c)
-  done;
-  Buffer.contents b
-
 let type_field st { name; typ; supertype; final } =
   if final && Option.is_none supertype
   then List [ Atom "type"; index st.type_names name; str_type st typ ]