Commit 75eef481 authored by Simon Marlow's avatar Simon Marlow
Browse files

add test for #713

parent 17366470
module Event
where
data SysReq = SysReq
data SysRsp = SysRsp
module FileIO where
import System.IO
import Foreign
import Foreign.C
foreign import ccall safe "fileio.h c_file_getresult"
c_file_getresult :: CInt -> IO CInt
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
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
import Scheduler
import Foreign
import Foreign.C
import System.Random
import Control.Concurrent
expensive = f (500 :: Int)
where f 0 = stop
f n = do
r <- atom $ getStdRandom (randomR (0,99::Int))
r `seq` f $! n-1
main = do
m <- newEmptyMVar
forkIO (do
runTIO $ map (\x->expensive) [1..500]
putMVar m ())
takeMVar m
module Thread
( ThreadTree (..)
, ContM (..)
, atom
, stop
, buildThread
)
where
----------------------------------
data ThreadTree req rsp m =
Atom (m (ThreadTree req rsp m))
| Stop
----------------------------------
newtype ContM req rsp m a = ContM ((a-> ThreadTree req rsp m)-> ThreadTree req rsp m)
instance Monad m => Monad (ContM req rsp m) where
m >>= f = contmBind m f
return = contmReturn
contmBind :: (ContM req rsp m a) -> (a -> (ContM req rsp m b)) -> (ContM req rsp m b)
contmBind (ContM x) f =
ContM(\y-> x (\z-> let ContM f' = f z in f' y))
contmReturn :: a -> (ContM req rsp m a)
contmReturn x = ContM(\c -> c x)
{-- how to build primitive ContM blocks... --}
atom :: Monad m => (m a) -> (ContM req rsp m a)
atom mx = ContM( \c -> Atom( do x <- mx; return (c x) ))
stop :: (ContM req rsp m a)
stop = ContM( \c -> Stop )
buildThread :: (ContM req rsp m a) -> ThreadTree req rsp m
buildThread (ContM f) = f (\c->Stop)
----------------------------------
# Test for bug #713, results in crashes in GHC prior to 20060315 with +RTS -N2
# the conditions are fairly delicate. It must be compiled without optimisation,
# hence -O0:
test('concprog002', compose(only_ways(['threaded2']),
compose(exit_code(1),
skip_if_fast)),
multimod_compile_and_run, ['Server','-debug -O0'])
clean_o_hi()
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment