Text, simple test

interpreter/exec/eval.ml

@@ -10,12 +10,14 @@ open Source
 module Link = Error.Make ()
 module Trap = Error.Make ()
 module Exception = Error.Make ()
+module Suspension = Error.Make ()
 module Exhaustion = Error.Make ()
 module Crash = Error.Make ()
 
 exception Link = Link.Error
 exception Trap = Trap.Error
 exception Exception = Exception.Error
+exception Suspension = Suspension.Error
 exception Exhaustion = Exhaustion.Error
 exception Crash = Crash.Error (* failure that cannot happen in valid code *)
 
@@ -66,7 +68,6 @@ and admin_instr' =
   | Frame of int * frame * code
   | Catch of int * event_inst option * instr list * code
   | Resume of (event_inst * idx) list * code
-
   | Trapping of string
   | Throwing of event_inst * value stack
   | Suspending of event_inst * value stack * ctxt
@@ -83,7 +84,8 @@ let plain e = Plain e.it @@ e.at
 
 let is_jumping e =
   match e.it with
-  | Trapping _ | Throwing _ | Returning _ | ReturningInvoke _ | Breaking _ ->
+  | Trapping _ | Throwing _ | Suspending _
+  | Returning _ | ReturningInvoke _ | Breaking _ ->
     true
   | _ -> false
 
@@ -745,7 +747,7 @@ let rec eval (c : config) : value stack =
     (match e.it with
     | Trapping msg ->  Trap.error e.at msg
     | Throwing _ -> Exception.error e.at "unhandled exception"
-    | Suspending _ -> Exception.error e.at "unhandled event"
+    | Suspending _ -> Suspension.error e.at "unhandled event"
     | Returning _ | ReturningInvoke _ -> Crash.error e.at "undefined frame"
     | Breaking _ -> Crash.error e.at "undefined label"
     | _ -> assert false

interpreter/exec/eval.mli

@@ -4,6 +4,7 @@ open Instance
 exception Link of Source.region * string
 exception Trap of Source.region * string
 exception Exception of Source.region * string
+exception Suspension of Source.region * string
 exception Exhaustion of Source.region * string
 exception Crash of Source.region * string
 

interpreter/script/js.ml

@@ -143,6 +143,14 @@ function assert_exception(action) {
   throw new Error("Wasm exception expected");
 }
 
+function assert_suspension(action) {
+  try { action() } catch (e) {
+    /* TODO: Not clear how to observe form JS */
+    return;
+  }
+  throw new Error("Wasm exception expected");
+}
+
 let StackOverflow;
 try { (function f() { 1 + f() })() } catch (e) { StackOverflow = e.constructor }
 
@@ -536,6 +544,8 @@ let of_assertion mods ass =
     of_assertion' mods act "assert_trap" [] None
   | AssertException (act, _) ->
     of_assertion' mods act "assert_exception" [] None
+  | AssertSuspension (act, _) ->
+    of_assertion' mods act "assert_suspension" [] None
   | AssertExhaustion (act, _) ->
     of_assertion' mods act "assert_exhaustion" [] None
 

interpreter/script/run.ml

@@ -446,6 +446,13 @@ let run_assertion ass =
     | _ -> Assert.error ass.at "expected exception"
     )
 
+  | AssertSuspension (act, re) ->
+    trace ("Asserting suspension...");
+    (match run_action act with
+    | exception Eval.Suspension (_, msg) -> assert_message ass.at "runtime" msg re
+    | _ -> Assert.error ass.at "expected suspension"
+    )
+
   | AssertExhaustion (act, re) ->
     trace ("Asserting exhaustion...");
     (match run_action act with

interpreter/script/script.ml

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

interpreter/text/arrange.ml

@@ -564,10 +564,12 @@ 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)])]
-  | AssertExhaustion (act, re) ->
-    [Node ("assert_exhaustion", [action mode act; Atom (string re)])]
   | AssertException (act, re) ->
     [Node ("assert_exception", [action mode act; Atom (string re)])]
+  | AssertSuspension (act, re) ->
+    [Node ("assert_suspension", [action mode act; Atom (string re)])]
+  | AssertExhaustion (act, re) ->
+    [Node ("assert_exhaustion", [action mode act; Atom (string re)])]
 
 let command mode cmd =
   match cmd.it with

interpreter/text/lexer.mll

@@ -167,6 +167,7 @@ rule token = parse
   | "funcref" { FUNCREF }
   | (nxx as t) { NUM_TYPE (num_type t) }
   | "mut" { MUT }
