1 files changed, 74 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/prog002/Scheduler.hs b/testsuite/tests/concurrent/prog002/Scheduler.hs
new file mode 100644
index 0000000000..bbfd374c43
--- /dev/null
+++ b/testsuite/tests/concurrent/prog002/Scheduler.hs
@@ -0,0 +1,74 @@
+module Scheduler 
+( runTIO
+, module Event
+, module Thread
+, TTree
+, TIO
+) 
+where
+
+import Event
+import Thread
+import Control.Concurrent
+import System.IO
+
+--------------------------------
+type TTree = ThreadTree SysReq SysRsp IO
+type TIO   = ContM SysReq SysRsp IO
+
+
+runTIO :: [TIO ()] -> IO ()
+runTIO l = runThreads $ map buildThread l 
+
+data World = World 
+    { mReadyQ :: ! (Chan (TTree))  }
+
+max_steps = 1
+worker_pure world= 
+  do 
+      t <- readChan readyq
+      case t of
+        (Atom _) -> return ()
+        _ -> return ()
+      exec_thread max_steps t
+      return ()
+ where
+ readyq = mReadyQ world
+
+ exec_thread 0 t =
+  do putStr "."; hFlush stdout
+     writeChan readyq t
+ exec_thread c (Atom mx) = 
+     do 
+        x <- mx
+        exec_thread (c-1) x
+ exec_thread c (Stop) = return ()
+ 
+runThreads :: [TTree] -> IO ()
+runThreads l =
+  do 
+     mready <- newChan
+     writeList2Chan mready l
+     let world = World mready 
+     multiloop world
+
+loop_p world = do worker_pure world; loop_p world
+
+multiloop world = 
+  do 
+	-- a mixture of bound threads & lightweight threads 
+	-- to make things interesting...
+     forkOS (loop_p world)
+     forkOS (loop_p world)
+     forkOS (loop_p world)
+     forkOS (loop_p world)
+     forkOS (loop_p world)
+     forkOS (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     forkIO (loop_p world)
+     loop_p world