[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,30 @@ 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 +286,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 +525,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/script/js.ml

@@ -135,6 +135,11 @@ function assert_trap(action) {
   throw new Error("Wasm trap expected");
 }
 
+function assert_exception(action) {
+  try { action() } catch (e) { return; }
+  throw new Error("exception expected");
+}
+
 let StackOverflow;
 try { (function f() { 1 + f() })() } catch (e) { StackOverflow = e.constructor }
 
@@ -508,6 +513,8 @@ let of_assertion mods ass =
     of_assertion' mods act "assert_trap" [] None
   | AssertExhaustion (act, _) ->
     of_assertion' mods act "assert_exhaustion" [] None
+  | AssertUncaughtException act ->
+    of_assertion' mods act "assert_exception" [] None
 
 let of_command mods cmd =
   "\n// " ^ Filename.basename cmd.at.left.file ^

interpreter/script/run.ml

@@ -458,6 +458,8 @@ let run_assertion ass =
     | _ -> Assert.error ass.at "expected runtime error"
     )
 
+  | AssertUncaughtException act -> () (* TODO *)
+
   | AssertExhaustion (act, re) ->
     trace ("Asserting exhaustion...");
     (match run_action act with

interpreter/script/script.ml

@@ -32,6 +32,7 @@ and assertion' =
   | AssertUninstantiable of definition * string
   | AssertReturn of action * result list
   | AssertTrap of action * string
+  | AssertUncaughtException of action
   | AssertExhaustion of action * string
 
 type command = command' Source.phrase

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 =
@@ -538,6 +550,8 @@ let assertion mode ass =
     [Node ("assert_return", action mode act :: List.map (result mode) results)]
   | AssertTrap (act, re) ->
     [Node ("assert_trap", [action mode act; Atom (string re)])]
+  | AssertUncaughtException act ->
+    [Node ("assert_exception", [action mode act])]
   | AssertExhaustion (act, re) ->
     [Node ("assert_exhaustion", [action mode act; Atom (string re)])]
 

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 }
@@ -379,6 +387,7 @@ rule token = parse
   | "assert_unlinkable" { ASSERT_UNLINKABLE }
   | "assert_return" { ASSERT_RETURN }
   | "assert_trap" { ASSERT_TRAP }
+  | "assert_exception" { ASSERT_EXCEPTION }
   | "assert_exhaustion" { ASSERT_EXHAUSTION }
   | "nan:canonical" { NAN Script.CanonicalNan }
   | "nan:arithmetic" { NAN Script.ArithmeticNan }

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,12 +191,13 @@ 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
 %token SCRIPT REGISTER INVOKE GET
 %token ASSERT_MALFORMED ASSERT_INVALID ASSERT_SOFT_INVALID ASSERT_UNLINKABLE
-%token ASSERT_RETURN ASSERT_TRAP ASSERT_EXHAUSTION
+%token ASSERT_RETURN ASSERT_TRAP ASSERT_EXCEPTION ASSERT_EXHAUSTION
 %token NAN
 %token INPUT OUTPUT
 %token EOF
@@ -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] }
@@ -1085,6 +1168,8 @@ assertion :
     { AssertUninstantiable (snd $3, $4) @@ at () }
   | LPAR ASSERT_RETURN action result_list RPAR { AssertReturn ($3, $4) @@ at () }
   | LPAR ASSERT_TRAP action STRING RPAR { AssertTrap ($3, $4) @@ at () }
+  | LPAR ASSERT_EXCEPTION action RPAR
+    { AssertUncaughtException $3 @@ at () }
   | LPAR ASSERT_EXHAUSTION action STRING RPAR { AssertExhaustion ($3, $4) @@ at () }
 
 cmd :