[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,29 @@ 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 ct = catch_list s in
+    let ca = if peek s = Some 0x19 then begin
+      ignore (u8 s);
+      Some (instr_block s)
+    end else
+      None
+    in
+    if ct <> [] || ca <> None then begin
+      end_ s;
+      try_catch bt es ct ca
+    end else
+      begin match op s with
+      | 0x0b -> try_catch bt es [] None
+      | 0x18 -> try_delegate bt es (at var s)
+      | b -> illegal s pos b
+      end
+  | 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 +285,10 @@ 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,11 +524,19 @@ 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 catch_list s =
+  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 s
+  end else
+    []
 
 let const s =
   let c = at instr_block s in

interpreter/binary/encode.ml

@@ -156,13 +156,28 @@ let encode m =
         op 0x04; block_type bt; list instr es1;
         if es2 <> [] then op 0x05;
         list instr es2; end_ ()
-
+      | TryCatch (bt, es, ct, ca) ->
+        op 0x06; block_type bt; list instr es;
+        let catch (tag, es) =
+          op 0x07; var tag; list instr es
+        in
+        list catch ct;
+        begin match ca with
+          | None -> ()
+          | Some es -> op 0x19; list instr es
+        end;
+        end_ ()
+      | TryDelegate (bt, es, x) ->
+        op 0x06; block_type bt; list instr es;
+        op 0x18; var x
       | 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

interpreter/syntax/ast.ml

@@ -114,6 +114,13 @@ and instr' =
   | Unary of unop                     (* unary numeric operator *)
   | Binary of binop                   (* binary numeric operator *)
   | Convert of cvtop                  (* conversion *)
+  | TryCatch of block_type * instr list * (* try *)
+                (var * instr list) list * (* catch exception with tag *)
+                instr list option     (* catch_all *)
+  | TryDelegate of block_type * instr list * (* try *)
+                   var                (* delegate to outer handler *)
+  | Throw of var                      (* throw exception *)
+  | Rethrow of var                    (* rethrow exception *)
 
 
 (* Globals & Functions *)

interpreter/syntax/free.ml

@@ -87,6 +87,15 @@ let rec instr (e : instr) =
     memories zero
   | MemoryInit x -> memories zero ++ datas (var x)
   | DataDrop x -> datas (var x)
+  | TryCatch (bt, es, ct, ca) ->
+    let catch (tag, es) = events (var tag) ++ block es in
+    let catch_all = function
+      | None -> empty
+      | Some es -> block es in
+    block es ++ (list catch ct) ++ catch_all ca
+  | TryDelegate (bt, es, x) -> block es ++ events (var x)
+  | 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}

interpreter/syntax/operators.ml

@@ -19,13 +19,17 @@ 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_catch bt es ct ca = TryCatch (bt, es, ct, ca)
+let try_delegate bt es x = TryDelegate (bt, es, 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,6 +279,18 @@ let rec instr e =
     | Unary op -> unop op, []
     | Binary op -> binop op, []
     | Convert op -> cvtop op, []
+    | TryCatch (bt, es, ct, ca) ->
+      let catch (tag, es) = Node ("catch " ^ var tag, list instr es) in
+      let catch_all = match ca with
+        | Some es -> [Node ("catch_all", list instr es)]
+        | None -> [] in
+      let handler = list catch ct @ catch_all in
+      "try", block_type bt @ [Node ("do", list instr es)] @ handler
+    | TryDelegate (bt, es, x) ->
+      let delegate = [Node ("delegate " ^ var x, [])] in
+      "try", block_type bt @ [Node ("do", list instr es)] @ delegate
+    | Throw x -> "throw " ^ var x, []
+    | Rethrow x -> "rethrow " ^ var x, []
   in Node (head, inner)
 
 let const head c =

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  $4 ts es c' }
+  | TRY labeling_opt block DELEGATE var
+    { fun c -> let c' = $2 c [] in
+      let ts, es = $3 c' in try_delegate ts es ($5 c label) }
 
 block :
   | type_use block_param_body
@@ -524,6 +535,44 @@ block_result_body :
     { let FuncType (ins, out) = fst $5 in
       FuncType (ins, $3 @ out), snd $5 }
 
+handler_instr :
+  | catch_list_instr END
+    { fun bt es c -> try_catch bt es (handlers c $1) None }
+  | catch_list_instr catch_all END
+    { fun bt es c -> try_catch bt es (handlers c $1) (Some ($2 c)) }
+  | catch_all END
+    { fun bt es c -> try_catch bt es [] (Some ($1 c)) }
+  | END { fun bt es c -> try_catch bt es [] None }
+
+catch_list_instr :
+  | catch catch_list_instr { $1 :: $2 }
+  | catch { [$1] }
+
+handler :
+  | catch_list
+      { fun bt es _ c' ->
+        let cs = (List.map (fun (l, i) -> (l c' event, i c')) $1) in
+        try_catch bt es cs None }
+  | catch_list LPAR catch_all RPAR
+    { fun bt es _ c' ->
+      let cs = (List.map (fun (l, i) -> (l c' event, i c')) $1) in
+      try_catch bt es cs (Some ($3 c')) }
+  | LPAR catch_all RPAR
+    { fun bt es _ c' -> try_catch bt es [] (Some ($2 c')) }
+  | LPAR DELEGATE var RPAR
+    { fun bt es c _ -> try_delegate bt es ($3 c label) }
+  | /* empty */ { fun bt es c _ -> try_catch bt es [] 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 +594,8 @@ 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 [], $3 c c' }
 
 select_expr_results :
   | LPAR RESULT value_type_list RPAR select_expr_results
@@ -614,6 +665,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' ->
+      let bt = VarBlockType (inline_type_explicit c' ($1 c' type_) (fst $2) at) in
+      snd $2 bt 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 snd $1 bt 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 bt c c' -> $5 bt ($3 c') c c' }
+
 instr_list :
   | /* empty */ { fun c -> [] }
   | select_instr { fun c -> [$1 c] }

interpreter/valid/valid.ml

@@ -402,6 +402,11 @@ 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]
 
+  | TryCatch _ -> [] --> [] (* TODO *)
+  | TryDelegate _ -> [] --> [] (* 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/exports.wast

@@ -57,6 +57,10 @@
   (module (func) (memory 0) (export "a" (func 0)) (export "a" (memory 0)))
   "duplicate export name"
 )
+(assert_invalid
+  (module (event $e0 (export "e0")) (event $e1 (export "e0")))
+  "duplicate export name"
+)
 
 
 ;; Globals