[interpreter] Add event section

Author: thibaudmichaud

interpreter/binary/decode.ml

@@ -527,6 +527,7 @@ let id s =
     | 10 -> `CodeSection
     | 11 -> `DataSection
     | 12 -> `DataCountSection
+    | 13 -> `EventSection
     | _ -> error s (pos s) "malformed section id"
     ) bo
 
@@ -555,6 +556,7 @@ let import_desc s =
   | 0x01 -> TableImport (table_type s)
   | 0x02 -> MemoryImport (memory_type s)
   | 0x03 -> GlobalImport (global_type s)
+  | 0x04 -> ignore (vu32 s); EventImport (at var s)
   | _ -> error s (pos s - 1) "malformed import kind"
 
 let import s =
@@ -592,6 +594,13 @@ let memory s =
 let memory_section s =
   section `MemorySection (vec (at memory)) [] s
 
+(* Event section *)
+
+let event s =
+  ignore (vu32 s); var s
+
+let event_section s =
+  section `EventSection (vec (at event)) [] s
 
 (* Global section *)
 
@@ -612,6 +621,7 @@ let export_desc s =
   | 0x01 -> TableExport (at var s)
   | 0x02 -> MemoryExport (at var s)
   | 0x03 -> GlobalExport (at var s)
+  | 0x04 -> EventExport (at var s)
   | _ -> error s (pos s - 1) "malformed export kind"
 
 let export s =
@@ -787,6 +797,8 @@ let module_ s =
   iterate custom_section s;
   let memories = memory_section s in
   iterate custom_section s;
+  let events = event_section s in
+  iterate custom_section s;
   let globals = global_section s in
   iterate custom_section s;
   let exports = export_section s in
@@ -812,7 +824,8 @@ let module_ s =
   let funcs =
     List.map2 Source.(fun t f -> {f.it with ftype = t} @@ f.at)
       func_types func_bodies
-  in {types; tables; memories; globals; funcs; imports; exports; elems; datas; start}
+  in {types; tables; memories; events; globals; funcs; imports; exports; elems;
+      datas; start}
 
 
 let decode name bs = at module_ (stream name bs)

interpreter/binary/encode.ml

@@ -426,6 +426,7 @@ let encode m =
       | TableImport t -> u8 0x01; table_type t
       | MemoryImport t -> u8 0x02; memory_type t
       | GlobalImport t -> u8 0x03; global_type t
+      | EventImport x -> u8 0x04; vu32 0x00l; var x
 
     let import im =
       let {module_name; item_name; idesc} = im.it in
@@ -456,6 +457,12 @@ let encode m =
     let memory_section mems =
       section 5 (vec memory) mems (mems <> [])
 
+    (* Event section *)
+    let event e = vu32 0x00l; var e
+
+    let event_section es =
+      section 13 (vec event) es (es <> [])
+
     (* Global section *)
     let global g =
       let {gtype; ginit} = g.it in
@@ -471,6 +478,7 @@ let encode m =
       | TableExport x -> u8 1; var x
       | MemoryExport x -> u8 2; var x
       | GlobalExport x -> u8 3; var x
+      | EventExport x -> u8 4; var x
 
     let export ex =
       let {name = n; edesc} = ex.it in
@@ -579,6 +587,7 @@ let encode m =
       func_section m.it.funcs;
       table_section m.it.tables;
       memory_section m.it.memories;
+      event_section m.it.events;
       global_section m.it.globals;
       export_section m.it.exports;
       start_section m.it.start;

interpreter/exec/eval.ml

@@ -85,6 +85,7 @@ let type_ (inst : module_inst) x = lookup "type" inst.types x
 let func (inst : module_inst) x = lookup "function" inst.funcs x
 let table (inst : module_inst) x = lookup "table" inst.tables x
 let memory (inst : module_inst) x = lookup "memory" inst.memories x
