[interpreter] Parse and convert EH opcodes

Add support for EH opcodes in the parser, AST, encoder, decoder and
formatter, and add spec tests.

This can already be used to convert the tests to JS, but not run them
with the interpreter yet since validation and execution are still
missing.

Author: thibaudmichaud

interpreter/binary/decode.ml

@@ -246,7 +246,15 @@ let rec instr s =
     end
 
   | 0x05 -> error s pos "misplaced ELSE opcode"
-  | 0x06| 0x07 | 0x08 | 0x09 | 0x0a as b -> illegal s pos b
+  | 0x06 ->
+    let bt = block_type s in
+    let es' = instr_block s in
+    let h = handler s in
+    try_ bt es' h
+  | 0x07 -> error s pos "misplaced CATCH opcode"
+  | 0x08 -> throw (at var s)
+  | 0x09 -> rethrow (at var s)
+  | 0x0a as b -> illegal s pos b
   | 0x0b -> error s pos "misplaced END opcode"
 
   | 0x0c -> br (at var s)
@@ -263,7 +271,9 @@ let rec instr s =
     let x = at var s in
     call_indirect x y
 
-  | 0x12 | 0x13 | 0x14 | 0x15 | 0x16 | 0x17 | 0x18 | 0x19 as b -> illegal s pos b
+  | 0x12 | 0x13 | 0x14 | 0x15 | 0x16 | 0x17 as b -> illegal s pos b
+  | 0x18 -> error s pos "misplaced DELEGATE opcode"
+  | 0x19 -> error s pos "misplaced CATCH_ALL opcode"
 
   | 0x1a -> drop
   | 0x1b -> select None
@@ -499,12 +509,39 @@ let rec instr s =
 and instr_block s = List.rev (instr_block' s [])
 and instr_block' s es =
   match peek s with
-  | None | Some (0x05 | 0x0b) -> es
+  | None | Some (0x05 | 0x07 | 0x0a | 0x0b | 0x18 | 0x19) -> es
   | _ ->
     let pos = pos s in
     let e' = instr s in
     instr_block' s (Source.(e' @@ region s pos pos) :: es)
 
+and handler s =
+  let rec catch_list () =
+    if peek s = Some 0x07 then begin
+      ignore (u8 s);
+      let tag = at var s in
+      let instrs = instr_block s in
+      (tag, instrs) :: catch_list ()
+    end else
+      []
+  in
+  let cs = catch_list () in
+  let catch_all = if peek s = Some 0x19 then begin
+    ignore (u8 s);
+    Some (instr_block s)
+  end else
+    None
+  in
+  if cs <> [] || catch_all <> None then begin
+    end_ s;
+    catch cs catch_all
+  end else
+    let pos = pos s in
+    match op s with
+    | 0x0b -> catch [] None
+    | 0x18 -> delegate (at var s)
+    | b -> illegal s pos b
+
 let const s =
   let c = at instr_block s in
   end_ s;

interpreter/binary/encode.ml

@@ -156,13 +156,17 @@ let encode m =
         op 0x04; block_type bt; list instr es1;
         if es2 <> [] then op 0x05;
         list instr es2; end_ ()
+      | Try (bt, es, h) ->
+        op 0x06; block_type bt; list instr es; handler h
 
       | Br x -> op 0x0c; var x
       | BrIf x -> op 0x0d; var x
       | BrTable (xs, x) -> op 0x0e; vec var xs; var x
       | Return -> op 0x0f
       | Call x -> op 0x10; var x
       | CallIndirect (x, y) -> op 0x11; var y; var x
+      | Throw x -> op 0x08; var x
+      | Rethrow x -> op 0x09; var x
 
       | Drop -> op 0x1a
       | Select None -> op 0x1b
@@ -401,6 +405,19 @@ let encode m =
       | Convert (F64 F64Op.DemoteF64) -> assert false
       | Convert (F64 F64Op.ReinterpretInt) -> op 0xbf
 
