Implementation and test suite for resume_throw_ref

interpreter/binary/decode.ml

@@ -646,7 +646,10 @@ let rec instr s =
     let tag = at var s in
     let xls = vec on_clause s in
     resume_throw x tag xls
-  (* TODO: resume_throw_ref *)
+  | 0xe5 ->
+    let x   = at var s in
+    let xls = vec on_clause s in
+    resume_throw_ref x xls
   | 0xe6 ->
     let x = at var s in
     let y = at var s in

interpreter/binary/encode.ml

@@ -303,7 +303,7 @@ struct
     | Suspend x -> op 0xe2; var x
     | Resume (x, xls) -> op 0xe3; var x; resumetable xls
     | ResumeThrow (x, y, xls) -> op 0xe4; var x; var y; resumetable xls
-    (* TOOD: resume_throw_ref *)
+    | ResumeThrowRef (x, xls) -> op 0xe5; var x; resumetable xls
     | Switch (x, y) -> op 0xe6; var x; var y
 
     | Throw x -> op 0x08; var x

interpreter/exec/eval.ml

@@ -407,6 +407,22 @@ let rec step (c : config) : config =
         cont := None;
         vs', [Prompt (hs, ctxt ([], [Throwing (tagt, args) @@ e.at])) @@ e.at]
 
+      | ResumeThrowRef (x, xls), Ref _ :: Ref (NullRef _) :: vs ->
+        vs, [Trapping "null exception reference" @@ e.at]
+
+      | ResumeThrowRef (x, xls), Ref (NullRef _) :: vs ->
+        vs, [Trapping "null continuation reference" @@ e.at]
+
+      | ResumeThrowRef (x, xls), Ref (ContRef {contents = None}) :: Ref _ :: vs ->
+        vs, [Trapping "continuation already consumed" @@ e.at]
+
+      | ResumeThrowRef (x, xls),
+        Ref (ContRef ({contents = Some (n, ctxt)} as cont)) ::
+          Ref (Exn.(ExnRef (Exn (tagt, args)))) :: vs ->
+        let hs = handle_table c xls in
+        cont := None;
+        vs, [Prompt (hs, ctxt ([], [Throwing (tagt, args) @@ e.at])) @@ e.at]
+
       | Switch (x, y), Ref (NullRef _) :: vs ->
          vs, [Trapping "null continuation reference" @@ e.at]
 

interpreter/syntax/ast.ml

@@ -177,6 +177,7 @@ and instr' =
   | Suspend of idx                    (* suspend continuation *)
   | Resume of idx * (idx * hdl) list  (* resume continuation *)
   | ResumeThrow of idx * idx * (idx * hdl) list (* abort continuation *)
+  | ResumeThrowRef of idx * (idx * hdl) list (* abort continuation *)
   | Switch of idx * idx               (* direct switch continuation *)
   | Throw of idx                      (* throw exception *)
   | ThrowRef                          (* rethrow exception *)

interpreter/syntax/free.ml

@@ -181,6 +181,7 @@ let rec instr (e : instr) =
   | ContNew x -> types (idx x)
   | ContBind (x, y) -> types (idx x) ++ types (idx y)
   | ResumeThrow (x, y, xys) -> types (idx x) ++ tags (idx y) ++ list (fun (x, y) -> tags (idx x) ++ hdl y) xys
+  | ResumeThrowRef (x, xys) -> types (idx x) ++ list (fun (x, y) -> tags (idx x) ++ hdl y) xys
   | Resume (x, xys) -> types (idx x) ++ list (fun (x, y) -> tags (idx x) ++ hdl y) xys
   | Suspend x -> tags (idx x)
   | Switch (x, z) -> types (idx x) ++ tags (idx z)

interpreter/syntax/operators.ml

@@ -54,6 +54,7 @@ let cont_bind x y = ContBind (x, y)
 let suspend x = Suspend x
 let resume x xys = Resume (x, xys)
 let resume_throw x y xys = ResumeThrow (x, y, xys)