+let event (inst : module_inst) x = lookup "event" inst.events x
 let global (inst : module_inst) x = lookup "global" inst.globals x
 let elem (inst : module_inst) x = lookup "element segment" inst.elems x
 let data (inst : module_inst) x = lookup "data segment" inst.datas x
@@ -580,6 +581,9 @@ let create_memory (inst : module_inst) (mem : memory) : memory_inst =
   let {mtype} = mem.it in
   Memory.alloc mtype
 
+let create_event (inst : module_inst) (e : event) : event_inst =
+  type_ inst e
+
 let create_global (inst : module_inst) (glob : global) : global_inst =
   let {gtype; ginit} = glob.it in
   let v = eval_const inst ginit in
@@ -593,6 +597,7 @@ let create_export (inst : module_inst) (ex : export) : export_inst =
     | TableExport x -> ExternTable (table inst x)
     | MemoryExport x -> ExternMemory (memory inst x)
     | GlobalExport x -> ExternGlobal (global inst x)
+    | EventExport x -> ExternEvent (event inst x)
   in (name, ext)
 
 let create_elem (inst : module_inst) (seg : elem_segment) : elem_inst =
@@ -612,6 +617,7 @@ let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst)
   | ExternFunc func -> {inst with funcs = func :: inst.funcs}
   | ExternTable tab -> {inst with tables = tab :: inst.tables}
   | ExternMemory mem -> {inst with memories = mem :: inst.memories}
+  | ExternEvent event -> {inst with events = event :: inst.events}
   | ExternGlobal glob -> {inst with globals = glob :: inst.globals}
 
 let init_func (inst : module_inst) (func : func_inst) =
@@ -654,7 +660,7 @@ let run_start start =
 
 let init (m : module_) (exts : extern list) : module_inst =
   let
-    { imports; tables; memories; globals; funcs; types;
+    { imports; tables; memories; events; globals; funcs; types;
       exports; elems; datas; start
     } = m.it
   in
@@ -670,6 +676,7 @@ let init (m : module_) (exts : extern list) : module_inst =
     { inst1 with
       tables = inst1.tables @ List.map (create_table inst1) tables;
       memories = inst1.memories @ List.map (create_memory inst1) memories;
+      events = inst1.events @ List.map (create_event inst1) events;
       globals = inst1.globals @ List.map (create_global inst1) globals;
     }
   in

interpreter/runtime/instance.ml

@@ -6,6 +6,7 @@ type module_inst =
   funcs : func_inst list;
   tables : table_inst list;
   memories : memory_inst list;
+  events : event_inst list;
   globals : global_inst list;
   exports : export_inst list;
   elems : elem_inst list;
@@ -15,6 +16,7 @@ type module_inst =
 and func_inst = module_inst ref Func.t
 and table_inst = Table.t
 and memory_inst = Memory.t
+and event_inst = func_type
 and global_inst = Global.t
 and export_inst = Ast.name * extern
 and elem_inst = Values.ref_ list ref
@@ -24,6 +26,7 @@ and extern =
   | ExternFunc of func_inst
   | ExternTable of table_inst
   | ExternMemory of memory_inst
+  | ExternEvent of event_inst
   | ExternGlobal of global_inst
 
 
@@ -47,14 +50,15 @@ let () =
 (* Auxiliary functions *)
 
 let empty_module_inst =
-  { types = []; funcs = []; tables = []; memories = []; globals = [];
-    exports = []; elems = []; datas = [] }
+  { types = []; funcs = []; tables = []; memories = []; events = [];
+    globals = []; exports = []; elems = []; datas = [] }
 
 let extern_type_of = function
   | ExternFunc func -> ExternFuncType (Func.type_of func)
   | ExternTable tab -> ExternTableType (Table.type_of tab)
   | ExternMemory mem -> ExternMemoryType (Memory.type_of mem)
   | ExternGlobal glob -> ExternGlobalType (Global.type_of glob)
+  | ExternEvent event -> ExternEventType event
 
 let export inst name =
   try Some (List.assoc name inst.exports) with Not_found -> None

interpreter/script/run.ml

@@ -215,6 +215,7 @@ let print_import m im =
     | ExternFuncType t -> "func", string_of_func_type t
     | ExternTableType t -> "table", string_of_table_type t
     | ExternMemoryType t -> "memory", string_of_memory_type t
+    | ExternEventType t -> "event", string_of_func_type t
     | ExternGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  import %s \"%s\" \"%s\" : %s\n"
@@ -228,6 +229,7 @@ let print_export m ex =
     | ExternFuncType t -> "func", string_of_func_type t
     | ExternTableType t -> "table", string_of_table_type t
     | ExternMemoryType t -> "memory", string_of_memory_type t
+    | ExternEventType t -> "event", string_of_func_type t
     | ExternGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  export %s \"%s\" : %s\n"

interpreter/syntax/ast.ml

@@ -150,6 +150,8 @@ and memory' =
   mtype : memory_type;
 }
 
+type event = int32 Source.phrase
+
 type segment_mode = segment_mode' Source.phrase
 and segment_mode' =
   | Passive
@@ -182,6 +184,7 @@ and export_desc' =
   | TableExport of var
   | MemoryExport of var
   | GlobalExport of var
+  | EventExport of var
 
 type export = export' Source.phrase
 and export' =
@@ -196,6 +199,7 @@ and import_desc' =
   | TableImport of table_type
   | MemoryImport of memory_type
   | GlobalImport of global_type
+  | EventImport of var
 
 type import = import' Source.phrase
 and import' =
@@ -212,6 +216,7 @@ and module_' =
   globals : global list;
   tables : table list;
   memories : memory list;
+  events : event list;
   funcs : func list;
   start : var option;
   elems : elem_segment list;
@@ -229,6 +234,7 @@ let empty_module =
   globals = [];
   tables = [];
   memories = [];
+  events = [];
   funcs = [];
   start = None;
   elems = [];
@@ -248,6 +254,7 @@ let import_type (m : module_) (im : import) : extern_type =
   | FuncImport x -> ExternFuncType (func_type_for m x)
   | TableImport t -> ExternTableType t
   | MemoryImport t -> ExternMemoryType t
+  | EventImport x -> ExternEventType (func_type_for m x)
   | GlobalImport t -> ExternGlobalType t
 
 let export_type (m : module_) (ex : export) : extern_type =
@@ -268,6 +275,10 @@ let export_type (m : module_) (ex : export) : extern_type =
   | GlobalExport x ->
     let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in
     ExternGlobalType (nth gts x.it)
+  | EventExport x ->
+    let ets =
+      events its @ List.map (fun e -> func_type_for m e) m.it.events
+    in ExternEventType (nth ets x.it)
 
 let string_of_name n =
   let b = Buffer.create 16 in

interpreter/syntax/free.ml

@@ -9,6 +9,7 @@ type t =
   globals : Set.t;
   tables : Set.t;
   memories : Set.t;
+  events : Set.t;
   funcs : Set.t;
   elems : Set.t;
   datas : Set.t;
@@ -22,6 +23,7 @@ let empty : t =
   globals = Set.empty;
   tables = Set.empty;
   memories = Set.empty;
+  events = Set.empty;
   funcs = Set.empty;
   elems = Set.empty;
   datas = Set.empty;
@@ -35,6 +37,7 @@ let union (s1 : t) (s2 : t) : t =
   globals = Set.union s1.globals s2.globals;
   tables = Set.union s1.tables s2.tables;
   memories = Set.union s1.memories s2.memories;
+  events = Set.union s1.events s2.events;
   funcs = Set.union s1.funcs s2.funcs;
   elems = Set.union s1.elems s2.elems;
   datas = Set.union s1.datas s2.datas;
@@ -46,6 +49,7 @@ let types s = {empty with types = s}
 let globals s = {empty with globals = s}
 let tables s = {empty with tables = s}
 let memories s = {empty with memories = s}
+let events s = {empty with events = s}
 let funcs s = {empty with funcs = s}
 let elems s = {empty with elems = s}
 let datas s = {empty with datas = s}
@@ -93,6 +97,7 @@ let global (g : global) = const g.it.ginit
 let func (f : func) = {(block f.it.body) with locals = Set.empty}
 let table (t : table) = empty
 let memory (m : memory) = empty
+let event (e : event) = empty
 
 let segment_mode f (m : segment_mode) =
   match m.it with
@@ -112,13 +117,15 @@ let export_desc (d : export_desc) =
   | FuncExport x -> funcs (var x)
   | TableExport x -> tables (var x)
   | MemoryExport x -> memories (var x)
+  | EventExport x -> events (var x)
   | GlobalExport x -> globals (var x)
 
 let import_desc (d : import_desc) =
   match d.it with
   | FuncImport x -> types (var x)
   | TableImport tt -> empty
   | MemoryImport mt -> empty
+  | EventImport x -> types (var x)
   | GlobalImport gt -> empty
 
 let export (e : export) = export_desc e.it.edesc

interpreter/syntax/free.mli

@@ -6,6 +6,7 @@ type t =
   globals : Set.t;
   tables : Set.t;
   memories : Set.t;
+  events : Set.t;
   funcs : Set.t;
   elems : Set.t;
   datas : Set.t;
@@ -25,6 +26,7 @@ val global : Ast.global -> t
 val func : Ast.func -> t
 val table : Ast.table -> t
 val memory : Ast.memory -> t
+val event : Ast.event -> t
 val elem : Ast.elem_segment -> t
 val data : Ast.data_segment -> t
 val export : Ast.export -> t

interpreter/syntax/types.ml

@@ -10,11 +10,13 @@ type 'a limits = {min : 'a; max : 'a option}
 type mutability = Immutable | Mutable
 type table_type = TableType of Int32.t limits * ref_type
 type memory_type = MemoryType of Int32.t limits
+type event_type = func_type
 type global_type = GlobalType of value_type * mutability
 type extern_type =
   | ExternFuncType of func_type
   | ExternTableType of table_type
   | ExternMemoryType of memory_type
+  | ExternEventType of event_type
   | ExternGlobalType of global_type
 
 type pack_size = Pack8 | Pack16 | Pack32
@@ -49,6 +51,8 @@ let tables =
   Lib.List.map_filter (function ExternTableType t -> Some t | _ -> None)
 let memories =
   Lib.List.map_filter (function ExternMemoryType t -> Some t | _ -> None)
+let events =
+  Lib.List.map_filter (function ExternEventType t -> Some t | _ -> None)
 let globals =
   Lib.List.map_filter (function ExternGlobalType t -> Some t | _ -> None)
 
@@ -76,7 +80,8 @@ let match_global_type gt1 gt2 =
 
 let match_extern_type et1 et2 =
   match et1, et2 with
-  | ExternFuncType ft1, ExternFuncType ft2 -> match_func_type ft1 ft2
+  | ExternFuncType ft1, ExternFuncType ft2
+  | ExternEventType ft1, ExternEventType ft2 -> match_func_type ft1 ft2
   | ExternTableType tt1, ExternTableType tt2 -> match_table_type tt1 tt2
   | ExternMemoryType mt1, ExternMemoryType mt2 -> match_memory_type mt1 mt2
   | ExternGlobalType gt1, ExternGlobalType gt2 -> match_global_type gt1 gt2
@@ -132,4 +137,5 @@ let string_of_extern_type = function
   | ExternFuncType ft -> "func " ^ string_of_func_type ft
   | ExternTableType tt -> "table " ^ string_of_table_type tt
   | ExternMemoryType mt -> "memory " ^ string_of_memory_type mt
+  | ExternEventType et -> "event " ^ string_of_func_type et
   | ExternGlobalType gt -> "global " ^ string_of_global_type gt