diff --git a/dune-project b/dune-project index 24005e538d..ceecbd1657 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.6) +(lang dune 3.11) (name eliom) (maintainers dev@ocsigen.org) diff --git a/eliom.opam b/eliom.opam index 05695292a1..3e4e363e4b 100644 --- a/eliom.opam +++ b/eliom.opam @@ -14,7 +14,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "http://ocsigen.org/eliom/" bug-reports: "https://github.com/ocsigen/eliom/issues" depends: [ - "dune" {>= "3.6"} + "dune" {>= "3.11"} "ocaml" {>= "4.08.0"} "ocamlfind" "ppx_deriving" diff --git a/src/lib/client/dune b/src/lib/client/dune index 513d1d10ab..0e5d37c6bf 100644 --- a/src/lib/client/dune +++ b/src/lib/client/dune @@ -12,7 +12,9 @@ lwt_react ocsigenserver.baselib.base cohttp tyxml reactiveData) (foreign_stubs (language c) (names eliom_stubs)) - (js_of_ocaml (javascript_files eliom_client.js))) + (js_of_ocaml + (javascript_files eliom_client.js) + (wasm_files eliom_client.wat))) (include dune.client) diff --git a/src/lib/client/eliom_client.wat b/src/lib/client/eliom_client.wat new file mode 100644 index 0000000000..d048cbc476 --- /dev/null +++ b/src/lib/client/eliom_client.wat @@ -0,0 +1,680 @@ +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) + (import "obj" "double_array_tag" (global $double_array_tag i32)) + (import "string" "caml_string_cat" + (func $caml_string_cat + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "obj" "caml_is_closure" + (func $caml_is_closure (param (ref eq)) (result i32))) + (import "effect" "caml_is_continuation" + (func $caml_is_continuation (param (ref eq)) (result i32))) + (import "bindings" "map_new" (func $map_new (result (ref any)))) + (import "bindings" "map_get" + (func $map_get (param (ref any)) (param (ref eq)) (result i31ref))) + (import "bindings" "map_set" + (func $map_set (param (ref any)) (param (ref eq)) (param (ref i31)))) + (import "io" "caml_really_putblock" + (func $caml_really_putblock + (param (ref eq)) (param (ref $string)) (param i32) (param i32))) + (import "io" "caml_really_getblock" + (func $caml_really_getblock + (param (ref eq)) (param (ref $string)) (param i32) (param i32) + (result i32))) + (import "io" "caml_flush_if_unbuffered" + (func $caml_flush_if_unbuffered (param (ref eq)))) + (import "custom" "caml_init_custom_operations" + (func $caml_init_custom_operations)) + (import "custom" "caml_find_custom_operations" + (func $caml_find_custom_operations + (param (ref $string)) (result (ref null $custom_operations)))) + (import "obj" "caml_callback_2" + (func $caml_callback_2 + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $js (struct (field anyref))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (data $bad_length "unwrap_value: bad length") + + (func (export "caml_unwrap_value_from_string") + (param $unwrapper (ref eq)) + (param $vstr (ref eq)) (param $vofs (ref eq)) (result (ref eq)) + (local $str (ref $string)) + (local $ofs i32) + (local $s (ref $intern_state)) + (local $h (ref $marshal_header)) + (local.set $str (ref.cast (ref $string) (local.get $vstr))) + (local.set $ofs (i31.get_u (ref.cast (ref i31) (local.get $vofs)))) + (local.set $s + (call $get_intern_state (local.get $str) (local.get $ofs))) + (local.set $h (call $parse_header (local.get $s))) + (if (i32.gt_s + (i32.add (local.get $ofs) + (i32.add (struct.get $marshal_header $data_len (local.get $h)) + (i32.const 20))) + (array.len (local.get $str))) + (then + (call $caml_failwith + (array.new_data $string $bad_length + (i32.const 0) (i32.const 24))))) + (return_call $intern_rec + (local.get $unwrapper) (local.get $s) (local.get $h))) + + (global $Intext_magic_number_small i32 (i32.const 0x8495A6BE)) + (global $Intext_magic_number_big i32 (i32.const 0x8495A6BF)) + + (global $PREFIX_SMALL_BLOCK i32 (i32.const 0x80)) + (global $PREFIX_SMALL_INT i32 (i32.const 0x40)) + (global $PREFIX_SMALL_STRING i32 (i32.const 0x20)) + (global $CODE_INT8 i32 (i32.const 0x00)) + (global $CODE_INT16 i32 (i32.const 0x01)) + (global $CODE_INT32 i32 (i32.const 0x02)) + (global $CODE_INT64 i32 (i32.const 0x03)) + (global $CODE_SHARED8 i32 (i32.const 0x04)) + (global $CODE_SHARED16 i32 (i32.const 0x05)) + (global $CODE_SHARED32 i32 (i32.const 0x06)) + (global $CODE_BLOCK32 i32 (i32.const 0x08)) + (global $CODE_BLOCK64 i32 (i32.const 0x13)) + (global $CODE_STRING8 i32 (i32.const 0x09)) + (global $CODE_STRING32 i32 (i32.const 0x0A)) + (global $CODE_DOUBLE_BIG i32 (i32.const 0x0B)) + (global $CODE_DOUBLE_LITTLE i32 (i32.const 0x0C)) + (global $CODE_DOUBLE_ARRAY8_BIG i32 (i32.const 0x0D)) + (global $CODE_DOUBLE_ARRAY8_LITTLE i32 (i32.const 0x0E)) + (global $CODE_DOUBLE_ARRAY32_BIG i32 (i32.const 0x0F)) + (global $CODE_DOUBLE_ARRAY32_LITTLE i32 (i32.const 0x07)) + (global $CODE_CODEPOINTER i32 (i32.const 0x10)) + (global $CODE_INFIXPOINTER i32 (i32.const 0x11)) + (global $CODE_CUSTOM i32 (i32.const 0x12)) + (global $CODE_CUSTOM_LEN i32 (i32.const 0x18)) + (global $CODE_CUSTOM_FIXED i32 (i32.const 0x19)) + + (type $intern_state + (struct + (field $src (ref $string)) + (field $pos (mut i32)) + (field $obj_table (mut (ref $block))) + (field $obj_counter (mut i32)))) + + (func $get_intern_state + (param $src (ref $string)) (param $pos i32) (result (ref $intern_state)) + (struct.new $intern_state + (local.get $src) (local.get $pos) (array.new_fixed $block 0) + (i32.const 0))) + + (func $read8u (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_u $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read8s (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_s $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read16u (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read16s (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_s $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read32 (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 24)) + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))) + (i32.const 16))) + (i32.or + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 2))) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 3)))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 4))) + (local.get $res)) + + (func $readblock (param $s (ref $intern_state)) (param $str (ref $string)) + (local $len i32) (local $pos i32) + (local.set $len (array.len (local.get $str))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (array.copy $string $string + (local.get $str) (i32.const 0) + (struct.get $intern_state $src (local.get $s)) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (local.get $len)))) + + (func $readstr (param $s (ref $intern_state)) (result (ref $string)) + (local $len i32) (local $pos i32) (local $res (ref $string)) + (local $src (ref $string)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (loop $loop + (if (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $len))) + (then + (local.set $len (i32.add (local.get $len) (i32.const 1))) + (br $loop)))) + (local.set $res (array.new $string (i32.const 0) (local.get $len))) + (array.copy $string $string + (local.get $res) (i32.const 0) + (local.get $src) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.add (local.get $len) (i32.const 1)))) + (local.get $res)) + + (func $readfloat + (param $s (ref $intern_state)) (param $code i32) (result f64) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local $d i64) + (local $i i32) + (local $v (ref eq)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 8))) + (if (i32.eq (local.get $code) (global.get $CODE_DOUBLE_BIG)) + (then + (loop $loop + (local.set $d + (i64.or + (i64.shl (local.get $d) (i64.const 8)) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8))))) + (else + (loop $loop + (local.set $d + (i64.rotr + (i64.or (local.get $d) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i))))) + (i64.const 8))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8)))))) + (f64.reinterpret_i64 (local.get $d))) + + (func $readfloats + (param $s (ref $intern_state)) (param $code i32) (param $len i32) + (result (ref eq)) + (local $dest (ref $float_array)) + (local $i i32) + (local.set $code + (select (global.get $CODE_DOUBLE_BIG) (global.get $CODE_DOUBLE_LITTLE) + (i32.or + (i32.eq (local.get $code) (global.get $CODE_DOUBLE_ARRAY8_BIG)) + (i32.eq (local.get $code) + (global.get $CODE_DOUBLE_ARRAY32_BIG))))) + (local.set $dest (array.new $float_array (f64.const 0) (local.get $len))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $dest) (local.get $i) + (call $readfloat (local.get $s) (local.get $code))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $dest)) + + (func $register_object (param $s (ref $intern_state)) (param $v (ref eq)) + (local $p i32) + (local.set $p (struct.get $intern_state $obj_counter (local.get $s))) + (array.set $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $p) (local.get $v)) + (struct.set $intern_state $obj_counter (local.get $s) + (i32.add (local.get $p) (i32.const 1)))) + + (data $unknown_custom "unwrap_value: unknown custom block identifier") + (data $expected_size "unwrap_value: expected a fixed-size custom block") + (data $incorrect_size + "unwrap_value: incorrect length of serialized custom block") + + (func $intern_custom + (param $s (ref $intern_state)) (param $code i32) (result (ref eq)) + (local $ops (ref $custom_operations)) + (local $expected_size i32) + (local $r ((ref eq) i32)) + (block $unknown + (local.set $ops + (br_on_null $unknown + (call + $caml_find_custom_operations + (call $readstr + (local.get $s))))) + (block $no_length + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_FIXED)) + (then + (local.set $expected_size + (struct.get $fixed_length $bsize_32 + (br_on_null $no_length + (struct.get $custom_operations $fixed_length + (local.get $ops)))))) + (else + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_LEN)) + (then + (local.set $expected_size (call $read32 (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (struct.get $intern_state $pos (local.get $s)) + (i32.const 8))))))) + (local.set $r + (call_ref $deserialize (local.get $s) + (struct.get $custom_operations $deserialize (local.get $ops)))) + (if (i32.and + (i32.ne (tuple.extract 1 (local.get $r)) + (local.get $expected_size)) + (i32.ne (local.get $code) (global.get $CODE_CUSTOM))) + (then + (call $caml_failwith + (array.new_data $string $incorrect_size + (i32.const 0) (i32.const 57))))) + (return (tuple.extract 0 (local.get $r)))) + (call $caml_failwith + (array.new_data $string $expected_size + (i32.const 0) (i32.const 48)))) + (call $caml_failwith + (array.new_data $string $unknown_custom + (i32.const 0) (i32.const 45))) + (ref.i31 (i32.const 0))) + + (data $integer_too_large "unwrap_value: integer too large") + (data $code_pointer "unwrap_value: code pointer") + (data $ill_formed "unwrap_value: ill-formed message") + (data $incorrect_value "unwrap_value: incorrect value") + + (type $stack_item + (struct + (field $blk (ref $block)) + (field $pos (mut i32)) + (field $ofs i32) + (field $next (ref null $stack_item)))) + + (func $intern_rec + (param $unwrapper (ref eq)) + (param $s (ref $intern_state)) (param $h (ref $marshal_header)) + (result (ref eq)) + (local $late_unwrap_mark (ref $block)) + (local $res (ref $block)) (local $dest (ref $block)) + (local $sp (ref $stack_item)) + (local $code i32) + (local $header i32) (local $tag i32) (local $size i32) + (local $len i32) (local $pos i32) (local $pos' i32) (local $ofs i32) + (local $b (ref $block)) + (local $str (ref $string)) + (local $v (ref eq)) (local $v' (ref eq)) + (call $caml_init_custom_operations) + (local.set $late_unwrap_mark (array.new_fixed $block 0)) + (local.set $res (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + (local.set $sp + (struct.new $stack_item + (local.get $res) (i32.const 0) (i32.const -1) + (ref.null $stack_item))) + (local.set $size (struct.get $marshal_header $num_objects (local.get $h))) + (struct.set $intern_state $obj_table (local.get $s) + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (local.set $v (ref.i31 (i32.const 0))) ;; keep validator happy + (block $exit + (loop $loop + (block $done + (block $read_block + (block $read_string + (block $read_double_array + (block $read_shared + (local.set $code (call $read8u (local.get $s))) + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_INT)) + (then + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_BLOCK)) + (then + ;; Small block + (local.set $tag + (i32.and (local.get $code) (i32.const 0xF))) + (local.set $size + (i32.and (i32.shr_u (local.get $code) (i32.const 4)) + (i32.const 0x7))) + (br $read_block)) + (else + ;; Small int + (local.set $v + (ref.i31 + (i32.and (local.get $code) (i32.const 0x3F)))) + (br $done)))) + (else + (if (i32.ge_u (local.get $code) + (global.get $PREFIX_SMALL_STRING)) + (then + (local.set $len + (i32.and (local.get $code) (i32.const 0x1F))) + (br $read_string)) + (else + (block $INT8 + (block $INT16 + (block $INT32 + (block $INT64 + (block $SHARED8 + (block $SHARED16 + (block $SHARED32 + (block $BLOCK32 + (block $STRING8 + (block $STRING32 + (block $DOUBLE + (block $DOUBLE_ARRAY8 + (block $DOUBLE_ARRAY32 + (block $CODEPOINTER + (block $CUSTOM + (block $default + (br_table $INT8 $INT16 $INT32 $INT64 + $SHARED8 $SHARED16 $SHARED32 + $DOUBLE_ARRAY32 $BLOCK32 $STRING8 + $STRING32 $DOUBLE $DOUBLE + $DOUBLE_ARRAY8 $DOUBLE_ARRAY8 + $DOUBLE_ARRAY32 $CODEPOINTER + $CODEPOINTER $CUSTOM $default + $default $default $default $default + $CUSTOM $CUSTOM $default + (local.get $code))) + ;; default + (call $caml_failwith + (array.new_data $string $ill_formed + (i32.const 0) (i32.const 32))) + (br $done)) + ;; CUSTOM + (local.set $v + (call $intern_custom (local.get $s) + (local.get $code))) + (call $register_object (local.get $s) + (local.get $v)) + (br $done)) + ;; CODEPOINTER + (call $caml_failwith + (array.new_data $string $code_pointer + (i32.const 0) (i32.const 26))) + (br $done)) + ;; DOUBLE_ARRAY32 + (local.set $len + (call $read32 (local.get $s))) + (br $read_double_array)) + ;; DOUBLE_ARRAY8 + (local.set $len + (call $read8u (local.get $s))) + (br $read_double_array)) + ;; DOUBLE + (local.set $v + (struct.new $float + (call $readfloat + (local.get $s) (local.get $code)))) + (call $register_object + (local.get $s) (local.get $v)) + (br $done)) + ;; STRING32 + (local.set $len (call $read32 (local.get $s))) + (br $read_string)) + ;; STRING8 + (local.set $len (call $read8u (local.get $s))) + (br $read_string)) + ;; BLOCK32 + (local.set $header (call $read32 (local.get $s))) + (local.set $tag + (i32.and (local.get $header) + (i32.const 0xFF))) + (local.set $size + (i32.shr_u (local.get $header) + (i32.const 10))) + (br $read_block)) + ;; SHARED32 + (local.set $ofs (call $read32 (local.get $s))) + (br $read_shared)) + ;; SHARED16 + (local.set $ofs (call $read16u (local.get $s))) + (br $read_shared)) + ;; SHARED8 + (local.set $ofs (call $read8u (local.get $s))) + (br $read_shared)) + ;; INT64 + (call $caml_failwith + (array.new_data $string $integer_too_large + (i32.const 0) (i32.const 31))) + (br $done)) + ;; INT32 + (local.set $v (ref.i31 (call $read32 (local.get $s)))) + (br $done)) + ;; INT16 + (local.set $v (ref.i31 (call $read16s (local.get $s)))) + (br $done)) + ;; INT8 + (local.set $v (ref.i31 (call $read8s (local.get $s)))) + (br $done)) + )))) + ;; read_shared + (local.set $ofs + (i32.sub + (struct.get $intern_state $obj_counter (local.get $s)) + (local.get $ofs))) + (local.set $v + (array.get $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $ofs))) + (br_if $done (i32.eqz (ref.test (ref $block) (local.get $v)))) + (local.set $b (ref.cast (ref $block) (local.get $v))) + (local.set $len (array.len (local.get $b))) + (br_if $done (i32.lt_u (local.get $len) (i32.const 2))) + (local.set $v' + (array.get $block (local.get $b) + (i32.sub (local.get $len) (i32.const 1)))) + (br_if $done (i32.eqz (ref.test (ref $block) (local.get $v')))) + (local.set $b (ref.cast (ref $block) (local.get $v'))) + (br_if $done (i32.ne (array.len (local.get $b)) (i32.const 4))) + (br_if $done + (i32.eqz + (ref.eq (array.get $block (local.get $b) (i32.const 2)) + (local.get $late_unwrap_mark)))) + (array.set $block (local.get $b) (i32.const 3) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.get $stack_item $blk (local.get $sp)) + (ref.i31 + (struct.get $stack_item $pos (local.get $sp)))) + (array.get $block (local.get $b) (i32.const 3)))) + (br $done)) + ;; read_double_array + (local.set $v + (call $readfloats + (local.get $s) (local.get $code) (local.get $len))) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_string + (local.set $str (array.new $string (i32.const 0) (local.get $len))) + (call $readblock (local.get $s) (local.get $str)) + (local.set $v (local.get $str)) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_block + (local.set $b + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $size) (i32.const 1)))) + (array.set $block (local.get $b) (i32.const 0) + (ref.i31 (local.get $tag))) + (if (local.get $size) + (then + (local.set $sp + (struct.new $stack_item + (local.get $b) (i32.const 1) + (struct.get $intern_state $obj_counter (local.get $s)) + (local.get $sp))) + (call $register_object (local.get $s) (local.get $b)) + (br $loop))) + (local.set $v (local.get $b)) + (br $done)) + ;; done + (loop $assign + (local.set $dest (struct.get $stack_item $blk (local.get $sp))) + (local.set $pos (struct.get $stack_item $pos (local.get $sp))) + (array.set $block (local.get $dest) (local.get $pos) (local.get $v)) + (local.set $pos' (i32.add (local.get $pos) (i32.const 1))) + (struct.set $stack_item $pos (local.get $sp) (local.get $pos')) + (local.set $len (array.len (local.get $dest))) + (br_if $loop (i32.ne (local.get $pos') (local.get $len))) + (local.set $v (local.get $dest)) + (local.set $ofs (struct.get $stack_item $ofs (local.get $sp))) + (local.set $sp + (br_on_null $exit (struct.get $stack_item $next (local.get $sp)))) + (br_if $assign (i32.lt_u (local.get $len) (i32.const 2))) + (br_if $assign + (i32.eqz + (ref.eq (array.get $block (local.get $dest) (i32.const 0)) + (ref.i31 (i32.const 0))))) + (local.set $v + (array.get $block (local.get $dest) + (i32.sub (local.get $len) (i32.const 1)))) + (br_if $assign (i32.eqz (ref.test (ref $block) (local.get $v)))) + (local.set $b (ref.cast (ref $block) (local.get $v))) + (br_if $assign (i32.ne (array.len (local.get $b)) (i32.const 3))) + (br_if $assign + (i32.eqz + (ref.eq (array.get $block (local.get $b) (i32.const 2)) + (array.get $block + (struct.get $intern_state $obj_table (local.get $s)) + (i32.const 1))))) + (local.set $v + (call $caml_callback_2 (local.get $unwrapper) + (local.get $b) (local.get $dest))) + (if (ref.test (ref $block) (local.get $v)) + (then + (local.set $v + (array.get $block (ref.cast (ref $block) (local.get $v)) + (i32.const 1))) + (array.set $block + (struct.get $intern_state $obj_table (local.get $s)) + (local.get $ofs) (local.get $v))) + (else + (array.set $block (local.get $dest) + (i32.sub (local.get $len) (i32.const 1)) + (array.new_fixed $block 4 (ref.i31 (i32.const 0)) + (array.get $block (local.get $b) (i32.const 1)) + (local.get $late_unwrap_mark) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.get $stack_item $blk (local.get $sp)) + (ref.i31 + (struct.get $stack_item $pos (local.get $sp)))) + (ref.i31 (i32.const 0))))) + (local.set $v (local.get $dest)) + )) + (br $assign)))) + (drop (block $incorrect_value (result (ref eq)) + (local.set $b + (br_on_cast_fail $incorrect_value (ref eq) (ref $block) + (array.get $block (local.get $res) (i32.const 0)))) + (if (i32.eq (array.len (local.get $b)) (i32.const 3)) + (return (array.get $block (local.get $b) (i32.const 2)))) + (ref.i31 (i32.const 0)))) + (call $caml_failwith + (array.new_data $string $incorrect_value (i32.const 0) (i32.const 29))) + (ref.i31 (i32.const 0))) + + (data $too_large + "unwrap_value: object too large to be read back on a 32-bit platform") + (data $bad_object "unwrap_value: bad object") + + (type $marshal_header + (struct + (field $data_len i32) + (field $num_objects i32))) + + (func $parse_header + (param $s (ref $intern_state)) + (result (ref $marshal_header)) + (local $magic i32) + (local $data_len i32) (local $num_objects i32) (local $whsize i32) + (local.set $magic (call $read32 (local.get $s))) + (if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big)) + (then + (call $caml_failwith + (array.new_data $string $too_large + (i32.const 0) (i32.const 67))))) + (if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small)) + (then + (call $caml_failwith + (array.new_data $string $bad_object + (i32.const 0) (i32.const 24))))) + (local.set $data_len (call $read32 (local.get $s))) + (local.set $num_objects (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (struct.new $marshal_header + (local.get $data_len) + (local.get $num_objects))) +) diff --git a/src/lib/eliom_unwrap.client.ml b/src/lib/eliom_unwrap.client.ml index f05de73ff1..eed64dba2c 100644 --- a/src/lib/eliom_unwrap.client.ml +++ b/src/lib/eliom_unwrap.client.ml @@ -72,7 +72,7 @@ let apply_unwrapper unwrapper v = let late_unwrap_value old_value new_value = let old_value = Obj.repr old_value in List.iter - (fun {parent; field} -> Js.Unsafe.set parent field new_value) + (fun {parent; field} -> Obj.set_field parent (field - 1) (Obj.repr new_value)) (Obj.obj (Obj.field (Obj.field old_value (Obj.size old_value - 1)) 2)) external raw_unmarshal_and_unwrap