fixup! [interpreter] Add event section

Author: thibaudmichaud

interpreter/binary/decode.ml

@@ -135,6 +135,9 @@ let sized f s =
 
 open Types
 
+let zero s = expect 0x00 s "zero byte expected"
+let var s = vu32 s
+
 let num_type s =
   match vs7 s with
   | -0x01 -> I32Type
@@ -189,17 +192,17 @@ let global_type s =
   let mut = mutability s in
   GlobalType (t, mut)
 
+let event_type s =
+  zero s; var s
+
 
 (* Decode instructions *)
 
 open Ast
 open Operators
 
-let var s = vu32 s
-
 let op s = u8 s
 let end_ s = expect 0x0b s "END opcode expected"
-let zero s = expect 0x00 s "zero byte expected"
 
 let memop s =
   let align = vu32 s in
@@ -556,7 +559,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)
+  | 0x04 -> EventImport (at event_type s)
   | _ -> error s (pos s - 1) "malformed import kind"
 
 let import s =
@@ -596,11 +599,8 @@ let memory_section s =
 
 (* Event section *)
 
-let event s =
-  ignore (vu32 s); var s
-
 let event_section s =
-  section `EventSection (vec (at event)) [] s
+  section `EventSection (vec (at event_type)) [] s
 
 (* Global section *)
 

interpreter/binary/encode.ml

@@ -90,6 +90,9 @@ let encode m =
     (* Types *)
 
     open Types
+    open Source
+
+    let var x = vu32 x.it
 
     let num_type = function
       | I32Type -> vs7 (-0x01)
@@ -118,6 +121,8 @@ let encode m =
     let memory_type = function
       | MemoryType lim -> limits vu32 lim
 
+    let event_type x = vu32 0x00l; var x
+
     let mutability = function
       | Immutable -> u8 0
       | Mutable -> u8 1
@@ -127,7 +132,6 @@ let encode m =
 
     (* Expressions *)
 
-    open Source
     open Ast
     open Values
 
@@ -136,8 +140,6 @@ let encode m =
 
     let memop {align; offset; _} = vu32 (Int32.of_int align); vu32 offset
 
-    let var x = vu32 x.it
-
     let block_type = function
       | VarBlockType x -> vs33 x.it
       | ValBlockType None -> vs7 (-0x40)
@@ -426,7 +428,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
+      | EventImport x -> u8 0x04; event_type x
 
     let import im =
       let {module_name; item_name; idesc} = im.it in

interpreter/exec/eval.ml

@@ -582,7 +582,7 @@ let create_memory (inst : module_inst) (mem : memory) : memory_inst =
   Memory.alloc mtype
 
 let create_event (inst : module_inst) (e : event) : event_inst =
-  type_ inst e
+  Event.alloc (type_ inst e)
 
 let create_global (inst : module_inst) (glob : global) : global_inst =
   let {gtype; ginit} = glob.it in

interpreter/runtime/event.ml

@@ -0,0 +1,10 @@
+open Types
+
+type event = {ty : func_type}
+type t = event
+
+let alloc ty =
+   {ty}
+
+let type_of evt =
+  evt.ty

interpreter/runtime/instance.ml

@@ -16,7 +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 event_inst = Event.t
 and global_inst = Global.t
 and export_inst = Ast.name * extern
 and elem_inst = Values.ref_ list ref
@@ -58,7 +58,7 @@ let extern_type_of = function
   | 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
+  | ExternEvent event -> ExternEventType (Event.type_of event)
 
 let export inst name =
   try Some (List.assoc name inst.exports) with Not_found -> None

interpreter/syntax/types.ml

@@ -10,13 +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 event_type = EventType of int32
 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
+  | ExternEventType of func_type
   | ExternGlobalType of global_type
 
 type pack_size = Pack8 | Pack16 | Pack32
@@ -51,10 +51,10 @@ 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)
+let events =
+  Lib.List.map_filter (function ExternEventType t -> Some t | _ -> None)
 
 
 (* Subtyping *)
