Merge pull request #1 from effect-handlers/tiny-exn

Minimal exception handling extension

interpreter/binary/decode.ml

@@ -270,7 +270,18 @@ 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 es1 = instr_block s in
+    expect 0x07 s "CATCH opcode expected";
+    let es2 = instr_block s in
+    end_ s;
+    try_ bt es1 es2
+  | 0x07 -> error s pos "misplaced CATCH opcode"
+  | 0x08 -> throw
+
+  | 0x09 | 0x0a as b -> illegal s pos b
   | 0x0b -> error s pos "misplaced END opcode"
 
   | 0x0c -> br (at var s)
@@ -538,7 +549,7 @@ 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 | 0x0b) -> es
   | _ ->
     let pos = pos s in
     let e' = instr s in

interpreter/binary/encode.ml

@@ -428,6 +428,11 @@ let encode m =
       | Convert (F64 F64Op.DemoteF64) -> assert false
       | Convert (F64 F64Op.ReinterpretInt) -> op 0xbf
 
+      | Try (bt, es1, es2) ->
+        op 0x06; block_type bt; list instr es1;
+        op 0x07; list instr es2; end_ ()
+      | Throw -> op 0x08
+
     let const c =
       list instr c.it; end_ ()
 

interpreter/exec/eval.ml

@@ -11,11 +11,13 @@ module Link = Error.Make ()
 module Trap = Error.Make ()
 module Crash = Error.Make ()
 module Exhaustion = Error.Make ()
+module Uncaught = Error.Make ()
 
 exception Link = Link.Error
 exception Trap = Trap.Error
 exception Crash = Crash.Error (* failure that cannot happen in valid code *)
 exception Exhaustion = Exhaustion.Error
+exception Uncaught = Uncaught.Error
 
 let table_error at = function
   | Table.Bounds -> "out of bounds table access"
@@ -66,6 +68,8 @@ and admin_instr' =
   | Label of int * instr list * code
   | Local of int * value list * code
   | Frame of int * frame * code