+  | "cont" { CONT }
 
   | (nxx as t)".const"
     { let open Source in
@@ -214,6 +215,11 @@ rule token = parse
   | "catch" { CATCH }
   | "catch_all" { CATCH_ALL }
 
+  | "cont.new" { CONT_NEW }
+  | "cont.suspend" { CONT_SUSPEND }
+  | "cont.throw" { CONT_THROW }
+  | "cont.resume" { CONT_RESUME }
+
   | "local.get" { LOCAL_GET }
   | "local.set" { LOCAL_SET }
   | "local.tee" { LOCAL_TEE }
@@ -395,6 +401,7 @@ rule token = parse
   | "assert_return" { ASSERT_RETURN }
   | "assert_trap" { ASSERT_TRAP }
   | "assert_exception" { ASSERT_EXCEPTION }
+  | "assert_suspension" { ASSERT_SUSPENSION }
   | "assert_exhaustion" { ASSERT_EXHAUSTION }
   | "nan:canonical" { NAN Script.CanonicalNan }
   | "nan:arithmetic" { NAN Script.ArithmeticNan }

interpreter/text/parser.mly

@@ -213,10 +213,11 @@ let inline_func_type_explicit (c : context) x ft at =
 
 %token LPAR RPAR
 %token NAT INT FLOAT STRING VAR
-%token NUM_TYPE FUNCREF EXTERNREF REF EXTERN NULL MUT
+%token NUM_TYPE FUNCREF EXTERNREF REF EXTERN NULL MUT CONT
 %token UNREACHABLE NOP DROP SELECT
 %token BLOCK END IF THEN ELSE LOOP LET
 %token THROW TRY DO CATCH CATCH_ALL
+%token CONT_NEW CONT_SUSPEND CONT_THROW CONT_RESUME
 %token BR BR_IF BR_TABLE BR_ON_NULL
 %token CALL CALL_REF CALL_INDIRECT RETURN RETURN_CALL_REF FUNC_BIND
 %token LOCAL_GET LOCAL_SET LOCAL_TEE GLOBAL_GET GLOBAL_SET
@@ -231,7 +232,7 @@ 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_EXCEPTION ASSERT_EXHAUSTION
+%token ASSERT_RETURN ASSERT_TRAP ASSERT_EXCEPTION ASSERT_SUSPENSION ASSERT_EXHAUSTION
 %token NAN
 %token INPUT OUTPUT
 %token EOF
@@ -305,6 +306,32 @@ global_type :
 
 def_type :
   | LPAR FUNC func_type RPAR { fun c -> FuncDefType ($3 c) }
+  | LPAR CONT cont_type RPAR { fun c -> ContDefType (ContType (SynVar ($3 c).it)) }
+
+cont_type :
+  | type_use cont_type_params
+    { let at1 = ati 1 in
+      fun c ->
+      match $2 c with
+      | FuncType ([], []) -> $1 c type_
+      | ft -> inline_func_type_explicit c ($1 c type_) ft at1 }
+  | cont_type_params
+    /* TODO: the inline type is broken for now */
+    { let at = at () in fun c -> inline_func_type c ($1 c) at }
+
+cont_type_params :
+  | LPAR PARAM value_type_list RPAR cont_type_params
+    { fun c -> let FuncType (ts1, ts2) = $5 c in
+      FuncType (snd $3 c @ ts1, ts2) }
+  | cont_type_results
+    { fun c -> FuncType ([], $1 c) }
+
+cont_type_results :
+  | LPAR RESULT value_type_list RPAR cont_type_results
+    { fun c -> snd $3 c @ $5 c }
+  | /* empty */
+    { fun c -> [] }
+
 
 func_type :
   | /* empty */
@@ -398,6 +425,7 @@ instr :
   | plain_instr { let at = at () in fun c -> [$1 c @@ at] }
   | select_instr_instr { fun c -> let e, es = $1 c in e :: es }
   | call_instr_instr { fun c -> let e, es = $1 c in e :: es }
+  | resume_instr_instr { fun c -> let e, es = $1 c in e :: es }
   | block_instr { let at = at () in fun c -> [$1 c @@ at] }
   | expr { $1 } /* Sugar */
 
@@ -416,6 +444,9 @@ plain_instr :
   | CALL var { fun c -> call ($2 c func) }
   | CALL_REF { fun c -> call_ref }
   | RETURN_CALL_REF { fun c -> return_call_ref }
+  | CONT_NEW LPAR TYPE var RPAR { fun c -> cont_new ($4 c type_) }
+  | CONT_SUSPEND var { fun c -> cont_suspend ($2 c event) }
+  | CONT_THROW var { fun c -> cont_throw ($2 c event) }
   | 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) }
@@ -550,6 +581,29 @@ call_instr_results_instr :
     { fun c -> [], $1 c }
 
 
+resume_instr :
+  | CONT_RESUME resume_instr_handler
+    { let at = at () in fun c -> cont_resume ($2 c) @@ at }
+
+resume_instr_handler :
+  | LPAR EVENT var var RPAR resume_instr_handler
+    { fun c -> ($3 c event, $4 c label) :: $6 c }
+  | /* empty */
+    { fun c -> [] }
+
+
+resume_instr_instr :
+  | CONT_RESUME resume_instr_handler_instr
+    { let at1 = ati 1 in
+      fun c -> let hs, es = $2 c in cont_resume hs @@ at1, es }
+
+resume_instr_handler_instr :
+  | LPAR EVENT var var RPAR resume_instr_handler_instr
+    { fun c -> let hs, es = $6 c in ($3 c event, $4 c label) :: hs, es }
+  | instr
+    { fun c -> [], $1 c }
+
+
 block_instr :
   | BLOCK labeling_opt block END labeling_end_opt
     { fun c -> let c' = $2 c $5 in let bt, es = $3 c' in block bt es }
@@ -663,6 +717,8 @@ expr1 :  /* Sugar */
       fun c -> let x, es = $2 c in es, call_indirect (0l @@ at1) x }
   | FUNC_BIND call_expr_type
     { fun c -> let x, es = $2 c in es, func_bind x }
+  | CONT_RESUME resume_expr_handler
+    { fun c -> let hs, es = $2 c in es, cont_resume 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
@@ -709,6 +765,13 @@ call_expr_results :
   | expr_list
     { fun c -> [], $1 c }
 
+resume_expr_handler :
+  | LPAR EVENT var var RPAR resume_expr_handler
+    { fun c -> let hs, es = $6 c in ($3 c event, $4 c label) :: hs, es }
+  | expr_list
+    { fun c -> [], $1 c }
+
+
 
 try_block :
   | type_use try_block_param_body
@@ -790,6 +853,7 @@ instr_list :
   | /* empty */ { fun c -> [] }
   | select_instr { fun c -> [$1 c] }
   | call_instr { fun c -> [$1 c] }
+  | resume_instr { fun c -> [$1 c] }
   | instr instr_list { fun c -> $1 c @ $2 c }
 
 expr_list :
@@ -1269,6 +1333,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_EXCEPTION action STRING RPAR { AssertException ($3, $4) @@ at () }
+  | LPAR ASSERT_SUSPENSION action STRING RPAR { AssertSuspension ($3, $4) @@ at () }
   | LPAR ASSERT_EXHAUSTION action STRING RPAR { AssertExhaustion ($3, $4) @@ at () }
 
 cmd :

test/core/cont.wast

@@ -0,0 +1,82 @@
+(module
+  (event $e1)
+  (event $e2)
+
+  (type $f1 (func))
+  (type $k1 (cont (type $f1)))
+
+  (func $f1 (export "unhandled-1")
+    (cont.suspend $e1)
+  )
+
+  (func (export "unhandled-2")
+    (block $h (result (ref $k1))
+      (cont.resume (event $e2 $h) (cont.new (type $k1) (ref.func $f1)))
+      (unreachable)
+    )
+    (drop)
+  )
+
+  (func (export "handled")
+    (block $h (result (ref $k1))
+      (cont.resume (event $e1 $h) (cont.new (type $k1) (ref.func $f1)))
+      (unreachable)
+    )
+    (drop)
+  )
+)
+
+(assert_suspension (invoke "unhandled-1") "unhandled")
+(assert_suspension (invoke "unhandled-2") "unhandled")
+(assert_return (invoke "handled"))
+
+
+(module $state
+  (event $get (result i32))
+  (event $set (param i32) (result i32))
+
+  (type $f (func (param i32) (result i32)))
+  (type $k (cont (type $f)))
+
+  (func $runner (param $s i32) (param $k (ref $k)) (result i32)
+    (loop $loop
+      (block $on_get (result (ref $k))
+        (block $on_set (result i32 (ref $k))
+          (cont.resume (event $get $on_get) (event $set $on_set)
+            (local.get $s) (local.get $k)
+          )
+          (return)
+        )
+        ;; on set
+        (local.set $k)
+        (local.set $s)
+        (br $loop)
+      )
+      ;; on get
+      (local.set $k)
+      (br $loop)
+    )
+    (unreachable)
+  )
+
+  (func $f (param i32) (result i32)
+    (drop (cont.suspend $set (i32.const 7)))
+    (i32.add
+      (cont.suspend $get)
+      (i32.mul
+        (i32.const 2)
+        (i32.add
+          (cont.suspend $set (i32.const 3))
+          (cont.suspend $get)
+        )
+      )
+    )
+  )
+
+  (elem declare func $f)
+  (func (export "run") (result i32)
+    (call $runner (i32.const 0) (cont.new (type $k) (ref.func $f)))
+  )
+)
+
+(assert_return (invoke "run") (i32.const 19))