+let resume_throw_ref x xys = ResumeThrowRef (x, xys)
 let switch x y = Switch (x, y)
 let throw x = Throw x
 let throw_ref = ThrowRef

interpreter/text/arrange.ml

@@ -561,6 +561,8 @@ let rec instr e =
       "resume " ^ var x, resumetable xys
     | ResumeThrow (x, y, xys) ->
       "resume_throw " ^ var x ^ " " ^ var y, resumetable xys
+    | ResumeThrowRef (x, xys) ->
+      "resume_throw_ref " ^ var x, resumetable xys
     | Switch (x, z) ->
       "switch " ^ var x ^ " " ^ var z, []
     | Throw x -> "throw " ^ var x, []

interpreter/text/lexer.mll

@@ -230,6 +230,7 @@ rule token = parse
       | "suspend" -> SUSPEND
       | "resume" -> RESUME
       | "resume_throw" -> RESUME_THROW
+      | "resume_throw_ref" -> RESUME_THROW_REF
       | "switch" -> SWITCH
 
 

interpreter/text/parser.mly

@@ -304,7 +304,7 @@ let parse_annots (m : module_) : Custom.section list =
 %token MUT FIELD STRUCT ARRAY SUB FINAL REC
 %token UNREACHABLE NOP DROP SELECT
 %token BLOCK END IF THEN ELSE LOOP
-%token CONT_NEW CONT_BIND SUSPEND RESUME RESUME_THROW SWITCH
+%token CONT_NEW CONT_BIND SUSPEND RESUME RESUME_THROW RESUME_THROW_REF SWITCH
 %token BR BR_IF BR_TABLE BR_ON_NON_NULL
 %token<Ast.idx -> Ast.instr'> BR_ON_NULL
 %token<Ast.idx -> Types.ref_type -> Types.ref_type -> Ast.instr'> BR_ON_CAST
@@ -789,6 +789,11 @@ resume_instr_instr_list :
       let x  = $2 c type_ in
       let tag = $3 c tag in
       let hs, es = $4 c in (resume_throw x tag hs @@ loc1) :: es }
+  | RESUME_THROW_REF var resume_instr_handler_instr
+    { let loc1 = $loc($1) in
+      fun c ->
+      let x  = $2 c type_ in
+      let hs, es = $3 c in (resume_throw_ref x hs @@ loc1) :: es }
 
 resume_instr_handler_instr :
   | LPAR ON var var RPAR resume_instr_handler_instr
@@ -907,6 +912,11 @@ expr1 :  /* Sugar */
       let tag = $3 c tag in
       let hs, es = $4 c in
       es, resume_throw x tag hs }
+  | RESUME_THROW_REF var resume_expr_handler
+    { fun c ->
+      let x = $2 c type_ in
+      let hs, es = $3 c in
+      es, resume_throw_ref x hs }
   | BLOCK labeling_opt block
     { fun c -> let c' = $2 c [] in let bt, es = $3 c' in [], block bt es }
   | LOOP labeling_opt block

interpreter/valid/valid.ml

@@ -658,6 +658,12 @@ let rec check_instr (c : context) (e : instr) (s : infer_result_type) : infer_in
     check_resume_table c ts2 xys e.at;
     (ts0 @ [RefT (Null, VarHT (StatX x.it))]) --> ts2, []
 
+  | ResumeThrowRef (x, xys) ->
+    let ct = cont_type c x in
+    let FuncT (ts1, ts2) = func_type_of_cont_type c ct x.at in
+    check_resume_table c ts2 xys e.at;
+    ([RefT (Null, ExnHT); RefT (Null, VarHT (StatX x.it))]) --> ts2, []
+
   | Switch (x, y) ->
      let ct1 = cont_type c x in
      let FuncT (ts11, ts12) = func_type_of_cont_type c ct1 x.at in