From 94d028a962a8a7aff70a462bb2d69483f12c8006 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 16 Dec 2024 16:00:42 +0100 Subject: [PATCH] WIP --- compiler/lib-wasm/gc_target.ml | 132 ++++++++---- compiler/lib-wasm/generate.ml | 20 +- compiler/lib-wasm/target_sig.ml | 4 + runtime/wasm/bigarray.wat | 52 ++++- runtime/wasm/bigstring.wat | 54 ++++- runtime/wasm/effect.wat | 6 +- runtime/wasm/fail.wat | 8 +- runtime/wasm/float.wat | 14 +- runtime/wasm/hash.wat | 29 ++- runtime/wasm/int64.wat | 15 +- runtime/wasm/ints.wat | 15 +- runtime/wasm/io.wat | 30 ++- runtime/wasm/jslib.wat | 160 ++++++--------- runtime/wasm/jsstring.wat | 256 +++++++++++++++++++++++- runtime/wasm/lexing.wat | 116 ++++++++--- runtime/wasm/marshal.wat | 72 ++++++- runtime/wasm/md5.wat | 22 +- runtime/wasm/obj.wat | 14 ++ runtime/wasm/parsing.wat | 176 +++++++++++----- runtime/wasm/printexc.wat | 49 +++-- runtime/wasm/runtime.js | 40 +++- runtime/wasm/stdlib.wat | 31 +-- runtime/wasm/str.wat | 212 ++++++++++++++------ runtime/wasm/string.wat | 342 +++++++++++++++++++++++++++++--- runtime/wasm/sys.wat | 18 +- 25 files changed, 1505 insertions(+), 382 deletions(-) diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index de4bd02349..42af3722b2 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/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) ])) diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index d5e590dff2..803c41f91e 100644 --- a/compiler/lib-wasm/generate.ml +++ b/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" diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml index 227da6d972..16c05164c0 100644 --- a/compiler/lib-wasm/target_sig.ml +++ b/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 diff --git a/runtime/wasm/bigarray.wat b/runtime/wasm/bigarray.wat index 875ecf23c0..747393d757 100644 --- a/runtime/wasm/bigarray.wat +++ b/runtime/wasm/bigarray.wat @@ -77,6 +77,12 @@ (func $ta_blit_to_bytes (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) (param i32))) + (import "bindings" "ta_blit_from_string" + (func $ta_blit_from_string + (param anyref) (param i32) (param (ref extern)) (param i32) + (param i32))) + (import "bindings" "ta_to_string" + (func $ta_to_string (param (ref extern)) (result (ref any)))) (import "fail" "caml_bound_error" (func $caml_bound_error)) (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) (import "fail" "caml_invalid_argument" @@ -124,9 +130,12 @@ (func $caml_deserialize_int_4 (param (ref eq)) (result i32))) (import "marshal" "caml_deserialize_int_8" (func $caml_deserialize_int_8 (param (ref eq)) (result i64))) + (import "jsstring" "jsstring_length" + (func $jsstring_length (param anyref) (result i32))) (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))) @@ -2020,10 +2029,23 @@ (i32.wrap_i64 (i64.shr_u (local.get $d) (i64.const 32)))) (ref.i31 (i32.const 0))) - (export "caml_bytes_of_array" (func $caml_string_of_array)) - (func $caml_string_of_array (export "caml_string_of_array") +(#if use-js-string +(#then + (func (export "caml_string_of_array") (param (ref eq)) (result (ref eq)) ;; used to convert a typed array to a string + (local $a (ref extern)) + (local.set $a + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0))))) + (struct.new $string (call $ta_to_string (local.get $a)))) +) +(#else + (export "caml_string_of_array" (func $caml_bytes_of_array)) +)) + + (func $caml_bytes_of_array (export "caml_bytes_of_array") + (param (ref eq)) (result (ref eq)) + ;; used to convert a typed array to bytes (local $a (ref extern)) (local $len i32) (local $s (ref $bytes)) (local.set $a @@ -2035,8 +2057,30 @@ (local.get $len)) (local.get $s)) - (export "caml_uint8_array_of_bytes" (func $caml_uint8_array_of_string)) - (func $caml_uint8_array_of_string (export "caml_uint8_array_of_string") +(#if use-js-string +(#then + (func (export "caml_uint8_array_of_string") + (param (ref eq)) (result (ref eq)) + ;; Convert a string to a typed array + (local $ta (ref extern)) (local $len i32) + (local $s anyref) + (local.set $s + (struct.get $string 0 (ref.cast (ref $string) (local.get 0)))) + (local.set $len (call $jsstring_length (local.get $s))) + (local.set $ta + (call $ta_create + (i32.const 3) ;; Uint8Array + (local.get $len))) + (call $ta_blit_from_string + (local.get $s) (i32.const 0) (local.get $ta) (i32.const 0) + (local.get $len)) + (call $wrap (any.convert_extern (local.get $ta)))) +) +(#else + (export "caml_uint8_array_of_string" (func $caml_uint8_array_of_bytes)) +)) + + (func $caml_uint8_array_of_bytes (export "caml_uint8_array_of_bytes") (param (ref eq)) (result (ref eq)) ;; Convert bytes to a typed array (local $ta (ref extern)) (local $len i32) diff --git a/runtime/wasm/bigstring.wat b/runtime/wasm/bigstring.wat index 7671cdd5ad..9539530992 100644 --- a/runtime/wasm/bigstring.wat +++ b/runtime/wasm/bigstring.wat @@ -56,10 +56,30 @@ (func $ta_blit_to_bytes (param (ref extern)) (param i32) (param (ref $bytes)) (param i32) (param i32))) + (import "bindings" "ta_blit_from_string" + (func $ta_blit_from_string + (param anyref) (param i32) (param (ref extern)) (param i32) + (param i32))) (import "hash" "caml_hash_mix_int" (func $caml_hash_mix_int (param i32) (param i32) (result i32))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) + +(#if use-js-string +(#then + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) + (func $string_val (param $s (ref eq)) (result externref) + (extern.convert_any + (struct.get $string 0 (ref.cast (ref $string) (local.get $s))))) +) +(#else + (func $string_get (param $s (ref $bytes)) (param $i i32) (result i32) + (array.get $bytes (local.get $s) (local.get $i))) + (func $string_val (param $s (ref eq)) (result (ref $bytes)) + (ref.cast (ref $bytes) (local.get $s))) +)) (func (export "caml_hash_mix_bigstring") (param $h i32) (param $b (ref eq)) (result i32) @@ -160,10 +180,16 @@ (local $i i32) (local $pos1 i32) (local $pos2 i32) (local $len i32) (local $c1 i32) (local $c2 i32) (local $d1 (ref extern)) +(#if use-js-string +(#then + (local $s2 externref) +) +(#else (local $s2 (ref $bytes)) +)) (local.set $d1 (call $caml_ba_get_data (local.get $s1))) (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) - (local.set $s2 (ref.cast (ref $bytes) (local.get $vs2))) + (local.set $s2 (call $string_val (local.get $vs2))) (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) (loop $loop @@ -173,7 +199,7 @@ (call $ta_get_ui8 (local.get $d1) (i32.add (local.get $pos1) (local.get $i)))) (local.set $c2 - (array.get_u $bytes (local.get $s2) + (call $string_get (local.get $s2) (i32.add (local.get $pos2) (local.get $i)))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (br_if $loop (i32.eq (local.get $c1) (local.get $c2))) @@ -203,8 +229,32 @@ (br $loop)))) (ref.i31 (i32.const -1))) +(#if use-js-string +(#then + (func (export "caml_bigstring_blit_string_to_ba") + (param $str1 (ref eq)) (param $vpos1 (ref eq)) + (param $ba2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $s1 anyref) + (local $d2 (ref extern)) + (local.set $s1 + (struct.get $string 0 (ref.cast (ref $string) (local.get $str1)))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $d2 (call $caml_ba_get_data (local.get $ba2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (call $ta_blit_from_string + (local.get $s1) (local.get $pos1) + (local.get $d2) (local.get $pos2) + (local.get $len)) + (ref.i31 (i32.const 0))) +) +(#else (export "caml_bigstring_blit_string_to_ba" (func $caml_bigstring_blit_bytes_to_ba)) +)) + (func $caml_bigstring_blit_bytes_to_ba (export "caml_bigstring_blit_bytes_to_ba") (param $str1 (ref eq)) (param $vpos1 (ref eq)) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 04d86abe1c..022fdd118c 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -24,7 +24,7 @@ (func $caml_fresh_oo_id (param (ref eq)) (result (ref eq)))) (import "obj" "cont_tag" (global $cont_tag i32)) (import "stdlib" "caml_named_value" - (func $caml_named_value (param (ref $bytes)) (result (ref null eq)))) + (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) @@ -36,6 +36,8 @@ (param $f funcref) (param $env eqref) (result anyref))) (import "bindings" "resume_fiber" (func $resume_fiber (param externref) (param (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -134,7 +136,7 @@ (local.get $eff))) (call $caml_raise_constant (array.new_fixed $block 3 (ref.i31 (i32.const 248)) - (local.get $effect_unhandled) + (call $caml_string_of_bytes (local.get $effect_unhandled)) (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) (ref.i31 (i32.const 0))) diff --git a/runtime/wasm/fail.wat b/runtime/wasm/fail.wat index 2661139d01..b7cf829491 100644 --- a/runtime/wasm/fail.wat +++ b/runtime/wasm/fail.wat @@ -19,6 +19,8 @@ (import "stdlib" "caml_global_data" (global $caml_global_data (mut (ref $block)))) (import "bindings" "jstag" (tag $javascript_exception (param externref))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -48,7 +50,7 @@ (return_call $caml_raise_with_arg (array.get $block (global.get $caml_global_data) (global.get $SYS_ERROR_EXN)) - (local.get $msg))) + (call $caml_string_of_bytes (local.get $msg)))) (global $FAILURE_EXN i32 (i32.const 2)) @@ -60,7 +62,7 @@ (return_call $caml_raise_with_arg (array.get $block (global.get $caml_global_data) (global.get $FAILURE_EXN)) - (local.get 0))) + (call $caml_string_of_bytes (local.get $arg)))) (global $INVALID_EXN i32 (i32.const 3)) @@ -69,7 +71,7 @@ (return_call $caml_raise_with_arg (array.get $block (global.get $caml_global_data) (global.get $INVALID_EXN)) - (local.get 0))) + (call $caml_string_of_bytes (local.get 0)))) (data $index_out_of_bounds "index out of bounds") diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat index 75165b52fb..7712e2f8c7 100644 --- a/runtime/wasm/float.wat +++ b/runtime/wasm/float.wat @@ -31,6 +31,10 @@ (func $jsstring_of_bytes (param (ref $bytes)) (result anyref))) (import "jsstring" "bytes_of_jsstring" (func $bytes_of_jsstring (param anyref) (result (ref $bytes)))) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $float (struct (field f64))) (type $bytes (array (mut i8))) @@ -192,7 +196,7 @@ (then (array.set $bytes (local.get $s) (i32.const 0) (local.get $style)))))) - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) (data $format_error "format_float: bad format") @@ -268,7 +272,8 @@ (local.set $f (struct.get $float 0 (ref.cast (ref $float) (local.get 1)))) (local.set $b (i64.reinterpret_f64 (local.get $f))) (local.set $format - (call $parse_format (ref.cast (ref $bytes) (local.get 0)))) + (call $parse_format + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get 0))))) (local.set $sign_style (tuple.extract 4 0 (local.get $format))) (local.set $precision (tuple.extract 4 1 (local.get $format))) (local.set $conversion (tuple.extract 4 2 (local.get $format))) @@ -337,7 +342,7 @@ (i32.sub (local.get $c) (i32.const 32))))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (br_if $uppercase (i32.lt_u (local.get $i) (local.get $len)))))) - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) (data $float_of_string "float_of_string") @@ -493,7 +498,8 @@ (local $s' (ref $bytes)) (local $negative i32) (local $c i32) (local $f f64) - (local.set $s (ref.cast (ref $bytes) (local.get 0))) + (local.set $s ;; ZZZ work directly on string? + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get 0)))) (local.set $len (array.len (local.get $s))) (loop $count (if (i32.lt_u (local.get $i) (local.get $len)) diff --git a/runtime/wasm/hash.wat b/runtime/wasm/hash.wat index fea021cd9d..9132f7f684 100644 --- a/runtime/wasm/hash.wat +++ b/runtime/wasm/hash.wat @@ -25,6 +25,7 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) (type $float (struct (field f64))) (type $js (struct (field anyref))) @@ -109,7 +110,7 @@ (then (local.set $i (i32.const 0)))) (return_call $caml_hash_mix_int (local.get $h) (local.get $i))) - (func $caml_hash_mix_string (export "caml_hash_mix_string") + (func $caml_hash_mix_bytes (export "caml_hash_mix_string") ;;ZZZ (param $h i32) (param $s (ref $bytes)) (result i32) (local $i i32) (local $len i32) (local $w i32) (local.set $len (array.len (local.get $s))) @@ -157,6 +158,11 @@ (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) (i32.xor (local.get $h) (local.get $len))) + (func $caml_hash_mix_string + (param $h i32) (param $s (ref $string)) (result i32) + (return_call $jsstring_hash + (local.get $h) (struct.get $js 0 (local.get $s)))) + (global $HASH_QUEUE_SIZE i32 (i32.const 256)) (global $MAX_FORWARD_DEREFERENCE i32 (i32.const 1000)) @@ -205,10 +211,10 @@ (i32.const 1)))) (local.set $num (i32.sub (local.get $num) (i32.const 1))) (br $loop))) - (drop (block $not_string (result (ref eq)) + (drop (block $not_bytes (result (ref eq)) (local.set $h - (call $caml_hash_mix_string (local.get $h) - (br_on_cast_fail $not_string (ref eq) (ref $bytes) + (call $caml_hash_mix_bytes (local.get $h) + (br_on_cast_fail $not_bytes (ref eq) (ref $bytes) (local.get $v)))) (local.set $num (i32.sub (local.get $num) (i32.const 1))) (br $loop))) @@ -312,6 +318,8 @@ (ref.i31 (i32.and (call $caml_hash_mix_final (local.get $h)) (i32.const 0x3FFFFFFF)))) +(#if use-js-string +(#then (func (export "caml_string_hash") (param (ref eq)) (param (ref eq)) (result (ref eq)) (local $h i32) @@ -319,7 +327,20 @@ (i32.and (call $caml_hash_mix_final (call $caml_hash_mix_string + (i31.get_s (ref.cast (ref i31) (local.get 0))) + (ref.cast (ref $string) (local.get 1)))) + (i32.const 0x3FFFFFFF)))) +) +(#else + (func (export "caml_string_hash") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $h i32) + (ref.i31 + (i32.and + (call $caml_hash_mix_final + (call $caml_hash_mix_bytes (i31.get_s (ref.cast (ref i31) (local.get 0))) (ref.cast (ref $bytes) (local.get 1)))) (i32.const 0x3FFFFFFF)))) +)) ) diff --git a/runtime/wasm/int64.wat b/runtime/wasm/int64.wat index a873f39ff6..899bd62bc8 100644 --- a/runtime/wasm/int64.wat +++ b/runtime/wasm/int64.wat @@ -32,6 +32,10 @@ (global $lowercase_hex_table (ref $chars))) (import "ints" "uppercase_hex_table" (global $uppercase_hex_table (ref $chars))) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $bytes (array (mut i8))) (type $compare @@ -194,7 +198,9 @@ (local $s (ref $bytes)) (local $i i32) (local $signedness i32) (local $sign i32) (local $base i32) (local $t (tuple i32 i32 i32 i32)) - (local.set $s (ref.cast (ref $bytes) (local.get $v))) + ;;ZZZ ??? + (local.set $s + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get $v)))) (local.set $t (call $parse_sign_and_base (local.get $s))) (local.set $i (tuple.extract 4 0 (local.get $t))) (local.set $signedness (tuple.extract 4 1 (local.get $t))) @@ -236,7 +242,7 @@ (then (array.set $bytes (local.get $s) (i32.const 0) (i32.const 45)))) ;; '-' - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) (type $chars (array i8)) @@ -251,7 +257,8 @@ (local $i i32) (local $n i64) (local $chars (ref $chars)) - (local.set $s (ref.cast (ref $bytes) (local.get 0))) + (local.set $s ;; ZZZ ??? + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get 0)))) (local.set $d (struct.get $int64 1 (ref.cast (ref $int64) (local.get 1)))) (if (i32.eq (array.len (local.get $s)) (i32.const 2)) (then @@ -326,6 +333,6 @@ (array.set $bytes (local.get $s) (i32.const 1) (select (i32.const 88) (i32.const 120) ;; 'X' 'x' (local.get $uppercase))))))))) - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) ) diff --git a/runtime/wasm/ints.wat b/runtime/wasm/ints.wat index 4ec4e3b0f6..f5de5daa9c 100644 --- a/runtime/wasm/ints.wat +++ b/runtime/wasm/ints.wat @@ -19,6 +19,10 @@ (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $bytes (array (mut i8))) @@ -101,7 +105,8 @@ (local $signedness i32) (local $sign i32) (local $base i32) (local $res i32) (local $threshold i32) (local $t (tuple i32 i32 i32 i32)) - (local.set $s (ref.cast (ref $bytes) (local.get $v))) + (local.set $s ;; ZZZ??? + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get $v)))) (local.set $len (array.len (local.get $s))) (if (i32.eqz (local.get $len)) (then (call $caml_failwith (local.get $errmsg)))) @@ -220,7 +225,7 @@ (then (array.set $bytes (local.get $s) (i32.const 0) (i32.const 45)))) ;; '-' - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) (data $format_error "format_int: bad format") @@ -303,7 +308,9 @@ (local $i i32) (local $n i32) (local $chars (ref $chars)) - (local.set $s (ref.cast (ref $bytes) (local.get 0))) + ;; ZZZ Avoid conversion? + (local.set $s + (ref.cast (ref $bytes) (call $caml_bytes_of_string (local.get 0)))) (if (i32.eq (array.len (local.get $s)) (i32.const 2)) (then (if (i32.eq (array.get_u $bytes (local.get $s) (i32.const 1)) @@ -383,5 +390,5 @@ (array.set $bytes (local.get $s) (i32.const 1) (select (i32.const 88) (i32.const 120) ;; 'X' 'x' (local.get $uppercase))))))))) - (local.get $s)) + (return_call $caml_string_of_bytes (local.get $s))) ) diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index b15d566864..c5ed0d175a 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -77,6 +77,8 @@ (tag $javascript_exception (param externref))) (import "sys" "caml_handle_sys_error" (func $caml_handle_sys_error (param externref))) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) (import "bindings" "map_new" (func $map_new (result (ref extern)))) (import "bindings" "map_get" @@ -754,8 +756,34 @@ (local.set $len (i32.sub (local.get $len) (local.get $written))) (br $loop))))) - (export "caml_ml_output_bytes" (func $caml_ml_output)) +(#if use-js-string +(#then (func $caml_ml_output (export "caml_ml_output") + (param $ch (ref eq)) (param $s (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos i32) (local $len i32) (local $written i32) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $written + (call $caml_putblock (ref.cast (ref $channel) (local.get $ch)) + ;; ZZZ skip conversion + (ref.cast (ref $bytes) + (call $caml_bytes_of_string (local.get $s))) + (local.get $pos) (local.get $len))) + (local.set $pos (i32.add (local.get $pos) (local.get $written))) + (local.set $len (i32.sub (local.get $len) (local.get $written))) + (br $loop)))) + (call $caml_flush_if_unbuffered (local.get $ch)) + (ref.i31 (i32.const 0))) +) +(#else + (export "caml_ml_output" (func $caml_ml_output_bytes)) +)) + + (func $caml_ml_output_bytes (export "caml_ml_output_bytes") (param $ch (ref eq)) (param $s (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) (local $pos i32) (local $len i32) (local $written i32) diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index 76ae47fdd3..a7221bd689 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -76,7 +76,7 @@ (import "fail" "caml_failwith_tag" (func $caml_failwith_tag (result (ref eq)))) (import "stdlib" "caml_named_value" - (func $caml_named_value (param (ref $bytes)) (result (ref null eq)))) + (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "obj" "caml_callback_1" (func $caml_callback_1 (param (ref eq)) (param (ref eq)) (result (ref eq)))) @@ -88,6 +88,14 @@ (func $jsstring_of_bytes (param (ref $bytes)) (result anyref))) (import "jsstring" "bytes_of_jsstring" (func $bytes_of_jsstring (param anyref) (result (ref $bytes)))) + (import "jsstring" "jsstring_of_string" + (func $jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "jsstring" "string_of_jsstring" + (func $string_of_jsstring (param (ref eq)) (result (ref eq)))) + (import "jsstring" "jsbytes_of_bytes" + (func $jsbytes_of_bytes (param (ref $bytes)) (result anyref))) + (import "jsstring" "bytes_of_jsbytes" + (func $bytes_of_jsbytes (param anyref) (result (ref $bytes)))) (import "int32" "caml_copy_int32" (func $caml_copy_int32 (param i32) (result (ref eq)))) (import "int32" "Int32_val" @@ -262,7 +270,7 @@ (array.get $block (local.get $a) (local.get $i)))) (call $set (local.get $o) (call $unwrap - (call $caml_jsstring_of_bytes + (call $caml_jsstring_of_string (array.get $block (local.get $p) (i32.const 1)))) (call $unwrap (array.get $block (local.get $p) (i32.const 2)))) @@ -451,116 +459,64 @@ (local.get $acc))))))))) (return_call $unwrap (local.get $acc))) - (export "caml_js_from_string" (func $caml_jsstring_of_bytes)) - (func $caml_jsstring_of_bytes (export "caml_jsstring_of_string") + (export "caml_js_from_string" (func $jsstring_of_string)) + +(#if use-js-string +(#then + (export "caml_jsstring_of_string" (func $jsstring_of_string)) + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)) + (return_call $jsstring_of_string (local.get 0))) +) +(#else + (func $caml_jsstring_of_string (export "caml_jsstring_of_string") (param (ref eq)) (result (ref eq)) (local $s (ref $bytes)) (local.set $s (ref.cast (ref $bytes) (local.get 0))) (return (struct.new $js (call $jsstring_of_bytes (local.get $s))))) +)) - (func $caml_jsbytes_of_bytes (export "caml_jsbytes_of_string") +(#if use-js-string +(#then + (func (export "caml_jsbytes_of_string") + (param (ref eq)) (result (ref eq)) + (local.get 0)) +) +(#else + (export "caml_jsbytes_of_string" (func $caml_jsbytes_of_bytes)) +)) + + (func $caml_jsbytes_of_bytes (param (ref eq)) (result (ref eq)) (local $s (ref $bytes)) - (local $s' (ref $bytes)) - (local $l i32) (local $i i32) (local $n i32) (local $c i32) (local.set $s (ref.cast (ref $bytes) (local.get 0))) - (local.set $l (array.len (local.get $s))) - (local.set $i (i32.const 0)) - (local.set $n (i32.const 0)) - (loop $count - (if (i32.lt_u (local.get $i) (local.get $l)) - (then - (if (i32.ge_u (array.get_u $bytes (local.get $s) (local.get $i)) - (i32.const 128)) - (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) - (local.set $i (i32.add (local.get $i) (i32.const 1))) - (br $count)))) - (if (i32.eqz (local.get $n)) - (then - (return - (struct.new $js - (call $jsstring_of_bytes (local.get $s)))))) - (local.set $s' - (array.new $bytes (i32.const 0) - (i32.add (local.get $i) (local.get $n)))) - (local.set $i (i32.const 0)) - (local.set $n (i32.const 0)) - (loop $fill - (if (i32.lt_u (local.get $i) (local.get $l)) - (then - (local.set $c (array.get_u $bytes (local.get $s) (local.get $i))) - (if (i32.lt_u (local.get $c) (i32.const 128)) - (then - (array.set $bytes - (local.get $s') (local.get $n) (local.get $c)) - (local.set $n (i32.add (local.get $n) (i32.const 1)))) - (else - (array.set $bytes (local.get $s') - (local.get $n) - (i32.or (i32.shr_u (local.get $c) (i32.const 6)) - (i32.const 0xC0))) - (array.set $bytes (local.get $s') - (i32.add (local.get $n) (i32.const 1)) - (i32.or (i32.const 0x80) - (i32.and (local.get $c) (i32.const 0x3F)))) - (local.set $n (i32.add (local.get $n) (i32.const 2))))) - (local.set $i (i32.add (local.get $i) (i32.const 1))) - (br $fill)))) - (return (struct.new $js (call $jsstring_of_bytes (local.get $s'))))) - + (return (struct.new $js (call $jsbytes_of_bytes (local.get $s))))) + +(#if use-js-string +(#then + (export "caml_js_to_string" (func $string_of_jsstring)) + (export "caml_string_of_jsstring" (func $string_of_jsstring)) + (func $caml_string_of_jsstring (param (ref eq)) (result (ref eq)) + (return_call $string_of_jsstring (local.get 0))) +) +(#else (export "caml_js_to_string" (func $caml_string_of_jsstring)) (func $caml_string_of_jsstring (export "caml_string_of_jsstring") (param $s (ref eq)) (result (ref eq)) (return_call $bytes_of_jsstring (struct.get $js 0 (ref.cast (ref $js) (local.get $s))))) +)) +(#if use-js-string +(#then (func (export "caml_string_of_jsbytes") (param $s (ref eq)) (result (ref eq)) - (local $l i32) (local $i i32) (local $n i32) (local $c i32) - (local $s' (ref $bytes)) (local $s'' (ref $bytes)) - (local.set $s' - (call $bytes_of_jsstring - (struct.get $js 0 (ref.cast (ref $js) (local.get $s))))) - (local.set $l (array.len (local.get $s'))) - (local.set $i (i32.const 0)) - (local.set $n (i32.const 0)) - (loop $count - (if (i32.lt_u (local.get $i) (local.get $l)) - (then - (if (i32.ge_u (array.get_u $bytes (local.get $s') (local.get $i)) - (i32.const 0xC0)) - (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) - (local.set $i (i32.add (local.get $i) (i32.const 1))) - (br $count)))) - (if (i32.eqz (local.get $n)) (then (return (local.get $s')))) - (local.set $s'' - (array.new $bytes (i32.const 0) - (i32.sub (local.get $i) (local.get $n)))) - (local.set $i (i32.const 0)) - (local.set $n (i32.const 0)) - (loop $fill - (if (i32.lt_u (local.get $i) (local.get $l)) - (then - (local.set $c - (array.get_u $bytes (local.get $s') (local.get $i))) - (if (i32.lt_u (local.get $c) (i32.const 0xC0)) - (then - (array.set $bytes - (local.get $s'') (local.get $n) (local.get $c)) - (local.set $i (i32.add (local.get $i) (i32.const 1)))) - (else - (array.set $bytes (local.get $s'') - (local.get $n) - (i32.sub - (i32.add - (i32.shl (local.get $c) (i32.const 6)) - (array.get_u $bytes (local.get $s') - (i32.add (local.get $i) (i32.const 1)))) - (i32.const 0x3080))) - (local.set $i (i32.add (local.get $i) (i32.const 2))))) - (local.set $n (i32.add (local.get $n) (i32.const 1))) - (br $fill)))) - (local.get $s'')) + (local.get 0)) +) +(#else + (func (export "caml_string_of_jsbytes") (param $s (ref eq)) (result (ref eq)) + (return_call $bytes_of_jsbytes + (struct.get $js 0 (ref.cast (ref $js) (local.get $s))))) +)) (func (export "caml_list_to_js_array") (param (ref eq)) (result (ref eq)) @@ -639,7 +595,7 @@ (call $meth_call (local.get $exn) (call $unwrap - (call $caml_jsstring_of_bytes + (call $caml_jsstring_of_string (array.new_data $bytes $toString (i32.const 0) (i32.const 8)))) (any.convert_extern (call $new_array (i32.const 0)))))))) @@ -675,5 +631,13 @@ (func (export "caml_jsoo_flags_use_js_string") (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.const 0))) + (ref.i31 +(#if use-js-string +(#then + (i32.const 1) +) +(#else + (i32.const 0) +)) + )) ) diff --git a/runtime/wasm/jsstring.wat b/runtime/wasm/jsstring.wat index 81bbe1f5c0..6195e144b4 100644 --- a/runtime/wasm/jsstring.wat +++ b/runtime/wasm/jsstring.wat @@ -22,11 +22,14 @@ (func $is_string (param externref) (result i32))) (import "wasm:js-string" "hash" (func $hash_string (param i32) (param anyref) (result i32))) + (import "wasm:js-string" "length" + (func $string_length (param externref) (result i32))) (import "wasm:js-string" "fromCharCodeArray" (func $fromCharCodeArray (param (ref null $wstring)) (param i32) (param i32) (result (ref extern)))) - + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) (import "wasm:text-decoder" "decodeStringFromUTF8Array" (func $decodeStringFromUTF8Array (param (ref null $bytes)) (param i32) (param i32) @@ -34,7 +37,6 @@ (import "wasm:text-encoder" "encodeStringToUTF8Array" (func $encodeStringToUTF8Array (param externref) (result (ref $bytes)))) - (import "bindings" "read_string" (func $read_string (param i32) (result anyref))) (import "bindings" "read_string_stream" @@ -43,8 +45,13 @@ (func $write_string (param anyref) (result i32))) (import "bindings" "append_string" (func $append_string (param anyref) (param anyref) (result anyref))) + (import "js" "caml_utf16_of_utf8" + (func $utf16_of_utf8 (param anyref) (result anyref))) + (import "js" "caml_utf8_of_utf16" + (func $utf8_of_utf16 (param anyref) (result anyref))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) (type $wstring (array (mut i16))) (global $text_converters_available (mut i32) (i32.const 0)) @@ -96,6 +103,9 @@ (func (export "jsstring_test") (param $s anyref) (result i32) (return_call $is_string (extern.convert_any (local.get $s)))) + (func (export "jsstring_length") (param $s anyref) (result i32) + (return_call $string_length (extern.convert_any (local.get $s)))) + (export "jsstring_hash" (func $hash_string)) ;; Used by package zarith_stubs_js @@ -133,16 +143,148 @@ (return_call $jsstring_of_subbytes_fallback (local.get $s) (local.get $pos) (local.get $len))) - (func (export "jsstring_of_bytes") (param $s (ref $bytes)) (result anyref) + (func $jsstring_of_bytes (export "jsstring_of_bytes") + (param $s (ref $bytes)) (result anyref) (return_call $jsstring_of_subbytes (local.get $s) (i32.const 0) (array.len (local.get $s)))) - (func (export "bytes_of_jsstring") (param $s anyref) (result (ref $bytes)) + (func $bytes_of_jsstring (export "bytes_of_jsstring") + (param $s anyref) (result (ref $bytes)) (if (global.get $text_converters_available) (then (return_call $encodeStringToUTF8Array (extern.convert_any (local.get $s))))) - (return_call $string_of_jsstring_fallback (local.get $s))) + (return_call $bytes_of_jsstring_fallback (local.get $s))) + + (func $string_is_ascii (param $vs (ref eq)) (result i32) + (local $s externref) (local $len i32) (local $i i32) + (local.set $s + (extern.convert_any + (struct.get $string 0 (ref.cast (ref $string) (local.get $vs))))) + (local.set $len (call $string_length (local.get $s))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (if (i32.ge_u (call $string_get (local.get $s) (local.get $i)) + (i32.const 128)) + (then (return (i32.const 0)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (i32.const 1)) + + (func (export "jsstring_of_string") + (param $s (ref eq)) (result (ref eq)) + (if (result (ref eq)) (call $string_is_ascii (local.get $s)) + (then + (local.get $s)) + (else + (return + (struct.new $string + (call $utf16_of_utf8 + (struct.get $string 0 + (ref.cast (ref $string) (local.get $s))))))))) + + (func (export "string_of_jsstring") + (param $s (ref eq)) (result (ref eq)) + (if (result (ref eq)) (call $string_is_ascii (local.get $s)) + (then + (local.get $s)) + (else + (return + (struct.new $string + (call $utf8_of_utf16 + (struct.get $string 0 + (ref.cast (ref $string) (local.get $s))))))))) + + (func (export "jsbytes_of_bytes") (param $s (ref $bytes)) (result anyref) + (local $s' (ref $bytes)) + (local $l i32) (local $i i32) (local $n i32) (local $c i32) + (local.set $l (array.len (local.get $s))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $count + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (if (i32.ge_u (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.const 128)) + (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $count)))) + (if (i32.eqz (local.get $n)) + (then + (return_call $jsstring_of_bytes (local.get $s)))) + (local.set $s' + (array.new $bytes (i32.const 0) + (i32.add (local.get $i) (local.get $n)))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $fill + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c (array.get_u $bytes (local.get $s) (local.get $i))) + (if (i32.lt_u (local.get $c) (i32.const 128)) + (then + (array.set $bytes + (local.get $s') (local.get $n) (local.get $c)) + (local.set $n (i32.add (local.get $n) (i32.const 1)))) + (else + (array.set $bytes (local.get $s') + (local.get $n) + (i32.or (i32.shr_u (local.get $c) (i32.const 6)) + (i32.const 0xC0))) + (array.set $bytes (local.get $s') + (i32.add (local.get $n) (i32.const 1)) + (i32.or (i32.const 0x80) + (i32.and (local.get $c) (i32.const 0x3F)))) + (local.set $n (i32.add (local.get $n) (i32.const 2))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $fill)))) + (return_call $jsstring_of_bytes (local.get $s'))) + + (func (export "bytes_of_jsbytes") (param $s anyref) (result (ref $bytes)) + (local $l i32) (local $i i32) (local $n i32) (local $c i32) + (local $s' (ref $bytes)) (local $s'' (ref $bytes)) + (local.set $s' (call $bytes_of_jsstring (local.get $s))) + (local.set $l (array.len (local.get $s'))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $count + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (if (i32.ge_u (array.get_u $bytes (local.get $s') (local.get $i)) + (i32.const 0xC0)) + (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $count)))) + (if (i32.eqz (local.get $n)) (then (return (local.get $s')))) + (local.set $s'' + (array.new $bytes (i32.const 0) + (i32.sub (local.get $i) (local.get $n)))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $fill + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c + (array.get_u $bytes (local.get $s') (local.get $i))) + (if (i32.lt_u (local.get $c) (i32.const 0xC0)) + (then + (array.set $bytes + (local.get $s'') (local.get $n) (local.get $c)) + (local.set $i (i32.add (local.get $i) (i32.const 1)))) + (else + (array.set $bytes (local.get $s'') + (local.get $n) + (i32.sub + (i32.add + (i32.shl (local.get $c) (i32.const 6)) + (array.get_u $bytes (local.get $s') + (i32.add (local.get $i) (i32.const 1)))) + (i32.const 0x3080))) + (local.set $i (i32.add (local.get $i) (i32.const 2))))) + (local.set $n (i32.add (local.get $n) (i32.const 1))) + (br $fill)))) + (local.get $s'')) ;; Fallback implementation of string conversion functions @@ -210,7 +352,7 @@ (struct (field $s (ref $bytes)) (field $next (ref null $stack)))) (global $stack (mut (ref null $stack)) (ref.null $stack)) - (func $string_of_jsstring_fallback (param $s anyref) (result (ref $bytes)) + (func $bytes_of_jsstring_fallback (param $s anyref) (result (ref $bytes)) (local $ofs i32) (local $len i32) (local $s' (ref $bytes)) (local $s'' (ref $bytes)) (local $item (ref $stack)) @@ -257,4 +399,106 @@ (local.set $s (array.new $bytes (i32.const 0) (local.get $len))) (call $read_from_buffer (local.get $s) (i32.const 0) (local.get $len)) (global.set $stack (struct.new $stack (local.get $s) (global.get $stack)))) + + (func $utf16_to_utf8 + (param $s externref) (param $l i32) (param $b (ref $wstring)) (result i32) + (local $i i32) (local $j i32) (local $c i32) (local $d i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c (call $string_get (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_u (local.get $c) (i32.const 0x80)) + (then + (array.set $wstring + (local.get $b) (local.get $j) (local.get $c)) + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (br $loop))) + (if (i32.lt_u (local.get $c) (i32.const 0x800)) + (then + (array.set $wstring + (local.get $b) (local.get $j) + (i32.or (i32.const 0xC0) + (i32.shr_u (local.get $c) (i32.const 6)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 1)) + (i32.or (i32.const 0x80) + (i32.and (local.get $c) (i32.const 0x3F)))) + (local.set $j (i32.add (local.get $j) (i32.const 2))) + (br $loop))) + (if (i32.and + (i32.ge_u (local.get $c) (i32.const 0xD800)) + (i32.lt_u (local.get $c) (i32.const 0xE000))) + (then + (if (i32.and + (i32.lt_u (local.get $c) (i32.const 0xDC00)) + (i32.lt_u (local.get $i) (local.get $l))) + (then + (local.set $d + (call $string_get (local.get $s) (local.get $i))) + (if (i32.and + (i32.ge_u (local.get $c) (i32.const 0xDC00)) + (i32.lt_u (local.get $c) (i32.const 0xE000))) + (then + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (i32.sub + (i32.add + (i32.shl + (local.get $c) + (i32.const 10)) + (local.get $d)) + (i32.const 0x35fdc00))) + (array.set $wstring + (local.get $b) (local.get $j) + (i32.or (i32.const 0xE0) + (i32.shr_u (local.get $c) + (i32.const 18)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 1)) + (i32.or (i32.const 0x80) + (i32.and + (i32.shr_u (local.get $c) + (i32.const 12)) + (i32.const 0x3F)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 2)) + (i32.or (i32.const 0x80) + (i32.and + (i32.shr_u (local.get $c) + (i32.const 6)) + (i32.const 0x3F)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 3)) + (i32.or (i32.const 0x80) + (i32.and (local.get $c) + (i32.const 0x3F)))) + (local.set $j + (i32.add (local.get $j) (i32.const 4))) + (br $loop))))) + ;; replacement character + (local.set $c (i32.const 0xFFFD)))) + (array.set $wstring + (local.get $b) (local.get $j) + (i32.or (i32.const 0xE0) + (i32.shr_u (local.get $c) (i32.const 12)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 1)) + (i32.or (i32.const 0x80) + (i32.and (i32.shr_u (local.get $c) (i32.const 6)) + (i32.const 0x3F)))) + (array.set $wstring + (local.get $b) + (i32.add (local.get $j) (i32.const 2)) + (i32.or (i32.const 0x80) + (i32.and (local.get $c) (i32.const 0x3F)))) + (local.set $j (i32.add (local.get $j) (i32.const 3))) + (br $loop)))) + (local.get $j)) ) diff --git a/runtime/wasm/lexing.wat b/runtime/wasm/lexing.wat index 5ff59fdd0b..f2b4c8ef18 100644 --- a/runtime/wasm/lexing.wat +++ b/runtime/wasm/lexing.wat @@ -20,15 +20,38 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) - (func $get (param $a (ref eq)) (param $i i32) (result i32) - (local $s (ref $bytes)) - (local.set $s (ref.cast (ref $bytes) (local.get $a))) +(#if use-js-string +(#then + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) + + (func $string_val (param $s (ref eq)) (result externref) + (extern.convert_any + (struct.get $string 0 (ref.cast (ref $string) (local.get $s))))) +) +(#else + (func $string_get (param $s (ref $bytes)) (param $i i32) (result i32) + (array.get $bytes (local.get $s) (local.get $i))) + (func $string_val (param $s (ref eq)) (result (ref $bytes)) + (ref.cast (ref $bytes) (local.get $s))) +)) + + (func $get +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $i i32) (result i32) (local.set $i (i32.add (local.get $i) (local.get $i))) (i32.extend16_s - (i32.or (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.or (call $string_get (local.get $s) (local.get $i)) (i32.shl - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.add (local.get $i) (i32.const 1))) (i32.const 8))))) @@ -65,12 +88,23 @@ (local $buffer (ref $bytes)) (local $vpos (ref eq)) (local $action (ref eq)) (local $pos i32) (local $base i32) (local $backtrk i32) +(#if use-js-string +(#then + (local $lex_base externref) + (local $lex_backtrk externref) + (local $lex_check externref) + (local $lex_check_code externref) + (local $lex_trans externref) + (local $lex_default externref) +) +(#else (local $lex_base (ref $bytes)) (local $lex_backtrk (ref $bytes)) (local $lex_check (ref $bytes)) (local $lex_check_code (ref $bytes)) (local $lex_trans (ref $bytes)) (local $lex_default (ref $bytes)) +)) (local.set $tbl (ref.cast (ref $block) (local.get $vtbl))) (local.set $lexbuf (ref.cast (ref $block) (local.get $vlexbuf))) (local.set $state @@ -91,22 +125,22 @@ (else (local.set $state (i32.sub (i32.const -1) (local.get $state))))) (local.set $lex_base - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_base)))) (local.set $lex_backtrk - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_backtrk)))) (local.set $lex_check - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_check)))) (local.set $lex_check_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_check_code)))) (local.set $lex_trans - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_trans)))) (local.set $lex_default - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_default)))) (loop $loop (local.set $base (call $get (local.get $lex_base) (local.get $state))) @@ -185,7 +219,14 @@ (br $loop))) (func $run_mem - (param $s (ref $bytes)) (param $i i32) (param $lexbuf (ref $block)) +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $i i32) (param $lexbuf (ref $block)) (param $curr_pos (ref eq)) (local $dst i32) (local $src i32) (local $mem (ref $block)) @@ -193,11 +234,11 @@ (ref.cast (ref $block) (array.get $block (local.get $lexbuf) (global.get $lex_mem)))) (loop $loop - (local.set $dst (array.get_u $bytes (local.get $s) (local.get $i))) + (local.set $dst (call $string_get (local.get $s) (local.get $i))) (if (i32.eq (local.get $dst) (i32.const 0xff)) (then (return))) (local.set $src - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.add (local.get $i) (i32.const 1)))) (local.set $i (i32.add (local.get $i) (i32.const 2))) (array.set $block (local.get $mem) @@ -211,7 +252,14 @@ (br $loop))) (func $run_tag - (param $s (ref $bytes)) (param $i i32) (param $lexbuf (ref $block)) +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $i i32) (param $lexbuf (ref $block)) (return_call $run_mem (local.get $s) (local.get $i) (local.get $lexbuf) (ref.i31 (i32.const -1)))) @@ -227,6 +275,21 @@ (local $vpos (ref eq)) (local $action (ref eq)) (local $pos i32) (local $base i32) (local $backtrk i32) (local $pc_off i32) (local $base_code i32) +(#if use-js-string +(#then + (local $lex_code externref) + (local $lex_base externref) + (local $lex_base_code externref) + (local $lex_backtrk externref) + (local $lex_backtrk_code externref) + (local $lex_check externref) + (local $lex_check_code externref) + (local $lex_trans externref) + (local $lex_trans_code externref) + (local $lex_default externref) + (local $lex_default_code externref) +) +(#else (local $lex_code (ref $bytes)) (local $lex_base (ref $bytes)) (local $lex_base_code (ref $bytes)) @@ -238,6 +301,7 @@ (local $lex_trans_code (ref $bytes)) (local $lex_default (ref $bytes)) (local $lex_default_code (ref $bytes)) +)) (local.set $tbl (ref.cast (ref $block) (local.get $vtbl))) (local.set $lexbuf (ref.cast (ref $block) (local.get $vlexbuf))) (local.set $state @@ -258,37 +322,37 @@ (else (local.set $state (i32.sub (i32.const -1) (local.get $state))))) (local.set $lex_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_code)))) (local.set $lex_base - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_base)))) (local.set $lex_base_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_base_code)))) (local.set $lex_backtrk - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_backtrk)))) (local.set $lex_backtrk_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_backtrk_code)))) (local.set $lex_check - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_check)))) (local.set $lex_check_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_check_code)))) (local.set $lex_trans - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_trans)))) (local.set $lex_trans_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_trans_code)))) (local.set $lex_default - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_default)))) (local.set $lex_default_code - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tbl) (global.get $lex_default_code)))) (loop $loop (local.set $base (call $get (local.get $lex_base) (local.get $state))) diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat index 48ee44b3dd..78945704da 100644 --- a/runtime/wasm/marshal.wat +++ b/runtime/wasm/marshal.wat @@ -46,6 +46,16 @@ (import "custom" "caml_find_custom_operations" (func $caml_find_custom_operations (param (ref $bytes)) (result (ref null $custom_operations)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) + (import "jsstring" "jsstring_length" + (func $jsstring_length (param anyref) (result i32))) + (import "string" "caml_blit_string" + (func $caml_blit_string + (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq)))) (import "version-dependent" "caml_marshal_header_size" (global $caml_marshal_header_size i32)) @@ -633,7 +643,7 @@ ;; read_string (local.set $str (array.new $bytes (i32.const 0) (local.get $len))) (call $readblock (local.get $s) (local.get $str)) - (local.set $v (local.get $str)) + (local.set $v (call $caml_string_of_bytes (local.get $str))) (call $register_object (local.get $s) (local.get $v)) (br $done)) ;; read_block @@ -895,6 +905,19 @@ (struct.get $extern_state $buf (local.get $s)) (local.get $pos) (local.get $str) (i32.const 0) (local.get $len))) + (func $writestring + (param $s (ref $extern_state)) (param $str anyref) (param $len i32) + (local $pos i32) + (local.set $len (call $jsstring_length (local.get $str))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (local.get $len))) + (drop + (call $caml_blit_string ;; ZZZ lower level func? + (struct.new $js (local.get $str)) (ref.i31 (i32.const 0)) + (struct.get $extern_state $buf (local.get $s)) + (ref.i31 (local.get $pos)) + (ref.i31 (local.get $len))))) + (func $writefloat (param $s (ref $extern_state)) (param $f f64) (local $pos i32) (local $buf (ref $bytes)) (local $d i64) (local $i i32) @@ -1021,7 +1044,7 @@ (i32.or (local.get $tag) (i32.shl (local.get $sz) (i32.const 10))))))) - (func $extern_string (param $s (ref $extern_state)) (param $v (ref $bytes)) + (func $extern_bytes (param $s (ref $extern_state)) (param $v (ref $bytes)) (local $len i32) (local.set $len (array.len (local.get $v))) (if (i32.lt_u (local.get $len) (i32.const 0x20)) @@ -1037,6 +1060,22 @@ (local.get $len)))))) (call $writeblock (local.get $s) (local.get $v))) + (func $extern_string (param $s (ref $extern_state)) (param $v anyref) + (local $len i32) + (local.set $len (call $jsstring_length (local.get $v))) + (if (i32.lt_u (local.get $len) (i32.const 0x20)) + (then + (call $write (local.get $s) + (i32.add (global.get $PREFIX_SMALL_STRING) (local.get $len)))) + (else (if (i32.lt_u (local.get $len) (i32.const 0x100)) + (then + (call $writecode8 (local.get $s) (global.get $CODE_STRING8) + (local.get $len))) + (else + (call $writecode32 (local.get $s) (global.get $CODE_STRING32) + (local.get $len)))))) + (call $writestring (local.get $s) (local.get $v) (local.get $len))) + (func $extern_float (param $s (ref $extern_state)) (param $v f64) (call $write (local.get $s) (global.get $CODE_DOUBLE_LITTLE)) (call $writefloat (local.get $s) (local.get $v))) @@ -1129,6 +1168,7 @@ (local $hd i32) (local $tag i32) (local $sz i32) (local $pos i32) (local $r (tuple i32 i32)) + (local $js anyref) (loop $loop (block $next_item (drop (block $not_int (result (ref eq)) @@ -1188,7 +1228,7 @@ (local.set $str (br_on_cast_fail $not_string (ref eq) (ref $bytes) (local.get $v))) - (call $extern_string (local.get $s) (local.get $str)) + (call $extern_bytes (local.get $s) (local.get $str)) (local.set $sz (array.len (local.get $str))) (call $extern_size (local.get $s) (i32.add (i32.const 1) @@ -1236,11 +1276,25 @@ (call $caml_invalid_argument (array.new_data $bytes $cont_value (i32.const 0) (i32.const 32))))) - (if (ref.test (ref $js) (local.get $v)) - (then - (call $caml_invalid_argument - (array.new_data $bytes $js_value - (i32.const 0) (i32.const 47))))) + (drop (block $not_js (result (ref eq)) + (local.set $js + (struct.get $js 0 + (br_on_cast_fail $not_js (ref eq) (ref $js) + (local.get $v)))) + (if (call $jsstring_test (local.get $js)) + (then + (call $extern_string (local.get $s) (local.get $js)) + (local.set $sz (call $jsstring_length (local.get $js))) + (call $extern_size (local.get $s) + (i32.add (i32.const 1) + (i32.shr_u (local.get $sz) (i32.const 2))) + (i32.add (i32.const 1) + (i32.shr_u (local.get $sz) (i32.const 3)))) + (br $next_item))) + (call $caml_invalid_argument + (array.new_data $bytes $js_value + (i32.const 0) (i32.const 47))) + (ref.i31 (i32.const 0)))) (call $caml_invalid_argument (array.new_data $bytes $abstract_value (i32.const 0) (i32.const 28))) @@ -1346,7 +1400,7 @@ (br_on_null $done (struct.get $output_block $next (local.get $blk)))) (br $loop))) - (local.get $res)) + (return_call $caml_string_of_bytes (local.get $res))) (func (export "caml_output_value_to_buffer") (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) diff --git a/runtime/wasm/md5.wat b/runtime/wasm/md5.wat index 671de14964..ada3645788 100644 --- a/runtime/wasm/md5.wat +++ b/runtime/wasm/md5.wat @@ -21,6 +21,10 @@ (param (ref eq)) (param (ref $bytes)) (param i32) (param i32) (result i32))) (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (type $bytes (array (mut i8))) (type $int_array (array (mut i32))) @@ -32,7 +36,19 @@ (field (ref $int_array)) ;; buffer (field (ref $bytes)))) ;; intermediate buffer - (func (export "caml_md5_string") (export "caml_md5_bytes") +(#if use-js-string +(#then + (func (export "caml_md5_string") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $caml_md5_bytes + (call $caml_bytes_of_string (local.get 0)) + (local.get 1) (local.get 2))) +) +(#else + (export "caml_md5_string" (func $caml_md5_bytes)) +)) + + (func $caml_md5_bytes (export "caml_md5_bytes") (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) (local $ctx (ref $context)) (local.set $ctx (call $MD5Init)) @@ -484,7 +500,7 @@ (local.get $input) (local.get $input_pos) (local.get $input_len))))) - (func $MD5Final (param $ctx (ref $context)) (result (ref $bytes)) + (func $MD5Final (param $ctx (ref $context)) (result (ref eq)) (local $in_buf i32) (local $i i32) (local $len i64) (local $w (ref $int_array)) (local $buffer (ref $bytes)) (local $res (ref $bytes)) @@ -547,5 +563,5 @@ (i32.shl (local.get $i) (i32.const 3)))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (br_if $loop (i32.lt_u (local.get $i) (i32.const 16)))) - (local.get $res)) + (return_call $caml_string_of_bytes (local.get $res))) ) diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat index 602d81ad84..7c6dea3b7f 100644 --- a/runtime/wasm/obj.wat +++ b/runtime/wasm/obj.wat @@ -25,9 +25,12 @@ (func $caml_is_continuation (param (ref eq)) (result i32))) (import "effect" "caml_trampoline_ref" (global $caml_trampoline_ref (mut (ref null $function_1)))) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) + (type $js (struct (field anyref))) (type $float (struct (field f64))) (type $float_array (array (mut f64))) (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) @@ -216,6 +219,10 @@ (struct.get $float 0 (br_on_cast_fail $not_float (ref eq) (ref $float) (local.get 0))))))) + (if (ref.test (ref $js) (local.get 0)) + (then + ;; ZZZ check string + (return (local.get 0)))) (call $caml_dup_custom (local.get 0))) (func (export "caml_obj_with_tag") @@ -258,6 +265,13 @@ (then (return (ref.i31 (global.get $closure_tag))))) (if (call $caml_is_continuation (local.get $v)) (then (return (ref.i31 (global.get $cont_tag))))) + (drop (block $not_string (result (ref eq)) + (if (call $jsstring_test + (struct.get $js 0 + (br_on_cast_fail $not_string (ref eq) (ref $js) + (local.get $v)))) + (then (return (ref.i31 (global.get $string_tag))))) + (ref.i31 (i32.const 0)))) (ref.i31 (global.get $abstract_tag))) (func (export "caml_obj_make_forward") diff --git a/runtime/wasm/parsing.wat b/runtime/wasm/parsing.wat index 8567734727..e122fcb988 100644 --- a/runtime/wasm/parsing.wat +++ b/runtime/wasm/parsing.wat @@ -21,6 +21,10 @@ (func $caml_ml_output (param (ref eq)) (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "io" "caml_ml_output_bytes" + (func $caml_ml_output_bytes + (param (ref eq)) (param (ref eq)) (param (ref eq)) (param (ref eq)) + (result (ref eq)))) (import "io" "caml_ml_flush" (func $caml_ml_flush (param (ref eq)) (result (ref eq)))) (import "ints" "caml_format_int" @@ -29,19 +33,66 @@ (import "float" "caml_format_float" (func $caml_format_float (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_length" + (func $caml_string_length (param (ref eq)) (result i32))) (type $float (struct (field f64))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) - (func $get (param $a (ref eq)) (param $i i32) (result i32) - (local $s (ref $bytes)) - (local.set $s (ref.cast (ref $bytes) (local.get $a))) +(#if use-js-string +(#then + (import "wasm:js-string" "substring" + (func $string_substring (param externref i32 i32) (result (ref extern)))) + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) + + (func $string_sub + (param $s externref) (param $i i32) (param $l i32) (result (ref eq)) + (struct.new $string + (any.convert_extern + (call $string_substring + (local.get $s) + (local.get $i) + (i32.add (local.get $i) (local.get $l)))))) + + (func $string_val (param $s (ref eq)) (result externref) + (extern.convert_any + (struct.get $string 0 (ref.cast (ref $string) (local.get $s))))) +) +(#else + (func $string_sub + (param $s (ref $bytes)) (param $i i32) (param $l i32) (result (ref eq)) + (local $s' (ref $bytes)) + (local.set $s' (array.new $bytes (i32.const 0) (local.get $l))) + (array.copy $bytes $bytes + (local.get $s') (i32.const 0) + (local.get $s) (local.get $i) + (local.get $l)) + (local.get $s')) + (func $string_get (param $s (ref $bytes)) (param $i i32) (result i32) + (array.get $bytes (local.get $s) (local.get $i))) + (func $string_val (param $s (ref eq)) (result (ref $bytes)) + (ref.cast (ref $bytes) (local.get $s))) +)) + + (func $get +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $i i32) (result i32) (local.set $i (i32.add (local.get $i) (local.get $i))) (i32.extend16_s - (i32.or (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.or (call $string_get (local.get $s) (local.get $i)) (i32.shl - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.add (local.get $i) (i32.const 1))) (i32.const 8))))) @@ -100,11 +151,19 @@ (global $tbl_names_const i32 (i32.const 15)) (global $tbl_names_block i32 (i32.const 16)) - (func $strlen (param $s (ref $bytes)) (param $p i32) (result i32) + (func $strlen +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $p i32) (result i32) (local $i i32) (local.set $i (local.get $p)) (loop $loop - (if (i32.ne (array.get_u $bytes (local.get $s) (local.get $i)) + (if (i32.ne (call $string_get (local.get $s) (local.get $i)) (i32.const 0)) (then (local.set $i (i32.add (local.get $i) (i32.const 1))) @@ -114,15 +173,22 @@ (data $unknown_token "") (func $token_name (param $vnames (ref eq)) (param $number i32) (result (ref eq)) - (local $names (ref $bytes)) (local $i i32) (local $len i32) - (local $name (ref $bytes)) - (local.set $names (ref.cast (ref $bytes) (local.get $vnames))) +(#if use-js-string +(#then + (local $names externref) +) +(#else + (local $names (ref $bytes)) +)) + (local $i i32) (local $len i32) + (local.set $names (call $string_val (local.get $vnames))) (loop $loop - (if (i32.eqz (array.get_u $bytes (local.get $names) (local.get $i))) + (if (i32.eqz (call $string_get (local.get $names) (local.get $i))) (then (return - (array.new_data $bytes $unknown_token - (i32.const 0) (i32.const 15))))) + (call $caml_string_of_bytes + (array.new_data $bytes $unknown_token + (i32.const 0) (i32.const 15)))))) (if (i32.ne (local.get $number) (i32.const 0)) (then (local.set $i @@ -132,23 +198,26 @@ (local.set $number (i32.sub (local.get $number) (i32.const 1))) (br $loop)))) (local.set $len (call $strlen (local.get $names) (local.get $i))) - (local.set $name (array.new $bytes (i32.const 0) (local.get $len))) - (array.copy $bytes $bytes - (local.get $name) (i32.const 0) - (local.get $names) (local.get $i) (local.get $len)) - (local.get $name)) + (return_call $string_sub + (local.get $names) (local.get $i) (local.get $len))) - (func $output (param (ref eq)) + (func $output (param $s (ref eq)) + (drop + (call $caml_ml_output (global.get $caml_stderr) + (local.get $s) (ref.i31 (i32.const 0)) + (ref.i31 (call $caml_string_length (local.get $s)))))) + + (func $output_bytes (param (ref eq)) (local $s (ref $bytes)) (local.set $s (ref.cast (ref $bytes) (local.get 0))) (drop - (call $caml_ml_output (global.get $caml_stderr) + (call $caml_ml_output_bytes (global.get $caml_stderr) (local.get $s) (ref.i31 (i32.const 0)) (ref.i31 (array.len (local.get $s)))))) (func $output_nl (drop - (call $caml_ml_output (global.get $caml_stderr) + (call $caml_ml_output_bytes (global.get $caml_stderr) (array.new_fixed $bytes 1 (i32.const 10)) (ref.i31 (i32.const 0)) (ref.i31 (i32.const 1)))) (drop (call $caml_ml_flush (global.get $caml_stderr)))) @@ -156,7 +225,8 @@ (func $output_int (param i32) (call $output (call $caml_format_int - (array.new_fixed $bytes 2 (i32.const 37) (i32.const 100)) + (call $caml_string_of_bytes + (array.new_fixed $bytes 2 (i32.const 37) (i32.const 100))) (ref.i31 (local.get 0))))) (data $State "State ") @@ -168,10 +238,10 @@ (local $v (ref eq)) (if (ref.test (ref i31) (local.get $tok)) (then - (call $output + (call $output_bytes (array.new_data $bytes $State (i32.const 0) (i32.const 6))) (call $output_int (local.get $state)) - (call $output + (call $output_bytes (array.new_data $bytes $read_token (i32.const 0) (i32.const 13))) (call $output (call $token_name @@ -180,10 +250,10 @@ (i31.get_u (ref.cast (ref i31) (local.get $tok))))) (call $output_nl)) (else - (call $output + (call $output_bytes (array.new_data $bytes $State (i32.const 0) (i32.const 6))) (call $output_int (local.get $state)) - (call $output + (call $output_bytes (array.new_data $bytes $read_token (i32.const 0) (i32.const 13))) (local.set $b (ref.cast (ref $block) (local.get $tok))) (call $output @@ -193,7 +263,7 @@ (i31.get_u (ref.cast (ref i31) (array.get $block (local.get $b) (i32.const 0)))))) - (call $output (array.new_fixed $bytes 1 (i32.const 40))) ;; "(" + (call $output_bytes (array.new_fixed $bytes 1 (i32.const 40))) ;; "(" (local.set $v (array.get $block (local.get $b) (i32.const 1))) (if (ref.test (ref i31) (local.get $v)) (then @@ -209,9 +279,9 @@ (i32.const 37) (i32.const 103)) (local.get $v)))) (else - (call $output + (call $output_bytes (array.new_fixed $bytes 1 (i32.const 95))))))))) ;; '_' - (call $output (array.new_fixed $bytes 1 (i32.const 41))) ;; ")" + (call $output_bytes (array.new_fixed $bytes 1 (i32.const 41))) ;; ")" (call $output_nl)))) (data $recovering_in_state "Recovering in state ") @@ -230,6 +300,19 @@ (local $errflag i32) (local $tables (ref $block)) (local $env (ref $block)) (local $cmd i32) (local $arg (ref $block)) +(#if use-js-string +(#then + (local $tbl_defred externref) + (local $tbl_sindex externref) + (local $tbl_check externref) + (local $tbl_rindex externref) + (local $tbl_table externref) + (local $tbl_len externref) + (local $tbl_lhs externref) + (local $tbl_gindex externref) + (local $tbl_dgoto externref) +) +(#else (local $tbl_defred (ref $bytes)) (local $tbl_sindex (ref $bytes)) (local $tbl_check (ref $bytes)) @@ -239,33 +322,34 @@ (local $tbl_lhs (ref $bytes)) (local $tbl_gindex (ref $bytes)) (local $tbl_dgoto (ref $bytes)) +)) (local.set $tables (ref.cast (ref $block) (local.get $vtables))) (local.set $tbl_defred - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_defred)))) (local.set $tbl_sindex - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_sindex)))) (local.set $tbl_check - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_check)))) (local.set $tbl_rindex - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_rindex)))) (local.set $tbl_table - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_table)))) (local.set $tbl_len - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_len)))) (local.set $tbl_lhs - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_lhs)))) (local.set $tbl_gindex - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_gindex)))) (local.set $tbl_dgoto - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $tables) (global.get $tbl_dgoto)))) (local.set $env (ref.cast (ref $block) (local.get $venv))) (local.set $cmd (i31.get_s (ref.cast (ref i31) (local.get $vcmd)))) @@ -455,7 +539,7 @@ (then (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $recovering_in_state (i32.const 0) @@ -468,7 +552,7 @@ (br $next))))))) (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $discarding_state (i32.const 0) (i32.const 17))) (call $output_int (local.get $state1)) @@ -481,7 +565,7 @@ (then (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $no_more_states_to_discard (i32.const 0) (i32.const 25))) @@ -498,7 +582,7 @@ (return (ref.i31 (global.get $RAISE_PARSE_ERROR))))) (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $discarding_last_token_read (i32.const 0) (i32.const 26))) (call $output_nl))) @@ -518,11 +602,11 @@ ;; shift_recover: (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $State (i32.const 0) (i32.const 6))) (call $output_int (local.get $state)) - (call $output + (call $output_bytes (array.new_data $bytes $shift_to_state (i32.const 0) (i32.const 17))) (call $output_int @@ -568,10 +652,10 @@ ;; reduce: (if (global.get $caml_parser_trace) (then - (call $output + (call $output_bytes (array.new_data $bytes $State (i32.const 0) (i32.const 6))) (call $output_int (local.get $state)) - (call $output + (call $output_bytes (array.new_data $bytes $reduce_by_rule (i32.const 0) (i32.const 17))) (call $output_int (local.get $n)) diff --git a/runtime/wasm/printexc.wat b/runtime/wasm/printexc.wat index 0f93596955..1203269644 100644 --- a/runtime/wasm/printexc.wat +++ b/runtime/wasm/printexc.wat @@ -21,8 +21,19 @@ (import "ints" "caml_format_int" (func $caml_format_int (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_length" + (func $caml_string_length (param (ref eq)) (result i32))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) + (import "string" "caml_blit_string" + (func $caml_blit_string + (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq)))) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) (type $block (array (mut (ref eq)))) + (type $string (struct (field anyref))) (type $bytes (array (mut i8))) (type $buffer @@ -41,26 +52,39 @@ (struct.set $buffer 0 (local.get $buf) (i32.add (local.get $pos) (i32.const 1)))))) - (func $add_string (param $buf (ref $buffer)) (param $v (ref eq)) + (func $add_string (param $buf (ref $buffer)) (param $s (ref eq)) (local $pos i32) (local $len i32) (local $data (ref $bytes)) - (local $s (ref $bytes)) (local.set $pos (struct.get $buffer 0 (local.get $buf))) (local.set $data (struct.get $buffer 1 (local.get $buf))) - (local.set $s (ref.cast (ref $bytes) (local.get $v))) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $caml_string_length (local.get $s))) (if (i32.gt_u (i32.add (local.get $pos) (local.get $len)) (array.len (local.get $data))) (then (local.set $len (i32.sub (array.len (local.get $data)) (local.get $pos))))) - (array.copy $bytes $bytes - (local.get $data) (local.get $pos) - (local.get $s) (i32.const 0) - (local.get $len)) + (drop (call $caml_blit_string + (local.get $s) (ref.i31 (i32.const 0)) + (local.get $data) (ref.i31 (local.get $pos)) + (ref.i31 (local.get $len)))) (struct.set $buffer 0 (local.get $buf) (i32.add (local.get $pos) (local.get $len)))) +(#if use-js-string +(#then + (func $is_string (param $v (ref eq)) (result i32) + (drop (block $not_string (result (ref eq)) + (return_call $jsstring_test + (struct.get $string 0 + (br_on_cast_fail $not_string (ref eq) (ref $string) + (local.get $v)))))) + (i32.const 0)) +) +(#else + (func $is_string (param $v (ref eq)) (result i32) + (ref.test (ref $bytes) (local.get $v))) +)) + (func (export "caml_format_exception") (param (ref eq)) (result (ref eq)) (local $exn (ref $block)) (local $buf (ref $buffer)) @@ -117,10 +141,11 @@ (then (call $add_string (local.get $buf) (call $caml_format_int - (array.new_fixed $bytes 2 - (i32.const 37) (i32.const 100)) ;; %d + (call $caml_string_of_bytes + (array.new_fixed $bytes 2 + (i32.const 37) (i32.const 100))) ;; %d (ref.cast (ref i31) (local.get $v))))) - (else (if (ref.test (ref $bytes) (local.get $v)) + (else (if (call $is_string (local.get $v)) (then (call $add_char (local.get $buf) (i32.const 34)) ;; '\"' @@ -146,7 +171,7 @@ (local.get $s) (i32.const 0) (struct.get $buffer 1 (local.get $buf)) (i32.const 0) (struct.get $buffer 0 (local.get $buf))) - (local.get $s)) + (call $caml_string_of_bytes (local.get $s))) (else (array.get $block (local.get $exn) (i32.const 1))))) ) diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index acc22b28d9..9c57a3a481 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -130,7 +130,27 @@ return (((h + (h << 2)) | 0) + (0xe6546b64 | 0)) | 0; } function hash_string(h, s) { - for (var i = 0; i < s.length; i++) h = hash_int(h, s.charCodeAt(i)); + const len = s.length; + for (var i = 0; i + 4 <= len; i += 4) { + var w = + s.charCodeAt(i) | + (s.charCodeAt(i + 1) << 8) | + (s.charCodeAt(i + 2) << 16) | + (s.charCodeAt(i + 3) << 24); + h = hash_int(h, w); + } + w = 0; + switch (len & 3) { + case 3: + // biome-ignore lint/suspicious/noFallthroughSwitchClause: + w = s.charCodeAt(i + 2) << 16; + case 2: + // biome-ignore lint/suspicious/noFallthroughSwitchClause: + w |= s.charCodeAt(i + 1) << 8; + case 1: + w |= s.charCodeAt(i); + h = hash_int(h, w); + } return h ^ s.length; } @@ -227,6 +247,17 @@ ta_blit_to_bytes: (a, p1, s, p2, l) => { for (let i = 0; i < l; i++) string_set(s, p2 + i, a[p1 + i]); }, + ta_blit_from_string: (s, p1, a, p2, l) => { + for (let i = 0; i < l; i++) a[p2 + i] = s.charCodeAt(p1 + i); + }, + ta_to_string: (a) => { + let len = a.length; + if (len <= 4096) return String.fromCharCode(...a); + var s = ""; + for (let i = 0; 0 < len; i += 1024, len -= 1024) + s += String.fromCharCode(...a.subarray(i, i + Math.min(len, 1024))); + return s; + }, wrap_callback: (f) => function (...args) { if (args.length === 0) { @@ -438,11 +469,16 @@ }; const string_ops = { test: (v) => +(typeof v === "string"), - compare: (s1, s2) => (s1 < s2 ? -1 : +(s1 > s2)), + compare: (s1, s2) => (s1 === s2 ? 0 : s1 < s2 ? -1 : 1), hash: hash_string, decodeStringFromUTF8Array: () => "", encodeStringToUTF8Array: () => 0, fromCharCodeArray: () => "", + length: (s) => s.length, + charCodeAt: (s, i) => s.charCodeAt(i), + concat: (s1, s2) => s1.concat(s2), + equals: (s1, s2) => +(s1 === s2), + substring: (s, i, j) => s.substring(i, j), }; const imports = Object.assign( { diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat index 8fa847e8d7..a5132d3fb6 100644 --- a/runtime/wasm/stdlib.wat +++ b/runtime/wasm/stdlib.wat @@ -35,6 +35,8 @@ (import "string" "caml_string_concat" (func $caml_string_concat (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) (import "printexc" "caml_format_exception" (func $caml_format_exception (param (ref eq)) (result (ref eq)))) (import "sys" "ocaml_exit" (tag $ocaml_exit (param i32))) @@ -43,11 +45,12 @@ (import "bindings" "throw" (func $throw (param externref))) (type $block (array (mut (ref eq)))) + (type $string (struct (field anyref))) (type $bytes (array (mut i8))) (type $assoc (struct - (field (ref $bytes)) + (field (ref eq)) (field (mut (ref eq))) (field (mut (ref null $assoc))))) @@ -76,7 +79,9 @@ (br $loop)))) (func $caml_named_value (export "caml_named_value") - (param $s (ref $bytes)) (result (ref null eq)) + (param $v (ref eq)) (result (ref null eq)) + (local $s (ref eq)) + (local.set $s (call $caml_string_of_bytes (local.get $v))) (block $not_found (return (struct.get $assoc 1 @@ -114,9 +119,7 @@ (return (ref.i31 (i32.const 0)))) (array.set $assoc_array (global.get $named_value_table) (local.get $h) - (struct.new $assoc - (ref.cast (ref $bytes) (local.get 0)) - (local.get 1) (local.get $r))) + (struct.new $assoc (local.get 0) (local.get 1) (local.get $r))) (ref.i31 (i32.const 0))) ;; Used only for testing (tests-jsoo/bin), but inconvenient to pull out @@ -209,9 +212,9 @@ (call $caml_callback_2 (br_on_null $not_registered (call $caml_named_value - (array.new_data $bytes - $handle_uncaught_exception - (i32.const 0) (i32.const 34)))) + (array.new_data $bytes + $handle_uncaught_exception + (i32.const 0) (i32.const 34)))) (local.get $exn) (ref.i31 (i32.const 0)))) (br $exit)) @@ -227,11 +230,13 @@ (call $unwrap (call $caml_jsstring_of_string (call $caml_string_concat - (array.new_data $bytes $fatal_error - (i32.const 0) (i32.const 23)) + (call $caml_string_of_bytes + (array.new_data $bytes $fatal_error + (i32.const 0) (i32.const 23))) (call $caml_string_concat (call $caml_format_exception (local.get $exn)) - (array.new_fixed $bytes 1 - (i32.const 10)))))))) ;; `\n` - (call $exit (i32.const 2))))) + (call $caml_string_of_bytes + (array.new_fixed $bytes 1 + (i32.const 10))))))))) ;; `\n` + (call $exit (i32.const 2))))) ) diff --git a/runtime/wasm/str.wat b/runtime/wasm/str.wat index 5890d6b2e0..bc86ecee4f 100644 --- a/runtime/wasm/str.wat +++ b/runtime/wasm/str.wat @@ -19,8 +19,35 @@ (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) + (import "string" "caml_blit_string" + (func $caml_blit_string + (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq)))) + +(#if use-js-string +(#then + (import "wasm:js-string" "length" + (func $string_length (param externref) (result i32))) + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) + + (func $string_val (param $s (ref eq)) (result externref) + (extern.convert_any + (struct.get $string 0 (ref.cast (ref $string) (local.get $s))))) +) +(#else + (func $string_length (param $s (ref $bytes)) (result i32) + (array.len (local.get $s))) + (func $string_get (param $s (ref $bytes)) (param $i i32) (result i32) + (array.get $bytes (local.get $s) (local.get $i))) + (func $string_val (param $s (ref eq)) (result (ref $bytes)) + (ref.cast (ref $bytes) (local.get $s))) +)) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) (type $block (array (mut (ref eq)))) (type $char_table (array i8)) @@ -67,24 +94,48 @@ (i32.shr_u (local.get $c) (i32.const 3))) (i32.and (local.get $c) (i32.const 7))))) - (func $in_bitset (param $s (ref $bytes)) (param $c i32) (result i32) + (func $in_bitset +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $c i32) (result i32) (i32.and (i32.const 1) (i32.shr_u - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.shr_u (local.get $c) (i32.const 3))) (i32.and (local.get $c) (i32.const 7))))) (func $re_match - (param $vre (ref eq)) (param $s (ref $bytes)) (param $pos i32) - (param $accept_partial_match i32) (result (ref eq)) + (param $vre (ref eq)) +(#if use-js-string +(#then + (param $s externref) +) +(#else + (param $s (ref $bytes)) +)) + (param $pos i32) (param $accept_partial_match i32) (result (ref eq)) (local $res (ref $block)) - (local $s' (ref $bytes)) (local $set (ref $bytes)) +(#if use-js-string +(#then + (local $s' externref) + (local $set externref) + (local $normtable externref) +) +(#else + (local $s' (ref $bytes)) + (local $set (ref $bytes)) + (local $normtable (ref $bytes)) +)) (local $len i32) (local $instr i32) (local $arg i32) (local $i i32) (local $j i32) (local $l i32) (local $re (ref $block)) (local $prog (ref $block)) (local $cpool (ref $block)) - (local $normtable (ref $bytes)) (local $numgroups i32) (local $numregisters i32) (local $group_start (ref $int_array)) @@ -94,7 +145,7 @@ (local $stack (ref null $stack)) (local $u (ref $undo)) (local $p (ref $pos)) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $string_length (local.get $s))) (local.set $re (ref.cast (ref $block) (local.get $vre))) (local.set $prog (ref.cast (ref $block) @@ -103,8 +154,7 @@ (ref.cast (ref $block) (array.get $block (local.get $re) (i32.const 2)))) (local.set $normtable - (ref.cast (ref $bytes) - (array.get $block (local.get $re) (i32.const 3)))) + (call $string_val (array.get $block (local.get $re) (i32.const 3)))) (local.set $numgroups (i31.get_s (ref.cast (ref i31) @@ -166,7 +216,7 @@ (i32.shr_u (local.get $instr) (i32.const 8))) (br_if $backtrack (i32.ne (local.get $arg) - (array.get_u $bytes + (call $string_get (local.get $s) (local.get $pos)))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -178,9 +228,9 @@ (i32.shr_u (local.get $instr) (i32.const 8))) (br_if $backtrack (i32.ne (local.get $arg) - (array.get_u $bytes + (call $string_get (local.get $normtable) - (array.get_u $bytes + (call $string_get (local.get $s) (local.get $pos))))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -189,11 +239,12 @@ (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) (local.set $s' - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) - (i32.add (local.get $arg) (i32.const 1))))) + (i32.add (local.get $arg) + (i32.const 1))))) (local.set $i (i32.const 0)) - (local.set $l (array.len (local.get $s'))) + (local.set $l (call $string_length (local.get $s'))) (loop $loop (if (i32.lt_u (local.get $i) (local.get $l)) (then @@ -202,9 +253,9 @@ (local.get $pos) (local.get $len))) (br_if $backtrack (i32.ne - (array.get_u $bytes (local.get $s') + (call $string_get (local.get $s') (local.get $i)) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos)))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -216,11 +267,12 @@ (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) (local.set $s' - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) - (i32.add (local.get $arg) (i32.const 1))))) + (i32.add (local.get $arg) + (i32.const 1))))) (local.set $i (i32.const 0)) - (local.set $l (array.len (local.get $s'))) + (local.set $l (call $string_length (local.get $s'))) (loop $loop (if (i32.lt_u (local.get $i) (local.get $l)) (then @@ -229,11 +281,11 @@ (local.get $pos) (local.get $len))) (br_if $backtrack (i32.ne - (array.get_u $bytes (local.get $s') + (call $string_get (local.get $s') (local.get $i)) - (array.get_u $bytes + (call $string_get (local.get $normtable) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos))))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -249,11 +301,11 @@ (br_if $backtrack (i32.eqz (call $in_bitset - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) (i32.add (local.get $arg) (i32.const 1)))) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos))))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -262,7 +314,7 @@ (br_if $continue (i32.eqz (local.get $pos))) (br_if $continue (i32.eq (i32.const 10) ;; '\n' - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.sub (local.get $pos) (i32.const 1))))) (br $backtrack)) ;; EOL @@ -270,7 +322,7 @@ (i32.eq (local.get $pos) (local.get $len))) (br_if $continue (i32.eq (i32.const 10) ;; '\n' - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos)))) (br $backtrack)) ;; WORDBOUNDARY @@ -280,7 +332,7 @@ (i32.eq (local.get $pos) (local.get $len))) (br_if $continue (call $is_word_letter - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos)))) (br $backtrack)) (else @@ -288,7 +340,7 @@ (then (br_if $continue (call $is_word_letter - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.sub (local.get $pos) (i32.const 1))))) (br $backtrack)) @@ -296,11 +348,11 @@ (br_if $continue (i32.ne (call $is_word_letter - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (i32.sub (local.get $pos) (i32.const 1)))) (call $is_word_letter - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos))))) (br $backtrack)))))) ;; BEGGROUP @@ -348,9 +400,9 @@ (i32.eq (local.get $pos) (local.get $len))) (br_if $backtrack (i32.ne - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $i)) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos)))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) @@ -363,10 +415,11 @@ (if (i32.lt_u (local.get $pos) (local.get $len)) (then (if (call $in_bitset - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) - (i32.add (local.get $arg) (i32.const 1)))) - (array.get_u $bytes (local.get $s) + (i32.add (local.get $arg) + (i32.const 1)))) + (call $string_get (local.get $s) (local.get $pos))) (then (local.set $pos @@ -375,14 +428,14 @@ ;; SIMPLESTAR (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) (local.set $set - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) - (i32.add (local.get $arg) (i32.const 1))))) + (i32.add (local.get $arg) (i32.const 1))))) (loop $loop (if (i32.lt_u (local.get $pos) (local.get $len)) (then (if (call $in_bitset (local.get $set) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos))) (then (local.set $pos @@ -393,20 +446,20 @@ (br_if $prefix_match (i32.eq (local.get $pos) (local.get $len))) (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) (local.set $set - (ref.cast (ref $bytes) + (call $string_val (array.get $block (local.get $cpool) - (i32.add (local.get $arg) (i32.const 1))))) + (i32.add (local.get $arg) (i32.const 1))))) (br_if $backtrack (i32.eqz (call $in_bitset (local.get $set) - (array.get_u $bytes (local.get $s) (local.get $pos))))) + (call $string_get (local.get $s) (local.get $pos))))) (loop $loop (local.set $pos (i32.add (local.get $pos) (i32.const 1))) (if (i32.lt_u (local.get $pos) (local.get $len)) (then (br_if $loop (call $in_bitset (local.get $set) - (array.get_u $bytes (local.get $s) + (call $string_get (local.get $s) (local.get $pos))))))) (br $continue)) ;; GOTO @@ -513,12 +566,18 @@ (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) (result (ref eq)) ;; ZZZ startchars +(#if use-js-string +(#then + (local $s externref) +) +(#else (local $s (ref $bytes)) +)) (local $pos i32) (local $len i32) (local $res (ref eq)) - (local.set $s (ref.cast (ref $bytes) (local.get $vs))) + (local.set $s (call $string_val (local.get $vs))) (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $string_length (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then (call $caml_invalid_argument @@ -541,12 +600,18 @@ (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) (result (ref eq)) ;; ZZZ startchars +(#if use-js-string +(#then + (local $s externref) +) +(#else (local $s (ref $bytes)) +)) (local $pos i32) (local $len i32) (local $res (ref eq)) - (local.set $s (ref.cast (ref $bytes) (local.get $vs))) + (local.set $s (call $string_val (local.get $vs))) (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $string_length (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then (call $caml_invalid_argument @@ -569,12 +634,18 @@ (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) (result (ref eq)) ;; ZZZ startchars +(#if use-js-string +(#then + (local $s externref) +) +(#else (local $s (ref $bytes)) +)) (local $pos i32) (local $len i32) (local $res (ref eq)) - (local.set $s (ref.cast (ref $bytes) (local.get $vs))) + (local.set $s (call $string_val (local.get $vs))) (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $string_length (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then (call $caml_invalid_argument @@ -594,12 +665,18 @@ (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) (result (ref eq)) ;; ZZZ startchars +(#if use-js-string +(#then + (local $s externref) +) +(#else (local $s (ref $bytes)) +)) (local $pos i32) (local $len i32) (local $res (ref eq)) - (local.set $s (ref.cast (ref $bytes) (local.get $vs))) + (local.set $s (call $string_val (local.get $vs))) (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) - (local.set $len (array.len (local.get $s))) + (local.set $len (call $string_length (local.get $s))) (if (i32.gt_u (local.get $pos) (local.get $len)) (then (call $caml_invalid_argument @@ -617,23 +694,27 @@ (data $unmatched_group "Str.replace: reference to unmatched group") (func (export "re_replacement_text") - (param $vrepl (ref eq)) (param $vgroups (ref eq)) (param $vorig (ref eq)) + (param $vrepl (ref eq)) (param $vgroups (ref eq)) (param $orig (ref eq)) (result (ref eq)) +(#if use-js-string +(#then + (local $repl externref) +) +(#else (local $repl (ref $bytes)) +)) (local $groups (ref $block)) - (local $orig (ref $bytes)) (local $res (ref $bytes)) (local $i i32) (local $j i32) (local $l i32) (local $len i32) (local $c i32) (local $start i32) (local $end i32) - (local.set $repl (ref.cast (ref $bytes) (local.get $vrepl))) - (local.set $l (array.len (local.get $repl))) + (local.set $repl (call $string_val (local.get $vrepl))) + (local.set $l (call $string_length (local.get $repl))) (local.set $groups (ref.cast (ref $block) (local.get $vgroups))) - (local.set $orig (ref.cast (ref $bytes) (local.get $vorig))) (loop $loop (if (i32.lt_u (local.get $i) (local.get $l)) (then (local.set $c - (array.get_u $bytes (local.get $repl) (local.get $i))) + (call $string_get (local.get $repl) (local.get $i))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (if (i32.ne (local.get $c) (i32.const 92)) ;; '\\' (then @@ -645,7 +726,7 @@ (array.new_data $bytes $illegal_backslash (i32.const 0) (i32.const 39))))) (local.set $c - (array.get_u $bytes (local.get $repl) (local.get $i))) + (call $string_get (local.get $repl) (local.get $i))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (if (i32.eq (local.get $c) (i32.const 92)) ;; '\\' (then @@ -688,7 +769,7 @@ (if (i32.lt_u (local.get $i) (local.get $l)) (then (local.set $c - (array.get_u $bytes (local.get $repl) (local.get $i))) + (call $string_get (local.get $repl) (local.get $i))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (if (i32.ne (local.get $c) (i32.const 92)) ;; '\\' (then @@ -697,7 +778,7 @@ (local.set $j (i32.add (local.get $j) (i32.const 1))) (br $loop))) (local.set $c - (array.get_u $bytes (local.get $repl) (local.get $i))) + (call $string_get (local.get $repl) (local.get $i))) (local.set $i (i32.add (local.get $i) (i32.const 1))) (if (i32.eq (local.get $c) (i32.const 92)) ;; '\\' (then @@ -733,11 +814,12 @@ (array.get $block (local.get $groups) (i32.add (local.get $c) (i32.const 2)))))) (local.set $len (i32.sub (local.get $end) (local.get $start))) - (array.copy $bytes $bytes - (local.get $res) (local.get $j) - (local.get $orig) (local.get $start) - (local.get $len)) + (drop + (call $caml_blit_string + (local.get $orig) (ref.i31 (local.get $start)) + (local.get $res) (ref.i31 (local.get $j)) + (ref.i31 (local.get $len)))) (local.set $j (i32.add (local.get $j) (local.get $len))) (br $loop)))) - (local.get $res)) + (call $caml_string_of_bytes (local.get $res))) ) diff --git a/runtime/wasm/string.wat b/runtime/wasm/string.wat index a0eb47fa78..5eb1d18db5 100644 --- a/runtime/wasm/string.wat +++ b/runtime/wasm/string.wat @@ -19,11 +19,115 @@ (import "fail" "caml_bound_error" (func $caml_bound_error)) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param $arg (ref eq)))) + (import "wasm:js-string" "equals" + (func $string_equals (param externref externref) (result i32))) + (import "wasm:js-string" "compare" + (func $string_compare (param externref externref) (result i32))) + (import "wasm:js-string" "length" + (func $string_length (param externref) (result i32))) + (import "wasm:js-string" "charCodeAt" + (func $string_get (param externref i32) (result i32))) + (import "wasm:js-string" "concat" + (func $string_concat (param externref externref) (result (ref extern)))) + (import "jsstring" "jsbytes_of_bytes" + (func $jsbytes_of_bytes (param (ref $bytes)) (result anyref))) (type $bytes (array (mut i8))) + (type $string (struct (field anyref))) - (export "caml_bytes_equal" (func $caml_string_equal)) +(#if use-js-string +(#then (func $caml_string_equal (export "caml_string_equal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (call $string_equals + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))))) + + (func (export "caml_string_notequal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (return + (ref.i31 (i32.eqz (i31.get_u (ref.cast (ref i31) + (call $caml_string_equal (local.get $p1) (local.get $p2)))))))) + + (func (export "caml_string_compare") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (call $string_compare + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))))) + + (func (export "caml_string_lessequal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.le_s + (call $string_compare + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))) + (i32.const 0)))) + + (func (export "caml_string_lessthan") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.lt_s + (call $string_compare + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))) + (i32.const 0)))) + + (func (export "caml_string_greaterequal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.ge_s + (call $string_compare + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))) + (i32.const 0)))) + + (func (export "caml_string_greaterthan") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.gt_s + (call $string_compare + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $p2))))) + (i32.const 0)))) +) +(#else + (export "caml_string_equal" (func $caml_bytes_equal)) + (export "caml_string_notequal" (func $caml_bytes_notequal)) + (export "caml_string_compare" (func $caml_bytes_compare)) + (export "caml_string_lessequal" (func $caml_bytes_lessequal)) + (export "caml_string_lessthan" (func $caml_bytes_lessthan)) + (export "caml_string_greaterequal" (func $caml_bytes_greaterequal)) + (export "caml_string_greaterthan" (func $caml_bytes_greaterthan)) +)) + + (func $caml_bytes_equal (export "caml_bytes_equal") (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) (local $s1 (ref $bytes)) (local $s2 (ref $bytes)) (local $len i32) (local $i i32) @@ -45,14 +149,13 @@ (br $loop)))) (ref.i31 (i32.const 1))) - (export "caml_bytes_notequal" (func $caml_string_notequal)) - (func $caml_string_notequal (export "caml_string_notequal") + (func $caml_bytes_notequal (export "caml_bytes_notequal") (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) (return (ref.i31 (i32.eqz (i31.get_u (ref.cast (ref i31) - (call $caml_string_equal (local.get $p1) (local.get $p2)))))))) + (call $caml_bytes_equal (local.get $p1) (local.get $p2)))))))) - (func $string_compare + (func $bytes_compare (param $p1 (ref eq)) (param $p2 (ref eq)) (result i32) (local $s1 (ref $bytes)) (local $s2 (ref $bytes)) (local $l1 i32) (local $l2 i32) (local $len i32) (local $i i32) @@ -85,39 +188,61 @@ (then (return (i32.const 1)))) (i32.const 0)) - (export "caml_bytes_compare" (func $caml_string_compare)) - (func $caml_string_compare (export "caml_string_compare") + (func $caml_bytes_compare (export "caml_bytes_compare") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (call $string_compare (local.get 0) (local.get 1)))) + (ref.i31 (call $bytes_compare (local.get 0) (local.get 1)))) - (export "caml_bytes_lessequal" (func $caml_string_lessequal)) - (func $caml_string_lessequal (export "caml_string_lessequal") + (func $caml_bytes_lessequal (export "caml_bytes_lessequal") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.le_s (call $string_compare (local.get 0) (local.get 1)) + (ref.i31 (i32.le_s (call $bytes_compare (local.get 0) (local.get 1)) (i32.const 0)))) - (export "caml_bytes_lessthan" (func $caml_string_lessthan)) - (func $caml_string_lessthan (export "caml_string_lessthan") + (func $caml_bytes_lessthan (export "caml_bytes_lessthan") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.lt_s (call $string_compare (local.get 0) (local.get 1)) + (ref.i31 (i32.lt_s (call $bytes_compare (local.get 0) (local.get 1)) (i32.const 0)))) - (export "caml_bytes_greaterequal" (func $caml_string_greaterequal)) - (func $caml_string_greaterequal (export "caml_string_greaterequal") + (func $caml_bytes_greaterequal (export "caml_bytes_greaterequal") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.ge_s (call $string_compare (local.get 0) (local.get 1)) + (ref.i31 (i32.ge_s (call $bytes_compare (local.get 0) (local.get 1)) (i32.const 0)))) - (export "caml_bytes_greaterthan" (func $caml_string_greaterthan)) - (func $caml_string_greaterthan (export "caml_string_greaterthan") + (func $caml_bytes_greaterthan (export "caml_bytes_greaterthan") (param (ref eq)) (param (ref eq)) (result (ref eq)) - (ref.i31 (i32.gt_s (call $string_compare (local.get 0) (local.get 1)) + (ref.i31 (i32.gt_s (call $bytes_compare (local.get 0) (local.get 1)) (i32.const 0)))) +(#if use-js-string +(#then + (func (export "caml_bytes_of_string") (param $v (ref eq)) (result (ref eq)) + (local $s externref) (local $b (ref $bytes)) (local $l i32) (local $i i32) + (local.set $s + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $v))))) + (local.set $l (call $string_length (local.get $s))) + (local.set $b (array.new $bytes (i32.const 0) (local.get $l))) + ;; loop from JS ? + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (array.set $bytes (local.get $b) (local.get $i) + (call $string_get (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $b)) + + (func (export "caml_string_of_bytes") (param $b (ref eq)) (result (ref eq)) + (return + (struct.new $string + (call $jsbytes_of_bytes (ref.cast (ref $bytes) (local.get $b)))))) +) +(#else (export "caml_bytes_of_string" (func $caml_string_of_bytes)) (func $caml_string_of_bytes (export "caml_string_of_bytes") (param $v (ref eq)) (result (ref eq)) (local.get $v)) +)) (data $string_create "Bytes.create") @@ -132,8 +257,44 @@ (i32.const 0) (i32.const 12))))) (array.new $bytes (i32.const 0) (local.get $l))) - (export "caml_blit_bytes" (func $caml_blit_string)) - (func $caml_blit_string (export "caml_blit_string") +(#if use-js-string +(#then + (func $blit_string + (param $s anyref) (param $i1 i32) + (param $b (ref $bytes)) (param $i2 i32) + (param $n i32) + (local $s' externref) + (local $i i32) + (local.set $s' (extern.convert_any (local.get $s))) + ;; loop from JS?? + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $n)) + (then + (array.set $bytes (local.get $b) + (i32.add (local.get $i2) (local.get $i)) + (call $string_get + (local.get $s') (i32.add (local.get $i1) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func (export "caml_blit_string") + (param $v1 (ref eq)) (param $i1 (ref eq)) + (param $v2 (ref eq)) (param $i2 (ref eq)) + (param $n (ref eq)) (result (ref eq)) + (call $blit_string + (struct.get $string 0 + (ref.cast (ref $string) (local.get $v1))) + (i31.get_s (ref.cast (ref i31) (local.get $i1))) + (ref.cast (ref $bytes) (local.get $v2)) + (i31.get_s (ref.cast (ref i31) (local.get $i2))) + (i31.get_s (ref.cast (ref i31) (local.get $n)))) + (ref.i31 (i32.const 0))) +) +(#else + (export "caml_blit_string" (func $caml_blit_bytes)) +)) + + (func $caml_blit_bytes (export "caml_blit_bytes") (param $v1 (ref eq)) (param $i1 (ref eq)) (param $v2 (ref eq)) (param $i2 (ref eq)) (param $n (ref eq)) (result (ref eq)) @@ -155,7 +316,111 @@ (i31.get_u (ref.cast (ref i31) (local.get $len)))) (ref.i31 (i32.const 0))) +(#if use-js-string +(#then + (func (export "caml_string_get16") + (param $v (ref eq)) (param $i (ref eq)) (result (ref eq)) + (local $s externref) (local $p i32) + (local.set $s + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $v))))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 1)) + (call $string_length (local.get $s))) + (then (call $caml_bound_error))) + (ref.i31 (i32.or + (call $string_get (local.get $s) (local.get $p)) + (i32.shl (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 1))) + (i32.const 8))))) + + (func (export "caml_string_get32") + (param $v (ref eq)) (param $i (ref eq)) (result i32) + (local $s externref) (local $p i32) + (local.set $s + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $v))))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 3)) + (call $string_length (local.get $s))) + (then (call $caml_bound_error))) + (i32.or + (i32.or + (call $string_get (local.get $s) (local.get $p)) + (i32.shl (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 2))) + (i32.const 16)) + (i32.shl (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 3))) + (i32.const 24))))) + + (func (export "caml_string_get64") + (param $v (ref eq)) (param $i (ref eq)) (result i64) + (local $s externref) (local $p i32) + (local.set $s + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $v))))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 7)) + (call $string_length (local.get $s))) + (then (call $caml_bound_error))) + (i64.or + (i64.or + (i64.or + (i64.extend_i32_u + (call $string_get (local.get $s) (local.get $p))) + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 1)))) + (i64.const 8))) + (i64.or + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 2)))) + (i64.const 16)) + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 3)))) + (i64.const 24)))) + (i64.or + (i64.or + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 4)))) + (i64.const 32)) + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 5)))) + (i64.const 40))) + (i64.or + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 6)))) + (i64.const 48)) + (i64.shl (i64.extend_i32_u + (call $string_get (local.get $s) + (i32.add (local.get $p) (i32.const 7)))) + (i64.const 56)))))) +) +(#else (export "caml_string_get16" (func $caml_bytes_get16)) + (export "caml_string_get32" (func $caml_bytes_get32)) + (export "caml_string_get64" (func $caml_bytes_get64)) +)) + (func $caml_bytes_get16 (export "caml_bytes_get16") (param $v (ref eq)) (param $i (ref eq)) (result (ref eq)) (local $s (ref $bytes)) (local $p i32) @@ -172,7 +437,6 @@ (i32.add (local.get $p) (i32.const 1))) (i32.const 8))))) - (export "caml_string_get32" (func $caml_bytes_get32)) (func $caml_bytes_get32 (export "caml_bytes_get32") (param $v (ref eq)) (param $i (ref eq)) (result i32) (local $s (ref $bytes)) (local $p i32) @@ -197,7 +461,6 @@ (i32.add (local.get $p) (i32.const 3))) (i32.const 24))))) - (export "caml_string_get64" (func $caml_bytes_get64)) (func $caml_bytes_get64 (export "caml_bytes_get64") (param $v (ref eq)) (param $i (ref eq)) (result i64) (local $s (ref $bytes)) (local $p i32) @@ -320,6 +583,22 @@ (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 56)))) (ref.i31 (i32.const 0))) +(#if use-js-string +(#then + (func (export "caml_string_concat") + (param $s1 (ref eq)) (param $s2 (ref eq)) (result (ref eq)) + (return + (struct.new $string + (any.convert_extern + (call $string_concat + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $s1)))) + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $s2))))))))) +) +(#else (func (export "caml_string_concat") (param $vs1 (ref eq)) (param $vs2 (ref eq)) (result (ref eq)) (local $s1 (ref $bytes)) (local $s2 (ref $bytes)) @@ -339,4 +618,19 @@ (local.get $s) (local.get $l1) (local.get $s2) (i32.const 0) (local.get $l2)) (local.get $s)) +)) + +(#if use-js-string +(#then + (func (export "caml_string_length") (param $s (ref eq)) (result i32) + (return_call $string_length + (extern.convert_any + (struct.get $string 0 + (ref.cast (ref $string) (local.get $s)))))) +) +(#else + (func (export "caml_string_length") (param $s (ref eq)) (result i32) + (array.len (ref.cast (ref $bytes) (local.get $s)))) +)) + ) diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index 24e72ab2cf..9de9a6f48e 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -47,6 +47,10 @@ (tag $javascript_exception (param externref))) (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) + (import "string" "caml_string_of_bytes" + (func $caml_string_of_bytes (param (ref eq)) (result (ref eq)))) + (import "string" "caml_bytes_of_string" + (func $caml_bytes_of_string (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -155,7 +159,8 @@ ;; ZZZ ;; (call $log_js (string.const "caml_sys_get_config")) (array.new_fixed $block 4 (ref.i31 (i32.const 0)) - (array.new_data $bytes $Unix (i32.const 0) (i32.const 4)) + (call $caml_string_of_bytes + (array.new_data $bytes $Unix (i32.const 0) (i32.const 4))) (ref.i31 (i32.const 32)) (ref.i31 (i32.const 0)))) @@ -190,9 +195,10 @@ (func $caml_handle_sys_error (export "caml_handle_sys_error") (param $exn externref) (call $caml_raise_sys_error - (call $caml_string_of_jsstring - (call $caml_js_meth_call - (call $wrap (any.convert_extern (local.get $exn))) - (array.new_data $bytes $toString (i32.const 0) (i32.const 8)) - (array.new_fixed $block 1 (ref.i31 (i32.const 0))))))) + (call $caml_bytes_of_string + (call $caml_string_of_jsstring + (call $caml_js_meth_call + (call $wrap (any.convert_extern (local.get $exn))) + (array.new_data $bytes $toString (i32.const 0) (i32.const 8)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))))))) )