+    and handler = function
+      | Catch (cs, c) ->
+        let catch (tag, es) =
+          u8 0x07; var tag; list instr es
+        in
+        list catch cs;
+        begin match c with
+          | None -> ()
+          | Some es -> u8 0x19; list instr es
+        end;
+        end_ ()
+      | Delegate x -> u8 0x18; var x
+
     let const c =
       list instr c.it; end_ ()
 

interpreter/syntax/ast.ml

@@ -114,6 +114,14 @@ and instr' =
   | Unary of unop                     (* unary numeric operator *)
   | Binary of binop                   (* binary numeric operator *)
   | Convert of cvtop                  (* conversion *)
+  | Try of block_type * instr list *  (* try *)
+           handler                    (* handle exception *)
+  | Throw of var                      (* throw exception *)
+  | Rethrow of var                    (* rethrow exception *)
+and handler =
+  | Catch of (var * instr list) list * (* tagged catch blocks *)
+             instr list option        (* optional catch_all *)
+  | Delegate of var                   (* delegate *)
 
 
 (* Globals & Functions *)

interpreter/syntax/free.ml

@@ -87,10 +87,24 @@ let rec instr (e : instr) =
     memories zero
   | MemoryInit x -> memories zero ++ datas (var x)
   | DataDrop x -> datas (var x)
+  | Try (bt, es, h) -> block es ++ handler h
+  | Throw x ->  events (var x)
+  | Rethrow x ->  labels (var x)
 
 and block (es : instr list) =
   let free = list instr es in {free with labels = shift free.labels}
 
+and handler = function
+  | Catch (cs, catch_all) ->
+    let rec catch_list = function
+      | (tag, es) :: cs ->
+        events (var tag) ++ (block es) ++ catch_list cs
+      | [] -> match catch_all with
+        | Some es -> block es
+        | None -> empty
+    in catch_list cs
+  | Delegate x -> events (var x)
+
 let const (c : const) = block c.it
 
 let global (g : global) = const g.it.ginit

interpreter/syntax/operators.ml

@@ -19,13 +19,18 @@ let select t = Select t
 let block bt es = Block (bt, es)
 let loop bt es = Loop (bt, es)
 let if_ bt es1 es2 = If (bt, es1, es2)
+let try_ bt es h = Try (bt, es, h)
+let catch cs c = Catch (cs, c)
+let delegate x = Delegate x
 let br x = Br x
 let br_if x = BrIf x
 let br_table xs x = BrTable (xs, x)
 
 let return = Return
 let call x = Call x
 let call_indirect x y = CallIndirect (x, y)
+let throw x = Throw x
+let rethrow x = Rethrow x
 
 let local_get x = LocalGet x
 let local_set x = LocalSet x

interpreter/text/arrange.ml

@@ -279,7 +279,19 @@ let rec instr e =
     | Unary op -> unop op, []
     | Binary op -> binop op, []
     | Convert op -> cvtop op, []
+    | Try (bt, es, h) ->
+      "try", block_type bt @ [Node ("do", list instr es)] @ handler h
+    | Throw x -> "throw " ^ var x, []
+    | Rethrow x -> "rethrow " ^ var x, []
   in Node (head, inner)
+and handler = function
+  | Catch (cs, c) ->
+    let catch (tag, es) = Node ("catch " ^ var tag, list instr es) in
+    let catch_all = match c with
+      | Some es -> [Node ("catch_all", list instr es)]
+      | None -> [] in
+    list catch cs @ catch_all
+  | Delegate x -> [Node ("delegate " ^ var x, [])]
 
 let const head c =
   match c.it with

interpreter/text/lexer.mll

@@ -348,6 +348,14 @@ rule token = parse
   | "i32.reinterpret_f32" { CONVERT i32_reinterpret_f32 }
   | "i64.reinterpret_f64" { CONVERT i64_reinterpret_f64 }
 
