Wasm_of_ocaml: implement use-js-string flag

Author: vouillon

compiler/lib-wasm/gc_target.ml

@@ -35,14 +35,31 @@ module Type = struct
           ; typ = W.Array { mut = true; typ = Value value }
           })
 
-  let string_type =
-    register_type "string" (fun () ->
+  let bytes_type =
+    register_type "bytes" (fun () ->
         return
           { supertype = None
           ; final = true
           ; typ = W.Array { mut = true; typ = Packed I8 }
           })
 
+  let string_type =
+    register_type "string" (fun () ->
+        return
+          (if Config.Flag.use_js_string ()
+           then
+             { supertype = None
+             ; final = true
+             ; typ =
+                 W.Struct
+                   [ { mut = false; typ = Value (Ref { nullable = true; typ = Any }) } ]
+             }
+           else
+             { supertype = None
+             ; final = true
+             ; typ = W.Array { mut = true; typ = Packed I8 }
+             }))
+
   let float_type =
     register_type "float" (fun () ->
         return
@@ -121,7 +138,7 @@ module Type = struct
 
   let custom_operations_type =
     register_type "custom_operations" (fun () ->
-        let* string = string_type in
+        let* bytes = bytes_type in
         let* compare = compare_type in
         let* hash = hash_type in
         let* fixed_length = fixed_length_type in
@@ -134,7 +151,7 @@ module Type = struct
           ; typ =
               W.Struct
                 [ { mut = false
-                  ; typ = Value (Ref { nullable = false; typ = Type string })
+                  ; typ = Value (Ref { nullable = false; typ = Type bytes })
                   }
                 ; { mut = false
                   ; typ = Value (Ref { nullable = true; typ = Type compare })
@@ -794,15 +811,50 @@ module Memory = struct
        wasm_array_set ~ty:Type.float_array_type (load a) (load i) (unbox_float (load v)))
 
   let bytes_length e =
-    let* ty = Type.string_type in
+    let* ty = Type.bytes_type in
     let* e = wasm_cast ty e in
     return (W.ArrayLen e)
 
   let bytes_get e e' =
-    Value.val_int (wasm_array_get ~ty:Type.string_type e (Value.int_val e'))
+    Value.val_int (wasm_array_get ~ty:Type.bytes_type e (Value.int_val e'))
 
   let bytes_set e e' e'' =
-    wasm_array_set ~ty:Type.string_type e (Value.int_val e') (Value.int_val e'')
+    wasm_array_set ~ty:Type.bytes_type e (Value.int_val e') (Value.int_val e'')
+
+  let string_value e =
+    let* string = Type.string_type in
+    let* e = wasm_struct_get string (wasm_cast string e) 0 in
+    return (W.ExternConvertAny e)
+
+  let string_length e =
+    if Config.Flag.use_js_string ()
+    then
+      let* f =
+        register_import
+          ~import_module:"wasm:js-string"
+          ~name:"length"
+          (Fun { W.params = [ Ref { nullable = true; typ = Extern } ]; result = [ I32 ] })
+      in
+      let* e = string_value e in
+      return (W.Call (f, [ e ]))
+    else bytes_length e
+
+  let string_get e e' =
+    if Config.Flag.use_js_string ()
+    then
+      let* f =
+        register_import
+          ~import_module:"wasm:js-string"
+          ~name:"charCodeAt"
+          (Fun
+             { W.params = [ Ref { nullable = true; typ = Extern }; I32 ]
+             ; result = [ I32 ]
+             })
+      in
+      let* e = string_value e in
+      let* e' = Value.int_val e' in
+      Value.val_int (return (W.Call (f, [ e; e' ])))
+    else bytes_get e e'
 
   let field e idx = wasm_array_get e (Arith.const (Int32.of_int (idx + 1)))
 
@@ -929,6 +981,21 @@ module Constant = struct
     | Const_named of string
     | Mutated
 
+  let translate_js_string s =
+    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 } })
+    in
+    let* ty = Type.js_type in
+    return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet x ]))
+
   let rec translate_rec c =
     match c with
     | Code.Int i -> return (Const, W.RefI31 (Const (I32 (Targetint.to_int32 i))))
@@ -987,38 +1054,29 @@ module Constant = struct
           | Utf (Utf8 s) -> str_js_utf8 s
           | Byte s -> str_js_byte 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 } })
-        in
-        let* ty = Type.js_type in
-        return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet x ]))
+        translate_js_string s
     | String s ->
-        let* ty = Type.string_type in
-        if String.length s >= string_length_threshold
-        then
-          let name = Code.Var.fresh_n "string" in
-          let* () = register_data_segment name s in
-          return
-            ( Mutated
-            , W.ArrayNewData
-                (ty, name, Const (I32 0l), Const (I32 (Int32.of_int (String.length s))))
-            )
+        if Config.Flag.use_js_string ()
+        then translate_js_string (str_js_byte s)
         else
-          let l =
-            String.fold_right
-              ~f:(fun c r -> W.Const (I32 (Int32.of_int (Char.code c))) :: r)
-              s
-              ~init:[]
-          in
-          return (Const_named ("str_" ^ s), W.ArrayNewFixed (ty, l))
+          let* ty = Type.string_type in
+          if String.length s >= string_length_threshold
+          then
+            let name = Code.Var.fresh_n "string" in
+            let* () = register_data_segment name s in
+            return
+              ( Mutated
+              , W.ArrayNewData
+                  (ty, name, Const (I32 0l), Const (I32 (Int32.of_int (String.length s))))
+              )
+          else
+            let l =
+              String.fold_right
+                ~f:(fun c r -> W.Const (I32 (Int32.of_int (Char.code c))) :: r)
+                s
+                ~init:[]
+            in
+            return (Const_named ("str_" ^ s), W.ArrayNewFixed (ty, l))
     | Float f ->
         let* ty = Type.float_type in
         return (Const, W.StructNew (ty, [ Const (F64 f) ]))

compiler/lib-wasm/generate.ml

@@ -285,22 +285,29 @@ module Generate (Target : Target_sig.S) = struct
                 seq (Memory.array_set x y z) Value.unit
             | Extern "caml_floatarray_unsafe_set", [ x; y; z ] ->
                 seq (Memory.float_array_set x y z) Value.unit
-            | Extern ("caml_string_unsafe_get" | "caml_bytes_unsafe_get"), [ x; y ] ->
-                Memory.bytes_get x y
-            | Extern ("caml_string_unsafe_set" | "caml_bytes_unsafe_set"), [ x; y; z ] ->
+            | Extern "caml_string_unsafe_get", [ x; y ] -> Memory.string_get x y
+            | Extern "caml_bytes_unsafe_get", [ x; y ] -> Memory.bytes_get x y
+            | Extern "caml_bytes_unsafe_set", [ x; y; z ] ->
                 seq (Memory.bytes_set x y z) Value.unit
-            | Extern ("caml_string_get" | "caml_bytes_get"), [ x; y ] ->
+            | Extern "caml_string_get", [ x; y ] ->
+                seq
+                  (let* cond = Arith.uge (Value.int_val y) (Memory.string_length x) in
+                   instr (W.Br_if (label_index context bound_error_pc, cond)))
+                  (Memory.string_get x y)
+            | Extern "caml_bytes_get", [ x; y ] ->
                 seq
                   (let* cond = Arith.uge (Value.int_val y) (Memory.bytes_length x) in
                    instr (W.Br_if (label_index context bound_error_pc, cond)))
                   (Memory.bytes_get x y)
-            | Extern ("caml_string_set" | "caml_bytes_set"), [ x; y; z ] ->
+            | Extern "caml_bytes_set", [ x; y; z ] ->
                 seq
                   (let* cond = Arith.uge (Value.int_val y) (Memory.bytes_length x) in
                    let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
                    Memory.bytes_set x y z)
                   Value.unit
-            | Extern ("caml_ml_string_length" | "caml_ml_bytes_length"), [ x ] ->
+            | Extern "caml_ml_string_length", [ x ] ->
+                Value.val_int (Memory.string_length x)
+            | Extern "caml_ml_bytes_length", [ x ] ->
                 Value.val_int (Memory.bytes_length x)
             | Extern "%int_add", [ x; y ] -> Value.int_add x y
             | Extern "%int_sub", [ x; y ] -> Value.int_sub x y
@@ -776,7 +783,6 @@ module Generate (Target : Target_sig.S) = struct
                     ( Extern
                         ( "caml_string_get"
                         | "caml_bytes_get"
-                        | "caml_string_set"
                         | "caml_bytes_set"
                         | "caml_check_bound"
                         | "caml_check_bound_gen"

compiler/lib-wasm/target_sig.ml

@@ -77,6 +77,10 @@ module type S = sig
 
     val bytes_set : expression -> expression -> expression -> unit Code_generation.t
 
+    val string_length : expression -> expression
+
+    val string_get : expression -> expression -> expression
+
     val box_float : expression -> expression
 
     val unbox_float : expression -> expression

runtime/wasm/array.wat

@@ -21,10 +21,11 @@
 
    (type $block (array (mut (ref eq))))
    (type $bytes (array (mut i8)))
+   (type $string (struct (field anyref)))
    (type $float (struct (field f64)))
    (type $float_array (array (mut f64)))
 
-   (data $Array_make "Array.make")
+   (#string $Array_make "Array.make")
 
    (global $empty_array (ref eq)
       (array.new_fixed $block 1 (ref.i31 (i32.const 0))))
@@ -34,10 +35,7 @@
       (local $sz i32) (local $b (ref $block)) (local $f f64)
       (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
       (if (i32.lt_s (local.get $sz) (i32.const 0))
-         (then
-            (call $caml_invalid_argument
-               (array.new_data $bytes $Array_make
-                               (i32.const 0) (i32.const 10)))))
+         (then (call $caml_invalid_argument (global.get $Array_make))))
       (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array))))
       (drop (block $not_float (result (ref eq))
          (local.set $f
@@ -56,10 +54,7 @@
       (local $sz i32) (local $f f64)
       (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
       (if (i32.lt_s (local.get $sz) (i32.const 0))
-         (then
-            (call $caml_invalid_argument
-               (array.new_data $bytes $Array_make
-                               (i32.const 0) (i32.const 10)))))
+         (then (call $caml_invalid_argument (global.get $Array_make))))
       (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array))))
       (local.set $f
          (struct.get $float 0
@@ -73,10 +68,7 @@
       (local $sz i32)
       (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n))))
       (if (i32.lt_s (local.get $sz) (i32.const 0))
-         (then
-            (call $caml_invalid_argument
-               (array.new_data $bytes $Array_make
-                               (i32.const 0) (i32.const 10)))))
+         (then (call $caml_invalid_argument (global.get $Array_make))))
       (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array))))
       (array.new $float_array (f64.const 0) (local.get $sz)))
 

runtime/wasm/backtrace.wat

@@ -21,6 +21,7 @@
 
    (type $block (array (mut (ref eq))))
    (type $bytes (array (mut i8)))
+   (type $string (struct (field anyref)))
 
    (func (export "caml_get_exception_raw_backtrace")
       (param (ref eq)) (result (ref eq))
@@ -38,14 +39,12 @@
       (param (ref eq)) (result (ref eq))
       (ref.i31 (i32.const 0)))
 
-   (data $raw_backtrace_slot_err
+   (#string $raw_backtrace_slot_err
       "Printexc.get_raw_backtrace_slot: index out of bounds")
 
    (func (export "caml_raw_backtrace_slot")
       (param (ref eq) (ref eq)) (result (ref eq))
-      (call $caml_invalid_argument
-          (array.new_data $bytes $raw_backtrace_slot_err
-             (i32.const 0) (i32.const 52)))
+      (call $caml_invalid_argument (global.get $raw_backtrace_slot_err))
       (ref.i31 (i32.const 0)))
 
    (func (export "caml_convert_raw_backtrace_slot")