{-# LANGUAGE BangPatterns,CPP #-}
module CASList where

import Control.Monad
import Data.IORef
import Control.Concurrent
import Control.Concurrent.Chan
import System.Environment
import Data.Time

-- #define USE_UNPACK
-- #define USE_STRICT

#if defined(USE_UNPACK)
#define UNPACK(p) {-# UNPACK #-} !(p)
#elif defined(USE_STRICT)
#define UNPACK(p) !(p)
#else
#define UNPACK(p) p
#endif

data List a = Node { val :: a
                   , next :: UNPACK(IORef (List a)) }
            | DelNode { next :: UNPACK(IORef (List a)) }
            | Null
            | Head { next :: UNPACK(IORef (List a)) } deriving Eq

data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
                                 tailList :: UNPACK(IORef (IORef (List a))) }

{-# INLINE myNext #-}
myNext :: List a -> IORef (List a)
myNext Node{next = n} = n
myNext DelNode{next = n} = n
myNext Head{next = n} = n
myNext _ = error "myNext"

-- we assume a static head pointer, pointing to the first node which must be Head
-- the deleted field of Head is always False, it's only there to make some of the code
-- more uniform
-- tail points to the last node which must be Null

type Iterator a = IORef (IORef (List a))

-------------------------------------------
-- auxiliary functions

while b cmd = if b then do {cmd; while b cmd}
              else return ()

repeatUntil cmd = do { b <- cmd; if b then return ()
                                  else repeatUntil cmd }

atomCAS :: Eq a => IORef a -> a -> a -> IO Bool
atomCAS ptr old new =
   atomicModifyIORef ptr (\ cur -> if cur == old
                                   then (new, True)
                                   else (cur, False))

atomicWrite :: IORef a -> a -> IO ()
atomicWrite ptr x =
   atomicModifyIORef ptr (\ _ -> (x,()))

----------------------------------------------
-- functions operating on lists

-- we create a new list
newList :: IO (ListHandle a)
newList =
   do null <- newIORef Null
      hd <- newIORef (Head {next = null })
      hdPtr <- newIORef hd
      tailPtr <- newIORef null
      return (ListHandle {headList = hdPtr, tailList = tailPtr})

-- we add a new node, by overwriting the null tail node
-- we only need to adjust tailList but not headList because
-- of the static Head
-- we return the location of the newly added node
addToTail :: Eq a => ListHandle a -> a -> IO ()
addToTail (ListHandle {tailList = tailPtrPtr}) x =
   do null <- newIORef Null
      repeatUntil
         (do tailPtr <- readIORef tailPtrPtr
             b <- atomCAS tailPtr Null (Node {val = x, next = null})
             return b )
        -- we atomically update the tail
        -- (by spinning on the tailPtr)
      atomicWrite tailPtrPtr null

find :: Eq a => ListHandle a -> a -> IO Bool
find (ListHandle { headList = head }) x =
  let go !prevPtr =
           do prevNode <- readIORef prevPtr
              let curPtr = myNext prevNode -- head/node/delnode have all next
              curNode <- readIORef curPtr
              case curNode of
                Node {val = y, next = nextNode } ->
                   if (x == y)
                   then -- node found and alive
                      return True
                   else go curPtr -- continue
                Null -> return False -- reached end of list
                DelNode {next = nextNode } ->
                         -- atomically delete curNode by setting the next of prevNode to next of curNode
                         -- if this fails we simply move ahead
                        case prevNode of
                          Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode,
                                                                             next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          DelNode {} -> go curPtr    -- if parent deleted simply move ahead
             {-
                correct as well, but a deleted parent deleting a child is (for certain cases) a useless operation
                                     do atomicModifyIORef prevPtr ( \ cur -> (cur{next = nextNode},True))
                                        go prevPtr
              -}

  in do startPtr <- readIORef head
        go startPtr

delete :: Eq a => ListHandle a -> a -> IO Bool
delete (ListHandle { headList = head }) x =
  let go prevPtr =
        do do prevNode <- readIORef prevPtr
              let curPtr = next prevNode -- head/node/delnode have all next
              curNode <- readIORef curPtr
              case curNode of
                Node {val = y, next = nextNode } ->
                   if (x == y)
                   then -- node found and alive
                      do b <- atomCAS curPtr curNode (DelNode {next = nextNode})
                         if b then return True
                          else go prevPtr -- spin
                   else go curPtr -- continue
                Null -> return False -- reached end of list
                DelNode {next = nextNode } ->
                         -- atomically delete curNode by setting the next of prevNode to next of curNode
                         -- if this fails we simply move ahead
                        case prevNode of
                          Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode,
                                                                             next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          DelNode {} -> go curPtr    -- if parent deleted simply move ahead

  in do startPtr <- readIORef head
        go startPtr

-- the iterator always points to the PREVIOUS node,
-- recall that there's a static dummy new Head
-- Assumption: iterators are private,
-- ie they won't be shared among threads
newIterator :: ListHandle a -> IO (Iterator a)
newIterator (ListHandle {headList = hd}) =
  do hdPtr <- readIORef hd
     it <- newIORef hdPtr
     return it

-- we iterate through the list and return the first "not deleted" node
-- we delink deleted nodes
-- there's no need to adjust headList, tailList
-- cause headList has a static Head and
-- tailList points to Null
iterateList :: Eq a => Iterator a -> IO (Maybe (IORef (List a)))
iterateList itPtrPtr =
  let go prevPtr =
        do do prevNode <- readIORef prevPtr
              let curPtr = next prevNode -- head/node/delnode have all next
              curNode <- readIORef curPtr
              case curNode of
                Node {} -> do writeIORef itPtrPtr curPtr
                                 -- adjust iterator
                              return (Just curPtr)
                Null -> return Nothing -- reached end of list
                DelNode {next = nextNode} ->
                         -- atomically delete curNode by setting the next of prevNode to next of curNode
                         -- if this fails we simply move ahead
                        case prevNode of
                          Node {} -> do b <- atomCAS prevPtr prevNode (Node {val = val prevNode,
                                                                             next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          Head {} -> do b <- atomCAS prevPtr prevNode (Head {next = nextNode})
                                        if b then go prevPtr
                                         else go curPtr
                          DelNode {} -> go curPtr    -- if parent deleted simply move ahead

  in do startPtr <- readIORef itPtrPtr
        go startPtr

--printing and counting

printList :: Show a => ListHandle a -> IO ()
printList (ListHandle {headList = ptrPtr}) =
  do startptr <- (
          do ptr <- readIORef ptrPtr
             Head {next = startptr} <- readIORef ptr
             return startptr)
     printListHelp startptr

printListHelp :: Show a => IORef (List a) -> IO ()
printListHelp curNodePtr =
   do { curNode <- readIORef curNodePtr
      ; case curNode of
          Null -> putStr "Nil"
          Node {val = curval, next = curnext} ->
             do { putStr (show curval  ++ " -> ")
                ;  printListHelp curnext }
          DelNode {next = curnext} ->
             do { putStr ("DEAD -> ")
                ;  printListHelp curnext }
      }

cntList :: Show a => ListHandle a -> IO Int
cntList (ListHandle {headList = ptrPtr}) =
  do startptr <- (
          do ptr <- readIORef ptrPtr
             Head {next = startptr} <- readIORef ptr
             return startptr)
     cntListHelp startptr 0

cntListHelp :: Show a => IORef (List a) -> Int -> IO Int
cntListHelp curNodePtr i =
   do { curNode <- readIORef curNodePtr
      ; case curNode of
          Null -> return i
          Node {val = curval, next = curnext} ->
                cntListHelp curnext (i+1)
          DelNode {next = curnext} ->
                cntListHelp curnext (i+1)
      }


{-# LANGUAGE PatternGuards #-}
module Main (main) where

import qualified Data.Map as M
import Data.Map (Map)

import System.Environment
import System.IO
import Text.Regex
import Data.List
import Control.Monad
import Data.Maybe

type RawResults = Map (String,Int) [Double]

main = do
  [time,speedup] <- getArgs
  s <- getContents
  let raw = slurp_raw (lines s)
      avg = M.map calc_average raw

  let keys = M.keys avg
      modes = nub (map fst keys)
      cores = sort (nub (map snd keys))

  h <- openFile time WriteMode
  forM modes $ \m -> do
   hPutStrLn h (m ++ concatMap (',':) [ show (fromJust (M.lookup (m,n) avg))
                                      | n <- cores ])
  hClose h

  let
      baselines = M.fromList [ (m, fromJust (M.lookup (m,1) avg)) | m <- modes ]
      spd = M.mapWithKey (calc_speedup baselines) avg

  h <- openFile speedup WriteMode
  forM modes $ \m -> do
   hPutStrLn h (m ++ concatMap (',':) [ show (fromJust (M.lookup (m,n) spd))
                                      | n <- cores ])
  hClose h

calc_average :: [Double] -> Double
calc_average = foldl f 0 . zip [(1::Int)..]
  where f mean (i,x) = mean + (x - mean) / fromIntegral i

calc_speedup :: Map String Double -> (String,Int) -> Double -> Double
calc_speedup baselines (mode,_) result = base / result
  where Just base = M.lookup mode baselines

slurp_raw :: [String] -> RawResults
slurp_raw lines = add_results ("",1) M.empty lines
  where
    add_results m results [] = results
    add_results m results (line:lines)
      | Just [mode,cores] <- matchRegex header line
      = add_results (mode, read cores :: Int) results lines
      | Just [time] <- matchRegex result line
      = let t = read time :: Double in
        add_results m (M.insertWith (\_ o -> t:o) m [t] results) lines
      | otherwise
      = add_results m results lines

header = mkRegex "run\\.([^\\.]*)\\.N([0-9]*)"
result = mkRegex "time: ([0-9\\.]+)s"


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module Collection where

class Show e => Col c e | c -> e where
   newCol :: IO c
   insertCol :: c -> e -> IO ()
   deleteCol :: c -> e -> IO Bool
   findCol :: c -> e -> IO Bool
   printCol :: c -> IO ()
   cntCol :: c -> IO Int


{-# LANGUAGE CPP,PatternGuards #-}
module ImmList where

import Control.Concurrent
import Data.IORef
import qualified Data.Sequence as S
import Data.Sequence (Seq, (|>), (<|), (><), ViewL(..))
import Data.Maybe
import Data.Foldable

#if 0
newtype ListHandle a = ListHandle (IORef (Seq a))

newList :: IO (ListHandle a)
newList = do
  r <- newIORef S.empty
  return (ListHandle r)

addToTail :: Eq a => ListHandle a -> a -> IO ()
addToTail (ListHandle r) x =
  atomicModifyIORef r $ \s -> (s |> x, ())

find :: Eq a => ListHandle a -> a -> IO Bool
find (ListHandle r) x = do
  s <- readIORef r
  return (isJust (S.elemIndexL x s))

delete :: Eq a => ListHandle a -> a -> IO Bool
delete (ListHandle r) x = atomicModifyIORef r $ \s ->
  case S.breakl (== x) s of
    (xs, ys) | c :< zs <- S.viewl ys, c == x -> (xs >< zs, True)
             | otherwise                     -> (xs >< ys, False)

printList :: Show a => ListHandle a -> IO ()
printList (ListHandle r) = do
  s <- readIORef r
  print (toList s)

cntList :: Show a => ListHandle a -> IO Int
cntList (ListHandle r) = readIORef r >>= return . S.length
#else
newtype ListHandle a = ListHandle (IORef [a])

newList :: IO (ListHandle a)
newList = do
  r <- newIORef []
  return (ListHandle r)

addToTail :: Eq a => ListHandle a -> a -> IO ()
addToTail (ListHandle r) x =
  atomicModifyIORef r $ \s -> (s ++ [x], ())

find :: Eq a => ListHandle a -> a -> IO Bool
find (ListHandle r) x = do
  s <- readIORef r
  return (x `Prelude.elem` s)

delete :: Eq a => ListHandle a -> a -> IO Bool
delete (ListHandle r) x = atomicModifyIORef r $ \s ->
  case break (== x) s of
    (xs, ys) | (c:zs) <- ys, c == x -> (xs ++ zs, True)
             | otherwise            -> (xs ++ ys, False)

printList :: Show a => ListHandle a -> IO ()
printList (ListHandle r) = do
  s <- readIORef r
  print s

cntList :: Show a => ListHandle a -> IO Int
cntList (ListHandle r) = readIORef r >>= return . length
#endif


> {-# LANGUAGE BangPatterns,CPP #-}
> module IOList where

-- #define USE_UNPACK
-- #define USE_STRICT

#if defined(USE_UNPACK)
#define UNPACK(p) {-# UNPACK #-} !(p)
#elif defined(USE_STRICT)
#define UNPACK(p) !(p)
#else
#define UNPACK(p) p
#endif

> import Data.IORef

> data List a = Node { val :: a, next :: UNPACK(IORef (List a))}
>           | Null
>           | Head {next :: UNPACK(IORef (List a)) }

> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
>                            tailList :: UNPACK(IORef (IORef (List a))) }

> atomically = \x -> x

> -- we create a new list
> newList :: IO (ListHandle a)
> newList =
>   do null <- newIORef Null
>      hd <- newIORef (Head {next = null })
>      hdPtr <- newIORef hd
>      tailPtr <- newIORef null
>      return (ListHandle {headList = hdPtr, tailList = tailPtr})

> find ::  Eq a => ListHandle a -> a -> IO Bool
> find (ListHandle {headList = ptrPtr})  i =  do
>  ptr <- readIORef ptrPtr
>  Head {next = startptr} <- readIORef ptr
>  find2 startptr i
>   where
>    find2 :: Eq a => IORef (List a) -> a -> IO Bool
>    find2 curNodePtr i = do
>    { curNode <- readIORef curNodePtr
>    ; case curNode of
>        Null -> return False  -- we've reached the end of the list
>                              -- element not found
>        Node {val = curval, next = curnext} ->
>          if (curval == i) then return True -- element found
>          else find2 curnext i              -- keep searching
>    }

> -- we add a new node, by overwriting the null tail node
> -- we only need to adjust tailList but not headList because
> -- of the static Head
> -- we return the location of the newly added node
> addToTail :: ListHandle a -> a -> IO (IORef (List a))
> addToTail (ListHandle {tailList = tailPtrPtr}) x =
>   do tPtr <- atomically (
>                do null <- newIORef Null
>                   tailPtr <- readIORef tailPtrPtr
>                   writeIORef tailPtr (Node {val = x, next = null})
>                   writeIORef tailPtrPtr null
>                   return tailPtr
>              )
>      return tPtr

> delete :: Eq a => ListHandle a -> a -> IO Bool
> delete (ListHandle {headList = ptrPtr})  i =
>  atomically (
>          do startptr <- readIORef ptrPtr
>             delete2 startptr i)
>   where
>    delete2 :: Eq a => IORef (List a) -> a -> IO Bool
>    delete2 prevPtr i =
>     do
>    { prevNode <- readIORef prevPtr
>    ; let curNodePtr = next prevNode --  head/node have both next
>    ; curNode <- readIORef curNodePtr
>    ; case curNode of
>        Null -> return False  -- we've reached the end of the list
>                              -- element not found
>        Node {val = curval, next = nextNode} ->
>          if (curval /= i)
>           then delete2 curNodePtr i         -- keep searching
>           else
>               -- delete element (ie delink node)
>               do { case prevNode of
>                      Head {} -> do writeIORef prevPtr (Head {next = nextNode})
>                                    return True
>                      Node {} -> do writeIORef prevPtr
>                                       (Node {val = val prevNode, next = nextNode})
>                                    return True
>                  }
>     }

printing and counting

> printList :: Show a => ListHandle a -> IO ()
> printList (ListHandle {headList = ptrPtr}) =
>   do startptr <- (
>          do ptr <- readIORef ptrPtr
>             Head {next = startptr} <- readIORef ptr
>             return startptr)
>      printListHelp startptr

> printListHelp :: Show a => IORef (List a) -> IO ()
> printListHelp curNodePtr =
>   do { curNode <- readIORef curNodePtr
>      ; case curNode of
>          Null -> putStr "Nil"
>          Node {val = curval, next = curnext} ->
>             do { putStr (show curval  ++ " -> ")
>                ;  printListHelp curnext }
>      }

> cntList :: Show a => ListHandle a -> IO Int
> cntList (ListHandle {headList = ptrPtr}) =
>  do startptr <- (
>          do ptr <- readIORef ptrPtr
>             Head {next = startptr} <- readIORef ptr
>             return startptr)
>     cntListHelp startptr 0

> cntListHelp :: Show a => IORef (List a) -> Int -> IO Int
> cntListHelp curNodePtr i =
>   do { curNode <- readIORef curNodePtr
>      ; case curNode of
>          Null -> return i
>          Node {val = curval, next = curnext} ->
>                cntListHelp curnext (i+1)
>      }


> {-# LANGUAGE UndecidableInstances, PatternSignatures, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}

> module Main where

> import Data.IORef
> import Control.Concurrent
> --import Control.Concurrent.STM
> import System.Environment
> import Data.Time

> import System.Mem
> import Data.List

> import Collection
> import RefInterface

> import TestData
> import TestRun

-- the contenders (we can run stand-alone for a fixed test case mainPar)

> import qualified CASList as CAS
>-- import qualified CASusingSTMList as CASusingSTM
> import qualified MVarListLockCoupling as MLC
>-- import qualified MVarusingSTM as MLCusingSTM
>-- import qualified LazyList2 as Lazy
> import qualified IOList as I
>-- import qualified STMList as S
> import qualified ImmList as IMM

create List

> createList :: Col c e => [e] -> IO c
> createList n =
>   do nl <- newCol
>      mapM (insertCol nl) n
>      return nl

> 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 = 6   -- 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 :: Col c e => c -> [Op e] -> IO ()
> executeTasks lh ops =
>  do mapM (\ task ->
>           case task of
>              Find x -> do { findCol lh x; return () }
>              Insert x -> do { insertCol lh x; return () }
>              Delete x -> do { deleteCol 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

runnable version

 main = mainPar

parallel version

> type RUN = CAS.ListHandle Int

> main :: IO ()
> main =
>  do args <- getArgs
>     case args of
>      (mode:"-t":in_fname:rest) -> run_testdata in_fname mode
>--      [mode, t, l] ->
>--        do let len = read l :: Int
>--           let threads = read t :: Int
>--           let run nl = mainPar nl threads len
>--           case mode of
>--            "CAS"   -> do nl :: CAS.ListHandle Int <- createList [0..len]
>--                          run nl
>--            "CASusingSTM"   -> do nl :: CASusingSTM.ListHandle Int <- createList [0..len]
>--                                  run nl
>--            "LAZY" -> do nl :: Lazy.ListHandle Int <- createList [0..len]
>--                         run nl
>--            "MLC" -> do nl :: MLC.ListHandle Int <- createList [0..len]
>--                        run nl
>--            "MLCusingSTM" -> do nl :: MLCusingSTM.ListHandle Int <- createList [0..len]
>--                                run nl
>--            "IO" -> do nl  :: I.ListHandle Int <- createList [0..len]
>--                       run nl
>--            "STM" -> do nl  :: S.ListHandle Int <- createList [0..len]
>--                        run nl
>--            "IMM" -> do nl  :: IMM.ListHandle Int <- createList [0..len]
>--                        run nl

 mainPar :: Col c Int => c -> Int -> Int -> IO ()
 mainPar nl threads len =
  do let numbers = [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len])
                   ++ [1..len] ++ (reverse [1..len]) ++ [1..len] ++ (reverse [1..len])
     let ds = distribution numbers threads
     let ts = ds
     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))))
          ts
     atomically ( do counter <- readTVar wait
                     if counter < threads then retry
                      else return () )
     fin <- getCurrentTime
     putStrLn "Done"
     putStrLn $ "Time: " ++ show (diffUTCTime fin start)

 mainPar2 nl len =
   do cnt <- atomically (newTVar 0)
      printCol nl
      mapM (\ e -> forkIO ( do insertCol 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 () )

      printCol nl
      n <- cntCol nl
      putStrLn $ "Overall: " ++ show n

sequential version

> mainSeq nl len =
>  do let threads = 4
>     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

> mainTest nl len =
>  do
>     printCol nl

      r <- deleteCol nl 3
      putStrLn ("Result : " ++ show r)
      find nl 10

>     insertCol nl 11

>     deleteCol nl 3
>     findCol nl 11

>     mapM (\x -> forkIO (insertCol nl x)) [12..50]

>     threadDelay 1000000

> {-
>     putStrLn "Start"
>     executeTasks nl $ createTasks [1..len]
>     find nl (len+1) -- we try to find a non-existent element
>                     -- this way, in the LazyList case, we will physically delete all (logically deleted) elements
> -}
>     putStrLn "End"
>     printCol nl


> 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-existent element
>                     -- this way, in the LazyList case, we will physically delete all (logically deleted) elements
> -}
>     putStrLn "End"
>     printList nl


{-# LANGUAGE BangPatterns,CPP #-}
module MVarListLockCoupling where

import Control.Monad
import Data.IORef
import Control.Concurrent
import Control.Concurrent.Chan
import System.Environment
import Data.Time

-- #define USE_UNPACK
-- #define USE_STRICT

#if defined(USE_UNPACK)
#define UNPACK(p) {-# UNPACK #-} !(p)
#elif defined(USE_STRICT)
#define UNPACK(p) !(p)
#else
#define UNPACK(p) p
#endif

data List a = Node { val :: a
                   , next :: UNPACK(MVar (List a)) }
            | Null
            | Head { next :: UNPACK(MVar (List a)) } deriving Eq

data ListHandle a = ListHandle { headList :: IORef (MVar (List a)),
                             tailList :: IORef (MVar (List a)) }

-- we assume a static head pointer, pointing to the first node which must be Head
-- the deleted field of Head is always False, it's only there to make some of the code
-- more uniform
-- tail points to the last node which must be Null

-- head is static, therefore IORef
-- tail will be adjusted, therefore MVar

type Iterator a = IORef (MVar (List a))

-- iterators are private

-------------------------------------------
-- auxiliary functions

while b cmd = if b then do {cmd; while b cmd}
              else return ()

repeatUntil cmd = do { b <- cmd; if b then return ()
                                  else repeatUntil cmd }

atomCAS :: Eq a => IORef a -> a -> a -> IO Bool
atomCAS ptr old new =
   atomicModifyIORef ptr (\ cur -> if cur == old
                                   then (new, True)
                                   else (cur, False))

atomicWrite :: IORef a -> a -> IO ()
atomicWrite ptr x =
   atomicModifyIORef ptr (\ _ -> (x,()))

----------------------------------------------
-- functions operating on lists

-- we create a new list
newList :: IO (ListHandle a)
newList =
   do null <- newMVar Null
      hd <- newMVar (Head {next = null })
      hdPtr <- newIORef hd
      tailPtr <- newIORef null
      return (ListHandle {headList = hdPtr, tailList = tailPtr})

-- we add a new node, by overwriting the null tail node
-- we only need to adjust tailList but not headList because
-- of the static Head
-- we return the location of the newly added node
addToTail :: Eq a => ListHandle a -> a -> IO ()
addToTail (ListHandle {tailList = tailPtrPtr}) x =
   do null <- newMVar Null
      tailPtr <- readIORef tailPtrPtr
      takeMVar tailPtr
      writeIORef tailPtrPtr null
      putMVar tailPtr (Node {val = x, next = null})

find :: Eq a => ListHandle a -> a -> IO Bool
find (ListHandle { headList = head }) x =
  let go prevPtr prevNode =
           do let curPtr = next prevNode -- head/node/delnode have all next
              curNode <- takeMVar curPtr
              case curNode of
                Node {val = y, next = nextNode } ->
                   if (x == y)
                   then -- node found
                      do putMVar prevPtr prevNode
                         putMVar curPtr curNode
                         return True
                   else
                      do putMVar prevPtr prevNode
                         go curPtr curNode -- continue
                Null -> do putMVar prevPtr prevNode
                           putMVar curPtr curNode
                           return False -- reached end of list
  in do startPtr <- readIORef head
        startNode <- takeMVar startPtr
        go startPtr startNode

delete :: Eq a => ListHandle a -> a -> IO Bool
delete (ListHandle { headList = head }) x =
  let go prevPtr prevNode =
        do do let curPtr = next prevNode -- head/node/delnode have all next
              curNode <- takeMVar curPtr
              case curNode of
                Node {val = y, next = nextNode } ->
                   if (x == y)
                   then -- delink node
                     do case prevNode of
                          Node {} -> do putMVar prevPtr (Node {val = val prevNode,
                                                               next = nextNode})
                                        putMVar curPtr curNode
                                        return True
                          Head {} -> do putMVar prevPtr (Head {next = nextNode})
                                        putMVar curPtr curNode
                                        return True
                   else do putMVar prevPtr prevNode
                           go curPtr curNode -- continue
                Null -> do putMVar curPtr curNode
                           putMVar prevPtr prevNode
                           return False -- reached end of list

  in do startPtr <- readIORef head
        startNode <- takeMVar startPtr
        go startPtr startNode

--printing and counting

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 }
      }

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)
      }


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