+  | "try" { TRY }
+  | "do" { DO }
+  | "catch" { CATCH }
+  | "catch_all" { CATCH_ALL }
+  | "delegate" { DELEGATE }
+  | "throw" { THROW }
+  | "rethrow" { RETHROW }
+
   | "type" { TYPE }
   | "func" { FUNC }
   | "start" { START }

interpreter/text/parser.mly

@@ -112,6 +112,8 @@ let func_type (c : context) x =
   try (Lib.List32.nth c.types.list x.it).it
   with Failure _ -> error x.at ("unknown type " ^ Int32.to_string x.it)
 
+let handlers (c : context) h =
+  List.map (fun (l, i) -> (l c event, i c)) h
 
 let anon category space n =
   let i = space.count in
@@ -179,7 +181,8 @@ let inline_type_explicit (c : context) x ft at =
 %token NAT INT FLOAT STRING VAR
 %token NUM_TYPE FUNCREF EXTERNREF EXTERN MUT
 %token UNREACHABLE NOP DROP SELECT
-%token BLOCK END IF THEN ELSE LOOP BR BR_IF BR_TABLE
+%token BLOCK END IF THEN ELSE LOOP BR BR_IF BR_TABLE TRY DO CATCH CATCH_ALL
+%token DELEGATE
 %token CALL CALL_INDIRECT RETURN
 %token LOCAL_GET LOCAL_SET LOCAL_TEE GLOBAL_GET GLOBAL_SET
 %token TABLE_GET TABLE_SET
@@ -188,6 +191,7 @@ let inline_type_explicit (c : context) x ft at =
 %token LOAD STORE OFFSET_EQ_NAT ALIGN_EQ_NAT
 %token CONST UNARY BINARY TEST COMPARE CONVERT
 %token REF_NULL REF_FUNC REF_EXTERN REF_IS_NULL
+%token THROW RETHROW
 %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL
 %token TABLE ELEM MEMORY EVENT DATA DECLARE OFFSET ITEM IMPORT EXPORT
 %token MODULE BIN QUOTE
@@ -358,6 +362,8 @@ plain_instr :
       br_table xs x }
   | RETURN { fun c -> return }
   | CALL var { fun c -> call ($2 c func) }
+  | THROW var { fun c -> throw ($2 c event) }
+  | RETHROW var { fun c -> rethrow ($2 c label)  }
   | LOCAL_GET var { fun c -> local_get ($2 c local) }
   | LOCAL_SET var { fun c -> local_set ($2 c local) }
   | LOCAL_TEE var { fun c -> local_tee ($2 c local) }
@@ -398,7 +404,6 @@ plain_instr :
   | BINARY { fun c -> $1 }
   | CONVERT { fun c -> $1 }
 
-
 select_instr :
   | SELECT select_instr_results
     { let at = at () in fun c -> let b, ts = $2 in
@@ -495,6 +500,12 @@ block_instr :
   | IF labeling_opt block ELSE labeling_end_opt instr_list END labeling_end_opt
     { fun c -> let c' = $2 c ($5 @ $8) in
       let ts, es1 = $3 c' in if_ ts es1 ($6 c') }
+  | TRY labeling_opt block handler_instr
+    { fun c -> let c' = $2 c [] in
+      let ts, es = $3 c' in try_ ts es ($4 c') }
+  | TRY labeling_opt block DELEGATE var
+    { fun c -> let c' = $2 c [] in
+      let ts, es = $3 c' in try_ ts es (delegate ($5 c label)) }
 
 block :
   | type_use block_param_body
@@ -524,6 +535,40 @@ block_result_body :
     { let FuncType (ins, out) = fst $5 in
       FuncType (ins, $3 @ out), snd $5 }
 
+handler_instr :
+  | catch_list_instr END
+    { fun c -> catch (handlers c $1) None }
+  | catch_list_instr catch_all END
+    { fun c -> catch (handlers c $1) (Some ($2 c)) }
+  | catch_all END
+    { fun c -> catch [] (Some ($1 c)) }
+  | END { fun c -> catch [] None }
+
+catch_list_instr :
+  | catch catch_list_instr { $1 :: $2 }
+  | catch { [$1] }
+
+handler :
+  | catch_list
+    { fun _ c' -> catch (List.map (fun (l, i) -> (l c' event, i c')) $1) None }
+  | catch_list LPAR catch_all RPAR
+    { fun _ c' -> catch (List.map (fun (l, i) -> (l c' event, i c')) $1) (Some ($3 c')) }
+  | LPAR catch_all RPAR
+    { fun _ c' -> catch [] (Some ($2 c')) }
+  | LPAR DELEGATE var RPAR
+    { fun c _ -> delegate ($3 c label) }
+  | /* empty */ { fun c _ -> catch [] None }
+
+catch_list :
+  | catch_list LPAR catch RPAR { $1 @ [$3] }
+  | LPAR catch RPAR { [$2] }
+
+catch :
+  | CATCH var instr_list { ($2, $3) }
+
+catch_all :
+  | CATCH_ALL instr_list { $2 }
+
 
 expr :  /* Sugar */
   | LPAR expr1 RPAR
@@ -545,6 +590,9 @@ expr1 :  /* Sugar */
   | IF labeling_opt if_block
     { fun c -> let c' = $2 c [] in
       let bt, (es, es1, es2) = $3 c c' in es, if_ bt es1 es2 }
+  | TRY labeling_opt try_block
+    { fun c -> let c' = $2 c [] in
+      let bt, (es, h) = $3 c c' in [], try_ bt es h }
 
 select_expr_results :
   | LPAR RESULT value_type_list RPAR select_expr_results
@@ -614,6 +662,38 @@ if_ :
   | LPAR THEN instr_list RPAR  /* Sugar */
     { fun c c' -> [], $3 c', [] }
 
+try_block :
+  | type_use try_block_param_body
+    { let at = at () in
+      fun c c' ->
+      VarBlockType (inline_type_explicit c' ($1 c' type_) (fst $2) at),
+      snd $2 c c' }
+  | try_block_param_body  /* Sugar */
+    { let at = at () in
+      fun c c' ->
+      let bt =
+        match fst $1 with
+        | FuncType ([], []) -> ValBlockType None
+        | FuncType ([], [t]) -> ValBlockType (Some t)
+        | ft ->  VarBlockType (inline_type c' ft at)
+      in bt, snd $1 c c' }
+
+try_block_param_body :
+  | try_block_result_body { $1 }
+  | LPAR PARAM value_type_list RPAR try_block_param_body
+    { let FuncType (ins, out) = fst $5 in
+      FuncType ($3 @ ins, out), snd $5 }
+
+try_block_result_body :
+  | try_ { FuncType ([], []), $1 }
+  | LPAR RESULT value_type_list RPAR try_block_result_body
+    { let FuncType (ins, out) = fst $5 in
+      FuncType (ins, $3 @ out), snd $5 }
+
+try_ :
+  | LPAR DO instr_list RPAR handler
+    { fun c c' -> $3 c', $5 c c' }
+
 instr_list :
   | /* empty */ { fun c -> [] }
   | select_instr { fun c -> [$1 c] }

interpreter/valid/valid.ml

@@ -402,6 +402,10 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type =
     let t1, t2 = type_cvtop e.at cvtop in
     [NumType t1] --> [NumType t2]
 
+  | Try _ -> [] --> [] (* TODO *)
+  | Throw _ -> [] --> [] (* TODO *)
+  | Rethrow _ -> [] --> [] (* TODO *)
+
 and check_seq (c : context) (s : infer_stack_type) (es : instr list)
   : infer_stack_type =
   match es with

test/core/event.wast

@@ -19,3 +19,11 @@
   (module (event (result i32)))
   "non-empty event result type"
 )
+
+(assert_invalid
+  (module
+    (event $e0 (export "e0"))
+    (event $e1 (export "e0"))
+  )
+  "duplicate export name"
+)