diff --git a/Control/Monad/Par/Scheds/Direct.hs b/Control/Monad/Par/Scheds/Direct.hs --- a/Control/Monad/Par/Scheds/Direct.hs +++ b/Control/Monad/Par/Scheds/Direct.hs @@ -11,6 +11,8 @@ -- TODO: Before declaring this module TRUSTWORTHY/SAFE, we need to -- make the IVar type abstract. +{-# LANGUAGE TypeFamilies #-} + -- | A scheduler for the Par monad based on directly performing IO -- actions when Par methods are called (i.e. without using a lazy -- trace data structure). @@ -45,6 +47,10 @@ import Control.Monad.Par.Scheds.DirectInternal (Par(..), Sched(..), HotVar, SessionID, Session(Session), newHotVar, readHotVar, modifyHotVar, modifyHotVar_, writeHotVarRaw) +#ifdef NEW_GENERIC +import qualified Control.Par.Class as PN +import qualified Control.Par.Class.Unsafe as PU +#endif import Control.DeepSeq import qualified Data.Map as M import qualified Data.Set as S @@ -809,6 +815,30 @@ instance Applicative Par where (<*>) = ap pure = return + +#ifdef NEW_GENERIC +instance PU.ParMonad Par where + fork = fork + internalLiftIO io = Par (lift $ lift io) + +instance PU.ParThreadSafe Par where + unsafeParIO io = Par (lift $ lift io) + +instance PN.ParFuture Par where + type Future Par = IVar + type FutContents Par a = () + get = get + spawn = spawn + spawn_ = spawn_ + spawnP = spawnP + +instance PN.ParIVar Par where + new = new + put_ = put_ + newFull = newFull + newFull_ = newFull_ +#endif + -- -------------------------------------------------------------------------------- @@ -838,7 +868,7 @@ dbgTakeMVar :: String -> MVar a -> IO a dbgTakeMVar msg mv = -- catch (takeMVar mv) ((\_ -> doDebugStuff) :: BlockedIndefinitelyOnMVar -> IO a) - E.catch (takeMVar mv) ((\_ -> doDebugStuff) :: IOError -> IO a) + E.catch (takeMVar mv) (\(_::IOError) -> doDebugStuff) where doDebugStuff = do printf "This takeMVar blocked indefinitely!: %s\n" msg error "failed" diff --git a/Control/Monad/Par/Scheds/Sparks.hs b/Control/Monad/Par/Scheds/Sparks.hs --- a/Control/Monad/Par/Scheds/Sparks.hs +++ b/Control/Monad/Par/Scheds/Sparks.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies, CPP #-} -- | This scheduler uses sparks (par/pseq) directly, but only supplies -- the @Monad.Par.Class.ParFuture@ interface. @@ -17,7 +18,14 @@ import Control.Parallel import qualified Control.Monad.Par.Class as PC -- import Control.Parallel.Strategies (rpar) +import System.IO.Unsafe (unsafePerformIO) +#ifdef NEW_GENERIC +import qualified Control.Par.Class as PN +import qualified Control.Par.Class.Unsafe as PU +#endif + + {-# INLINE runPar #-} {-# INLINE spawn #-} {-# INLINE spawn_ #-} @@ -62,6 +70,36 @@ instance Applicative Par where (<*>) = ap pure = return + +#ifdef NEW_GENERIC +doio :: IO a -> Par a +doio io = let x = unsafePerformIO io in + return $! x + +instance PU.ParMonad Par where + -- This is a No-Op for this monad. Because there are no side-effects permitted, + -- there is no way to observe whether anything happens on the child thread. + -- fork _m = return () + -- FIXME: except for exceptions!! + + -- This version doesn't work, because the spark may get spilled/dropped: + -- fork m = spawn m + + -- I think this is all that we're left with: + fork m = m + internalLiftIO = doio + +instance PU.ParThreadSafe Par where + unsafeParIO = doio + +instance PN.ParFuture Par where + type Future Par = Future + type FutContents Par a = () + get = get + spawn = spawn + spawn_ = spawn_ + spawnP = spawnP +#endif -- -------------------------------------------------------------------------------- diff --git a/Control/Monad/Par/Scheds/Trace.hs b/Control/Monad/Par/Scheds/Trace.hs --- a/Control/Monad/Par/Scheds/Trace.hs +++ b/Control/Monad/Par/Scheds/Trace.hs @@ -2,6 +2,8 @@ ExistentialQuantification, MultiParamTypeClasses, CPP #-} {- OPTIONS_GHC -Wall -fno-warn-name-shadowing -fwarn-unused-imports -} +{-# LANGUAGE TypeFamilies #-} + {- | This is the scheduler described in the paper "A Monad for Deterministic Parallelism". It is based on a lazy @Trace@ data structure that separates the scheduler from the @Par@ monad @@ -21,6 +23,11 @@ import Control.Monad as M hiding (mapM, sequence, join) import Prelude hiding (mapM, sequence, head,tail) +#ifdef NEW_GENERIC +import qualified Control.Par.Class as PN +import qualified Control.Par.Class.Unsafe as PU +#endif + -- ----------------------------------------------------------------------------- -- Not in 6.12: {- INLINABLE fork -} @@ -53,3 +60,27 @@ newFull = newFull newFull_ = newFull_ -- yield = yield + +#ifdef NEW_GENERIC +instance PU.ParMonad Par where + fork = fork + internalLiftIO io = Par (LiftIO io) + +instance PU.ParThreadSafe Par where + unsafeParIO io = Par (LiftIO io) + +instance PN.ParFuture Par where + type Future Par = IVar + type FutContents Par a = () + get = get + spawn = spawn + spawn_ = spawn_ + spawnP = spawnP + +instance PN.ParIVar Par where + new = new + put_ = put_ + newFull = newFull + newFull_ = newFull_ +#endif + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Simon Marlow 2011 +Copyright Simon Marlow, Ryan Newton 2011 All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Simon Marlow nor the names of other + * Neither the name of the authors nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/monad-par.cabal b/monad-par.cabal --- a/monad-par.cabal +++ b/monad-par.cabal @@ -1,5 +1,5 @@ Name: monad-par -Version: 0.3.4.5 +Version: 0.3.4.6 Synopsis: A library for parallel programming based on a monad @@ -23,6 +23,7 @@ -- 0.3.4.3 : Bugfix, Trace scheduler is now the default -- 0.3.4.4 : Use the Trace scheduler in Control.Monad.Par.IO too -- 0.3.4.5 : Extremely minor, fix to unit tests. +-- 0.3.4.6 : Add newgeneric flag, supporting the par-classes module. Description: The 'Par' monad offers a simple API for parallel programming. The @@ -80,6 +81,10 @@ Description: Use Chase-Lev Deques for higher-perf work-stealing. Default: False +Flag newgeneric + Description: Provide instances for the new par-classes generic Par programming interface. + Default: False + Library Source-repository head type: git @@ -118,6 +123,10 @@ if flag(chaselev) cpp-options: -DUSE_CHASELEV build-depends: chaselev-deque + + if flag(newgeneric) + cpp-options: -DNEW_GENERIC + build-depends: par-classes ghc-options: -O2 Other-modules: