git.iko.soy/distributed-process
on master help sign in
Final cleanup and documentation
634ae01Edsko de Vries
distributed-process/src/Control/Distributed/Process.hs+4−4
compare with master
unifiedsplit
@@ -117,15 +117,15 @@ import Control.Distributed.Process.Internal.Types
117 , WhereIsReply(..)
117 , WhereIsReply(..)
118 )
118 )
119import Control.Distributed.Process.Internal.Closure.BuiltIn
119import Control.Distributed.Process.Internal.Closure.BuiltIn
120− ( linkClosure
121− , unlinkClosure
122− , sendClosure
120+ ( sendClosure
123 , expectClosure
121 , expectClosure
124− , serializableDictUnit
125 )
122 )
126import Control.Distributed.Process.Internal.Closure.Derived
123import Control.Distributed.Process.Internal.Closure.Derived
127 ( cpSeq
124 ( cpSeq
128 , cpBind
125 , cpBind
126+ , linkClosure
127+ , unlinkClosure
128+ , serializableDictUnit
129 )
129 )
130import Control.Distributed.Process.Internal.Primitives
130import Control.Distributed.Process.Internal.Primitives
131 ( -- Basic messaging
131 ( -- Basic messaging
distributed-process/src/Control/Distributed/Process/Closure.hs+53−30
@@ -1,24 +1,6 @@
1-- | Implementation of 'Closure' that works around the absence of 'static'.
1-- | Implementation of 'Closure' that works around the absence of 'static'.
2--
2--
3−-- [Built-in closures]
4−--
5−-- We offer a number of standard commonly useful closures.
6−--
7−-- [Closure combinators]
8−--
9−-- Closures combinators allow to create closures from other closures. For
10−-- example, 'spawnSupervised' is defined as follows:
11−--
12−-- > spawnSupervised :: NodeId
13−-- > -> Closure (Process ())
14−-- > -> Process (ProcessId, MonitorRef)
15−-- > spawnSupervised nid proc = do
16−-- > us <- getSelfPid
17−-- > them <- spawn nid (linkClosure us `cpSeq` proc)
18−-- > ref <- monitor them
19−-- > return (them, ref)
20−--
21−-- [User-defined closures]
3+-- [User-defined monomorphic closures]
22--
4--
23-- Suppose we have a monomorphic function
5-- Suppose we have a monomorphic function
24--
6--
@@ -38,8 +20,8 @@
38--
20--
39-- > unClosure :: Typeable a => Closure a -> Process a
21-- > unClosure :: Typeable a => Closure a -> Process a
40--
22--
41−-- In general, given a monomorphic function @f :: a -> b@ the corresponding
23+-- In general, given a monomorphic function @f :: T1 -> T2@ the corresponding
42−-- function @$(mkClosure 'f)@ will have type @a -> Closure b@.
24+-- function @$(mkClosure 'f)@ will have type @T1 -> Closure T2@.
43--
25--
44-- The call to 'remotable' will also generate a function
26-- The call to 'remotable' will also generate a function
45--
27--
@@ -57,6 +39,44 @@
57--
39--
58-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.
40-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.
59--
41--
42+-- [User-defined polymorphic closures]
43+--
44+-- Suppose we have a polymorphic function
45+--
46+-- > first :: forall a b. (a, b) -> a
47+-- > first (x, _) = x
48+--
49+-- Then the Template Haskell splice
50+--
51+-- > remotable ['first]
52+--
53+-- creates a function
54+--
55+-- > $(mkClosure 'first) :: forall a b. (Typeable a, Typeable b)
56+-- > => Closure (a -> b -> a)
57+--
58+-- In general, given a polymorphic function @f :: forall a1 .. an. T@ the
59+-- corresponding function @$(mkClosure 'f)@ will have type
60+-- @forall a1 .. an. (Typeable a1, .., Typeable an) => Closure T@.
61+--
62+-- [Built-in closures]
63+--
64+-- We offer a number of standard commonly useful closures.
65+--
66+-- [Closure combinators]
67+--
68+-- Closures combinators allow to create closures from other closures. For
69+-- example, 'spawnSupervised' is defined as follows:
70+--
71+-- > spawnSupervised :: NodeId
72+-- > -> Closure (Process ())
73+-- > -> Process (ProcessId, MonitorRef)
74+-- > spawnSupervised nid proc = do
75+-- > us <- getSelfPid
76+-- > them <- spawn nid (linkClosure us `cpSeq` proc)
77+-- > ref <- monitor them
78+-- > return (them, ref)
79+--
60-- [Serializable Dictionaries]
80-- [Serializable Dictionaries]
61--
81--
62-- Some functions (such as 'sendClosure' or 'returnClosure') require an
82-- Some functions (such as 'sendClosure' or 'returnClosure') require an
@@ -71,8 +91,7 @@ module Control.Distributed.Process.Closure
71 ( -- * User-defined closures
91 ( -- * User-defined closures
72 remotable
92 remotable
73 , mkClosure
93 , mkClosure
74− , SerializableDict(..)
94+ -- * Process primitives
75− -- * Built-in closures
76 , linkClosure
95 , linkClosure
77 , unlinkClosure
96 , unlinkClosure
78 , sendClosure
97 , sendClosure
@@ -100,24 +119,27 @@ module Control.Distributed.Process.Closure
100 , cpEither
119 , cpEither
101 , cpUntag
120 , cpUntag
102 , cpFanIn
121 , cpFanIn
103− , cpApply
104 -- * Derived combinators for processes
122 -- * Derived combinators for processes
105 , cpBind
123 , cpBind
106 , cpSeq
124 , cpSeq
125+ -- * Serialization dictionaries
126+ , SerializableDict(..)
127+ , serializableDictUnit
107 ) where
128 ) where
108
129
109import Control.Distributed.Process.Internal.Types (SerializableDict(..))
130import Control.Distributed.Process.Internal.Types (SerializableDict(..))
110import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)
131import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)
111import Control.Distributed.Process.Internal.Closure.BuiltIn
132import Control.Distributed.Process.Internal.Closure.BuiltIn
112− ( linkClosure
113− , unlinkClosure
114− , sendClosure
133+ ( sendClosure
115 , returnClosure
134 , returnClosure
116 , expectClosure
135 , expectClosure
117 )
136 )
118import Control.Distributed.Process.Internal.Closure.Derived
137import Control.Distributed.Process.Internal.Closure.Derived
138+ ( -- Process primitives
139+ linkClosure
140+ , unlinkClosure
119− ( -- Generic combinators
141+ -- Generic combinators
120− closureApply
142+ , closureApply
121 , closureConst
143 , closureConst
122 , closureUnit
144 , closureUnit
123 -- Arrow combinators for processes
145 -- Arrow combinators for processes
@@ -138,8 +160,9 @@ import Control.Distributed.Process.Internal.Closure.Derived
138 , cpEither
160 , cpEither
139 , cpUntag
161 , cpUntag
140 , cpFanIn
162 , cpFanIn
141− , cpApply
142 -- Derived process operators
163 -- Derived process operators
143 , cpBind
164 , cpBind
144 , cpSeq
165 , cpSeq
166+ -- Serialization dictionaries
167+ , serializableDictUnit
145 )
168 )
distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+8−27
@@ -1,12 +1,8 @@
1−{-# LANGUAGE TemplateHaskell #-}
1+-- | Built-in closures
2module Control.Distributed.Process.Internal.Closure.BuiltIn
2module Control.Distributed.Process.Internal.Closure.BuiltIn
3− ( -- * Runtime support for the builtin closures
3+ ( -- Combinators
4− remoteTable
4+ closureApply
5− -- * Serialization dictionaries
5+ -- TODO
6− , serializableDictUnit
7− -- * Closures
8− , linkClosure
9− , unlinkClosure
10 , sendClosure
6 , sendClosure
11 , returnClosure
7 , returnClosure
12 , expectClosure
8 , expectClosure
@@ -14,39 +10,24 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn
14
10
15import Data.Binary (encode)
11import Data.Binary (encode)
16import Data.Typeable (Typeable, typeOf)
12import Data.Typeable (Typeable, typeOf)
17−import Control.Distributed.Process.Internal.Primitives (link, unlink)
18import Control.Distributed.Process.Internal.Types
13import Control.Distributed.Process.Internal.Types
19 ( ProcessId
14 ( ProcessId
20 , Closure
15 , Closure
21 , Process
16 , Process
22− , RemoteTable
23 , SerializableDict(..)
17 , SerializableDict(..)
24 , Closure(..)
18 , Closure(..)
25 , Static(..)
19 , Static(..)
26 , StaticLabel(..)
20 , StaticLabel(..)
27 )
21 )
28−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)
29import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
22import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
30
23
31−serializableDictUnit :: SerializableDict ()
32−serializableDictUnit = SerializableDict
33−
34−remotable ['link, 'unlink, 'serializableDictUnit]
35−
36−remoteTable :: RemoteTable -> RemoteTable
37−remoteTable = __remoteTable
38−
39--------------------------------------------------------------------------------
24--------------------------------------------------------------------------------
40−-- TH generated closures --
25+-- Combinators --
41--------------------------------------------------------------------------------
26--------------------------------------------------------------------------------
42
27
43−-- | Closure version of 'link'
28+closureApply :: Closure (a -> b) -> Closure a -> Closure b
44−linkClosure :: ProcessId -> Closure (Process ())
29+closureApply (Closure (Static labelf) envf) (Closure (Static labelx) envx) =
45−linkClosure = $(mkClosure 'link)
30+ Closure (Static ClosureApply) $ encode (labelf, envf, labelx, envx)
46−
47−-- | Closure version of 'unlink'
48−unlinkClosure :: ProcessId -> Closure (Process ())
49−unlinkClosure = $(mkClosure 'unlink)
50
31
51--------------------------------------------------------------------------------
32--------------------------------------------------------------------------------
52-- Polymorphic closures --
33-- Polymorphic closures --
distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hs+42−44
@@ -1,6 +1,9 @@
1-- | Derived (TH generated) closures
1-- | Derived (TH generated) closures
2module Control.Distributed.Process.Internal.Closure.Derived
2module Control.Distributed.Process.Internal.Closure.Derived
3 ( remoteTable
3 ( remoteTable
4+ -- * Process primitives
5+ , linkClosure
6+ , unlinkClosure
4 -- * Generic combinators
7 -- * Generic combinators
5 , closureApply
8 , closureApply
6 , closureConst
9 , closureConst
@@ -23,28 +26,32 @@ module Control.Distributed.Process.Internal.Closure.Derived
23 , cpEither
26 , cpEither
24 , cpUntag
27 , cpUntag
25 , cpFanIn
28 , cpFanIn
26− , cpApply
27 -- * Derived process operators
29 -- * Derived process operators
28 , cpBind
30 , cpBind
29 , cpSeq
31 , cpSeq
32+ -- * Serialization dictionaries
33+ , serializableDictUnit
30 ) where
34 ) where
31
35
32import Prelude hiding (lookup)
36import Prelude hiding (lookup)
33−import Data.Binary (encode)
34−import Data.Typeable (typeOf, Typeable)
37+import Data.Typeable (Typeable)
35import Data.Tuple (swap)
38import Data.Tuple (swap)
36import Control.Applicative ((<$>))
39import Control.Applicative ((<$>))
37import Control.Monad ((>=>))
40import Control.Monad ((>=>))
38import Control.Distributed.Process.Internal.Types
41import Control.Distributed.Process.Internal.Types
39 ( Closure(..)
42 ( Closure(..)
40− , Static(..)
41− , StaticLabel(..)
42 , Process
43 , Process
43 , RemoteTable
44 , RemoteTable
45+ , SerializableDict(..)
46+ , ProcessId
44 )
47 )
45import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
48import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
46import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)
49import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)
47−import Control.Distributed.Process.Internal.Primitives (unClosure)
50+import Control.Distributed.Process.Internal.Primitives
51+ ( link
52+ , unlink
53+ )
54+import Control.Distributed.Process.Internal.Closure.BuiltIn (closureApply)
48
55
49--------------------------------------------------------------------------------
56--------------------------------------------------------------------------------
50-- TH stuff --
57-- TH stuff --
@@ -80,10 +87,8 @@ untagProcess :: Either a a -> Process a
80untagProcess (Left x) = return x
87untagProcess (Left x) = return x
81untagProcess (Right y) = return y
88untagProcess (Right y) = return y
82
89
83−applyClosureProcess :: (Typeable a, Typeable b) => (Closure (a -> Process b), a) -> Process b
90+serializableDictUnit :: SerializableDict ()
84−applyClosureProcess (procClosure, a) = do
91+serializableDictUnit = SerializableDict
85− proc <- unClosure procClosure
86− proc a
87
92
88remotable [ 'const
93remotable [ 'const
89 , 'idUnit
94 , 'idUnit
@@ -95,18 +100,29 @@ remotable [ 'const
95 , 'leftProcess
100 , 'leftProcess
96 , 'mirrorProcess
101 , 'mirrorProcess
97 , 'untagProcess
102 , 'untagProcess
103+ , 'link
104+ , 'unlink
105+ , 'serializableDictUnit
98 ]
106 ]
99
107
100remoteTable :: RemoteTable -> RemoteTable
108remoteTable :: RemoteTable -> RemoteTable
101remoteTable = __remoteTable
109remoteTable = __remoteTable
102
110
103--------------------------------------------------------------------------------
111--------------------------------------------------------------------------------
104−-- Generic closure combinators --
112+-- Process primitives --
105--------------------------------------------------------------------------------
113--------------------------------------------------------------------------------
106
114
107−closureApply :: Closure (a -> b) -> Closure a -> Closure b
115+-- | Closure version of 'link'
108−closureApply (Closure (Static labelf) envf) (Closure (Static labelx) envx) =
116+linkClosure :: ProcessId -> Closure (Process ())
109− Closure (Static ClosureApply) $ encode (labelf, envf, labelx, envx)
117+linkClosure = $(mkClosure 'link)
118+
119+-- | Closure version of 'unlink'
120+unlinkClosure :: ProcessId -> Closure (Process ())
121+unlinkClosure = $(mkClosure 'unlink)
122+
123+--------------------------------------------------------------------------------
124+-- Generic closure combinators --
125+--------------------------------------------------------------------------------
110
126
111closureConst :: (Typeable a, Typeable b) => Closure (a -> b -> a)
127closureConst :: (Typeable a, Typeable b) => Closure (a -> b -> a)
112closureConst = $(mkClosure 'const)
128closureConst = $(mkClosure 'const)
@@ -128,47 +144,40 @@ cpElim :: Typeable a
128 => CP () a -> Closure (Process a)
144 => CP () a -> Closure (Process a)
129cpElim = flip closureApply closureUnit
145cpElim = flip closureApply closureUnit
130
146
131−cpId :: forall a. Typeable a
147+cpId :: Typeable a => CP a a
132− => CP a a
133cpId = $(mkClosure 'returnProcess)
148cpId = $(mkClosure 'returnProcess)
134
149
135−cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)
150+cpComp :: (Typeable a, Typeable b, Typeable c) => CP a b -> CP b c -> CP a c
136− => CP a b -> CP b c -> CP a c
137cpComp f g = $(mkClosure 'kleisliComposeProcess) `closureApply` f `closureApply` g
151cpComp f g = $(mkClosure 'kleisliComposeProcess) `closureApply` f `closureApply` g
138
152
139−cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)
153+cpFirst :: (Typeable a, Typeable b, Typeable c) => CP a b -> CP (a, c) (b, c)
140− => CP a b -> CP (a, c) (b, c)
141cpFirst = closureApply $(mkClosure 'firstProcess)
154cpFirst = closureApply $(mkClosure 'firstProcess)
142
155
143−cpSwap :: forall a b. (Typeable a, Typeable b)
156+cpSwap :: (Typeable a, Typeable b) => CP (a, b) (b, a)
144− => CP (a, b) (b, a)
145cpSwap = $(mkClosure 'swapProcess)
157cpSwap = $(mkClosure 'swapProcess)
146
158
147−cpSecond :: (Typeable a, Typeable b, Typeable c)
159+cpSecond :: (Typeable a, Typeable b, Typeable c) => CP a b -> CP (c, a) (c, b)
148− => CP a b -> CP (c, a) (c, b)
149cpSecond f = cpSwap `cpComp` cpFirst f `cpComp` cpSwap
160cpSecond f = cpSwap `cpComp` cpFirst f `cpComp` cpSwap
150
161
151cpPair :: (Typeable a, Typeable a', Typeable b, Typeable b')
162cpPair :: (Typeable a, Typeable a', Typeable b, Typeable b')
152− => CP a b -> CP a' b' -> CP (a, a') (b, b')
163+ => CP a b -> CP a' b' -> CP (a, a') (b, b')
153cpPair f g = cpFirst f `cpComp` cpSecond g
164cpPair f g = cpFirst f `cpComp` cpSecond g
154
165
155−cpCopy :: forall a. Typeable a
166+cpCopy :: Typeable a => CP a (a, a)
156− => CP a (a, a)
157cpCopy = $(mkClosure 'copyProcess)
167cpCopy = $(mkClosure 'copyProcess)
158
168
159−cpFanOut :: (Typeable a, Typeable b, Typeable c)
169+cpFanOut :: (Typeable a, Typeable b, Typeable c)
160 => CP a b -> CP a c -> CP a (b, c)
170 => CP a b -> CP a c -> CP a (b, c)
161cpFanOut f g = cpCopy `cpComp` (f `cpPair` g)
171cpFanOut f g = cpCopy `cpComp` (f `cpPair` g)
162
172
163−cpLeft :: forall a b c. (Typeable a, Typeable b, Typeable c)
173+cpLeft :: (Typeable a, Typeable b, Typeable c)
164 => CP a b -> CP (Either a c) (Either b c)
174 => CP a b -> CP (Either a c) (Either b c)
165cpLeft = closureApply $(mkClosure 'leftProcess)
175cpLeft = closureApply $(mkClosure 'leftProcess)
166
176
167−cpMirror :: forall a b. (Typeable a, Typeable b)
177+cpMirror :: (Typeable a, Typeable b) => CP (Either a b) (Either b a)
168− => CP (Either a b) (Either b a)
169cpMirror = $(mkClosure 'mirrorProcess)
178cpMirror = $(mkClosure 'mirrorProcess)
170
179
171−cpRight :: forall a b c. (Typeable a, Typeable b, Typeable c)
180+cpRight :: (Typeable a, Typeable b, Typeable c)
172 => CP a b -> CP (Either c a) (Either c b)
181 => CP a b -> CP (Either c a) (Either c b)
173cpRight f = cpMirror `cpComp` cpLeft f `cpComp` cpMirror
182cpRight f = cpMirror `cpComp` cpLeft f `cpComp` cpMirror
174
183
@@ -176,24 +185,13 @@ cpEither :: (Typeable a, Typeable a', Typeable b, Typeable b')
176 => CP a b -> CP a' b' -> CP (Either a a') (Either b b')
185 => CP a b -> CP a' b' -> CP (Either a a') (Either b b')
177cpEither f g = cpLeft f `cpComp` cpRight g
186cpEither f g = cpLeft f `cpComp` cpRight g
178
187
179−cpUntag :: forall a. Typeable a
188+cpUntag :: Typeable a => CP (Either a a) a
180− => CP (Either a a) a
181cpUntag = $(mkClosure 'untagProcess)
189cpUntag = $(mkClosure 'untagProcess)
182
190
183cpFanIn :: (Typeable a, Typeable b, Typeable c)
191cpFanIn :: (Typeable a, Typeable b, Typeable c)
184 => CP a c -> CP b c -> CP (Either a b) c
192 => CP a c -> CP b c -> CP (Either a b) c
185cpFanIn f g = (f `cpEither` g) `cpComp` cpUntag
193cpFanIn f g = (f `cpEither` g) `cpComp` cpUntag
186
194
187−cpApply :: forall a b. (Typeable a, Typeable b)
188− => CP (CP a b, a) b
189−cpApply = Closure (Static CpApply) $ encode ( typeOf aux
190− , typeOf (undefined :: a)
191− , typeOf (undefined :: Process b)
192− )
193− where
194− aux :: (Closure (a -> Process b), a) -> Process b
195− aux = undefined
196−
197--------------------------------------------------------------------------------
195--------------------------------------------------------------------------------
198-- Some derived operators for processes --
196-- Some derived operators for processes --
199--------------------------------------------------------------------------------
197--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs+7−27
@@ -12,21 +12,23 @@ import Control.Distributed.Process.Internal.Types
12 , remoteTableDict
12 , remoteTableDict
13 , StaticLabel(..)
13 , StaticLabel(..)
14 , ProcessId
14 , ProcessId
15− , Process
16− , Closure(Closure)
17− , Static(Static)
18 , RuntimeSerializableSupport(..)
15 , RuntimeSerializableSupport(..)
19 )
16 )
20import Control.Distributed.Process.Internal.Dynamic
17import Control.Distributed.Process.Internal.Dynamic
21 ( Dynamic(Dynamic)
18 ( Dynamic(Dynamic)
22 , toDyn
19 , toDyn
23− , dynApp
24 , dynApply
20 , dynApply
25− , unsafeCoerce#
26 )
21 )
27import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
22import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
28
23
29resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
24resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
25+-- Generic closure combinators
26+resolveClosure rtable ClosureApply env = do
27+ f <- resolveClosure rtable labelf envf
28+ x <- resolveClosure rtable labelx envx
29+ f `dynApply` x
30+ where
31+ (labelf, envf, labelx, envx) = decode env
30-- Built-in closures
32-- Built-in closures
31resolveClosure rtable ClosureSend env = do
33resolveClosure rtable ClosureSend env = do
32 rss <- rtable ^. remoteTableDict typ
34 rss <- rtable ^. remoteTableDict typ
@@ -42,28 +44,6 @@ resolveClosure rtable ClosureExpect env =
42 rssExpect <$> rtable ^. remoteTableDict typ
44 rssExpect <$> rtable ^. remoteTableDict typ
43 where
45 where
44 typ = decode env :: TypeRep
46 typ = decode env :: TypeRep
45−-- Generic closure combinators
46−resolveClosure rtable ClosureApply env = do
47− f <- resolveClosure rtable labelf envf
48− x <- resolveClosure rtable labelx envx
49− f `dynApply` x
50− where
51− (labelf, envf, labelx, envx) = decode env
52−resolveClosure rtable CpApply env =
53− return $ Dynamic typApply (unsafeCoerce# cpApply)
54− where
55− cpApply :: forall a b. (Closure (a -> Process b), a) -> Process b
56− cpApply (Closure (Static flabel) fenv, x) = do
57− let Just f = resolveClosure rtable flabel fenv
58− Dynamic typResult val = f `dynApp` Dynamic typA (unsafeCoerce# x)
59− if typResult == typProcB
60− then unsafeCoerce# val
61− else error $ "Type error in cpApply: "
62− ++ "mismatch between " ++ show typResult
63− ++ " and " ++ show typProcB
64−
65− (typApply, typA, typProcB) = decode env
66−
67-- User defined closures
47-- User defined closures
68resolveClosure rtable (UserStatic label) env = do
48resolveClosure rtable (UserStatic label) env = do
69 val <- rtable ^. remoteTableLabel label
49 val <- rtable ^. remoteTableLabel label
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+2−2
@@ -75,8 +75,8 @@ remotable ns = do
75
75
76-- | Create a closure
76-- | Create a closure
77--
77--
78−-- If @f :: a -> b@ then @mkClosure :: a -> Closure b@. Make sure to pass 'f'
78+-- See module documentation header for "Control.Distributed.Process.Closure"
79−-- as an argument to 'remotable' too.
79+-- for a detailed explanation and examples.
80mkClosure :: Name -> Q Exp
80mkClosure :: Name -> Q Exp
81mkClosure = varE . closureName
81mkClosure = varE . closureName
82
82
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+10−13
@@ -262,13 +262,12 @@ data ReceivePort a =
262data StaticLabel =
262data StaticLabel =
263 UserStatic String
263 UserStatic String
264 | PolyStatic String
264 | PolyStatic String
265+ -- Closure combinators
266+ | ClosureApply
265 -- Built-in closures
267 -- Built-in closures
266 | ClosureReturn
268 | ClosureReturn
267 | ClosureSend
269 | ClosureSend
268 | ClosureExpect
270 | ClosureExpect
269− -- Generic closure combinators
270− | ClosureApply
271− | CpApply
272 deriving (Typeable, Show)
271 deriving (Typeable, Show)
273
272
274-- | A static value is one that is bound at top-level.
273-- | A static value is one that is bound at top-level.
@@ -547,21 +546,19 @@ instance Binary Identifier where
547instance Binary StaticLabel where
546instance Binary StaticLabel where
548 put (UserStatic string) = putWord8 0 >> put string
547 put (UserStatic string) = putWord8 0 >> put string
549 put (PolyStatic string) = putWord8 1 >> put string
548 put (PolyStatic string) = putWord8 1 >> put string
549+ put ClosureApply = putWord8 2
550− put ClosureReturn = putWord8 2
550+ put ClosureReturn = putWord8 3
551− put ClosureSend = putWord8 3
551+ put ClosureSend = putWord8 4
552− put ClosureExpect = putWord8 4
552+ put ClosureExpect = putWord8 5
553− put ClosureApply = putWord8 6
554− put CpApply = putWord8 17
555 get = do
553 get = do
556 header <- getWord8
554 header <- getWord8
557 case header of
555 case header of
558 0 -> UserStatic <$> get
556 0 -> UserStatic <$> get
559 1 -> PolyStatic <$> get
557 1 -> PolyStatic <$> get
560− 2 -> return ClosureReturn
558+ 2 -> return ClosureApply
559+ 3 -> return ClosureReturn
561− 3 -> return ClosureSend
560+ 4 -> return ClosureSend
562− 4 -> return ClosureExpect
561+ 5 -> return ClosureExpect
563− 6 -> return ClosureApply
564− 17 -> return CpApply
565 _ -> fail "StaticLabel.get: invalid"
562 _ -> fail "StaticLabel.get: invalid"
566
563
567instance Binary WhereIsReply where
564instance Binary WhereIsReply where
distributed-process/src/Control/Distributed/Process/Node.hs+2−5
@@ -121,17 +121,14 @@ import Control.Distributed.Process.Internal.Dynamic (fromDynamic)
121import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
121import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)
122import Control.Distributed.Process.Internal.Node (runLocalProcess)
122import Control.Distributed.Process.Internal.Node (runLocalProcess)
123import Control.Distributed.Process.Internal.Primitives (expect, register)
123import Control.Distributed.Process.Internal.Primitives (expect, register)
124−import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)
124+import qualified Control.Distributed.Process.Internal.Closure.Derived as Derived (remoteTable)
125−import qualified Control.Distributed.Process.Internal.Closure.Derived as Combinators (remoteTable)
126
125
127--------------------------------------------------------------------------------
126--------------------------------------------------------------------------------
128-- Initialization --
127-- Initialization --
129--------------------------------------------------------------------------------
128--------------------------------------------------------------------------------
130
129
131initRemoteTable :: RemoteTable
130initRemoteTable :: RemoteTable
132−initRemoteTable = BuiltIn.remoteTable
133− . Combinators.remoteTable
134− $ RemoteTable Map.empty Map.empty
131+initRemoteTable = Derived.remoteTable $ RemoteTable Map.empty Map.empty
135
132
136-- | Initialize a new local node.
133-- | Initialize a new local node.
137--
134--
distributed-process/tests/TestClosure.hs−14
@@ -212,19 +212,6 @@ testSeq transport rtable = do
212 720 :: Int <- expect
212 720 :: Int <- expect
213 return ()
213 return ()
214
214
215−testApply :: Transport -> RemoteTable -> IO ()
216−testApply transport rtable = do
217− node <- newLocalNode transport rtable
218− runProcess node $ do
219− (120 :: Int) <- join (unClosure bar)
220− return ()
221− where
222− bar :: Closure (Process Int)
223− bar = closureApply cpApply foo
224−
225− foo :: Closure (Closure (Int -> Process Int), Int)
226− foo = $(mkClosure 'returnForTestApply) ($(mkClosure 'factorialOf) (), 5)
227−
228-- Test 'spawnSupervised'
215-- Test 'spawnSupervised'
229--
216--
230-- Set up a supervisor, spawn a child, then have a third process monitor the
217-- Set up a supervisor, spawn a child, then have a third process monitor the
@@ -294,7 +281,6 @@ main = do
294 , ("Bind", testBind transport rtable)
281 , ("Bind", testBind transport rtable)
295 , ("CallBind", testCallBind transport rtable)
282 , ("CallBind", testCallBind transport rtable)
296 , ("Seq", testSeq transport rtable)
283 , ("Seq", testSeq transport rtable)
297− , ("Apply", testApply transport rtable)
298 , ("SpawnSupervised", testSpawnSupervised transport rtable)
284 , ("SpawnSupervised", testSpawnSupervised transport rtable)
299 , ("SpawnInvalid", testSpawnInvalid transport rtable)
285 , ("SpawnInvalid", testSpawnInvalid transport rtable)
300 , ("ClosureExpect", testClosureExpect transport rtable)
286 , ("ClosureExpect", testClosureExpect transport rtable)