[interpreter/test] Implement new array allocation instructions (WebAssembly#283)

Author: rossberg

interpreter/README.md

@@ -304,6 +304,9 @@ op:
   struct.get(_<sign>)? <var> <var>
   struct.set <var> <var>
   array.new(_<default>)? <var>
+  array.new_fixed <var> <nat>
+  array.new_elem <var> <var>
+  array.new_data <var> <var>
   array.get(_<sign>)? <var>
   array.set <var>
   array.len <var>

interpreter/binary/decode.ml

@@ -593,6 +593,10 @@ let rec instr s =
     | 0x16l -> array_set (at var s)
     | 0x17l -> let _ = var s in array_len  (* TODO: remove var *)
 
+    | 0x19l -> let x = at var s in let n = u32 s in array_new_fixed x n
+    | 0x1bl -> let x = at var s in let y = at var s in array_new_data x y
+    | 0x1cl -> let x = at var s in let y = at var s in array_new_elem x y
+
     | 0x20l -> i31_new
     | 0x21l -> i31_get_s
     | 0x22l -> i31_get_u

interpreter/binary/encode.ml

@@ -397,6 +397,9 @@ struct
 
     | ArrayNew (x, Explicit) -> op 0xfb; op 0x11; var x
     | ArrayNew (x, Implicit) -> op 0xfb; op 0x12; var x
+    | ArrayNewFixed (x, n) -> op 0xfb; op 0x19; var x; u32 n
+    | ArrayNewElem (x, y) -> op 0xfb; op 0x1c; var x; var y
+    | ArrayNewData (x, y) -> op 0xfb; op 0x1b; var x; var y
     | ArrayGet (x, None) -> op 0xfb; op 0x13; var x
     | ArrayGet (x, Some SX) -> op 0xfb; op 0x14; var x
     | ArrayGet (x, Some ZX) -> op 0xfb; op 0x15; var x

interpreter/exec/eval.ml

@@ -173,13 +173,13 @@ let rec step (c : config) : config =
         let FuncType (ts1, ts2) = block_type c.frame.inst bt e.at in
         let n1 = List.length ts1 in
         let n2 = List.length ts2 in
-        let args, vs' = take n1 vs e.at, drop n1 vs e.at in
+        let args, vs' = split n1 vs e.at in
         vs', [Label (n2, [], (args, List.map plain es')) @@ e.at]
 
       | Loop (bt, es'), vs ->
         let FuncType (ts1, ts2) = block_type c.frame.inst bt e.at in
         let n1 = List.length ts1 in
-        let args, vs' = take n1 vs e.at, drop n1 vs e.at in
+        let args, vs' = split n1 vs e.at in
         vs', [Label (n1, [e' @@ e.at], (args, List.map plain es')) @@ e.at]
 
       | If (bt, es1, es2), Num (I32 i) :: vs' ->
@@ -813,11 +813,66 @@ let rec step (c : config) : config =
             try default_value (unpacked_storage_type st), vs'
             with Failure _ -> Crash.error e.at "non-defaultable type"
         in
-        let data = 
-          try Data.alloc_array (type_ c.frame.inst x) rtt n arg
+        let data =
+          try Data.alloc_array (type_ c.frame.inst x) rtt (Lib.List32.make n arg)
           with Failure _ -> Crash.error e.at "type mismatch packing value"
         in Ref (Data.DataRef data) :: vs'', []
 
+      | ArrayNewFixed (x, n), Ref (Rtt.RttRef rtt) :: vs' ->
+        let args, vs'' = split (I32.to_int_u n) vs' e.at in
+        let data =
+          try Data.alloc_array (type_ c.frame.inst x) rtt (List.rev args)
+          with Failure _ -> Crash.error e.at "type mismatch packing value"
+        in Ref (Data.DataRef data) :: vs'', []
+
+      | ArrayNewElem (x, y),
+        Ref (Rtt.RttRef rtt) :: Num (I32 n) :: Num (I32 s) :: vs' ->
+        if elem_oob c.frame y s n then
+          vs', [Trapping (table_error e.at Table.Bounds) @@ e.at]
+        else
+          let seg = elem c.frame.inst y in
+          let args =
+            List.map (fun r -> Ref r) (Lib.List32.take n (Lib.List32.drop s !seg)) in
+          let data =
+            try Data.alloc_array (type_ c.frame.inst x) rtt args
+            with Failure _ -> Crash.error e.at "type mismatch packing value"
+          in Ref (Data.DataRef data) :: vs', []
+
+      | ArrayNewData (x, y),
+        Ref (Rtt.RttRef rtt) :: Num (I32 n) :: Num (I32 s) :: vs' ->
+        if data_oob c.frame y s n then
+          vs', [Trapping (memory_error e.at Memory.Bounds) @@ e.at]
+        else
+          let ArrayType (FieldType (st, _)) = array_type c.frame.inst x in
+          let seg = data c.frame.inst y in
+          let bs = Bytes.of_string !seg in
+          let args = Lib.List32.init n
+            (fun i ->
+              let j = I32.to_int_u s + I32.to_int_u i * storage_size st in
+              match st with
+              | PackedStorageType Pack8 ->
+                Num (I32 (I32.of_int_u (Bytes.get_uint8 bs j)))
+              | PackedStorageType Pack16 ->
+                Num (I32 (I32.of_int_u (Bytes.get_uint16_le bs j)))
+              | ValueStorageType (NumType I32Type) ->
+                Num (I32 (Bytes.get_int32_le bs j))
+              | ValueStorageType (NumType I64Type) ->
+                Num (I64 (Bytes.get_int64_le bs j))
+              | ValueStorageType (NumType F32Type) ->
+                Num (F32 (F32.of_bits (Bytes.get_int32_le bs j)))
+              | ValueStorageType (NumType F64Type) ->
+                Num (F64 (F64.of_bits (Bytes.get_int64_le bs j)))
+              | ValueStorageType (VecType V128Type) ->
+                Vec (V128 (V128.of_bits (String.sub !seg j 16)))
+              | _ ->
+                Crash.error e.at "type mismatch packing value"
+            )
+          in
+          let data =
+            try Data.alloc_array (type_ c.frame.inst x) rtt args
+            with Failure _ -> Crash.error e.at "type mismatch packing value"
+          in Ref (Data.DataRef data) :: vs', []
+
       | ArrayGet (x, exto), Num (I32 i) :: Ref (NullRef _) :: vs' ->
         vs', [Trapping "null array reference" @@ e.at]
 

interpreter/runtime/data.ml

@@ -43,9 +43,9 @@ let alloc_struct x rtt vs =
   let StructType fts = as_struct_str_type (expand_ctx_type (def_of x)) in
   Struct (x, rtt, List.map2 alloc_field fts vs)
 
-let alloc_array x rtt n v =
+let alloc_array x rtt vs =
   let ArrayType ft = as_array_str_type (expand_ctx_type (def_of x)) in
-  Array (x, rtt, List.init (Int32.to_int n) (fun _ -> alloc_field ft v))
+  Array (x, rtt, List.map (alloc_field ft) vs)
 
 
 let type_inst_of = function

interpreter/runtime/data.mli

@@ -14,7 +14,7 @@ type t = data
 type ref_ += DataRef of data
 
 val alloc_struct : sem_var -> Rtt.t -> value list -> data
-val alloc_array : sem_var -> Rtt.t -> int32 -> value -> data
+val alloc_array : sem_var -> Rtt.t -> value list -> data
 
 val struct_type_of : data -> struct_type
 val array_type_of : data -> array_type

interpreter/syntax/ast.ml

@@ -205,6 +205,9 @@ and instr' =
   | StructGet of idx * idx * extension option  (* read structure field *)
   | StructSet of idx * idx            (* write structure field *)
   | ArrayNew of idx * initop          (* allocate array *)
+  | ArrayNewFixed of idx * int32      (* allocate fixed array *)
+  | ArrayNewElem of idx * idx         (* allocate array from element segment *)
+  | ArrayNewData of idx * idx         (* allocate array from data segment *)
   | ArrayGet of idx * extension option  (* read array slot *)
   | ArraySet of idx                   (* write array slot *)
   | ArrayLen                          (* read array length *)

interpreter/syntax/free.ml

@@ -123,7 +123,9 @@ let rec instr (e : instr) =
   | RefNull t -> heap_type t
   | RefFunc x -> funcs (idx x)
   | I31New | I31Get _ -> empty
-  | StructNew (x, _) | ArrayNew (x, _) -> types (idx x)
+  | StructNew (x, _) | ArrayNew (x, _) | ArrayNewFixed (x, _) -> types (idx x)
+  | ArrayNewElem (x, y) -> types (idx x) ++ elems (idx y)
+  | ArrayNewData (x, y) -> types (idx x) ++ datas (idx y)
   | StructGet (x, _, _) | StructSet (x, _) -> types (idx x)
   | ArrayGet (x, _) | ArraySet x -> types (idx x)
   | ArrayLen -> empty

interpreter/syntax/operators.ml

@@ -133,6 +133,9 @@ let struct_get_s x y = StructGet (x, y, Some SX)
 let struct_set x y = StructSet (x, y)
 let array_new x = ArrayNew (x, Explicit)
 let array_new_default x = ArrayNew (x, Implicit)
+let array_new_fixed x n = ArrayNewFixed (x, n)
+let array_new_elem x y = ArrayNewElem (x, y)
+let array_new_data x y = ArrayNewData (x, y)
 let array_get x = ArrayGet (x, None)
 let array_get_u x = ArrayGet (x, Some ZX)
 let array_get_s x = ArrayGet (x, Some SX)

interpreter/syntax/types.ml

@@ -79,6 +79,11 @@ let num_size = function
 let vec_size = function
   | V128Type -> 16
 
+let value_size = function
+  | NumType t -> num_size t
+  | VecType t -> vec_size t
+  | RefType _ | BotType -> failwith "value_size"
+
 let packed_size = function
   | Pack8 -> 1
   | Pack16 -> 2
@@ -88,11 +93,9 @@ let packed_size = function
 let packed_shape_size = function
   | Pack8x8 | Pack16x4 | Pack32x2 -> 8
 
-
-let is_packed_storage_type = function
-  | ValueStorageType _ -> false
-  | PackedStorageType _ -> true
-
+let storage_size = function
+  | PackedStorageType pt -> packed_size pt
+  | ValueStorageType t -> value_size t
 
 let is_syn_var = function SynVar _ -> true | _ -> false
 let is_sem_var = function SemVar _ -> true | _ -> false
@@ -132,6 +135,11 @@ let defaultable_value_type = function
   | BotType -> assert false
 
 
+let is_packed_storage_type = function
+  | ValueStorageType _ -> false
+  | PackedStorageType _ -> true
+
+
 (* Projections *)
 
 let unpacked_storage_type = function