{-# LANGUAGE ScopedTypeVariables #-}
{- |
Internal module providing a pool of threads.
-}
--
-- Copyright (c) 2009-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.ThreadPool (

    ThreadPoolEntry, ThreadPool(..), StopFlag(..), sequentialThreadPool, parallelThreadPool
  , threadPoolTest

) where

import qualified Control.Exception as Ex
import Control.Monad
import Control.Monad.Trans
import Control.Concurrent

-- for tests
import System.Random

data StopFlag
    = DoStop
    | DoNotStop
      deriving (StopFlag -> StopFlag -> Bool
(StopFlag -> StopFlag -> Bool)
-> (StopFlag -> StopFlag -> Bool) -> Eq StopFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StopFlag -> StopFlag -> Bool
== :: StopFlag -> StopFlag -> Bool
$c/= :: StopFlag -> StopFlag -> Bool
/= :: StopFlag -> StopFlag -> Bool
Eq, Int -> StopFlag -> ShowS
[StopFlag] -> ShowS
StopFlag -> String
(Int -> StopFlag -> ShowS)
-> (StopFlag -> String) -> ([StopFlag] -> ShowS) -> Show StopFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StopFlag -> ShowS
showsPrec :: Int -> StopFlag -> ShowS
$cshow :: StopFlag -> String
show :: StopFlag -> String
$cshowList :: [StopFlag] -> ShowS
showList :: [StopFlag] -> ShowS
Show, ReadPrec [StopFlag]
ReadPrec StopFlag
Int -> ReadS StopFlag
ReadS [StopFlag]
(Int -> ReadS StopFlag)
-> ReadS [StopFlag]
-> ReadPrec StopFlag
-> ReadPrec [StopFlag]
-> Read StopFlag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StopFlag
readsPrec :: Int -> ReadS StopFlag
$creadList :: ReadS [StopFlag]
readList :: ReadS [StopFlag]
$creadPrec :: ReadPrec StopFlag
readPrec :: ReadPrec StopFlag
$creadListPrec :: ReadPrec [StopFlag]
readListPrec :: ReadPrec [StopFlag]
Read)

type ThreadPoolEntry m a b = ( m a        -- pre-action, must not throw exceptions
                             , a -> IO b  -- action
                             , Either Ex.SomeException b -> m StopFlag
                               -- post-action, must not throw exceptions. If the result is
                               -- DoStop, the thread pool is terminated asap.
                             )

data ThreadPool m a b
    = ThreadPool
      { forall (m :: * -> *) a b.
ThreadPool m a b -> [ThreadPoolEntry m a b] -> m ()
tp_run :: [ThreadPoolEntry m a b] -> m () }

sequentialThreadPool :: MonadIO m => ThreadPool m a b
sequentialThreadPool :: forall (m :: * -> *) a b. MonadIO m => ThreadPool m a b
sequentialThreadPool = ([ThreadPoolEntry m a b] -> m ()) -> ThreadPool m a b
forall (m :: * -> *) a b.
([ThreadPoolEntry m a b] -> m ()) -> ThreadPool m a b
ThreadPool [ThreadPoolEntry m a b] -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
[ThreadPoolEntry m a b] -> m ()
runSequentially

parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b)
parallelThreadPool :: forall (m :: * -> *) a b. MonadIO m => Int -> m (ThreadPool m a b)
parallelThreadPool Int
n =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid number of workers: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n))
       ThreadPool m a b -> m (ThreadPool m a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([ThreadPoolEntry m a b] -> m ()) -> ThreadPool m a b
forall (m :: * -> *) a b.
([ThreadPoolEntry m a b] -> m ()) -> ThreadPool m a b
ThreadPool (Int -> [ThreadPoolEntry m a b] -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
Int -> [ThreadPoolEntry m a b] -> m ()
runParallel Int
n))

runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m ()
runSequentially :: forall (m :: * -> *) a b.
MonadIO m =>
[ThreadPoolEntry m a b] -> m ()
runSequentially [ThreadPoolEntry m a b]
entries =
    [ThreadPoolEntry m a b] -> m ()
