Scheduler example

interpreter/exec/eval.ml

@@ -77,9 +77,21 @@ and admin_instr' =
 
 and ctxt = code -> code
 
-type cont = int * ctxt
+type cont = int * ctxt  (* TODO: represent type properly *)
 type ref_ += ContRef of cont
 
+let () =
+  let type_of_ref' = !Value.type_of_ref' in
+  Value.type_of_ref' := function
+    | ContRef _ -> BotHeapType  (* TODO *)
+    | r -> type_of_ref' r
+
+let () =
+  let string_of_ref' = !Value.string_of_ref' in
+  Value.string_of_ref' := function
+    | ContRef _ -> "cont"
+    | r -> string_of_ref' r
+
 let plain e = Plain e.it @@ e.at
 
 let is_jumping e =

interpreter/valid/match.ml

@@ -26,6 +26,9 @@ let eq_nullability c a nul1 nul2 =
 let eq_mutability c a mut1 mut2 =
   mut1 = mut2
 
+let eq_resumability c a res1 res2 =
+  res1 = res2
+
 let eq_limits c a lim1 lim2 =
   lim1.min = lim2.min && lim1.max = lim2.max
 
@@ -78,12 +81,16 @@ and eq_memory_type c a (MemoryType lim1) (MemoryType lim2) =
 and eq_global_type c a (GlobalType (t1, mut1)) (GlobalType (t2, mut2)) =
   eq_mutability c a mut1 mut2 && eq_value_type c a t1 t2
 
+and eq_event_type c a (EventType (ft1, res1)) (EventType (ft2, res2)) =
+  eq_resumability c a res1 res2 && eq_func_type c [] ft1 ft2
+
 and eq_extern_type c a et1 et2 =
   match et1, et2 with
   | ExternFuncType ft1, ExternFuncType ft2 -> eq_func_type c a ft1 ft2
   | ExternTableType tt1, ExternTableType tt2 -> eq_table_type c a tt1 tt2
   | ExternMemoryType mt1, ExternMemoryType mt2 -> eq_memory_type c a mt1 mt2
   | ExternGlobalType gt1, ExternGlobalType gt2 -> eq_global_type c a gt1 gt2
+  | ExternEventType et1, ExternEventType et2 -> eq_event_type c a et1 et2
   | _, _ -> false
 
 
@@ -146,12 +153,16 @@ and match_global_type c a (GlobalType (t1, mut1)) (GlobalType (t2, mut2)) =
   | Immutable -> match_value_type c a t1 t2
   | Mutable -> eq_value_type c [] t1 t2
 
+and match_event_type c a (EventType (ft1, res1)) (EventType (ft2, res2)) =
+  eq_resumability c [] res1 res2 && match_func_type c [] ft1 ft2
+
 and match_extern_type c a et1 et2 =
   match et1, et2 with
   | ExternFuncType ft1, ExternFuncType ft2 -> match_func_type c a ft1 ft2
   | ExternTableType tt1, ExternTableType tt2 -> match_table_type c a tt1 tt2
   | ExternMemoryType mt1, ExternMemoryType mt2 -> match_memory_type c a mt1 mt2
   | ExternGlobalType gt1, ExternGlobalType gt2 -> match_global_type c a gt1 gt2
+  | ExternEventType et1, ExternEventType et2 -> match_event_type c a et1 et2
   | _, _ -> false
 
 and match_def_type c a dt1 dt2 =

test/core/cont.wast