module RefInterface where

import Control.Monad

class Monad m => Ref r m | m -> r, r -> m where
   newRef :: a -> m (r a)
   readRef :: (r a) -> m a
   writeRef :: (r a) -> a -> m ()
   atomicRef :: m a -> IO a
   retryRef :: m a


module TestData where

-- Test Data Data Type

-- Operation Tokens
data Op a = Find a | Delete a | Insert a deriving Show

-- A test Data.
--    t_name : Name of the test data.
--    t_threads : Number of concurrent threads to run
--    t_modes   : Concurrent modes selected. Multiple modes
--               will be batch tested in specified sequence
--    t_repeats : Number of runs to conduct on each mode.
--    t_init_list : Elements of the initial list
--    t_tasks : Sequence of operation each node
--              executes. Note this must correspond to
--              number of threads.
data TestData a = TestData { t_name      :: String
                           , t_threads   :: Int
                           , t_init_list :: [a]
                           , t_tasks     :: [[Op a]] }

instance Show a => Show (TestData a) where
  show tc = "Name: " ++ (t_name tc) ++ "\n" ++
            "Threads: " ++ (show $ t_threads tc) ++ "\n" ++
            "Initial-List:\n" ++ (show $ t_init_list tc) ++ "\n" ++
            "Tasks:\n" ++ (printOps $ t_tasks tc)
            where
              printOps (op:ops) = (show op) ++ "\n" ++ (printOps ops)
              printOps [] = ""


