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 (EventType (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 : event_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/script/run.ml

@@ -215,7 +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
+    | ExternEventType t -> "event", string_of_event_type t
     | ExternGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  import %s \"%s\" \"%s\" : %s\n"
@@ -229,7 +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
+    | ExternEventType t -> "event", string_of_event_type t
     | ExternGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  export %s \"%s\" : %s\n"

interpreter/syntax/ast.ml

@@ -254,7 +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)
+  | EventImport x -> ExternEventType (EventType (func_type_for m x))
   | GlobalImport t -> ExternGlobalType t
 
 let export_type (m : module_) (ex : export) : extern_type =
@@ -277,7 +277,7 @@ let export_type (m : module_) (ex : export) : extern_type =
     ExternGlobalType (nth gts x.it)
   | EventExport x ->
     let ets =
-      events its @ List.map (fun e -> func_type_for m e) m.it.events
+      events its @ List.map (fun e -> EventType (func_type_for m e)) m.it.events
     in ExternEventType (nth ets x.it)
 
 let string_of_name n =

interpreter/syntax/types.ml

@@ -10,7 +10,7 @@ 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 func_type
 type global_type = GlobalType of value_type * mutability
 type extern_type =
   | ExternFuncType of func_type
@@ -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 *)
@@ -78,13 +78,16 @@ let match_memory_type (MemoryType lim1) (MemoryType lim2) =
 let match_global_type gt1 gt2 =
   gt1 = gt2
 
+let match_event_type (EventType et1) (EventType et2) =
+  match_func_type et1 et2
+
 let match_extern_type et1 et2 =
   match et1, et2 with
-  | ExternFuncType ft1, ExternFuncType ft2
-  | ExternEventType ft1, ExternEventType ft2 -> match_func_type ft1 ft2
+  | ExternFuncType ft1, ExternFuncType 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
+  | ExternEventType et1, ExternEventType et2 -> match_event_type et1 et2
   | _, _ -> false
 
 
@@ -133,9 +136,12 @@ let string_of_stack_type ts =
 let string_of_func_type (FuncType (ins, out)) =
   string_of_stack_type ins ^ " -> " ^ string_of_stack_type out
 
+let string_of_event_type (EventType et) =
+  string_of_func_type et
+
 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 et -> "event " ^ string_of_event_type et

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], [], [] }
@@ -887,13 +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

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 (type_ c x) :: 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 (type_ c0 event)) events;
       elems = List.map (fun elem -> elem.it.etype) elems;
       datas = List.map (fun _data -> ()) datas;
     }