forall {m :: * -> *} {e} {t} {a}.
(MonadIO m, Exception e) =>
[(m t, t -> IO a, Either e a -> m StopFlag)] -> m ()
loop [ThreadPoolEntry m a b]
entries
    where
      loop :: [(m t, t -> IO a, Either e a -> m StopFlag)] -> m ()
loop [] = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      loop ((m t, t -> IO a, Either e a -> m StopFlag)
e:[(m t, t -> IO a, Either e a -> m StopFlag)]
es) =
          do StopFlag
b <- (m t, t -> IO a, Either e a -> m StopFlag) -> m StopFlag
forall {m :: * -> *} {e} {t} {a} {b}.
(MonadIO m, Exception e) =>
(m t, t -> IO a, Either e a -> m b) -> m b
run (m t, t -> IO a, Either e a -> m StopFlag)
e
             if StopFlag
b StopFlag -> StopFlag -> Bool
forall a. Eq a => a -> a -> Bool
== StopFlag
DoStop then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () else [(m t, t -> IO a, Either e a -> m StopFlag)] -> m ()
loop [(m t, t -> IO a, Either e a -> m StopFlag)]
es
      run :: (m t, t -> IO a, Either e a -> m b) -> m b
run (m t
pre, t -> IO a
action, Either e a -> m b
post) =
          do t
a <- m t
pre
             Either e a
b <- IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either e a) -> m (Either e a))
-> IO (Either e a) -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try (t -> IO a
action t
a)
             Either e a -> m b
post Either e a
b

data WorkItem m b = Work (IO b) (Either Ex.SomeException b -> m StopFlag) | Done

instance Show (WorkItem m b) where
    show :: WorkItem m b -> String
show (Work IO b
_ Either SomeException b -> m StopFlag
_) = String
"Work"
    show WorkItem m b
Done = String
"Done"

type NamedMVar a = (String, MVar a)
type NamedChan a = (String, Chan a)

type ToWorker m b = NamedMVar (WorkItem m b)

data WorkResult m b = WorkResult (m StopFlag) (ToWorker m b)

instance Show (WorkResult m b) where
    show :: WorkResult m b -> String
show WorkResult m b
_ = String
"WorkResult"

type FromWorker m b = NamedChan (WorkResult m b)

runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m ()
runParallel :: forall (m :: * -> *) a b.
MonadIO m =>
Int -> [ThreadPoolEntry m a b] -> m ()
runParallel Int
_ [] = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runParallel Int
n [ThreadPoolEntry m a b]
entries =
    do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid number of workers: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n))
       NamedChan (WorkResult m b)
fromWorker <- IO (NamedChan (WorkResult m b)) -> m (NamedChan (WorkResult m b))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NamedChan (WorkResult m b)) -> m (NamedChan (WorkResult m b)))
-> IO (NamedChan (WorkResult m b))
-> m (NamedChan (WorkResult m b))
forall a b. (a -> b) -> a -> b
$ String -> IO (NamedChan (WorkResult m b))
forall a. String -> IO (NamedChan a)
newNamedChan String
"fromWorker"
       let nWorkers :: Int
nWorkers = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n ([ThreadPoolEntry m a b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreadPoolEntry m a b]
entries)
       [ToWorker m b]
toWorkers <- (Int -> m (ToWorker m b)) -> [Int] -> m [ToWorker m b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
i -> IO (ToWorker m b) -> m (ToWorker m b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ToWorker m b) -> m (ToWorker m b))
-> IO (ToWorker m b) -> m (ToWorker m b)
forall a b. (a -> b) -> a -> b
$ Int -> NamedChan (WorkResult m b) -> IO (ToWorker m b)
mkWorker Int
i NamedChan (WorkResult m b)
fromWorker) [Int
1..Int
nWorkers]
       let ([ThreadPoolEntry m a b]
initEntries, [ThreadPoolEntry m a b]
restEntries) = Int
-> [ThreadPoolEntry m a b]
-> ([ThreadPoolEntry m a b], [ThreadPoolEntry m a b])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
nWorkers [ThreadPoolEntry m a b]
entries
       ((ToWorker m b, ThreadPoolEntry m a b) -> m ())
