[interpreter] Parse and convert EH opcodes (#160)

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 }