Commit 0bb68a04 authored by sewardj's avatar sewardj
Browse files

[project @ 2001-06-26 12:19:59 by sewardj]

Add concurrent/ tests.  Still needs work.
parent 25f7d5d5
include ($confdir ++ "/../vanilla-test.T")
-- Args to vt are: extra compile flags
-- extra run flags
-- expected process return value, if not zero
def myvt ( $args_c, $args_r, $ret_res )
{
vt ( " -package concurrent -fglasgow-exts " ++ $args_c,
$args_r, $ret_res )
}
--conc009_RUNTEST_OPTS = -x 1
--conc021_RUNTEST_OPTS = -x 250 -o2 conc021.stderr-mingw
test "conc001" { vt("", "", "") }
test "conc002" { vt("", "", "") }
test "conc003" { vt("", "", "") }
test "conc004" { vt("", "", "") }
test "conc005" { vt("", "", "") }
test "conc006" { vt("", "", "") }
test "conc007" { vt("", "+RTS -H128M -RTS", "") }
test "conc008" { vt("", "", "") }
test "conc009" { vt("", "", "") }
test "conc010" { vt("", "", "") }
test "conc012" { vt("", "", "") }
test "conc013" { vt("", "", "") }
test "conc014" { vt("", "", "") }
test "conc015" { vt("", "", "") }
test "conc016" { vt("", "", "") }
test "conc017" { vt("", "", "") }
test "conc018" { vt("", "", "") }
test "conc019" { vt("", "", "") }
--# conc020 *should* work on mingw32
test "conc020" { skip when $platform == "i386-unknown-mingw32"
vt("", "", "") }
test "conc021" { skip when $platform == "i386-unknown-mingw32"
vt("", "", "") }
test "conc022" { vt("", "", "") }
test "conc023" { vt("", "", "") }
test "conc024" { vt("", "", "") }
test "conc025" { vt("", "", "") }
test "conc026" { vt("", "", "") }
test "conc027" { vt("", "", "") }
test "conc028" { vt("", "", "") }
test "conc029" { vt("", "", "") }
test "conc030" { vt("", "", "") }
test "conc031" { vt("", "", "") }
module Main where
import Concurrent
-- two processes, one MVar communication.
main = do
s <- newEmptyMVar
let
write = do
putMVar s "hello world\n"
forkIO write
str <- takeMVar s
putStr str
module Main where
import Concurrent
main = do
c <- newChan
let writer = writeList2Chan c "Hello World\n"
forkIO writer
let reader = do char <- readChan c
if (char == '\n')
then return ()
else do putChar char; reader
reader
module Main where
import Concurrent
-- simple handshaking using two MVars,
-- must context switch twice for each character.
main = do
ready <- newEmptyMVar
datum <- newEmptyMVar
let
reader = do
putMVar ready ()
char <- takeMVar datum
if (char == '\n')
then return ()
else do putChar char; reader
writer "" = do
takeMVar ready
putMVar datum '\n'
writer (c:cs) = do
takeMVar ready
putMVar datum c
writer cs
forkIO reader
writer "Hello World"
module Main where
-- Test thread creation.
-- (from: Einar Wolfgang Karlsen <ewk@Informatik.Uni-Bremen.DE>)
import Concurrent
main :: IO ()
main = do
mvar <- newEmptyMVar
let
spawner :: (IO () -> IO ThreadId) -> Int -> IO ()
spawner c 0 = putMVar mvar ()
spawner c n = do { c (spawner c (n-1)); return ()}
spawner forkIO 1000000
takeMVar mvar
putStr "done"
module Main where
import Concurrent
-- same as conc004, but using the ChannelVar abstraction
main = do
v <- newCVar
done <- newEmptyMVar
let
reader = do
c <- readCVar v
if (c == '\n')
then putMVar done ()
else do putChar c; reader
writer [] = do writeCVar v '\n'; return ()
writer (c:cs) = do writeCVar v c; writer cs
forkIO reader
writer "Hello World"
takeMVar done
module Main where
import Concurrent
-- This test hopefully exercises the black hole code. The main thread
-- forks off another thread and starts on a large computation.
-- The child thread attempts to get the result of the same large
-- computation (and should get blocked doing so, because the parent
-- won't have evaluated it yet). When the result is available, the
-- child passes it back to the parent who prints it out.
test = sum [1..10000]
main = do
x <- newEmptyMVar
forkIO (if test > 0
then putMVar x test
else error "proc"
)
if test > 0 -- evaluate test
then do result <- takeMVar x
print result
else error "main"
{-# OPTIONS -fglasgow-exts #-}
module Main where
import Concurrent
import Exception
import IOExts
choose :: a -> a -> IO a
choose a b = do
ready <- newMVar ()
answer <- newEmptyMVar
a_id <- myForkIO (a `seq` takeMVar ready >> putMVar answer a)
b_id <- myForkIO (b `seq` takeMVar ready >> putMVar answer b)
it <- takeMVar answer
killThread a_id
killThread b_id
return it
-- We need to catch the exception raised by killThread and ignore it.
-- Otherwise the default handler will exit the program when this
-- exception is raised in any thread.
myForkIO :: IO () -> IO ThreadId
myForkIO io = forkIO (Exception.catch io (\e -> return ()))
main = do
let big = sum [1..]
small = sum [1..42]
test1 <- choose big small
test2 <- choose small big
print (test1,test2)
{-# OPTIONS -fglasgow-exts #-}
module Main where
import Concurrent
import Exception
-- Send ourselves a KillThread signal, catch it and recover.
main = do
id <- myThreadId
Exception.catch (killThread id) (\e -> putStr (show e))
{-# OPTIONS -fglasgow-exts #-}
module Main where
import Concurrent
import Exception
main = do
id <- myThreadId
throwTo id (ErrorCall "hello")
{-# OPTIONS -fglasgow-exts #-}
module Main where
import Concurrent
import Exception
-- Raise an exception in another thread. We need a lot of synchronisation here:
-- - an MVar for the second thread to block on which it waits for the
-- signal (block)
-- - an MVar to signal the main thread that the second thread is ready to
-- accept the signal (ready)
-- - an MVar to signal the main thread that the second thread has received
-- the signal (ready2). If we don't have this MVar, then the main
-- thread could exit before the second thread has time to print
-- the result.
main = do
block <- newEmptyMVar
ready <- newEmptyMVar
ready2 <- newEmptyMVar
id <- forkIO (Exception.catch (putMVar ready () >> takeMVar block)
(\e -> putStr (show e) >> putMVar ready2 ()))
takeMVar ready
throwTo id (ErrorCall "hello")
takeMVar ready2
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