@@ -137,5 +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
+  | ExternEventType ft -> "event " ^ string_of_func_type ft

interpreter/text/arrange.ml

@@ -361,11 +361,14 @@ let data i seg =
 
 (* Events *)
 
-let event off i e =
-  Node ("event",
+let event_with_name name e =
+  Node ("event" ^ name,
     [Node ("type " ^ var e, [])]
   )
 
+let event_with_index off i e =
+  event_with_name (" $" ^ nat (off + i)) e
+
 
 (* Modules *)
 
@@ -426,7 +429,7 @@ let module_with_var_opt x_opt m =
     imports @
     listi (table !tx) m.it.tables @
     listi (memory !mx) m.it.memories @
-    listi (event !ex) m.it.events @
+    listi (event_with_index !ex) m.it.events @
     listi (global !gx) m.it.globals @
     listi (func_with_index !fx) m.it.funcs @
     list export m.it.exports @

interpreter/text/parser.mly

@@ -851,11 +851,11 @@ event :
       fun c -> let x = $3 c anon_event bind_event @@ at in fun () -> $4 c x at }
 
 event_fields :
-  | type_use event_types
+  | type_use func_type
     { fun c x at ->
       let y = inline_type_explicit c ($1 c type_) $2 at in
       [y], [], [] }
-  | event_types  /* Sugar */
+  | func_type  /* Sugar */
     { fun c x at ->
       let y = inline_type c $1 at in
       [y], [], [] }
@@ -873,7 +873,7 @@ event_fields :
          idesc = EventImport y @@ at } @@ at ], [] }
   | inline_export event_fields  /* Sugar */
     { fun c x at ->
-      let fns, ims, exs = $2 c x at in fns, ims, $1 (EventExport x) c :: exs }
+      let evs, ims, exs = $2 c x at in evs, ims, $1 (EventExport x) c :: exs }
 
 event_fields_import :  /* Sugar */
   | event_fields_import_result { $1 }
@@ -887,19 +887,6 @@ event_fields_import_result :  /* Sugar */
   | LPAR RESULT value_type_list RPAR event_fields_import_result
     { let FuncType (ins, out) = $5 in FuncType (ins, $3 @ out) }
 
-event_types :
-  | event_result_types { $1 }
-  | LPAR PARAM value_type_list RPAR event_types
-    { let FuncType (ins, out) = $5 in FuncType ($3 @ ins, out) }
-  | LPAR PARAM bind_var value_type RPAR event_types  /* Sugar */
-    { let FuncType (ins, out) = $6 in FuncType ($4 :: ins, out) }
-
-event_result_types :
-  | /* empty */ { FuncType ([], []) }
-  | LPAR RESULT value_type_list RPAR event_result_types
-    { let FuncType (ins, out) = $5 in
-      FuncType (ins, $3 @ out) }
-
 global :
   | LPAR GLOBAL bind_var_opt global_fields RPAR
     { let at = at () in

interpreter/valid/valid.ml

@@ -575,7 +575,7 @@ let check_import (im : import) (c : context) : context =
     check_global_type gt idesc.at;
     {c with globals = gt :: c.globals}
   | EventImport x ->
-    {c with events = type_ c x :: c.events}
+    {c with events = EventType x.it :: c.events}
 
 module NameSet = Set.Make(struct type t = Ast.name let compare = compare end)
 
@@ -608,7 +608,7 @@ let check_module (m : module_) =
       funcs = c0.funcs @ List.map (fun f -> type_ c0 f.it.ftype) funcs;
       tables = c0.tables @ List.map (fun tab -> tab.it.ttype) tables;
       memories = c0.memories @ List.map (fun mem -> mem.it.mtype) memories;
-      events = c0.events @ List.map (fun event -> type_ c0 event) events;
+      events = c0.events @ List.map (fun event -> EventType event.it) events;
       elems = List.map (fun elem -> elem.it.etype) elems;
       datas = List.map (fun _data -> ()) datas;
     }