[interpreter] Implement bulk memory operations

interpreter/binary/decode.ml

@@ -193,13 +193,33 @@ let var s = vu32 s
 
 let op s = u8 s
 let end_ s = expect 0x0b s "END opcode expected"
+let zero_flag s = expect 0x00 s "zero flag expected"
 
 let memop s =
   let align = vu32 s in
   require (I32.le_u align 32l) s (pos s - 1) "invalid memop flags";
   let offset = vu32 s in
   Int32.to_int align, offset
 
+let misc_instr s =
+  let pos = pos s in
+  match op s with
+  | 0x08 ->
+    let x = at var s in
+    zero_flag s;
+    memory_init x
+  | 0x09 -> data_drop (at var s)
+  | 0x0a -> zero_flag s; zero_flag s; memory_copy
+  | 0x0b -> zero_flag s; memory_fill
+  | 0x0c ->
+    let x = at var s in
+    zero_flag s;
+    table_init x
+  | 0x0d -> elem_drop (at var s)
+  | 0x0e -> zero_flag s; zero_flag s; table_copy
+
+  | b -> illegal s pos b
+
 let rec instr s =
   let pos = pos s in
   match op s with
@@ -244,7 +264,7 @@ let rec instr s =
   | 0x10 -> call (at var s)
   | 0x11 ->
     let x = at var s in
-    expect 0x00 s "zero flag expected";
+    zero_flag s;
     call_indirect x
 
   | 0x12 | 0x13 | 0x14 | 0x15 | 0x16 | 0x17 | 0x18 | 0x19 as b -> illegal s pos b
@@ -287,12 +307,8 @@ let rec instr s =
   | 0x3d -> let a, o = memop s in i64_store16 a o
   | 0x3e -> let a, o = memop s in i64_store32 a o
 
-  | 0x3f ->
-    expect 0x00 s "zero flag expected";
-    memory_size
-  | 0x40 ->
-    expect 0x00 s "zero flag expected";
-    memory_grow
+  | 0x3f -> zero_flag s; memory_size
+  | 0x40 -> zero_flag s; memory_grow
 
   | 0x41 -> i32_const (at vs32 s)
   | 0x42 -> i64_const (at vs64 s)
@@ -432,6 +448,8 @@ let rec instr s =
   | 0xbe -> f32_reinterpret_i32
   | 0xbf -> f64_reinterpret_i64
 
+  | 0xfc -> misc_instr s
+
   | b -> illegal s pos b
 
 and instr_block s = List.rev (instr_block' s [])
@@ -589,10 +607,24 @@ let code_section s =
 (* Element section *)
 
 let segment dat s =
-  let index = at var s in
-  let offset = const s in
-  let init = dat s in
-  {index; offset; init}
+  match vu32 s with
+  | 0l ->
+    let index = Source.(0l @@ Source.no_region) in
+    let offset = const s in
+    let sdesc = Active {index; offset} in
+    let init = dat s in
+    {sdesc; init}
+  | 1l ->
+    let sdesc = Passive in
+    let init = dat s in
+    {sdesc; init}
+  | 2l ->
+    let index = at var s in
+    let offset = const s in
+    let sdesc = Active {index; offset} in
+    let init = dat s in
+    {sdesc; init}
+  | _ -> error s (pos s - 1) "invalid segment flags"
 
 let table_segment s =
   segment (vec (at var)) s

interpreter/binary/encode.ml

@@ -363,6 +363,14 @@ let encode m =
       | Convert (F64 F64Op.DemoteF64) -> assert false
       | Convert (F64 F64Op.ReinterpretInt) -> op 0xbf
 
+      | MemoryInit x -> op 0xfc; op 0x08; var x; u8 0x00
+      | DataDrop x -> op 0xfc; op 0x09; var x
+      | MemoryCopy -> op 0xfc; op 0x0a; u8 0x00; u8 0x00
+      | MemoryFill -> op 0xfc; op 0x0b; u8 0x00
+      | TableInit x -> op 0xfc; op 0x0c; var x; u8 0x00
+      | ElemDrop x -> op 0xfc; op 0x0d; var x
+      | TableCopy -> op 0xfc; op 0x0e; u8 0x00; u8 0x00
+
     let const c =
       list instr c.it; end_ ()
 
@@ -470,8 +478,18 @@ let encode m =
 
     (* Element section *)
     let segment dat seg =
-      let {index; offset; init} = seg.it in
-      var index; const offset; dat init
+      let {sdesc; init} = seg.it in
+      match sdesc with
+      | Active {index; offset} ->
+        if index.it = 0l then
+          u8 0x00
+        else begin
+          u8 0x02; var index
+        end;
+        const offset;
+        dat init
+      | Passive ->
+          u8 0x01; dat init
 
     let table_segment seg =
       segment (vec var) seg

interpreter/exec/eval.ml

@@ -388,26 +388,32 @@ let init_func (inst : module_inst) (func : func_inst) =
   | _ -> assert false
 
 let init_table (inst : module_inst) (seg : table_segment) =
-  let {index; offset = const; init} = seg.it in
-  let tab = table inst index in
-  let offset = i32 (eval_const inst const) const.at in
-  let end_ = Int32.(add offset (of_int (List.length init))) in
-  let bound = Table.size tab in
-  if I32.lt_u bound end_ || I32.lt_u end_ offset then
-    Link.error seg.at "elements segment does not fit table";
-  fun () ->
-    Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init)
+  let {sdesc; init} = seg.it in
+  match sdesc with
+  | Active {index; offset = const} ->
+    let tab = table inst index in
+    let offset = i32 (eval_const inst const) const.at in
+    let end_ = Int32.(add offset (of_int (List.length init))) in
+    let bound = Table.size tab in
+    if I32.lt_u bound end_ || I32.lt_u end_ offset then
+      Link.error seg.at "elements segment does not fit table";
+    fun () ->
+      Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init)
+  | Passive -> fun () -> ()
 
 let init_memory (inst : module_inst) (seg : memory_segment) =
