1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies, CPP #-}
-- | This scheduler uses sparks (par/pseq) directly, but only supplies
-- the @Monad.Par.Class.ParFuture@ interface.
module Control.Monad.Par.Scheds.Sparks
(
Par(..), Future(..),
runPar,
get, spawn, spawn_, spawnP, fixPar
)
where
import Control.Applicative
import Control.Monad
import Control.DeepSeq
import Control.Parallel
import qualified Control.Monad.Par.Class as PC
import Control.Monad.Fix (MonadFix (mfix))
-- import Control.Parallel.Strategies (rpar)
#ifdef NEW_GENERIC
import qualified Control.Par.Class as PN
import qualified Control.Par.Class.Unsafe as PU
import System.IO.Unsafe (unsafePerformIO)
#endif
{-# INLINE runPar #-}
{-# INLINE spawn #-}
{-# INLINE spawn_ #-}
{-# INLINE spawnP #-}
{-# INLINE get #-}
data Par a = Done a
data Future a = Future a
runPar :: Par a -> a
runPar (Done x) = x
spawn_ :: Par a -> Par (Future a)
-- spawn_ a = do a' <- rpar (runPar a); return (Future a')
spawn_ a = let a' = runPar a in a' `par` return (Future a')
spawn :: NFData a => Par a -> Par (Future a)
spawn a = let a' = runPar a in a' `par` return (Future (rnf a' `pseq` a'))
spawnP :: NFData a => a -> Par (Future a)
spawnP a = a `par` return (Future (rnf a `pseq` a))
get :: Future a -> Par a
get (Future a) = a `pseq` return a
--------------------------------------------------------------------------------
-- <boilerplate>
instance Monad Par where
return = pure
Done x >>= k = k x
instance PC.ParFuture Future Par where
get = get
spawn = spawn
spawn_ = spawn_
spawnP = spawnP
instance Functor Par where
fmap f xs = xs >>= return . f
instance Applicative Par where
(<*>) = ap
pure = Done
instance MonadFix Par where
mfix = fixPar
-- | Take the monadic fixpoint of a 'Par' computation. This is
-- the definition of 'mfix' for 'Par'.
fixPar :: (a -> Par a) -> Par a
fixPar f =
let fr = f (case fr of Done x -> x)
in fr
#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
-- </boilerplate>
--------------------------------------------------------------------------------
|