module TestDataParser (
   parse_testdata, -- Read a => FilePath -> IO (TestData a)
   write_testdata  -- Show a => TestData -> IO ()
) where

import TestData

-- Parser for parsing TestData. The following is a sample of a test data:
--
--
-- Name: sample
-- Threads: 4
-- Modes: ["CAS","IO","BACK"]
-- Repeat: 6
-- Initial-List:
-- [4,5,6,7,8,4,5,754,345,23432,6547,4]
-- Tasks:
-- [Find 3,Delete 4,Insert 34,Find 45]
-- [Delete 34,Insert 43,Delete 3,Delete 45,Find 87]
-- [Insert 3 , Find 6]
-- [Find 3,Find 67,  Insert 3]
--
--
-- Some assumptions:
--   - Number of tasks must correspond to number of threads.
--   - Fields must come in the exact sequence specified above.

-- Auxiliary Functions

partitionAt :: Eq a => (a -> Bool) -> [a] -> [[a]]
partitionAt f as =
  filter (/=[]) (partitionAt' f as)
  where
    partitionAt' _ [] = []
    partitionAt' f as = let (v,rest) = span f as
                        in v:(partitionAt' f (drop 1 rest))

is_delimit :: Char -> Bool
is_delimit ' '  = True
is_delimit '\n' = True
is_delimit _    = False

not_delimit :: Char -> Bool
not_delimit x = not (is_delimit x)

-- Parsing Functions

parse_token :: String -> (String,String)
parse_token str = let str' = dropWhile is_delimit str
                  in span not_delimit str'

parse_list :: String -> ([String],String)
parse_list str =
   let str' = dropWhile is_delimit str
   in parse_list (tail str')
   where
     parse_list str = let comma x = x == ','
                          close x = x == ']'
                          commaOrClose x = or [comma x,close x]
                          (a,rest)   = span (\x -> not $ commaOrClose x) str
                      in case head rest of
                           ',' -> let (as,rest') = parse_list (tail rest)
                                  in (a:as,rest')
                           ']' -> ([a],tail rest)

parse_list_many :: Int -> String -> ([[String]],String)
parse_list_many 0 str = ([],str)
parse_list_many n str = let (a,rest)   = parse_list str
                            (as,rest') = parse_list_many (n-1) rest
                        in (a:as,rest')

drop_token :: String -> String
drop_token str = let (_,rest) = parse_token str
                 in rest

-- Main function for parseing testcases from file
parse_testdata :: Read a => FilePath -> IO (TestData a)
parse_testdata fname = do
  { input <- readFile fname
  ; let (name,input1) = parse_token (drop_token input)
        (t,input2)    = parse_token (drop_token input1)
        (list,input3) = parse_list (drop_token input2)
        (ops,_)       = parse_list_many (read t) (drop_token input3)
  ; return $ TestData { t_name    = name
                      , t_threads = read t
                      , t_init_list = map read list
                      , t_tasks   = map readops ops } }
  where
    readops (s:ss) = let (oper,rest) = parse_token s
                         (arg,_)     = parse_token rest
                         x  = read arg
                         op = case oper of
                               "Find"   -> Find x
                               "Delete" -> Delete x
                               "Insert" -> Insert x
                               _        -> error ("parse_testdata: " ++ oper ++ "\n" ++ rest ++ "\n" ++ arg)
                     in op:(readops ss)
    readops [] = []

-- Main function for writing test data to file
write_testdata :: Show a => TestData a -> IO ()
write_testdata tc = writeFile (t_name tc) (show tc)


{-# LANGUAGE UndecidableInstances, PatternSignatures, FlexibleInstances, MultiParamTypeClasses #-}

module TestRun (
   run_testdata  -- FilePath -> FilePath -> IO ()
) where

import TestData
import TestDataParser
import Collection

import Control.Monad
import GHC.Conc
import Text.Printf
import Data.List
import Data.IORef
import Control.Concurrent
--import Control.Concurrent.STM
import System.Environment
import Data.Time
import System.Mem
import System.Random
import Control.Exception

-- the contenders
import qualified CASList as CAS
import qualified ImmList as IMM
--import qualified CASusingSTMList as CASusingSTM
import qualified MVarListLockCoupling as MLC
--import qualified MVarusingSTM as MLCusingSTM
--import qualified LazyList2 as Lazy
import qualified IOList as I
--import qualified STMList as S

instance (Eq e, Show e) => Col (CAS.ListHandle e) e where
   newCol = CAS.newList
   insertCol c e = do CAS.addToTail c e
                      return ()
   deleteCol = CAS.delete
   findCol = CAS.find
   printCol = CAS.printList
   cntCol = CAS.cntList

instance (Eq e, Show e) => Col (IMM.ListHandle e) e where
   newCol = IMM.newList
   insertCol c e = do IMM.addToTail c e
                      return ()
   deleteCol = IMM.delete
   findCol = IMM.find
   printCol = IMM.printList
   cntCol = IMM.cntList

--instance (Eq e, Show e) => Col (CASusingSTM.ListHandle e) e where
--   newCol = CASusingSTM.newList
--   insertCol c e = do CASusingSTM.addToTail c e
--                      return ()
--   deleteCol = CASusingSTM.delete
--   findCol = CASusingSTM.find
--   printCol = CASusingSTM.printList
--   cntCol = CASusingSTM.cntList

--instance (Eq e, Show e) => Col (Lazy.ListHandle e) e where
--   newCol = Lazy.newList
--   insertCol c e = do  Lazy.addToTail c e
--                       return ()
--   deleteCol =  Lazy.delete
--   findCol =  Lazy.find
--   printCol =  Lazy.printList
--   cntCol =  Lazy.cntList

instance (Eq e, Show e) => Col (I.ListHandle e) e where
   newCol = I.newList
   insertCol c e = do I.addToTail c e
                      return ()
   deleteCol = I.delete
   findCol = I.find
   printCol = I.printList
   cntCol = I.cntList

--instance (Eq e, Show e) => Col (MLCusingSTM.ListHandle e) e where
--   newCol = MLCusingSTM.newList
--   insertCol c e = do MLCusingSTM.addToTail c e
--                      return ()
--   deleteCol = MLCusingSTM.delete
--   findCol = MLCusingSTM.find
--   printCol = MLCusingSTM.printList
--   cntCol = MLCusingSTM.cntList

instance (Eq e, Show e) => Col (MLC.ListHandle e) e where
   newCol = MLC.newList
   insertCol c e = do MLC.addToTail c e
                      return ()
   deleteCol = MLC.delete
   findCol = MLC.find
   printCol = MLC.printList
   cntCol = MLC.cntList

--instance (Eq e, Show e) => Col (S.ListHandle e) e where
--   newCol = S.newList
--   insertCol c e = do S.addToTail c e
--                      return ()
--   deleteCol = S.delete
--   findCol = S.find
--   printCol = S.printList
--   cntCol = S.cntList

-- Auxiliary functions

createList :: Col c e => [e] -> IO c
createList n =
  do nl <- newCol
     mapM (insertCol nl) n
     return nl

executeTasks :: Col c e => c -> [Op e] -> IO ()
executeTasks lh ops =
 do mapM (\ task ->
          case task of
             Find x -> do { findCol lh x; return () }
             Insert x -> do { insertCol lh x; return () }
             Delete x -> do { deleteCol lh x; return () })
         ops
    return ()

appendIORef :: IORef [a] -> a -> IO ()
appendIORef ref a = do
  { as <- readIORef ref
  ; writeIORef ref (a:as) }

showComma :: [String] -> String
showComma (s:ss) = "," ++ s ++ (showComma ss)
showComma [] = ""

-- Main interface

run_testdata :: FilePath -> String -> IO ()
run_testdata testdata_fname mode = do
    { tc <- parse_testdata testdata_fname
    ; putStrLn "Test Initiated: "
    ; let init_elems = t_init_list tc
          works      = t_tasks tc
    ; medians  <- newIORef []
    ; highlows <- newIORef []
    ; runtests mode init_elems works (medians,highlows)
    }
    where
        runtests m elems works refs =
          case m of
             "CAS"   -> do nl :: CAS.ListHandle Int <- createList elems
                           runtest m works nl refs
             "IMM"   -> do nl :: IMM.ListHandle Int <- createList elems
                           runtest m works nl refs
--             "CASusingSTM"   -> do nl :: CASusingSTM.ListHandle Int <- createList elems
--                                   runtest m works nl refs
--             "LAZY" -> do nl :: Lazy.ListHandle Int <- createList elems
--                          runtest m works nl refs
             "MLC" -> do nl :: MLC.ListHandle Int <- createList elems
                         runtest m works nl refs
--             "MLCusingSTM" -> do nl :: MLCusingSTM.ListHandle Int <- createList elems
--                                 runtest m works nl refs
             "IO" -> do nl  :: I.ListHandle Int <- createList elems
                        runtest m works nl refs
--             "STM" -> do nl  :: S.ListHandle Int <- createList elems
--                         runtest m works nl refs
             trash -> fail $ "Oi! No such concurrency mode: " ++ trash

        runtest m works nl (medians,highlows) = do
          { putStrLn $ "Test Started: " ++ m
          ; performGC
--          ; wait <- atomically (newTVar 0)
          ; wait <- newEmptyMVar
          ; start <- getCurrentTime
          ; zipWithM (\n work -> forkOn n (do { executeTasks nl work
                                              ; putMVar wait () }))
                                              --atomically(do counter <- readTVar wait
--                                                              writeTVar wait (counter+1)) }))
            [0..] works
          ; replicateM_ (length works) (takeMVar wait)
--          ; atomically ( do { counter <- readTVar wait
--                            ; if counter < length works then retry
--                              else return () } )
          ; fin <- getCurrentTime
          ; let result = diffUTCTime fin start
          ; -- printf "time: %.2fs\n" (realToFrac result :: Double)
          ; return () }

        output_fname = "out"

        write_output mod ms mref hlref = do
          { if mod == 1
            then do { writeFile output_fname ""
                    ; output_header output_fname ms
                    ; appendFile output_fname ",,"
                    ; output_header output_fname ms
                    ; appendFile output_fname "\n1Core" }
            else appendFile output_fname ("\n" ++ (show mod) ++ "Cores")
          ; medians  <- readIORef mref
          ; highlows <- readIORef hlref
          ; let mstr = reverse $ map show medians
                hlstr = reverse $ highlows
          ; appendFile output_fname (filter (/='s') (showComma mstr))
          ; appendFile output_fname ",,"
          ; appendFile output_fname (filter (/='s') (showComma hlstr)) }

        output_header output_fname (m:ms) = do
          { appendFile output_fname ("," ++ m)
          ; output_header output_fname ms }
        output_header output_fname [] = return ()

        high_low results =
          let fst = head results
              lst = head $ drop ((length results) - 1) results
          in (fst,lst)


module Main (main) where

import GHC.Conc

main = do
  setAllocationCounter (10*1024)
  enableAllocationLimit
  print (length [1..])


module Main (main) where

import GHC.Conc
import Control.Concurrent
import Control.Exception
import System.Exit

main = do
  m <- newEmptyMVar
  let action =  do setAllocationCounter (10*1024)
                   enableAllocationLimit
                   print (length [1..])
  forkFinally action (putMVar m)
  r <- takeMVar m
  case r of
    Left e | Just AllocationLimitExceeded <- fromException e -> return ()
    _ -> print r >> exitFailure


module Main (main) where

import GHC.Conc
import Control.Concurrent
import Control.Exception

main = do
  setAllocationCounter (10*1024)
  enableAllocationLimit

  -- alloc limit overflow while masked: should successfully print the
  -- result, and then immediately raise the exception
  r <- mask_ $ try $ print (length [1..100000])

  print (r :: Either SomeException ())


module Main (main) where

import GHC.Conc
import Control.Concurrent
import Control.Exception
import System.Exit
import Control.Monad

-- check that +RTS -xq is doing the right thing: the test requires
-- +RTS -xq300k
-- Test does not work in GHCi as it load A Lot Of Things at start

main = do
  m <- newEmptyMVar
  let action = do
         e <- try $ do
          setAllocationCounter (10*1024)
          enableAllocationLimit
          print (length [1..])
         case e of
           Left AllocationLimitExceeded{} -> do
             c <- getAllocationCounter
             when (c < 250*1024 || c > 350*1024) $ fail $ "wrong limit grace: " ++ show c
             print (length [2..])
           Right _ ->
             fail "didn't catch AllocationLimitExceeded"

  forkFinally action (putMVar m)
  r <- takeMVar m
  case r of
    Left e | Just AllocationLimitExceeded <- fromException e -> return ()
    _ -> print r >> exitFailure


import Control.Exception
import Control.Concurrent
import GHC.Conc
import Control.Monad

nfib n = if n < 2 then 1 else nfib (n-2) + nfib (n-1)

main = do
   t <- mask_ $ forkIO $ forM_ [1..] $ \n -> nfib n `seq` allowInterrupt
   killThread t
   let loop = do r <- threadStatus t
                 when (r /= ThreadFinished) $ do yield; loop
   loop


import Control.Exception as E
import Control.Concurrent
import System.IO.Unsafe

-- x is killed during evaluation with an asynchronous exception, but
-- nevertheless gets overwritten with 'throw ThreadKilled' because the
-- async exception is re-thrown as a synchrnonous exception by
-- 'onException'.

main = do
  let x = unsafePerformIO $
             (do threadDelay 1000000; return 42)
             `onException` return ()

  t <- forkIO $ do evaluate x; return ()
  threadDelay 1000
  killThread t

  print x `E.catch` \e -> putStrLn ("main caught: " ++ show (e::SomeException))


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

module Main ( main ) where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (when)
import Foreign.Storable
import GHC.Exts
import GHC.IO

-- | Iterations per worker.
iters :: Int
iters = 1000000

main :: IO ()
main = do
    fetchAddSubTest
    fetchAndTest
    fetchNandTest
    fetchOrTest
    fetchXorTest
    casTest
    readWriteTest

-- | Test fetchAddIntArray# by having two threads concurrenctly
-- increment a counter and then checking the sum at the end.
fetchAddSubTest :: IO ()
fetchAddSubTest = do
    tot <- race 0
        (\ mba -> work fetchAddIntArray mba iters 2)
        (\ mba -> work fetchSubIntArray mba iters 1)
    assertEq 1000000 tot "fetchAddSubTest"
  where
    work :: (MByteArray -> Int -> Int -> IO ()) -> MByteArray -> Int -> Int
         -> IO ()
    work op mba 0 val = return ()
    work op mba n val = op mba 0 val >> work op mba (n-1) val

-- | Test fetchXorIntArray# by having two threads concurrenctly XORing
-- and then checking the result at the end. Works since XOR is
-- commutative.
--
-- Covers the code paths for AND, NAND, and OR as well.
fetchXorTest :: IO ()
fetchXorTest = do
    res <- race n0
        (\ mba -> work mba iters t1pat)
        (\ mba -> work mba iters t2pat)
    assertEq expected res "fetchXorTest"
  where
    work :: MByteArray -> Int -> Int -> IO ()
    work mba 0 val = return ()
    work mba n val = fetchXorIntArray mba 0 val >> work mba (n-1) val

    -- Initial value is a large prime and the two patterns are 1010...
    -- and 0101...
    (n0, t1pat, t2pat)
        | sizeOf (undefined :: Int) == 8 =
            (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
        | otherwise = (0x0000ffff, 0x55555555, 0x99999999)
    expected
        | sizeOf (undefined :: Int) == 8 = 4294967295
        | otherwise = 65535

-- The tests for AND, NAND, and OR are trivial for two reasons:
--
--  * The code path is already well exercised by 'fetchXorTest'.
--
--  * It's harder to test these operations, as a long sequence of them
--    convert to a single value but we'd like to write a test in the
--    style of 'fetchXorTest' that applies the operation repeatedly,
--    to make it likely that any race conditions are detected.
--
-- Right now we only test that they return the correct value for a
-- single op on each thread.

-- | Test an associative operation.
fetchOpTest :: (MByteArray -> Int -> Int -> IO ())
            -> Int -> String -> IO ()
fetchOpTest op expected name = do
    res <- race n0
        (\ mba -> work mba t1pat)
        (\ mba -> work mba t2pat)
    assertEq expected res name
  where
    work :: MByteArray -> Int -> IO ()
    work mba val = op mba 0 val

-- | Initial value and operation arguments for race test.
--
-- Initial value is a large prime and the two patterns are 1010...
-- and 0101...
n0, t1pat, t2pat :: Int
(n0, t1pat, t2pat)
    | sizeOf (undefined :: Int) == 8 =
        (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
    | otherwise = (0x0000ffff, 0x55555555, 0x99999999)

fetchAndTest :: IO ()
fetchAndTest = fetchOpTest fetchAndIntArray expected "fetchAndTest"
  where expected
            | sizeOf (undefined :: Int) == 8 = 286331153
            | otherwise = 4369

-- | Test NAND without any race, as NAND isn't associative.
fetchNandTest :: IO ()
fetchNandTest = do
    mba <- newByteArray (sizeOf (undefined :: Int))
    writeIntArray mba 0 n0
    fetchNandIntArray mba 0 t1pat
    fetchNandIntArray mba 0 t2pat
    res <- readIntArray mba 0
    assertEq expected res "fetchNandTest"
  where expected
            | sizeOf (undefined :: Int) == 8 = 7378697629770151799
            | otherwise = -2576976009

fetchOrTest :: IO ()
fetchOrTest = fetchOpTest fetchOrIntArray expected "fetchOrTest"
  where expected
            | sizeOf (undefined :: Int) == 8 = 15987178197787607039
            | otherwise = 3722313727

-- | Test casIntArray# by using it to emulate fetchAddIntArray# and
-- then having two threads concurrenctly increment a counter,
-- checking the sum at the end.
casTest :: IO ()
casTest = do
    tot <- race 0
        (\ mba -> work mba iters 1)
        (\ mba -> work mba iters 2)
    assertEq 3000000 tot "casTest"
  where
    work :: MByteArray -> Int -> Int -> IO ()
    work mba 0 val = return ()
    work mba n val = add mba 0 val >> work mba (n-1) val

    -- Fetch-and-add implemented using CAS.
    add :: MByteArray -> Int -> Int -> IO ()
    add mba ix n = do
        old <- readIntArray mba ix
        old' <- casIntArray mba ix old (old + n)
        when (old /= old') $ add mba ix n

-- | Tests atomic reads and writes by making sure that one thread sees
-- updates that are done on another. This test isn't very good at the
-- moment, as this might work even without atomic ops, but at least it
-- exercises the code.
readWriteTest :: IO ()
readWriteTest = do
    mba <- newByteArray (sizeOf (undefined :: Int))
    writeIntArray mba 0 0
    latch <- newEmptyMVar
    done <- newEmptyMVar
    forkIO $ do
        takeMVar latch
        n <- atomicReadIntArray mba 0
        assertEq 1 n "readWriteTest"
        putMVar done ()
    atomicWriteIntArray mba 0 1
    putMVar latch ()
    takeMVar done

-- | Create two threads that mutate the byte array passed to them
-- concurrently. The array is one word large.
race :: Int                    -- ^ Initial value of array element
     -> (MByteArray -> IO ())  -- ^ Thread 1 action
     -> (MByteArray -> IO ())  -- ^ Thread 2 action
     -> IO Int                 -- ^ Final value of array element
race n0 thread1 thread2 = do
    done1 <- newEmptyMVar
    done2 <- newEmptyMVar
    mba <- newByteArray (sizeOf (undefined :: Int))
    writeIntArray mba 0 n0
    forkIO $ thread1 mba >> putMVar done1 ()
    forkIO $ thread2 mba >> putMVar done2 ()
    mapM_ takeMVar [done1, done2]
    readIntArray mba 0

------------------------------------------------------------------------
-- Test helper

assertEq :: (Eq a, Show a) => a -> a -> String -> IO ()
assertEq expected actual name
    | expected == actual = putStrLn $ name ++ ": OK"
    | otherwise = do
        putStrLn $ name ++ ": FAIL"
        putStrLn $ "Expected: " ++ show expected
        putStrLn $ "  Actual: " ++ show actual

------------------------------------------------------------------------
-- Wrappers around MutableByteArray#

data MByteArray = MBA (MutableByteArray# RealWorld)

fetchAddIntArray :: MByteArray -> Int -> Int -> IO ()
fetchAddIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchAddIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

fetchSubIntArray :: MByteArray -> Int -> Int -> IO ()
fetchSubIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchSubIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

fetchAndIntArray :: MByteArray -> Int -> Int -> IO ()
fetchAndIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchAndIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

fetchNandIntArray :: MByteArray -> Int -> Int -> IO ()
fetchNandIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchNandIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

fetchOrIntArray :: MByteArray -> Int -> Int -> IO ()
fetchOrIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchOrIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

fetchXorIntArray :: MByteArray -> Int -> Int -> IO ()
fetchXorIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case fetchXorIntArray# mba# ix# n# s# of
        (# s2#, _ #) -> (# s2#, () #)

newByteArray :: Int -> IO MByteArray
newByteArray (I# n#) = IO $ \ s# ->
    case newByteArray# n# s# of
        (# s2#, mba# #) -> (# s2#, MBA mba# #)

writeIntArray :: MByteArray -> Int -> Int -> IO ()
writeIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case writeIntArray# mba# ix# n# s# of
        s2# -> (# s2#, () #)

readIntArray :: MByteArray -> Int -> IO Int
readIntArray (MBA mba#) (I# ix#) = IO $ \ s# ->
    case readIntArray# mba# ix# s# of
        (# s2#, n# #) -> (# s2#, I# n# #)

atomicWriteIntArray :: MByteArray -> Int -> Int -> IO ()
atomicWriteIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# ->
    case atomicWriteIntArray# mba# ix# n# s# of
        s2# -> (# s2#, () #)

atomicReadIntArray :: MByteArray -> Int -> IO Int
atomicReadIntArray (MBA mba#) (I# ix#) = IO $ \ s# ->
    case atomicReadIntArray# mba# ix# s# of
        (# s2#, n# #) -> (# s2#, I# n# #)

casIntArray :: MByteArray -> Int -> Int -> Int -> IO Int
casIntArray (MBA mba#) (I# ix#) (I# old#) (I# new#) = IO $ \ s# ->
    case casIntArray# mba# ix# old# new# s# of
        (# s2#, old2# #) -> (# s2#, I# old2# #)


{-# Language MagicHash, UnboxedTuples  #-}

-- | Note: extensive testing of atomic operations is performed in the
-- "atomic-primops" library.  Only extremely rudimentary tests appear
-- here.

import GHC.IO
import GHC.IORef
import GHC.ST
import GHC.STRef
import GHC.Prim
import GHC.Base
import Data.Primitive.Array
import Data.IORef
import Control.Monad

------------------------------------------------------------------------

casArrayST :: MutableArray s a -> Int -> a -> a -> ST s (Bool, a)
casArrayST (MutableArray arr#) (I# i#) old new = ST$ \s1# ->
  case casArray# arr# i# old new s1# of
    (# s2#, x#, res #) -> (# s2#, (isTrue# (x# ==# 0#), res) #)

casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'
         -> a -- ^ The 'old' value to compare
         -> a -- ^ The 'new' value to replace 'current' if @old == current@
         -> ST s (Bool, a)
casSTRef (STRef var#) old new = ST $ \s1# ->
   -- The primop treats the boolean as a sort of error code.
   -- Zero means the CAS worked, one that it didn't.
   -- We flip that here:
    case casMutVar# var# old new s1# of
      (# s2#, x#, res #) -> (# s2#, (isTrue# (x# ==# 0#), res) #)

-- | Performs a machine-level compare and swap operation on an
-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a
-- swap is performed, along with the 'current' value from the 'IORef'.
--
-- Note \"compare\" here means pointer equality in the sense of
-- 'GHC.Prim.reallyUnsafePtrEquality#'.
casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'
         -> a -- ^ The 'old' value to compare
         -> a -- ^ The 'new' value to replace 'current' if @old == current@
         -> IO (Bool, a)
casIORef (IORef var) old new = stToIO (casSTRef var old new)

------------------------------------------------------------------------
-- Make sure this Int corresponds to a single object in memory (NOINLINE):
{-# NOINLINE mynum #-}
mynum :: Int
mynum = 33

main = do
  putStrLn "Perform a CAS within an IORef"
  ref  <- newIORef mynum
  res  <- casIORef ref mynum 44
  res2 <- casIORef ref mynum 44
  putStrLn$ "  1st try should succeed: "++show res
  putStrLn$ "  2nd should fail: "++show res2

  ------------------------------------------------------------
  putStrLn "Perform a CAS within a MutableArray#"
  arr <- newArray 5 mynum

  res  <- stToIO$ casArrayST arr 3 mynum 44
  res2 <- stToIO$ casArrayST arr 3 mynum 44
  putStrLn$ "  1st try should succeed: "++show res
  putStrLn$ "  2nd should fail: "++show res2

  putStrLn "Printing array:"
  forM_ [0..4] $ \ i -> do
    x <- readArray arr i
    putStr ("  "++show x)
  putStrLn ""

  ------------------------------------------------------------
  putStrLn "Done."


module Main where

import Control.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 Control.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 Control.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 Control.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 100000
   takeMVar mvar
   putStr "done"


module Main where

import Control.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"


module Main where

import Control.Concurrent
import Control.Exception as E

choose :: a -> a -> IO a
choose a b = do
   ready <- newMVar ()
   answer <- newEmptyMVar
   a_id <- forkIO (a `seq` takeMVar ready >> putMVar answer a)
   b_id <- forkIO (b `seq` takeMVar ready >> putMVar answer b)
   it <- takeMVar answer
   killThread a_id
   killThread b_id
   return it

main = do
   let big = sum [1..]
       small = sum [1..42]
   test1 <- choose big small
   test2 <- choose small big
   print (test1,test2)


module Main where

import Control.Concurrent
import Control.Exception

-- Send ourselves a KillThread signal, catch it and recover.

main = do
  id <- myThreadId
  Control.Exception.catch (killThread id) $
     \e -> putStr (show (e::SomeException))


module Main where

import Control.Concurrent
import Control.Exception

main = do
  id <- myThreadId
  throwTo id (ErrorCall "hello")


module Main where

import Control.Concurrent
import Control.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 (Control.Exception.catch (putMVar ready () >> takeMVar block)
                (\e -> putStr (show (e::SomeException)) >> putMVar ready2 ()))
  takeMVar ready
  throwTo id (ErrorCall "hello")
  takeMVar ready2


module Main where

import Control.Concurrent
import Control.Exception
--import GlaExts

data Result = Died SomeException | Finished

-- Test stack overflow catching.  Should print "Died: stack overflow".

stackoverflow :: Int -> Int
stackoverflow 0 = 1
stackoverflow n = n + stackoverflow n

main = do
  let x = stackoverflow 1
  result <- newEmptyMVar
  forkIO $ Control.Exception.catch (evaluate x >> putMVar result Finished) $
                     \e -> putMVar result (Died e)
  res <- takeMVar result
  case res of
        Died e -> putStr ("Died: " ++ show e ++ "\n")
        Finished -> putStr "Ok.\n"


module Main where

-- !!! test Eq and Ord instances over thread Ids.

import Control.Concurrent

main = do
  tso1 <- forkIO (return ())
  tso2 <- forkIO (return ())
  print [compare tso1 tso2, compare tso1 tso1, compare tso2 tso1]


import Control.Concurrent
import Control.Exception

-- Test blocking of async exceptions in an exception handler.
-- The exception raised in the main thread should not be delivered
-- until the first exception handler finishes.
main = do
  main_thread <- myThreadId
  m <- newEmptyMVar
  forkIO (do { takeMVar m;  throwTo main_thread (ErrorCall "foo") })
  (do { throwIO (ErrorCall "wibble")
          `Control.Exception.catch`
            (\e -> let _ = e::ErrorCall in
                   do putMVar m (); evaluate (sum [1..10000]); putStrLn "done.")
       ; myDelay 500000 })
    `Control.Exception.catch`
       \e -> putStrLn ("caught: " ++ show (e::SomeException))

-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
  m <- newEmptyMVar
  forkIO $ do threadDelay usec; putMVar m ()
  takeMVar m


import Control.Concurrent
import Control.Exception

-- test blocking & unblocking of async exceptions.

-- the first exception "foo" should be caught by the "caught1" handler,
-- since async exceptions are blocked outside this handler.

-- the second exception "bar" should be caught by the outer "caught2" handler,
-- (i.e. this tests that async exceptions are properly unblocked after
-- being blocked).

main = do
  main_thread <- myThreadId
  print =<< getMaskingState -- False
  m <- newEmptyMVar
  m2 <- newEmptyMVar
  forkIO (do takeMVar m
             throwTo main_thread (ErrorCall "foo")
             throwTo main_thread (ErrorCall "bar")
             putMVar m2 ()
         )
  ( do
    mask $ \restore -> do
        putMVar m ()
        print =<< getMaskingState -- True
        sum [1..1] `seq` -- give 'foo' a chance to be raised
          (restore $ myDelay 500000)
                `Control.Exception.catch`
                    \e -> putStrLn ("caught1: " ++ show (e::SomeException))
    threadDelay 10000
    takeMVar m2
   )
    `Control.Exception.catch`
       \e -> do print =<< getMaskingState
                putStrLn ("caught2: " ++ show (e::SomeException))

-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
  m <- newEmptyMVar
  forkIO $ do threadDelay usec; putMVar m ()
  takeMVar m


import Control.Concurrent
import Control.Exception

-- version of conc015 using mask in place of the old deprecated
-- block/unblock.

-- test blocking & unblocking of async exceptions.

-- the first exception "foo" should be caught by the "caught1" handler,
-- since async exceptions are blocked outside this handler.

-- the second exception "bar" should be caught by the outer "caught2" handler,
-- (i.e. this tests that async exceptions are properly unblocked after
-- being blocked).

main = do
  main_thread <- myThreadId
  print =<< getMaskingState
  m <- newEmptyMVar
  m2 <- newEmptyMVar
  forkIO (do takeMVar m
             throwTo main_thread (ErrorCall "foo")
             throwTo main_thread (ErrorCall "bar")
             putMVar m2 ()
         )
  ( do
    mask $ \restore -> do
        putMVar m ()
        print =<< getMaskingState
        sum [1..100000] `seq` -- give 'foo' a chance to be raised
          (restore (myDelay 500000)
                `Control.Exception.catch`
                    \e -> putStrLn ("caught1: " ++ show (e::SomeException)))

    threadDelay 10000
    takeMVar m2
   )
    `Control.Exception.catch`
       \e -> do print =<< getMaskingState
                putStrLn ("caught2: " ++ show (e::SomeException))

-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
  m <- newEmptyMVar
  forkIO $ do threadDelay usec; putMVar m ()
  takeMVar m


import Control.Concurrent
import Control.Exception

-- check that we can still kill a thread that is blocked on
-- delivering an exception to us.

-- NB. this test is non-deterministic in the threaded2 way since 6.14,
-- because throwTo is now always interruptible, so the main thread's
-- killThread can be legitimately interrupted by the child thread's
-- killThread, rather than the other way around.  This happens because
-- the child thread is running on another processor, so the main
-- thread's throwTo is blocked waiting for a response, and while
-- waiting it is interruptible.

main = do
  main_thread <- myThreadId
  m <- newEmptyMVar
  sub_thread <- forkIO (do
                         takeMVar m
                         throwTo main_thread (ErrorCall "foo")
                        )
  mask_ $ do
    putMVar m ()
    sum [1..10000] `seq` -- to be sure the other thread is now blocked
      killThread sub_thread

  putStrLn "ok"


import Control.Concurrent
import Control.Exception

-- check that async exceptions are restored to their previous
-- state after an exception is raised and handled.

main = do
  main_thread <- myThreadId
  m1 <- newEmptyMVar
  m2 <- newEmptyMVar
  m3 <- newEmptyMVar
  forkIO (do
             takeMVar m1
             throwTo main_thread (ErrorCall "foo")
             takeMVar m2
             throwTo main_thread (ErrorCall "bar")
             putMVar m3 ()
         )
  (do
    mask $ \restore -> do
        (do putMVar m1 ()
            restore (
                -- unblocked, "foo" delivered to "caught1"
               myDelay 100000
             )
         ) `Control.Exception.catch`
              \e -> putStrLn ("caught1: " ++ show (e::SomeException))
        putMVar m2 ()
        -- blocked here, "bar" can't be delivered
        (sum [1..10000] `seq` return ())
          `Control.Exception.catch`
              \e -> putStrLn ("caught2: " ++ show (e::SomeException))
    -- unblocked here, "bar" delivered to "caught3"
    takeMVar m3
   )
   `Control.Exception.catch`
       \e -> putStrLn ("caught3: " ++ show (e::SomeException))

-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
  m <- newEmptyMVar
  forkIO $ do threadDelay usec; putMVar m ()
  takeMVar m


import Control.Concurrent
import Control.Exception
import GHC.Conc
import Foreign

-- test that putMVar blocks on a full MVar rather than raising an
-- exception.

main = do
     -- In this test we want a thread to get BlockedIndefinitely; that
     -- can't be the main thread because in GHCi the main thread
     -- doesn't get BlockedIndefinitely.  So we have to use a
     -- subthread, and "prevent* the main thread from getting
     -- BlockedIndefinitely when we're not in GHCi, which is what the
     -- following hack does:
  myThreadId >>= newStablePtr

  m <- newEmptyMVar
  t <- forkIO $ do
            Control.Exception.catch (do
                m <- newMVar ()
                putMVar m ()
             )
             (\e -> putMVar m (e::SomeException))
  takeMVar m >>= print
  -- should print "thread blocked indefinitely"


import Control.Concurrent
import Control.Exception
import Data.List
import System.Mem

-- !!! test that a child thread waiting on its own MVar will get killed by
-- a signal.

main = do
  forkIO (Control.Exception.catch (do { m <- newEmptyMVar; takeMVar m })
                $ \e -> putStrLn ("caught: " ++ show (e::SomeException)))
  threadDelay 10000
  System.Mem.performGC
  threadDelay 10000


import Control.Concurrent
import Control.Exception

main = do
  m <- newEmptyMVar
  t <- forkIO (mask_ $ takeMVar m)
  threadDelay 100000
  throwTo t (ErrorCall "I'm Interruptible")
  threadDelay 100000
  putMVar m ()  -- to avoid t being garbage collected


{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

-- !!! test for uncaught exception

foreign export ccall foo :: Int -> IO Int
foreign import ccall safe "foo" foo_imported :: Int -> IO Int

foo n = error "wurble"

main = foo_imported 3


{-# LANGUAGE MagicHash #-}
-- !!! test tryTakeMVar

import Control.Concurrent
import Control.Exception

import GHC.Exts         ( fork# )
import GHC.IO           ( IO(..) )
import GHC.Conc         ( ThreadId(..) )

main = do
  m <- newEmptyMVar
  r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
  print (r :: Maybe Int)

  m <- newMVar True
  r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
  print r

timeout
   :: Int       -- secs
   -> IO a      -- action to run
   -> IO a      -- action to run on timeout
   -> IO a

timeout secs action on_timeout
  = do
    threadid <- myThreadId
    timeout <- forkIO $ do threadDelay (secs * 1000000)
                           throwTo threadid (ErrorCall "__timeout")
    ( do result <- action
         killThread timeout
         return result
      )
      `Control.Exception.catch`
        \exception -> case fromException exception of
                       Just (ErrorCall "__timeout") -> on_timeout
                       _other -> do killThread timeout
                                    throw exception


{-# LANGUAGE ScopedTypeVariables #-}
-- !!! test threadDelay, Random, and QSemN.

-- start a large number (n) of threads each of which will wait for a
-- random delay between 0 and m seconds.  We use a semaphore to wait
-- for all the threads to finish.

import System.Random
import Control.Concurrent
import Control.Exception
import Control.Monad

n = 5000  -- no. of threads
m = 3000  -- maximum delay

main = do
   v <- newEmptyMVar
   is <- replicateM n $ getStdRandom (randomR (1,m))
   mapM_ (fork_sleep v) is
   replicateM_ n (takeMVar v)
   where
     fork_sleep v i = forkIO $ do threadDelay (i*1000); putMVar v ()


{-# LANGUAGE CPP #-}
module Main where

import Control.Exception
import Control.Concurrent
import System.Mem

-- illustrates the BlockOnDeadMVar exception

main = do
  id <- myThreadId
  forkIO (catch (do m <- newEmptyMVar; takeMVar m)
                (\e -> throwTo id (e::SomeException)))
  catch (do yield; performGC; threadDelay 1000000)
        (\e -> print (e::SomeException))


-- !!! Simple test of dupChan
-- Embarrassingly, the published version fails!

module Main where

import Control.Exception
import Control.Concurrent.Chan

main = do
          chan <- newChan
          ch <- dupChan chan
          writeChan chan "done"
          x <- readChan chan
          y <- readChan ch
          print ("Got "++x ++" "++y)


-- test for blocking putMVar

import Control.Concurrent

main = do
  m <- newMVar ()
  forkIO (threadDelay 100000 >> takeMVar m)
  putMVar m ()


import Control.Concurrent

main = do
  m <- newEmptyMVar
  end <- newEmptyMVar
  forkIO (sequence_ [ putMVar m () | _ <- [1 .. 10000] ])
  forkIO (sequence_ [ takeMVar m   | _ <- [1 .. 10000] ] >> putMVar end ())
  takeMVar end


-- test tryPutMVar

import Control.Concurrent

main = do
  m <- newMVar ()
  r <- tryPutMVar m ()
  print r
  takeMVar m
  r <- tryPutMVar m ()
  print r


{-# LANGUAGE CPP #-}
module Main where

import Control.Exception
import Control.Concurrent

-- the BlockOnDeadMVar exception doesn't cause any output by default

main = do
  forkIO (do m <- newEmptyMVar; takeMVar m)
  print (sum [1..10000])


{-# LANGUAGE CPP #-}
module Main where

import Control.Exception
import Control.Concurrent

-- the ThreadKilled exception doesn't cause any output by default

main = do
  m <- newEmptyMVar
  id <- forkIO (takeMVar m)
  yield
  killThread id
  putMVar m ()
  print (sum [1..50000])


import Control.Concurrent
import Control.Exception
import System.Mem ( performGC )
import System.Mem.Weak ( addFinalizer )

data P = P (MVar Bool)

-- Bug reported by Manuel Chakravarty, namely that we weren't checking
-- for runnable finalizers before declaring that the program is
-- deadlocked.

main = do
--  gcThread  -- with this thread enabled, no error
  mv <- newEmptyMVar
  let p = P mv
  addFinalizer p (set p)
  takeMVar mv >>= print
  putStrLn "End."
  where
    set (P mv) = putMVar mv True
    --
    -- this is just to demonstrate that it is only about the GC timing
    --
    gcThread = forkIO $ let gc = do
                                   putStrLn "delay"
                                   threadDelay 100000
                                   putStrLn "gc"
                                   performGC
                                   gc
                        in gc


-- !!! this test exposed a bug in the take/putMVar implementation in
-- !!! GHC 5.00.  It involves multiple blocking takes & puts on the
-- !!! same MVar.

import Control.Concurrent
import System.IO.Unsafe

awk True  True  z     = 1
awk False y     True  = 2
awk x     False False = 3

awk'1 True  True  z     = 1
awk'2 False y     True  = 2
awk'3 x     False False = 3

awk' x y z | ppm [a1'1,a1'2,a1'3] (x,y,z) = awk'1 x y z
           | ppm [a2'1,a2'2,a2'3] (x,y,z) = awk'2 x y z
           | ppm [a3'1,a3'2,a3'3] (x,y,z) = awk'3 x y z
           | otherwise                      = 0

a1'1 (True,y,z)  s = s True
a1'1 (x,y,z)     s = s False

a1'2 (x,True,z)  s = s True
a1'2 (x,y,z)     s = s False

a1'3 (x,y,z)     s = s True

a2'1 (False,y,z) s = s True
a2'1 (x,y,z)     s = s False

a2'2 (x,y,z)     s = s True

a2'3 (x,y,True)  s = s True
a2'3 (x,y,z)     s = s False

a3'1 (x,y,z)     s = s True

a3'2 (x,False,z) s = s True
a3'2 (x,y,z)     s = s False

a3'3 (x,y,False) s = s True
a3'3 (x,y,z)     s = s False

ppm fs as = unsafePerformIO (ppm' fs as)

ppm' fs as = do m <- newEmptyMVar
                let s = putMVar m
                hs <- sequence [forkIO (f as s)|f <- fs]
                result <- assess (length fs) m
                sequence (map killThread hs)
                return result
                  where assess 0 m = return True
                        assess n m = do h <- takeMVar m
                                        if h then (assess (n-1) m)
                                             else return False

main = do sequence [putStrLn (show (awk' x y z))|(x,y,z) <- args]
            where args = [
                          (t,t,t),
                          (t,t,f),
                          (t,f,t),
                          (t,f,f),
                          (f,t,t),
                          (f,t,f),
                          (f,f,t),
                          (f,f,f),
                          (t,t,n)
                          --(f,n,t),
                          --(n,f,f),
                         ]
                  t    = True
                  f    = False
                  n    = odd (last [1..])


import Control.Concurrent
import Control.Exception

-- !!! test that deadlock is raised as an exception properly
main = do
  r <- Control.Exception.try $ do
          m <- newEmptyMVar
          takeMVar m
          return ()
  print (r::Either SomeException ())


{-# LANGUAGE CPP #-}
import Control.Concurrent
import Control.Exception
import Foreign

import System.IO (hFlush,stdout)

-- !!! Try to get two threads into a knot depending on each other.

-- This should result in the main thread being sent a NonTermination
-- exception (in GHC 5.02, the program is terminated with "no threads
-- to run" instead).

main = do
  Foreign.newStablePtr stdout
        -- HACK, because when these two threads get blocked on each other,
        -- there's nothing keeping stdout alive so it will get finalized.
        -- SDM 12/3/2004
  let a = last ([1..10000] ++ [b])
      b = last ([2..10000] ++ [a])
        -- we have to be careful to ensure that the strictness analyser
        -- can't see that a and b are both bottom, otherwise the
        -- simplifier will go to town here, resulting in something like
        -- a = a and b = a.
  forkIO (print a `catch` \NonTermination -> return ())
        -- we need to catch in the child thread too, because it might
        -- get sent the NonTermination exception first.
  r <- Control.Exception.try (print b)
  print (r :: Either NonTermination ())


module Main where

import Control.Concurrent
import qualified Control.Exception as E

trapHandler :: MVar Int -> MVar () -> IO ()
trapHandler inVar caughtVar =
  (do E.mask_ $ do
          trapMsg <- takeMVar inVar
          putStrLn ("Handler got: " ++ show trapMsg)
      trapHandler inVar caughtVar
  )
  `E.catch`
  (trapExc inVar caughtVar)

trapExc :: MVar Int -> MVar () -> E.SomeException -> IO ()
-- If we have been killed then we are done
trapExc inVar caughtVar  e
  | Just E.ThreadKilled <- E.fromException e  = return ()
-- Otherwise...
trapExc inVar caughtVar e =
  do putStrLn ("Exception: " ++ show e)
     putMVar caughtVar ()
     trapHandler inVar caughtVar

main :: IO ()
main = do
  inVar <- newEmptyMVar
  caughtVar <- newEmptyMVar
  tid <- forkIO (trapHandler inVar caughtVar)
  yield
  putMVar inVar 1
  threadDelay 1000
  throwTo tid (E.ErrorCall "1st")
  takeMVar caughtVar
  putMVar inVar 2
  threadDelay 1000
  throwTo tid (E.ErrorCall "2nd")
        -- the second time around, exceptions will be blocked, because
        -- the trapHandler is effectively "still in the handler" from the
        -- first exception.  I'm not sure if this is by design or by
        -- accident.  Anyway, the trapHandler will at some point block
        -- in takeMVar, and thereby become interruptible, at which point
        -- it will receive the second exception.
  takeMVar caughtVar
  -- Running the GHCi way complains that tid is blocked indefinitely if
  -- it still exists, so kill it.
  killThread tid
  putStrLn "All done"


{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS -cpp #-}
module Main where

import Control.Concurrent
import Control.Exception
import Prelude hiding (catch)
import Foreign
import System.IO

#ifdef mingw32_HOST_OS
sleep n = sleepBlock (n*1000)
foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
#else
sleep n = sleepBlock n
foreign import ccall unsafe "sleep" sleepBlock :: Int -> IO ()
#endif

main :: IO ()
main = do
  newStablePtr stdout -- prevent stdout being finalized, sigh
  th <- newEmptyMVar
  forkIO $ do
     putStrLn "newThread started"
     sleep 1
     putMVar th "child"
  threadDelay 500000
  yield -- another hack, just in case child yields right after "sleep 1"
  putMVar th "main" `catch` (\BlockedIndefinitelyOnMVar -> return ())
        -- tests that the other thread doing an unsafe call to
        -- sleep(3) has blocked this thread.  Not sure if this
        -- is a useful test.
  x <- takeMVar th
  putStrLn x
  putStrLn "\nshutting down"


{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Control.Concurrent

#ifdef mingw32_HOST_OS
foreign import stdcall safe "Sleep" _sleepBlock :: Int -> IO ()
sleepBlock n = _sleepBlock (n*1000)
#else
foreign import ccall safe "sleep" sleepBlock :: Int -> IO ()
#endif

main :: IO ()
main = do
  th <- newEmptyMVar
  forkIO $ do
     putStrLn "newThread started"
     sleepBlock 1
     putStrLn "newThread back again"
     putMVar th "1 sec later"
  threadDelay 200000  -- make sure the newly created thread is run.
  putStrLn "mainThread"
  x <- takeMVar th
  putStrLn x
  putStrLn "\nshutting down"


{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Control.Concurrent

haskellFun :: Int -> IO ()
haskellFun c = putStrLn ("Haskell: " ++ show c)

foreign export ccall "hFun"  haskellFun :: Int -> IO ()
foreign import ccall safe "hFun"  hFun :: Int -> IO ()

#ifdef mingw32_HOST_OS
foreign import stdcall safe "Sleep" _sleepBlock :: Int -> IO ()
sleepBlock n = _sleepBlock (n*1000)
#else
foreign import ccall safe "sleep" sleepBlock :: Int -> IO ()
#endif

main :: IO ()
main = do
  th <- newEmptyMVar
  forkIO $ do
     putStrLn "newThread started"
     sleepBlock 1
     putStrLn "newThread back again"
     putMVar th "1 sec later"
  threadDelay 500000 >> putStrLn "mainThread"
        -- this will not be blocked in the threaded RTS
  forkIO $ (hFun 2)
        -- neither will this
  x <- takeMVar th
  putStrLn x
  putStrLn "\nshutting down"


{-# LANGUAGE ForeignFunctionInterface #-}

import Foreign
import System.IO.Unsafe
import System.Mem
import Control.Concurrent

foreign export ccall "performGC_" performGC' :: IO ()
performGC' = do putMVar m (); yield; performGC

foreign import ccall "performGC_" f :: IO ()

{-# NOINLINE m #-}
m = unsafePerformIO newEmptyMVar

main = do
  forkIO f
  takeMVar m

-- This tests for a bug in the garbage collector, whereby a main
-- thread that has completed may be GC'd before its return value is
-- propagated back to the caller of rts_evalIO().
--
-- The sequence we hope to create is:
--      - main thread (1) forks off thread (2)
--      - thread (2) invokes new main thread (3) via a 'safe' ccall
--      - thread (3) yields to thread (1)
--      - thread (1) completes, but cannot return yet because (3)
--        is the current main thread (unless we
--        are in SMP or RTS_SUPPORTS_THREADS mode)
--      - thread (3) invokes a GC
--      - thread (1) is GC'd, unless we're careful!


{-# LANGUAGE ForeignFunctionInterface #-}

import Foreign
import Data.IORef
import Control.Concurrent
import Control.Exception
import System.IO.Unsafe

foreign import ccall "wrapper"
  wrap :: IO () -> IO (FunPtr (IO ()))

foreign import ccall "dynamic"
  invoke :: FunPtr (IO ()) -> IO ()

{-# NOINLINE m #-}
m :: IORef ThreadId
m = unsafePerformIO (newIORef (error "m"))

main = do
  id <- myThreadId
  writeIORef m id
  raise' <- wrap raise
  invoke raise'

raise = do
  id <- readIORef m
  me <- myThreadId
  forkIO $ do threadDelay 10000; throwTo me (ErrorCall "timeout")
  throwTo id (ErrorCall "kapow!")


module Main where

import GHC.Conc

-- Create a new TVar and never use it
main = do
  putStr "Before\n"
  t <- atomically ( newTVar 42 )
  putStr "After\n"


module Main where

import GHC.Conc

-- Create a new TVar and check that it contains the expected value
main = do
  putStr "Before\n"
  t <- atomically ( newTVar 42 )
  r <- atomically ( readTVar t )
  putStr ("After " ++ (show r) ++ "\n")


module Main where

import GHC.Conc

-- Create a new TVar, update it and check that it contains the expected value after the
-- transaction
main = do
  putStr "Before\n"
  t <- atomically ( newTVar 42 )
  atomically ( writeTVar t 17 )
  r <- atomically ( readTVar t )
  putStr ("After " ++ (show r) ++ "\n")


module Main where

import GHC.Conc

-- Create a new TVar, update it and check that it contains the expected value within
-- the transaction
main = do
  putStr "Before\n"
  t <- atomically ( newTVar 42 )
  r <- atomically ( do writeTVar t 17
                       readTVar t)
  putStr ("After " ++ (show r) ++ "\n")


module Main where

import GHC.Conc
import Control.Concurrent

snapshot t1 t2 = atomically ( do v1 <- readTVar t1
                                 v2 <- readTVar t2
                                 return (v1, v2) )

twiddle mv _ _ 0 = putMVar mv ()
twiddle mv t1 t2 n = do atomically ( do v1 <- readTVar t1
                                        v2 <- readTVar t2
                                        writeTVar t2 (v1+1)
                                        writeTVar t1 (v2+1) )
                        twiddle mv t1 t2 (n-1)

-- Contended updates to a pair of TVars
main = do
  putStr "Before\n"
  (t1,t2) <- atomically ( do t1 <- newTVar 0
                             t2 <- newTVar 1
                             return (t1, t2))

  -- MVars used to signal completion
  t1c <- newEmptyMVar
  t2c <- newEmptyMVar

  forkIO (twiddle t1c t1 t2 1000)
  forkIO (twiddle t2c t1 t2 1000)

  -- Wait for threads to exit
  takeMVar t1c
  takeMVar t2c

  -- Display final state
  (r1,r2) <- snapshot t1 t2
  putStr ("After " ++ (show r1) ++ " , " ++ (show r2) ++ "\n")


module Main (main) where

import System.Environment
import Control.Concurrent
import Control.Monad

-----------------------------------------------------------------------------
-- test MVar throughput between the main thread and a child thread

-- This test runs quite slowly on the threaded/SMP RTS vs. the normal RTS,
-- because the main thread and child thread are run by different OS threads,
-- so each MVar communication requires real OS thread switching.
--
-- Figures I get are about a factor of 10 difference in speed, at GHC 6.5.

main = chanTest 300000

chanTest :: Int -> IO ()
chanTest n = do
  chan <- newEmptyMVar
  forkIO (writer chan n)
  reader chan n

reader chan 0 = return ()
reader chan n = do
  takeMVar chan
  reader chan (n-1)

writer chan 0 = return ()
writer chan n = do
  putMVar chan ()
  writer chan (n-1)


import Control.Concurrent
import Control.Exception

-- variation on conc020 that tests for threadDelay being interruptible.
-- On Windows, with the threaded RTS, in 6.6 and earlier, threadDelay is
-- not interruptible.
main = do
  m <- newEmptyMVar
  t <- forkIO (mask_ $ threadDelay 1000000)
  threadDelay 100000
  throwTo t (ErrorCall "I'm Interruptible")
  threadDelay 100000
  putMVar m ()  -- to avoid t being garbage collected


{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Test where

import Control.Concurrent
import Control.Monad
import Foreign.C

-- See also conc059_c.c
--
-- This test fires off some threads that will return after the RTS has
-- shut down.  This should not crash or confuse the RTS.

f :: Int -> IO ()
f x = do
  print x
  replicateM_ 10 $ forkIO $ do usleep (fromIntegral x); putStrLn "hello"
  return ()

foreign export ccall "f" f :: Int -> IO ()

#ifdef mingw32_HOST_OS
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif

foreign import WINDOWS_CCONV safe "Sleep" _sleep :: Int -> IO ()
usleep n = _sleep (n `quot` 1000)
#else
foreign import ccall safe "usleep" usleep  :: Int -> IO ()
#endif


-- test for bug #1067

import Control.Concurrent
import Control.Exception

main = do
         master <- myThreadId
         test master 10
         -- make sure we catch a final NonTermination exception to get
         -- a consistent result.
         threadDelay (10 * one_second)

test tid 0 = return ()
test tid n = do
  e <- try threads
  case e of
    Left NonTermination -> test tid (n-1)
    Right _ -> return ()
 where
    threads = do sequence $ replicate 3 $
                         forkIO $ do t <- myThreadId
                                     --putStrLn ("Start " ++ show t)
                                     threadDelay one_second
                                     --putStrLn ("End " ++ show t)
                                     throwTo tid NonTermination
                                     --putStrLn ("Thrown " ++ show t)
                 threadDelay (10 * one_second)

one_second :: Int
one_second = 100000


-- Test for bug #1047

import Control.Concurrent
import Control.Exception

-- This loop spends most of its time printing stuff, and very occasionally
-- pops outside 'block'.  This test ensures that a thread trying to
-- throwTo this thread will eventually succeed.
loop = mask_ (print "alive") >> loop

main = do tid <- forkIO loop
          threadDelay 1
          killThread tid


-- Test for bug #1047

import Control.Concurrent
import Control.Exception

-- This loop spends most of its time printing stuff, and very occasionally
-- executes 'unblock (return ())'.  This test ensures that a thread waiting
-- to throwTo this thread is not blocked indefinitely.
loop restore = do restore (return ()); print "alive"; loop restore

main = do tid <- forkIO (mask $ \restore -> loop restore)
          yield
          killThread tid


-- Test for bug #418

module Main where

import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)

main = do
    v <- newEmptyMVar
    a <- unsafeInterleaveIO (readMVar v)
    t <- forkIO (print a)
    threadDelay (100*1000)
    killThread t
    forkIO $ print a
    putMVar v ()


import Control.Concurrent
import Control.Exception
import GHC.Conc

-- test forkBlockIO
main = do
  main_thread <- myThreadId
  m <- newEmptyMVar
  sub_thread <- mask_ $ forkIO $
                      sum [1..100000] `seq`
                          throwTo main_thread (ErrorCall "foo")
  killThread sub_thread
  putStrLn "oops"


import Control.Concurrent
import Control.Exception

main = do
  -- stat -- main thread is not bound in GHCi
  m <- newEmptyMVar
  forkIO (do stat; putMVar m ())
  takeMVar m
  mask_ $ forkIO (do stat; putMVar m ())
  takeMVar m
  forkOS (do stat; putMVar m ())
  takeMVar m
  mask_ $ forkOS (do stat; putMVar m ())
  takeMVar m

stat = do
  x <- isCurrentThreadBound
  y <- getMaskingState
  print (x,y)


import Control.Concurrent
import GHC.Conc
import Data.List
import Data.Maybe

main = do
  t1 <- forkIO (threadDelay 100000000)
  m <- newEmptyMVar
  t2 <- forkIO (takeMVar m)
  t3 <- forkIO (let loop = do r <- tryTakeMVar m;
                              _ <- newEmptyMVar -- do some allocation :(
                              if isNothing r then loop else return ()
                in loop)
  t4 <- forkIO (return ())
  yield
  threadDelay 10000
  print =<< mapM threadStatus [t1,t2,t3,t4]
  putMVar m ()


module Main where

import Control.Concurrent

main = do
  t <- forkIO (return ())
  threadCapability t >>= print
  t <- forkOn 0 (return ())
  threadCapability t >>= print
  t <- forkOn 1 (return ())
  threadCapability t >>= print


module Main where

import Control.Concurrent

main = do
  t <- forkOn 0 (return ())
  threadCapability t >>= print
  t <- forkOn 1 (return ())
  threadCapability t >>= print


import Control.Exception
import Control.Concurrent

main = do
  m1 <- newEmptyMVar
  m2 <- newEmptyMVar
  t <- forkIO $ do
    mask_ $ return ()
    throwIO (ErrorCall "test") `catch`
       \e -> do
         let _ = e::SomeException
         print =<< getMaskingState
         putMVar m1 ()
         takeMVar m2
  takeMVar m1
  killThread t
   -- in GHC 7.2 and earlier this call will deadlock due to bug #4988.
   -- However, the RTS will resurrect the child thread, and in doing
   -- so will unblock the main thread, so the main thread doesn't get
   -- a BlockedIndefinitely exception.


{-# LANGUAGE CPP,ForeignFunctionInterface,InterruptibleFFI #-}
module Main where

import Control.Concurrent
import Control.Exception
import Foreign
import System.IO

#ifdef mingw32_HOST_OS
sleep n = sleepBlock (n*1000)
foreign import stdcall interruptible "Sleep" sleepBlock :: Int -> IO ()
#else
sleep n = sleepBlock n
foreign import ccall interruptible "sleep" sleepBlock :: Int -> IO ()
#endif

main :: IO ()
main = do
  newStablePtr stdout -- prevent stdout being finalized
  th <- newEmptyMVar

  tid <- forkIO $ do
     putStrLn "newThread started"
     (sleep 2 >> putStrLn "fail") `catch` (\ThreadKilled -> putStrLn "pass")
     putMVar th "child"

  -- if the killThread below gets blocked for more than a second, then
  -- this thread will kill the main thread and the test will fail.
  main <- myThreadId
  forkIO $ do threadDelay 1000000; throwTo main (ErrorCall "still waiting")

  yield
  threadDelay 500000
  killThread tid
  x <- takeMVar th
  putStrLn x
  putStrLn "\nshutting down"