+  | Catch of int * instr list * code
+  | Throwing
 
 type config =
 {
@@ -525,7 +529,17 @@ let rec step (c : config) : config =
 
       | Convert cvtop, Num n :: vs' ->
         (try Num (Eval_numeric.eval_cvtop cvtop n) :: vs', []
-        with exn -> vs', [Trapping (numeric_error e.at exn) @@ e.at])
+         with exn -> vs', [Trapping (numeric_error e.at exn) @@ e.at])
+
+      | Try (bt, es1, es2), vs ->
+        let FuncType (ts1, ts2) = block_type c.frame.inst bt e.at in
+        let n1 = List.length ts1 in
+        let n2 = List.length ts2 in
+        let args, vs' = split n1 vs e.at in
+        vs', [Catch (n2, es2, ([], [Label (n2, [], (args, List.map plain es1)) @@ e.at])) @@ e.at]
+
+      | Throw, vs ->
+         vs, [Throwing @@ e.at]
 
       | _ ->
         let s1 = string_of_values (List.rev vs) in
@@ -554,7 +568,10 @@ let rec step (c : config) : config =
       take n vs0 e.at @ vs, List.map plain es0
 
     | Label (n, es0, (vs', {it = Breaking (k, vs0); at} :: es')), vs ->
-      vs, [Breaking (Int32.sub k 1l, vs0) @@ at]
+       vs, [Breaking (Int32.sub k 1l, vs0) @@ at]
+
+    | Label (n, es0, (vs', {it = Throwing; at} :: _)), vs ->
+      vs, [Throwing @@ at]
 
     | Label (n, es0, (vs', e' :: es')), vs when is_jumping e' ->
       vs, [e']
@@ -582,7 +599,10 @@ let rec step (c : config) : config =
       vs, [Trapping msg @@ at]
 
     | Frame (n, frame', (vs', {it = Returning vs0; at} :: es')), vs ->
-      take n vs0 e.at @ vs, []
+       take n vs0 e.at @ vs, []
+
+    | Frame (n, frame', (vs', {it = Throwing; at} :: _)), vs ->
+      vs, [Throwing @@ at]
 
     | Frame (n, frame', (vs', {it = ReturningInvoke (vs0, f); at} :: es')), vs ->
       let FuncType (ts1, _) = Func.type_of f in
@@ -616,6 +636,22 @@ let rec step (c : config) : config =
       | Func.ClosureFunc (_, f', args') ->
         args @ args' @ vs', [Invoke f' @@ e.at]
       )
+
+    | Throwing, _ ->
+       Uncaught.error e.at "uncaught exception"
+
+    | Catch (_, _, (_, ({it = Trapping _ | Breaking _ | Returning _; _} as e) :: _)), vs ->
+      vs, [e]
+
+    | Catch (n, es1, (_, {it = Throwing; _} :: _)), vs ->
+      vs, [Label (n, [], ([], List.map plain es1)) @@ e.at]
+
+    | Catch (_, _, (vs', [])), vs ->
+      vs' @ vs, []
+
+    | Catch (n, es', code'), vs ->
+      let c' = step {c with code = code'} in
+      vs, [Catch (n, es', c'.code) @@ e.at]
   in {c with code = vs', es' @ List.tl es}
 
 

interpreter/exec/eval.mli

@@ -5,6 +5,7 @@ exception Link of Source.region * string
 exception Trap of Source.region * string
 exception Crash of Source.region * string
 exception Exhaustion of Source.region * string
+exception Uncaught of Source.region * string
 
 val init : Ast.module_ -> extern list -> module_inst (* raises Link, Trap *)
 val invoke : func_inst -> value list -> value list (* raises Trap *)

interpreter/script/js.ml

@@ -189,6 +189,13 @@ function assert_return(action, ...expected) {
     }
   }
 }
+
+function assert_uncaught(action) {
+  try { action() } catch (e) {
+    if (!(e instanceof WebAssembly.RuntimeError)) return;
+  }
+  throw new Error("Wasm uncaught exception expected");
+}
 |}
 
 
@@ -529,6 +536,8 @@ let of_assertion mods ass =
     of_assertion' mods act "assert_trap" [] None
   | AssertExhaustion (act, _) ->
     of_assertion' mods act "assert_exhaustion" [] None
+  | AssertUncaught (act, _) ->
+    of_assertion' mods act "assert_uncaught" [] None
 
 let of_command mods cmd =
   "\n// " ^ Filename.basename cmd.at.left.file ^

interpreter/script/run.ml

@@ -112,6 +112,7 @@ let input_from get_script run =
   | Eval.Trap (at, msg) -> error at "runtime trap" msg
   | Eval.Exhaustion (at, msg) -> error at "resource exhaustion" msg
   | Eval.Crash (at, msg) -> error at "runtime crash" msg
+  | Eval.Uncaught (at, msg) -> error at "runtime uncaught" msg
   | Encode.Code (at, msg) -> error at "encoding error" msg
   | Script.Error (at, msg) -> error at "script error" msg
   | IO (at, msg) -> error at "i/o error" msg
@@ -446,6 +447,13 @@ let run_assertion ass =
     | _ -> Assert.error ass.at "expected exhaustion error"
     )
 
+  | AssertUncaught (act, re) ->
+    trace ("Asserting exception...");
+    (match run_action act with
+    | exception Eval.Uncaught (_, msg) -> assert_message ass.at "runtime" msg re
+    | _ -> Assert.error ass.at "expected exception"
+    )
+
 let rec run_command cmd =
   match cmd.it with
   | Module (x_opt, def) ->

interpreter/script/script.ml

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

interpreter/syntax/ast.ml

@@ -125,6 +125,8 @@ and instr' =
   | Unary of unop                     (* unary numeric operator *)
   | Binary of binop                   (* binary numeric operator *)
   | Convert of cvtop                  (* conversion *)
+  | Try of block_type * instr list * instr list
+  | Throw
 
 
 (* Globals & Functions *)

interpreter/syntax/free.ml

@@ -123,6 +123,8 @@ let rec instr (e : instr) =
     memories zero
   | MemoryInit x -> memories zero ++ datas (idx x)
   | DataDrop x -> datas (idx x)
+  | Try (bt, es1, es2) -> block_type bt ++ block es1 ++ block es2
+  | Throw -> empty
 
 and block (es : instr list) =
   let free = list instr es in {free with labels = shift free.labels}

interpreter/syntax/operators.ml

@@ -238,3 +238,6 @@ let i32_reinterpret_f32 = Convert (I32 I32Op.ReinterpretFloat)
 let i64_reinterpret_f64 = Convert (I64 I64Op.ReinterpretFloat)
 let f32_reinterpret_i32 = Convert (F32 F32Op.ReinterpretInt)
 let f64_reinterpret_i64 = Convert (F64 F64Op.ReinterpretInt)
+
+let try_ bt es1 es2 = Try (bt, es1, es2)
+let throw = Throw

interpreter/text/arrange.ml

@@ -288,6 +288,10 @@ let rec instr e =
     | Unary op -> unop op, []
     | Binary op -> binop op, []
     | Convert op -> cvtop op, []
+    | Try (bt, es1, es2) ->
+      "try", block_type bt @
+        [Node ("do", list instr es1); Node ("catch", list instr es2)]
+    | Throw -> "throw", []
   in Node (head, inner)
 
 let const head c =
@@ -534,6 +538,8 @@ let assertion mode ass =
     [Node ("assert_trap", [action mode act; Atom (string re)])]
   | AssertExhaustion (act, re) ->
     [Node ("assert_exhaustion", [action mode act; Atom (string re)])]
+  | AssertUncaught (act, re) ->
+    [Node ("assert_uncaught", [action mode act; Atom (string re)])]
 
 let command mode cmd =
   match cmd.it with

interpreter/text/lexer.mll

@@ -387,11 +387,17 @@ rule token = parse
   | "assert_return" { ASSERT_RETURN }
   | "assert_trap" { ASSERT_TRAP }
   | "assert_exhaustion" { ASSERT_EXHAUSTION }
+  | "assert_uncaught" { ASSERT_UNCAUGHT }
   | "nan:canonical" { NAN Script.CanonicalNan }
   | "nan:arithmetic" { NAN Script.ArithmeticNan }
   | "input" { INPUT }
   | "output" { OUTPUT }
 
+  | "try" { TRY }
+  | "catch" { CATCH }
+  | "do" { DO }
+  | "throw" { THROW }
+
   | name as s { VAR s }
 
   | ";;"utf8_no_nl*eof { EOF }

interpreter/text/parser.mly

@@ -224,10 +224,11 @@ let inline_func_type_explicit (c : context) x ft at =
 %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_EXHAUSTION ASSERT_UNCAUGHT
 %token NAN
 %token INPUT OUTPUT
 %token EOF
+%token TRY CATCH DO THROW
 
 %token<string> NAT
 %token<string> INT
@@ -442,6 +443,7 @@ plain_instr :
   | UNARY { fun c -> $1 }
   | BINARY { fun c -> $1 }
   | CONVERT { fun c -> $1 }
+  | THROW { fun c -> throw }
 
 
 select_instr :
@@ -660,6 +662,10 @@ expr1 :  /* Sugar */
     { let at = at () in
       fun c -> let c' = enter_let ($2 c []) at in
       let bt, ls, es = $3 c c' in [], let_ bt ls es }
+  | TRY try_block
+    { fun c ->
+      let bt, (es1, es2) = $2 c in
+      [], try_ bt es1 es2 }
 
 select_expr_results :
   | LPAR RESULT value_type_list RPAR select_expr_results
@@ -692,6 +698,43 @@ call_expr_results :
     { fun c -> [], $1 c }
 
 
+try_block :
+  | type_use try_block_param_body
+    { let at = at () in
+      fun c ->
+      let t = $1 c type_ in
+      let ft, es = $2 c in
+      let x = SynVar (inline_func_type_explicit c t ft at).it in
+      VarBlockType x, es }
+  | try_block_param_body  /* Sugar */
+    { let at = at () in
+      fun c ->
+      let bt =
+        match fst ($1 c) with
+        | FuncType ([], []) -> ValBlockType None
+        | FuncType ([], [t]) -> ValBlockType (Some t)
+        | ft ->  VarBlockType (SynVar (inline_func_type c ft at).it)
+      in bt, snd ($1 c) }
+try_block_param_body :
+  | try_block_result_body { $1 }
+  | LPAR PARAM value_type_list RPAR try_block_param_body
+    { fun c ->
+      let FuncType (ins, out), es = $5 c in
+      let ins' = snd $3 c in
+      FuncType (ins' @ ins, out), es }
+try_block_result_body :
+  | try_ { fun c -> FuncType ([], []), $1 c }
+  | LPAR RESULT value_type_list RPAR try_block_result_body
+    { fun c ->
+      let FuncType (ins, out), es = $5 c in
+      let out' = snd $3 c in
+      FuncType (ins, out' @ out), es }
+try_ :
+ | LPAR DO instr_list RPAR LPAR CATCH instr_list RPAR
+   { fun c ->
+     let es1, es2 = $3 c, $7 c in
+     (es1, es2) }
+
 if_block :
   | type_use if_block_param_body
     { let at = at () in
@@ -1164,6 +1207,7 @@ assertion :
   | LPAR ASSERT_RETURN action result_list RPAR { AssertReturn ($3, $4) @@ at () }
   | LPAR ASSERT_TRAP action STRING RPAR { AssertTrap ($3, $4) @@ at () }
   | LPAR ASSERT_EXHAUSTION action STRING RPAR { AssertExhaustion ($3, $4) @@ at () }
+  | LPAR ASSERT_UNCAUGHT action STRING RPAR { AssertUncaught ($3, $4) @@ at () }
 
 cmd :
   | action { Action $1 @@ at () }

interpreter/valid/valid.ml

@@ -538,6 +538,16 @@ 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 (bt, es1, es2) ->
+    let FuncType (ts1, ts2) as ft1 = check_block_type c bt e.at in
+    check_block {c with labels = ts2 :: c.labels} es1 ft1 e.at;
+    let ft2 = FuncType ([], ts2) in
+    check_block {c with labels = ts2 :: c.labels} es2 ft2 e.at;
+    ts1 --> ts2
+
+  | Throw ->
+    [] -->... []
+
 and check_seq (c : context) (s : infer_stack_type) (es : instr list)
   : infer_stack_type =
   match es with