Abstract handler heap type. Extend testsuite

Author: dhil

interpreter/valid/match.ml

@@ -14,7 +14,7 @@ let abs_of_str_type _c = function
   | DefStructT _ | DefArrayT _ -> StructHT
   | DefFuncT _ -> FuncHT
   | DefContT _ -> ContHT
-  | DefHandlerT _ -> failwith "TODO abstract heap type for handlers"
+  | DefHandlerT _ -> HandlerHT
 
 let rec top_of_str_type c st =
   top_of_heap_type c (abs_of_str_type c st)

test/core/stack-switching/cont.wast

@@ -1119,7 +1119,7 @@
       (local.set $i (i32.add (i32.const 1) (local.get $i)))
       (br $next)))
 
-  (func $sumUp (export "sumUp") (param $n i32) (result i32)
+  (func (export "sumUp") (param $n i32) (result i32)
     (local $i i32)
     (local $j i32)
     (local $k (ref $ct))
@@ -1137,6 +1137,78 @@
    )
    (return (local.get $i)))
 
-  (elem declare func $nats)
+  (func $nats-bad (type $ft)
+    (local $h (ref $ht))
+    (local $i i32)
+    (local.set $h (local.get 0))
+    (loop $next
+      (suspend_to $ht $yield
+        (local.get $i) (local.get $h))
+      (drop) ;; drop the handle
+      (local.set $i (i32.add (i32.const 1) (local.get $i)))
+      (br $next)))
+
+  (func (export "sumUp-bad") (param $n i32) (result i32)
+    (local $i i32)
+    (local $j i32)
+    (local $k (ref $ct))
+    (local.set $k (cont.new $ct (ref.func $nats-bad)))
+    (loop $next
+      (block $on_yield (result i32 (ref $ct))
+        (resume_with $ct (on $yield $on_yield) (local.get $k))
+        (return (local.get $i))
+      ) ;; on_yield
+      (local.set $k)
+      (i32.add (local.get $i))
+      (local.set $i)
+      (local.set $j (i32.add (i32.const 1) (local.get $j)))
+      (br_if $next (i32.le_u (local.get $j) (local.get $n)))
+   )
+   (return (local.get $i)))
+
+  (elem declare func $nats $nats-bad)
 )
 (assert_return (invoke "sumUp" (i32.const 10)) (i32.const 55))
+(assert_suspension (invoke "sumUp-bad" (i32.const 10)) "unhandled tag")
+
+(module
+  (type $ht (handler))
+  (type $ft (func (param (ref $ht))))
+  (type $ct (cont $ft))
+
+  (type $ft2 (func))
+  (type $ct2 (cont $ft2))
+
+  (global $h1 (mut (ref null $ht)) (ref.null $ht))
+  (global $h2 (mut (ref null $ht)) (ref.null $ht))
+
+  (tag $yield)
+
+  (func $escape (type $ft)
+    (global.set $h2 (local.get 0))
+    (resume $ct2 (cont.new $ct2 (ref.func $do-suspend)))
+    (unreachable))
+
+  (func $do-suspend
+    (suspend_to $ht $yield (global.get $h1))
+    (unreachable))
+
+  (func $generate-name (type $ft)
+    (global.set $h1 (local.get 0))
+    (block $on_yield (result (ref $ct))
+      (resume_with $ct (on $yield $on_yield) (cont.new $ct (ref.func $escape)))
+      (unreachable)
+    ) ;; on_yield [named]
+    (unreachable))
+
+  (func (export "use-escapee")
+    (block $on_yield (result (ref $ct))
+      (resume_with $ct (on $yield $on_yield) (cont.new $ct (ref.func $generate-name)))
+      (unreachable)
+    ) ;; on_yield
+    (suspend_to $ht $yield (global.get $h2))
+    (unreachable))
+
+  (elem declare func $escape $do-suspend $generate-name)
+)
+(assert_suspension (invoke "use-escapee") "unhandled tag")