Minimal exception handling extension

This patch extends the interpreter with a minimal exception handling
facility. It is minimal in the sense that it supports only a single
exception which can be thrown and caught.

interpreter/binary/encode.ml

@@ -428,6 +428,8 @@ let encode m =
       | Convert (F64 F64Op.DemoteF64) -> assert false
       | Convert (F64 F64Op.ReinterpretInt) -> op 0xbf
 
+      | Try _ | Throw -> failwith "encode.ml: not yet implemented"
+
     let const c =
       list instr c.it; end_ ()
 

interpreter/exec/eval.ml

@@ -11,6 +11,7 @@ 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
@@ -66,6 +67,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 +528,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' = take n1 vs e.at, drop 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 +567,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 +598,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 +635,20 @@ 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; at} :: _)), vs ->
+      let exn = [] in
+      vs, [Label (n, [], (exn, List.map plain es1)) @@ e.at]
+
+    | 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/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 (_, es1, es2) -> 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 ("then", list instr es1); Node ("catch", list instr es2)]
+    | Throw -> "throw", []
   in Node (head, inner)
 
 let const head c =

interpreter/text/parser.mly

@@ -228,6 +228,7 @@ let inline_func_type_explicit (c : context) x ft at =
 %token NAN
 %token INPUT OUTPUT
 %token EOF
+%token TRY CATCH 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 THEN 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

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