diff options
Diffstat (limited to 'testsuite/tests/concurrent/prog003/MainMVarList.lhs')
| -rw-r--r-- | testsuite/tests/concurrent/prog003/MainMVarList.lhs | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/prog003/MainMVarList.lhs b/testsuite/tests/concurrent/prog003/MainMVarList.lhs new file mode 100644 index 0000000000..9bcf9b1240 --- /dev/null +++ b/testsuite/tests/concurrent/prog003/MainMVarList.lhs @@ -0,0 +1,237 @@ + +> module Main where + +> import Data.IORef +> import Control.Concurrent +> --import Control.Concurrent.STM +> import System.Environment +> import Data.Time + + +> import MVarList + + +printing + +> printList :: Show a => ListHandle a -> IO () +> printList (ListHandle {headList = ptrPtr}) = +> do startptr <- ( +> do ptr <- readIORef ptrPtr +> Head {next = startptr} <- readMVar ptr +> return startptr) +> printListHelp startptr + + +> printListHelp :: Show a => MVar (List a) -> IO () +> printListHelp curNodePtr = +> do { curNode <- readMVar curNodePtr +> ; case curNode of +> Null -> putStr "Nil" +> Node {val = curval, next = curnext} -> +> do { putStr (show curval ++ " -> ") +> ; printListHelp curnext } +> DelNode {val = curval, next = curnext} -> +> do { putStr (show curval ++ "DEAD -> ") +> ; printListHelp curnext } +> } + +> cntList :: Show a => ListHandle a -> IO Int +> cntList (ListHandle {headList = ptrPtr}) = +> do startptr <- ( +> do ptr <- readIORef ptrPtr +> Head {next = startptr} <- readMVar ptr +> return startptr) +> cntListHelp startptr 0 + + +> cntListHelp :: Show a => MVar (List a) -> Int -> IO Int +> cntListHelp curNodePtr i = +> do { curNode <- readMVar curNodePtr +> ; case curNode of +> Null -> return i +> Node {val = curval, next = curnext} -> +> cntListHelp curnext (i+1) +> DelNode {val = curval, next = curnext} -> +> cntListHelp curnext (i+1) +> } + + +create List + +> createList :: Int -> IO (ListHandle Int) +> createList n = +> do nl <- newList +> mapM (addToTail nl) [1..n] +> return nl + + +> data Op a = Find a | Insert a | Delete a deriving Show + + +> createTasks :: [a] -> [Op a] +> createTasks xs = task 1 xs +> where +> insCnt = 5 -- every 5th op is insert +> delCnt = 9 -- ever 9th op is delete +> task _ [] = [] +> task cnt (x:xs) +> | (cnt `mod` insCnt) == 0 = (Insert x) : task (cnt+1) xs +> | (cnt `mod` delCnt) == 0 = (Delete x) : task (cnt+1) xs +> | otherwise = (Find x) : task (cnt+1) xs + + + +mainly finds, some deletes which will be inserted again + +> specificTask1 :: [a] -> [Op a] +> specificTask1 xs = task 1 xs [] +> where +> delCnt = 5 -- every 6th op is delete +> insCnt = 50 -- after 5 deletes we'll insert them again +> task _ [] _ = [] +> task cnt (x:xs) deletes +> | length deletes == insCnt = map Insert deletes ++ task (cnt+1) (x:xs) [] +> | (cnt `mod` delCnt) == 0 = (Delete x) : task (cnt+1) xs (x:deletes) +> | otherwise = (Find x) : task (cnt+1) xs deletes + +> executeTasks :: Eq a => ListHandle a -> [Op a] -> IO () +> executeTasks lh ops = +> do mapM (\ task -> +> case task of +> Find x -> do { find lh x; return () } +> Insert x -> do { addToTail lh x; return () } +> Delete x -> do { delete lh x; return () }) +> ops +> return () + + put number into threads buckets + +> distribution :: [Int] -> Int -> [[Int]] +> distribution no threads = +> let init = map (\ _ -> []) [1..threads] +> go :: [Int] -> Int -> [[Int]] -> [[Int]] +> go [] _ acc = acc +> go (x:xs) cnt acc = +> let idx = cnt `mod` threads +> acc' = take idx acc ++ [x : (acc !! idx)] ++ drop (idx+1) acc +> in go xs (cnt+1) acc' +> +> in go no 1 init + +> insert :: Eq a => ListHandle a -> a -> IO () +> insert = addToTail + + +runnable version + +> main = mainPar + +parallel version + +> mainPar :: IO () +> mainPar = +> do let len = 3000 +> let threads = 4 +> nl <- createList len +> let numbers = [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len]) +> ++ [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len]) +> let [d1,d2,d3,d4] = distribution numbers threads +> let t1 = d1++d2++d3++d4 +> let t2 = d2++d3++d4++d1 +> let t3 = d3++d4++d1++d2 +> let t4 = d4++d1++d2++d3 +> wait <- atomically (newTVar 0) +> putStrLn "Start" +> start <- getCurrentTime +> mapM (\ t -> forkIO (do executeTasks nl (specificTask1 t) +> atomically(do counter <- readTVar wait +> writeTVar wait (counter+1)))) +> [t1,t2,t3,t4] +> atomically ( do counter <- readTVar wait +> if counter < 4 then retry +> else return () ) +> fin <- getCurrentTime +> putStrLn "Done" +> putStrLn $ "Time: " ++ show (diffUTCTime fin start) + + +> mainPar2 :: IO () +> mainPar2 = +> do nl <- createList 5 +> let len = 5 + 200 +> cnt <- atomically (newTVar 0) +> printList nl +> mapM (\ e -> forkIO ( do insert nl e +> atomically(do i <- readTVar cnt +> writeTVar cnt (i+1)))) +> [6..len] + +> atomically ( do i <- readTVar cnt +> if i <= len-6 then retry +> else return () ) + +> printList nl +> n <- cntList nl +> putStrLn $ "Overall: " ++ show n + + +sequential version + +> mainSeq :: IO () +> mainSeq = +> do let len = 3000 +> let threads = 4 +> nl <- createList len +> let numbers = [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len]) +> ++ [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len]) +> let [d1,d2,d3,d4] = distribution numbers threads +> let t1 = d1++d2++d3++d4 +> let t2 = d2++d3++d4++d1 +> let t3 = d3++d4++d1++d2 +> let t4 = d4++d1++d2++d3 +> putStrLn "Start" +> start <- getCurrentTime +> mapM (\ t -> executeTasks nl (specificTask1 t)) [t1,t2,t3,t4] +> fin <- getCurrentTime +> putStrLn "Done" +> putStrLn $ "Time: " ++ show (diffUTCTime fin start) + + +just testing + +> mainTest2 :: IO () +> mainTest2 = +> do let len = 10 +> nl <- createList len +> printList nl +> addToTail nl 1 +> printList nl + +> mainTest :: IO () +> mainTest = +> do let len = 10 +> nl <- createList len +> printList nl + + r <- delete nl 3 + putStrLn ("Result : " ++ show r) + find nl 10 + +> insert nl 11 + +> delete nl 3 +> find nl 11 + + +> mapM (\x -> forkIO (insert nl x)) [12..50] + +> threadDelay 1000000 + +> {- +> putStrLn "Start" +> executeTasks nl $ createTasks [1..len] +> find nl (len+1) -- we try to find a non-existant element +> -- this way, in the LazyList case, we will physically delete all (logically deleted) elements +> -} +> putStrLn "End" +> printList nl |