-> [(ToWorker m b, ThreadPoolEntry m a b)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(ToWorker m b
mvar, ThreadPoolEntry m a b
entry) -> ThreadPoolEntry m a b -> ToWorker m b -> m ()
runEntry ThreadPoolEntry m a b
entry ToWorker m b
mvar) ([ToWorker m b]
-> [ThreadPoolEntry m a b]
-> [(ToWorker m b, ThreadPoolEntry m a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ToWorker m b]
toWorkers [ThreadPoolEntry m a b]
initEntries)
       NamedChan (WorkResult m b)
-> Int -> [ThreadPoolEntry m a b] -> m ()
loop NamedChan (WorkResult m b)
fromWorker Int
nWorkers [ThreadPoolEntry m a b]
restEntries
    where
      loop :: FromWorker m b -> Int -> [ThreadPoolEntry m a b] -> m ()
      loop :: NamedChan (WorkResult m b)
-> Int -> [ThreadPoolEntry m a b] -> m ()
loop NamedChan (WorkResult m b)
fromWorker Int
nWorkers [] =
          NamedChan (WorkResult m b) -> Int -> m ()
cleanup NamedChan (WorkResult m b)
fromWorker Int
nWorkers
      loop NamedChan (WorkResult m b)
fromWorker Int
nWorkers (ThreadPoolEntry m a b
x:[ThreadPoolEntry m a b]
xs) =
          do (ToWorker m b
toWorker, StopFlag
stop) <- NamedChan (WorkResult m b) -> m (ToWorker m b, StopFlag)
waitForWorkerResult NamedChan (WorkResult m b)
fromWorker
             if StopFlag
stop StopFlag -> StopFlag -> Bool
forall a. Eq a => a -> a -> Bool
== StopFlag
DoStop
             then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             else do ThreadPoolEntry m a b -> ToWorker m b -> m ()
runEntry ThreadPoolEntry m a b
x ToWorker m b
toWorker
                     NamedChan (WorkResult m b)
-> Int -> [ThreadPoolEntry m a b] -> m ()
loop NamedChan (WorkResult m b)
fromWorker Int
nWorkers [ThreadPoolEntry m a b]
xs
      cleanup :: FromWorker m b -> Int -> m ()
      -- n is the number of workers that will still write to fromWorker
      cleanup :: NamedChan (WorkResult m b) -> Int -> m ()
cleanup NamedChan (WorkResult m b)
fromWorker Int
n =
          do String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"cleanup, n=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
             (ToWorker m b
toWorker, StopFlag
_) <- NamedChan (WorkResult m b) -> m (ToWorker m b, StopFlag)
waitForWorkerResult NamedChan (WorkResult m b)
fromWorker
             IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ToWorker m b -> WorkItem m b -> IO ()
forall a. Show a => NamedMVar a -> a -> IO ()
putNamedMVar ToWorker m b
toWorker WorkItem m b
forall (m :: * -> *) b. WorkItem m b
Done
             Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NamedChan (WorkResult m b) -> Int -> m ()
cleanup NamedChan (WorkResult m b)
fromWorker (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      waitForWorkerResult :: FromWorker m b -> m (ToWorker m b, StopFlag)
      waitForWorkerResult :: NamedChan (WorkResult m b) -> m (ToWorker m b, StopFlag)
waitForWorkerResult NamedChan (WorkResult m b)
fromWorker =
          do WorkResult m StopFlag
postAction ToWorker m b
toWorker <- IO (WorkResult m b) -> m (WorkResult m b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (WorkResult m b) -> m (WorkResult m b))
-> IO (WorkResult m b) -> m (WorkResult m b)
forall a b. (a -> b) -> a -> b
$ NamedChan (WorkResult m b) -> IO (WorkResult m b)
forall a. Show a => NamedChan a -> IO a
readNamedChan NamedChan (WorkResult m b)
fromWorker
             StopFlag
b <- m StopFlag
postAction
             (ToWorker m b, StopFlag) -> m (ToWorker m b, StopFlag)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ToWorker m b
toWorker, StopFlag
b)
      runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m ()
      runEntry :: ThreadPoolEntry m a b -> ToWorker m b -> m ()
runEntry (m a
pre, a -> IO b
action, Either SomeException b -> m StopFlag
post) ToWorker m b
toWorker =
          do a
a <- m a
pre
             IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ToWorker m b -> WorkItem m b -> IO ()
forall a. Show a => NamedMVar a -> a -> IO ()
putNamedMVar ToWorker m b
toWorker (IO b -> (Either SomeException b -> m StopFlag) -> WorkItem m b
forall (m :: * -> *) b.
IO b -> (Either SomeException b -> m StopFlag) -> WorkItem m b
Work (a -> IO b
action a
a) Either SomeException b -> m StopFlag
post)
      mkWorker :: Int -> FromWorker m b -> IO (ToWorker m b)
      mkWorker :: Int -> NamedChan (WorkResult m b) -> IO (ToWorker m b)
mkWorker Int
i NamedChan (WorkResult m b)
fromWorker =
          do ToWorker m b
toWorker <- String -> IO (ToWorker m b)
forall a. String -> IO (NamedMVar a)
newEmptyNamedMVar (String
"worker" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
             let loop :: IO ()
loop = do WorkItem m b
workItem <- ToWorker m b -> IO (WorkItem m b)
forall a. Show a => NamedMVar a -> IO a
takeNamedMVar ToWorker m b
toWorker
                           case WorkItem m b
workItem of
                             WorkItem m b
Done ->
                                 do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"worker" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" exiting!")
                                    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             Work IO b
action Either SomeException b -> m StopFlag
post ->
                                 do Either SomeException b
res <- IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try IO b
action
                                    Either SomeException b
_ <- Either SomeException b -> IO (Either SomeException b)
forall a. a -> IO a
Ex.evaluate Either SomeException b
res
                                    NamedChan (WorkResult m b) -> WorkResult m b -> IO ()
forall a. Show a => NamedChan a -> a -> IO ()
writeNamedChan NamedChan (WorkResult m b)
fromWorker (m StopFlag -> ToWorker m b -> WorkResult m b
forall (m :: * -> *) b.
m StopFlag -> ToWorker m b -> WorkResult m b
WorkResult (Either SomeException b -> m StopFlag
post Either SomeException b
res) ToWorker m b
toWorker)
                                    IO ()
loop
             ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO ()
loop IO () -> (BlockedIndefinitelyOnMVar -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Ex.catch` (\(BlockedIndefinitelyOnMVar
e::Ex.BlockedIndefinitelyOnMVar) ->
                                          String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"worker " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockedIndefinitelyOnMVar -> String
forall a. Show a => a -> String
show BlockedIndefinitelyOnMVar
e)))
             ToWorker m b -> IO (ToWorker m b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ToWorker m b
toWorker

--
-- Debugging and testing
--

_DEBUG_ :: Bool
_DEBUG_ = Bool
False

newNamedChan :: String -> IO (NamedChan a)
newNamedChan :: forall a. String -> IO (NamedChan a)
newNamedChan String
name =
    do Chan a
chan <- IO (Chan a)
forall a. IO (Chan a)
newChan
       NamedChan a -> IO (NamedChan a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, Chan a
chan)

readNamedChan :: Show a => NamedChan a -> IO a
readNamedChan :: forall a. Show a => NamedChan a -> IO a
readNamedChan (String
name, Chan a
chan) =
    do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"readChan[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]...")
       a
x <- Chan a -> IO a
forall a. Chan a -> IO a
readChan Chan a
chan
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"DONE readChan[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"]=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)
       a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

writeNamedChan :: Show a => NamedChan a -> a -> IO ()
writeNamedChan :: forall a. Show a => NamedChan a -> a -> IO ()
writeNamedChan (String
name, Chan a
chan) a
x =
    do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"writeChan[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)
       Chan a -> a -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan a
chan a
x

newEmptyNamedMVar :: String -> IO (NamedMVar a)
newEmptyNamedMVar :: forall a. String -> IO (NamedMVar a)
newEmptyNamedMVar String
name =
    do MVar a
mvar <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
       NamedMVar a -> IO (NamedMVar a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, MVar a
mvar)

putNamedMVar :: Show a => NamedMVar a -> a -> IO ()
putNamedMVar :: forall a. Show a => NamedMVar a -> a -> IO ()
putNamedMVar (String
name, MVar a
mvar) a
x =
    do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"putMVar[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"...")
       MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mvar a
x
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"DONE putMVar[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)

takeNamedMVar :: Show a => NamedMVar a -> IO a
takeNamedMVar :: forall a. Show a => NamedMVar a -> IO a
takeNamedMVar (String
name, MVar a
mvar) =
    do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"takeMVar[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]...")
       a
x <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mvar
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"DONE takeMVar[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)
       a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

debug :: MonadIO m => String -> m ()
debug :: forall (m :: * -> *). MonadIO m => String -> m ()
debug String
s = if Bool
_DEBUG_ then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
s else () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runTestParallel :: Int -> Int -> IO ()
runTestParallel :: Int -> Int -> IO ()
runTestParallel Int
nEntries Int
n =
    do String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"Running test " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
       [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
boxes <- (Int -> IO (NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int))
-> [Int]
-> IO [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
i -> do NamedMVar ((ThreadId, ThreadId, Int), ThreadId)
mvar <- String -> IO (NamedMVar ((ThreadId, ThreadId, Int), ThreadId))
forall a. String -> IO (NamedMVar a)
newEmptyNamedMVar (String
"testbox" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
                               (NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)
-> IO (NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedMVar ((ThreadId, ThreadId, Int), ThreadId)
mvar, Int
i))
                      [Int
1..Int
nEntries]
       let entries :: [(IO ThreadId, a -> IO (a, ThreadId, Int),
  Either SomeException (ThreadId, ThreadId, Int) -> IO StopFlag)]
entries = ((NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)
 -> (IO ThreadId, a -> IO (a, ThreadId, Int),
     Either SomeException (ThreadId, ThreadId, Int) -> IO StopFlag))
-> [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
-> [(IO ThreadId, a -> IO (a, ThreadId, Int),
     Either SomeException (ThreadId, ThreadId, Int) -> IO StopFlag)]
forall a b. (a -> b) -> [a] -> [b]
map (NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)
-> (IO ThreadId, a -> IO (a, ThreadId, Int),
    Either SomeException (ThreadId, ThreadId, Int) -> IO StopFlag)
forall {a} {a} {b} {a}.
(Show a, Show a) =>
(NamedMVar (a, ThreadId), b)
-> (IO ThreadId, a -> IO (a, ThreadId, b),
    Either a a -> IO StopFlag)
mkEntry [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
boxes
       Int
-> [ThreadPoolEntry IO ThreadId (ThreadId, ThreadId, Int)] -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
Int -> [ThreadPoolEntry m a b] -> m ()
runParallel Int
n [ThreadPoolEntry IO ThreadId (ThreadId, ThreadId, Int)]
forall {a}.
[(IO ThreadId, a -> IO (a, ThreadId, Int),
  Either SomeException (ThreadId, ThreadId, Int) -> IO StopFlag)]
entries
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"Checking boxes in test " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
       --runSequentially entries
       ((NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int) -> IO ())
-> [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int) -> IO ()
forall {a}.
(Show a, Eq a) =>
(NamedMVar ((ThreadId, ThreadId, a), ThreadId), a) -> IO ()
assertBox [(NamedMVar ((ThreadId, ThreadId, Int), ThreadId), Int)]
boxes
       String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String
"Test " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" successful")
    where
      mkEntry :: (NamedMVar (a, ThreadId), b)
-> (IO ThreadId, a -> IO (a, ThreadId, b),
    Either a a -> IO StopFlag)
mkEntry (NamedMVar (a, ThreadId)
mvar, b
i) =
          let pre :: IO ThreadId
pre = IO ThreadId
myThreadId
              post :: Either a a -> IO StopFlag
post Either a a
x = case Either a a
x of
                         Left a
err -> String -> IO StopFlag
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Exception in worker thread: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
err)
                         Right a
y -> do ThreadId
tid <- IO ThreadId
myThreadId
                                       NamedMVar (a, ThreadId) -> (a, ThreadId) -> IO ()
forall a. Show a => NamedMVar a -> a -> IO ()
putNamedMVar NamedMVar (a, ThreadId)
mvar (a
y, ThreadId
tid)
                                       StopFlag -> IO StopFlag
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StopFlag
DoNotStop
              action :: a -> IO (a, ThreadId, b)
action a
x = do ThreadId
tid <- IO ThreadId
myThreadId
                            Int
j <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
                            let micros :: Int
micros = (Int
j Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
50)
                            Int -> IO ()
threadDelay Int
micros
                            (a, ThreadId, b) -> IO (a, ThreadId, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, ThreadId
tid, b
i)
          in (IO ThreadId
pre, a -> IO (a, ThreadId, b)
forall {a}. a -> IO (a, ThreadId, b)
action, Either a a -> IO StopFlag
forall {a}. Show a => Either a a -> IO StopFlag
post)
      assertBox :: (NamedMVar ((ThreadId, ThreadId, a), ThreadId), a) -> IO ()
assertBox (NamedMVar ((ThreadId, ThreadId, a), ThreadId)
mvar, a
i) =
         do ((ThreadId
preTid, ThreadId
actionTid, a
i'), ThreadId
postTid) <- NamedMVar ((ThreadId, ThreadId, a), ThreadId)
-> IO ((ThreadId, ThreadId, a), ThreadId)
forall a. Show a => NamedMVar a -> IO a
takeNamedMVar NamedMVar ((ThreadId, ThreadId, a), ThreadId)
mvar
            ThreadId
tid <- IO ThreadId
myThreadId
            String -> ThreadId -> ThreadId -> IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadFail f, Show a) =>
String -> a -> a -> f ()
assertEq String
"pre-tid" ThreadId
tid ThreadId
preTid
            String -> ThreadId -> ThreadId -> IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadFail f, Show a) =>
String -> a -> a -> f ()
assertEq String
"post-tid" ThreadId
tid ThreadId
postTid
            String -> ThreadId -> ThreadId -> IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadFail f, Show a) =>
String -> a -> a -> f ()
assertNeq String
"action-tid" ThreadId
tid ThreadId
actionTid
            String -> a -> a -> IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadFail f, Show a) =>
String -> a -> a -> f ()
assertEq String
"i" a
i a
i'
      assertEq :: String -> a -> a -> f ()
assertEq String
what a
exp a
act =
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
exp a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
act) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" wrong, expected=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", actual=" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                    a -> String
forall a. Show a => a -> String
show a
act)
      assertNeq :: String -> a -> a -> f ()
assertNeq String
what a
exp a
act =
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
exp a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
act) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" wrong, did not expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp)

threadPoolTest :: (Int, Int) -> Int -> IO [()]
threadPoolTest (Int
i, Int
j) Int
nEntries =
    (Int -> IO ()) -> [Int] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int -> Int -> IO ()
runTestParallel Int
nEntries) [Int
i..Int
j] IO [()] -> (BlockedIndefinitelyOnMVar -> IO [()]) -> IO [()]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Ex.catch`
             (\(BlockedIndefinitelyOnMVar
e::Ex.BlockedIndefinitelyOnMVar) ->
                  String -> IO [()]
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"main-thread blocked " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockedIndefinitelyOnMVar -> String
forall a. Show a => a -> String
show BlockedIndefinitelyOnMVar
e))