From 0dba84f9a8cfe485933b9bd09706030bea178a84 Mon Sep 17 00:00:00 2001 From: Michael Walker Date: Wed, 18 Feb 2015 00:13:12 +0000 Subject: [PATCH] Add forkOn and getNumCapabilities --- Control/Monad/Conc/Class.hs | 26 ++++++++++++++++++-------- Test/DejaFu/Deterministic.hs | 14 ++++++++++++++ Test/DejaFu/Deterministic/IO.hs | 14 ++++++++++++++ 3 files changed, 46 insertions(+), 8 deletions(-) diff --git a/Control/Monad/Conc/Class.hs b/Control/Monad/Conc/Class.hs index e3f592e..a1a4313 100755 --- a/Control/Monad/Conc/Class.hs +++ b/Control/Monad/Conc/Class.hs @@ -41,12 +41,6 @@ import qualified Control.Monad.STM as S -- -- Every @MonadConc@ has an associated 'MonadSTM', transactions of -- which can be run atomically. --- --- A minimal implementation consists of 'fork', 'newEmptyCVar', --- 'tryPutCVar', and 'tryTakeCVar'. The default implementations of --- 'takeCVar' and 'putCVar', however, are very inefficient, and should --- probably always be overridden to make use of --- implementation-specific blocking functionality. class ( Monad m, MonadCatch m, MonadThrow m, MonadMask m , MonadSTM (STMLike m) , Eq (ThreadId m), Show (ThreadId m)) => MonadConc m where @@ -71,6 +65,16 @@ class ( Monad m, MonadCatch m, MonadThrow m, MonadMask m -- not be used within a 'mask' or 'uninterruptibleMask'. forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + -- | Fork a computation to happen on a specific processor. The + -- specified int is the /capability number/, typically capabilities + -- correspond to physical processors but this is implementation + -- dependent. The int is interpreted modulo to the total number of + -- capabilities as returned by 'getNumCapabilities'. + forkOn :: Int -> m () -> m (ThreadId m) + + -- | Get the number of Haskell threads that can run simultaneously. + getNumCapabilities :: m Int + -- | Get the @ThreadId@ of the current thread. myThreadId :: m (ThreadId m) @@ -79,7 +83,9 @@ class ( Monad m, MonadCatch m, MonadThrow m, MonadMask m -- | Put a value into a @CVar@. If there is already a value there, -- this will block until that value has been taken, at which point - -- the value will be stored. + -- the value will be stored. The default implementation is very bad, + -- as it does not make use of any blocking functionality, and should + -- probably b overridden. -- -- > putCVar cvar a = tryPutCVar cvar a >>= \b -> unless b $ putCVar cvar a putCVar :: CVar m a -> a -> m () @@ -97,7 +103,9 @@ class ( Monad m, MonadCatch m, MonadThrow m, MonadMask m -- | Take a value from a @CVar@. This \"empties\" the @CVar@, -- allowing a new value to be put in. This will block if there is no - -- value in the @CVar@ already, until one has been put. + -- value in the @CVar@ already, until one has been put. The default + -- implementation is very bad, as it does not make use of any + -- blocking functionality, and should probably b overridden. -- -- > takeCVar cvar = tryTakeCVar cvar >>= maybe (takeCVar cvar) return takeCVar :: CVar m a -> m a @@ -192,6 +200,8 @@ instance MonadConc IO where readCVar = readMVar fork = forkIO forkWithUnmask = C.forkIOWithUnmask + forkOn = C.forkOn + getNumCapabilities = C.getNumCapabilities myThreadId = C.myThreadId throwTo = C.throwTo newEmptyCVar = newEmptyMVar diff --git a/Test/DejaFu/Deterministic.hs b/Test/DejaFu/Deterministic.hs index 514112d..7d659e9 100755 --- a/Test/DejaFu/Deterministic.hs +++ b/Test/DejaFu/Deterministic.hs @@ -17,6 +17,8 @@ module Test.DejaFu.Deterministic , fork , forkFinally , forkWithUnmask + , forkOn + , getNumCapabilities , myThreadId , spawn , atomically @@ -90,6 +92,8 @@ instance C.MonadConc (Conc t) where fork = fork forkWithUnmask = forkWithUnmask + forkOn = forkOn + getNumCapabilities = getNumCapabilities myThreadId = myThreadId throwTo = throwTo newEmptyCVar = newEmptyCVar @@ -229,6 +233,16 @@ mask mb = C $ cont $ AMasking MaskedInterruptible (\f -> unC $ mb $ wrap f) uninterruptibleMask :: ((forall a. Conc t a -> Conc t a) -> Conc t b) -> Conc t b uninterruptibleMask mb = C $ cont $ AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f) +-- | Fork a computation to happen on a specific processor. This +-- implementation only has a single processor. +forkOn :: Int -> Conc t () -> Conc t ThreadId +forkOn _ = fork + +-- | Get the number of Haskell threads that can run +-- simultaneously. This implementation always returns 1. +getNumCapabilities :: Conc t Int +getNumCapabilities = return 1 + -- | Run the argument in one step. If the argument fails, the whole -- computation will fail. _concNoTest :: Conc t a -> Conc t a diff --git a/Test/DejaFu/Deterministic/IO.hs b/Test/DejaFu/Deterministic/IO.hs index 18164a8..779e2ab 100644 --- a/Test/DejaFu/Deterministic/IO.hs +++ b/Test/DejaFu/Deterministic/IO.hs @@ -21,6 +21,8 @@ module Test.DejaFu.Deterministic.IO , fork , forkFinally , forkWithUnmask + , forkOn + , getNumCapabilities , myThreadId , spawn , atomically @@ -94,6 +96,8 @@ instance C.MonadConc (ConcIO t) where fork = fork forkWithUnmask = forkWithUnmask + forkOn = forkOn + getNumCapabilities = getNumCapabilities myThreadId = myThreadId throwTo = throwTo newEmptyCVar = newEmptyCVar @@ -232,6 +236,16 @@ mask mb = C $ cont $ AMasking MaskedInterruptible (\f -> unC $ mb $ wrap f) uninterruptibleMask :: ((forall a. ConcIO t a -> ConcIO t a) -> ConcIO t b) -> ConcIO t b uninterruptibleMask mb = C $ cont $ AMasking MaskedUninterruptible (\f -> unC $ mb $ wrap f) +-- | Fork a computation to happen on a specific processor. This +-- implementation only has a single processor. +forkOn :: Int -> ConcIO t () -> ConcIO t ThreadId +forkOn _ = fork + +-- | Get the number of Haskell threads that can run +-- simultaneously. This implementation always returns 1. +getNumCapabilities :: ConcIO t Int +getNumCapabilities = return 1 + -- | Run the argument in one step. If the argument fails, the whole -- computation will fail. _concNoTest :: ConcIO t a -> ConcIO t a