@@ -1,3 +1,5 @@
+;; Unhandled events
+
 (module
   (exception $exn)
   (event $e1)
@@ -55,6 +57,8 @@
 (assert_exception (invoke "uncaught-2") "unhandled")
 
 
+;; Simple state example
+
 (module $state
   (event $get (result i32))
   (event $set (param i32) (result i32))
@@ -104,3 +108,147 @@
 )
 
 (assert_return (invoke "run") (i32.const 19))
+
+
+;; Simple scheduler example
+
+(module $scheduler
+  (type $proc (func))
+  (type $cont (cont $proc))
+
+  (event $yield (export "yield"))
+  (event $spawn (export "spawn") (param (ref $proc)))
+
+  (table $queue 0 (ref null $cont))
+  (global $qdelta i32 (i32.const 10))
+  (global $qback (mut i32) (i32.const 0))
+  (global $qfront (mut i32) (i32.const 0))
+
+  (func $queue-empty (result i32)
+    (i32.eq (global.get $qfront) (global.get $qback))
+  )
+
+  (func $dequeue (result (ref null $cont))
+    (local $k (ref null $cont))
+    ;; Check if queue is empty
+    (if (call $queue-empty)
+      (then (return (ref.null $cont)))
+    )
+    (local.set $k (table.get $queue (global.get $qfront)))
+    (global.set $qfront (i32.add (global.get $qfront) (i32.const 1)))
+    (local.get $k)
+  )
+
+  (func $enqueue (param $k (ref $cont))
+    (local $qlen i32)
+    ;; Check if queue is full
+    (if (i32.eq (global.get $qback) (table.size $queue))
+      (then
+        ;; Check if there is enough space in the front to compact
+        (if (i32.lt_u (global.get $qfront) (global.get $qdelta))
+          (then
+            ;; Not enough room, grow table
+            (drop (table.grow $queue (ref.null $cont) (global.get $qdelta)))
+          )
+          (else
+            ;; Enough room, move entries down
+            (local.set $qlen (i32.sub (global.get $qback) (global.get $qfront)))
+            (table.copy $queue $queue
+              (i32.const 0)
+              (global.get $qfront)
+              (local.get $qlen)
+            )
+            (table.fill $queue
+              (local.get $qlen)
+              (ref.null $cont)
+              (global.get $qfront)
+            )
+            (global.set $qfront (i32.const 0))
+            (global.set $qback (local.get $qlen))
+          )
+        )
+      )
+    )
+    (table.set $queue (global.get $qback) (local.get $k))
+    (global.set $qback (i32.add (global.get $qback) (i32.const 1)))
+  )
+
+  (func $scheduler (export "scheduler") (param $main (ref $proc))
+    (call $enqueue (cont.new (type $cont) (local.get $main)))
+    (loop $l
+      (if (call $queue-empty) (then (return)))
+      (block $on_yield (result (ref $cont))
+        (block $on_spawn (result (ref $proc) (ref $cont))
+          (cont.resume (event $yield $on_yield) (event $spawn $on_spawn)
+            (call $dequeue)
+          )
+          (br $l)  ;; thread terminated
+        )
+        ;; on $spawn, proc and cont on stack
+        (call $enqueue)             ;; continuation of old thread
+        (cont.new (type $cont))
+        (call $enqueue)             ;; new thread
+        (br $l)
+      )
+      ;; on $yield, cont on stack
+      (call $enqueue)
+      (br $l)
+    )
+  )
+)
+
+(register "scheduler")
+
+(module
+  (type $proc (func))
+  (type $cont (cont $proc))
+  (event $yield (import "scheduler" "yield"))
+  (event $spawn (import "scheduler" "spawn") (param (ref $proc)))
+  (func $scheduler (import "scheduler" "scheduler") (param $main (ref $proc)))
+
+  (func $log (import "spectest" "print_i32") (param i32))
+
+  (elem declare func $main $thread1 $thread2 $thread3)
+
+  (func $main
+    (call $log (i32.const 0))
+    (cont.suspend $spawn (ref.func $thread1))
+    (call $log (i32.const 1))
+    (cont.suspend $spawn (ref.func $thread2))
+    (call $log (i32.const 2))
+    (cont.suspend $spawn (ref.func $thread3))
+    (call $log (i32.const 3))
+  )
+
+  (func $thread1
+    (call $log (i32.const 10))
+    (cont.suspend $yield)
+    (call $log (i32.const 11))
+    (cont.suspend $yield)
+    (call $log (i32.const 12))
+    (cont.suspend $yield)
+    (call $log (i32.const 13))
+  )
+
+  (func $thread2
+    (call $log (i32.const 20))
+    (cont.suspend $yield)
+    (call $log (i32.const 21))
+  )
+
+  (func $thread3
+    (call $log (i32.const 30))
+    (cont.suspend $yield)
+    (call $log (i32.const 31))
+    (cont.suspend $yield)
+    (call $log (i32.const 32))
+  )
+
+  (func (export "run")
+    (call $log (i32.const -1))
+    (call $scheduler (ref.func $main))
+    (call $log (i32.const -2))
+  )
+)
+
+(assert_return (invoke "run"))