-  let {index; offset = const; init} = seg.it in
-  let mem = memory inst index in
-  let offset' = i32 (eval_const inst const) const.at in
-  let offset = I64_convert.extend_u_i32 offset' in
-  let end_ = Int64.(add offset (of_int (String.length init))) in
-  let bound = Memory.bound mem in
-  if I64.lt_u bound end_ || I64.lt_u end_ offset then
-    Link.error seg.at "data segment does not fit memory";
-  fun () -> Memory.store_bytes mem offset init
+  let {sdesc; init} = seg.it in
+  match sdesc with
+  | Active {index; offset = const} ->
+    let mem = memory inst index in
+    let offset' = i32 (eval_const inst const) const.at in
+    let offset = I64_convert.extend_u_i32 offset' in
+    let end_ = Int64.(add offset (of_int (String.length init))) in
+    let bound = Memory.bound mem in
+    if I64.lt_u bound end_ || I64.lt_u end_ offset then
+      Link.error seg.at "data segment does not fit memory";
+    fun () -> Memory.store_bytes mem offset init
+  | Passive -> fun () -> ()
 
 
 let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst)

interpreter/syntax/ast.ml

@@ -97,12 +97,23 @@ and instr' =
   | Unary of unop                     (* unary numeric operator *)
   | Binary of binop                   (* binary numeric operator *)
   | Convert of cvtop                  (* conversion *)
+  | MemoryInit of var                 (* initialize memory from segment *)
+  | DataDrop of var                   (* drop passive data segment *)
+  | MemoryCopy                        (* copy memory regions *)
+  | MemoryFill                        (* fill memory region with value *)
+  | TableInit of var                  (* initialize table from segment *)
+  | ElemDrop of var                   (* drop passive element segment *)
+  | TableCopy                         (* copy elements between table regions *)
 
 
 (* Globals & Functions *)
 
 type const = instr list Source.phrase
 
+type segment_desc =
+  | Active of {index : var; offset : const}
+  | Passive
+
 type global = global' Source.phrase
 and global' =
 {
@@ -136,8 +147,7 @@ and memory' =
 type 'data segment = 'data segment' Source.phrase
 and 'data segment' =
 {
-  index : var;
-  offset : const;
+  sdesc : segment_desc;
   init : 'data;
 }
 

interpreter/syntax/operators.ml

@@ -202,3 +202,10 @@ let f64_reinterpret_i64 = Convert (F64 F64Op.ReinterpretInt)
 let memory_size = MemorySize
 let memory_grow = MemoryGrow
 
+let memory_init x = MemoryInit x
+let data_drop x = DataDrop x
+let memory_copy = MemoryCopy
+let memory_fill = MemoryFill
+let table_init x = TableInit x
+let elem_drop x = ElemDrop x
+let table_copy = TableCopy

interpreter/syntax/types.ml

@@ -15,6 +15,7 @@ type extern_type =
   | ExternTableType of table_type
   | ExternMemoryType of memory_type
   | ExternGlobalType of global_type
+type segment_type = Seg
 
 
 (* Attributes *)

interpreter/text/arrange.ml

@@ -252,6 +252,13 @@ let rec instr e =
     | Unary op -> unop op, []
     | Binary op -> binop op, []
     | Convert op -> cvtop op, []
+    | MemoryInit x -> "memory.init " ^ var x, []
+    | DataDrop x -> "data.drop " ^ var x, []
+    | MemoryCopy -> "memory.copy", []
+    | MemoryFill -> "memory.fill", []
+    | TableInit x -> "table.init " ^ var x, []
+    | ElemDrop x -> "elem.drop " ^ var x, []
+    | TableCopy -> "table.copy", []
   in Node (head, inner)
 
 let const c =
@@ -290,8 +297,11 @@ let memory off i mem =
   Node ("memory $" ^ nat (off + i) ^ " " ^ limits nat32 lim, [])
 
 let segment head dat seg =
-  let {index; offset; init} = seg.it in
-  Node (head, atom var index :: Node ("offset", const offset) :: dat init)
+  let {sdesc; init} = seg.it in
+  match sdesc with
+  | Active {index; offset} ->
+    Node (head, atom var index :: Node ("offset", const offset) :: dat init)
+  | Passive -> Node (head, dat init)
 
 let elems seg =
   segment "elem" (list (atom var)) seg

interpreter/text/lexer.mll

@@ -317,6 +317,16 @@ rule token = parse
   | "memory.size" { MEMORY_SIZE }
   | "memory.grow" { MEMORY_GROW }
 
+  | "memory.init" { MEMORY_INIT }
+  | "data.drop" { DATA_DROP }
+  | "memory.copy" { MEMORY_COPY }
+  | "memory.fill" { MEMORY_FILL }
+  | "table.init" { TABLE_INIT }
+  | "elem.drop" { ELEM_DROP }
+  | "table.copy" { TABLE_COPY }
+
+  | "passive" { PASSIVE }
+
   | "type" { TYPE }
   | "func" { FUNC }
   | "start" { START }