6c76227 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Reintroduce mkClosure

6c76227Edsko de Vries14 years ago

distributed-process/distributed-process.cabal+2

compare with master

unifiedsplit

@@ -54,6 +54,8 @@ Library

54 Control.Distributed.Process.Internal.TypeRep,

55 Control.Distributed.Process.Internal.MessageT,

56 Control.Distributed.Process.Internal.Types,

57+ Control.Distributed.Process.Internal.Closure.Static,

58+ Control.Distributed.Process.Internal.Closure.MkClosure,

57 Control.Distributed.Process.Internal.Closure.Derived,

59 Control.Distributed.Process.Internal.Closure.Derived,

58 Control.Distributed.Process.Internal.Closure.TH,

60 Control.Distributed.Process.Internal.Closure.TH,

59 Control.Distributed.Process.Internal.Closure.Resolution,

61 Control.Distributed.Process.Internal.Closure.Resolution,

distributed-process/src/Control/Distributed/Process.hs+3−1

@@ -124,7 +124,9 @@ import Control.Distributed.Process.Internal.Closure.Derived

124 , cpExpect

125 , cpLink

126 , cpUnlink

127+ )

128+import Control.Distributed.Process.Internal.Closure.Static

127− , sdictUnit

129+ ( sdictUnit

128 , sdictUnit__static

130 , sdictUnit__static

129 )

131 )

130import Control.Distributed.Process.Internal.Primitives

132import Control.Distributed.Process.Internal.Primitives

distributed-process/src/Control/Distributed/Process/Closure.hs+18−9

@@ -91,6 +91,8 @@ module Control.Distributed.Process.Closure

91 ( -- * User-defined closures

92 remotable

93 , mkStatic

94+ , mkClosure

95+ , functionSDict

94 -- * Static functionals

96 -- * Static functionals

95 , staticConst

97 , staticConst

96 , staticCompose

98 , staticCompose

@@ -123,8 +125,12 @@ import Control.Distributed.Process.Internal.Types

123 ( SerializableDict(..)

125 ( SerializableDict(..)

124 , staticApply

126 , staticApply

125 )

127 )

126−import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

128+import Control.Distributed.Process.Internal.Closure.TH

129+ ( remotable

130+ , mkStatic

131+ , functionSDict

132+ )

127−import Control.Distributed.Process.Internal.Closure.Derived

133+import Control.Distributed.Process.Internal.Closure.Static

128 ( -- Static functionals

134 ( -- Static functionals

129 staticConst

135 staticConst

130 , staticCompose

136 , staticCompose

@@ -135,8 +141,16 @@ import Control.Distributed.Process.Internal.Closure.Derived

135 , staticDecode

141 , staticDecode

136 , staticClosure

142 , staticClosure

137 , toClosure

143 , toClosure

144+ -- Serialization dictionaries (and their static versions)

145+ , sdictUnit

146+ , sdictUnit__static

147+ , sdictProcessId

148+ , sdictProcessId__static

149+ )

150+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)

151+import Control.Distributed.Process.Internal.Closure.Derived

138− -- Closure versions of CH primitives

152+ ( -- Closure versions of CH primitives

139− , cpLink

153+ cpLink

140 , cpUnlink

154 , cpUnlink

141 , cpSend

155 , cpSend

142 , cpExpect

156 , cpExpect

@@ -144,9 +158,4 @@ import Control.Distributed.Process.Internal.Closure.Derived

144 , cpReturn

158 , cpReturn

145 , cpBind

159 , cpBind

146 , cpSeq

160 , cpSeq

147− -- Serialization dictionaries (and their static versions)

148− , sdictUnit

149− , sdictUnit__static

150− , sdictProcessId

151− , sdictProcessId__static

152 )

161 )

distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hs+25−129

@@ -1,18 +1,8 @@

1-- | Derived (TH generated) closures

2{-# LANGUAGE MagicHash #-}

3module Control.Distributed.Process.Internal.Closure.Derived

4− ( -- * Static functionals

5− staticConst

6− , staticCompose

7− , staticFirst

8− , staticSecond

9− , staticSplit

10− -- * Creating closures

11− , staticDecode

12− , staticClosure

13− , toClosure

14− -- * Closure versions of CH primitives

4+ ( -- * Closure versions of CH primitives

15− , cpLink

5+ cpLink

16 , cpUnlink

6 , cpUnlink

17 , cpSend

7 , cpSend

18 , cpExpect

8 , cpExpect

@@ -20,17 +10,12 @@ module Control.Distributed.Process.Internal.Closure.Derived

20 , cpReturn

10 , cpReturn

21 , cpBind

11 , cpBind

22 , cpSeq

12 , cpSeq

23− -- * Serialization dictionaries (and their static versions)

24− , sdictUnit

25− , sdictUnit__static

26− , sdictProcessId

27− , sdictProcessId__static

28 -- * Runtime support

13 -- * Runtime support

29 , __remoteTable

14 , __remoteTable

30 ) where

15 ) where

32−import Data.Binary (encode, decode)

17+import Data.Binary (encode)

33−import Data.ByteString.Lazy (ByteString, empty)

18+import Data.ByteString.Lazy (ByteString)

34import Data.Typeable (Typeable, typeOf, TypeRep, typeRepTyCon, TyCon)

19import Data.Typeable (Typeable, typeOf, TypeRep, typeRepTyCon, TyCon)

35import Control.Applicative ((<$>))

20import Control.Applicative ((<$>))

36import Control.Monad (join)

21import Control.Monad (join)

@@ -55,13 +40,24 @@ import Control.Distributed.Process.Internal.Primitives

55import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

40import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

56import Control.Distributed.Process.Internal.MessageT (getLocalNode)

41import Control.Distributed.Process.Internal.MessageT (getLocalNode)

57import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

42import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

43+import Control.Distributed.Process.Internal.Closure.Static

44+ ( staticCompose

45+ , staticDecode

46+ , staticClosure

47+ , staticSplit

48+ , staticFirst

49+ , staticConst

50+ , staticUnit

51+ , sdictProcessId

52+ , sdictProcessId__static

53+ )

54+import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)

58import Control.Distributed.Process.Internal.Dynamic

55import Control.Distributed.Process.Internal.Dynamic

59 ( Dynamic(Dynamic)

56 ( Dynamic(Dynamic)

60 , dynBind

57 , dynBind

61 , unsafeCoerce#

58 , unsafeCoerce#

62 , dynTypeRep

59 , dynTypeRep

63 )

60 )

64−import qualified Control.Arrow as Arrow (first, second, (***))

66--------------------------------------------------------------------------------

62--------------------------------------------------------------------------------

67-- Setup: A number of functions that we will pass to 'remotable' --

63-- Setup: A number of functions that we will pass to 'remotable' --

@@ -78,25 +74,8 @@ bindProcess = (>>=)

78joinProcess :: Process (Process a) -> Process a

74joinProcess :: Process (Process a) -> Process a

79joinProcess = join

75joinProcess = join

81−---- Functionals ---------------------------------------------------------------

82−

83−compose :: (b -> c) -> (a -> b) -> a -> c

84−compose = (.)

85−

86−first :: (a -> b) -> (a, c) -> (b, c)

87−first = Arrow.first

88−

89−second :: (a -> b) -> (c, a) -> (c, b)

90−second = Arrow.second

91−

92−split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')

93−split = (Arrow.***)

94−

95---- Variations on standard or CH functions with an explicit dictionary arg ----

77---- Variations on standard or CH functions with an explicit dictionary arg ----

97−decodeDict :: SerializableDict a -> ByteString -> a

98−decodeDict SerializableDict = decode

99−

100sendDict :: SerializableDict a -> ProcessId -> a -> Process ()

79sendDict :: SerializableDict a -> ProcessId -> a -> Process ()

101sendDict SerializableDict = send

80sendDict SerializableDict = send

102

@@ -105,20 +84,6 @@ expectDict SerializableDict = expect

105

106---- Serialization dictionaries ------------------------------------------------

85---- Serialization dictionaries ------------------------------------------------

107

108−-- | Serialization dictionary for '()'

109−--

110−-- Use @$(mkStatic sdictUnit)@ (instead of 'sdictUnit__static')

111−-- to refer to the static dictionary.

112−sdictUnit :: SerializableDict ()

113−sdictUnit = SerializableDict

114−

115−-- | Serialization dictionary for 'ProcessId'

116−--

117−-- Use @$(mkStatic sdictProcessId)@ (instead of 'sdictProcessId__static')

118−-- to refer to the static dictionary.

119−sdictProcessId :: SerializableDict ProcessId

120−sdictProcessId = SerializableDict

121−

122-- | Specialized serialization dictionary required in 'cpBind'

87-- | Specialized serialization dictionary required in 'cpBind'

123sdictBind :: SerializableDict (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)

88sdictBind :: SerializableDict (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)

124sdictBind = SerializableDict

89sdictBind = SerializableDict

@@ -142,8 +107,8 @@ unDynamic (pdyn, typ) = do

142 ++ " against expected type "

107 ++ " against expected type "

143 ++ show typ

108 ++ show typ

144

109

145−bindDyn :: (Process Dynamic, Process Dynamic) -> Process Dynamic

110+bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic

146−bindDyn (px, pf) = do

111+bindDyn () (px, pf) = do

147 x <- px

112 x <- px

148 f <- pf

113 f <- pf

149 case dynBind tyConProcess bindProcess x f of

114 case dynBind tyConProcess bindProcess x f of

@@ -162,23 +127,13 @@ remotable [ -- Monadic operations

162 'returnProcess

127 'returnProcess

163 , 'bindProcess

128 , 'bindProcess

164 , 'joinProcess

129 , 'joinProcess

165− -- Functionals (predefined)

166− , 'const

167− -- Functionals (defined above)

168− , 'compose

169− , 'first

170− , 'second

171− , 'split

172 -- CH primitives

130 -- CH primitives

173 , 'link

131 , 'link

174 , 'unlink

132 , 'unlink

175− -- Explicit dictionaries

133+ -- Explicit dictionaries

176− , 'decodeDict

177 , 'sendDict

134 , 'sendDict

178 , 'expectDict

135 , 'expectDict

179 -- Serialization dictionaries

136 -- Serialization dictionaries

180− , 'sdictUnit

181− , 'sdictProcessId

182 , 'sdictBind

137 , 'sdictBind

183 -- Specialized processes

138 -- Specialized processes

184 , 'unClosure

139 , 'unClosure

@@ -186,76 +141,17 @@ remotable [ -- Monadic operations

186 , 'bindDyn

141 , 'bindDyn

187 ]

142 ]

188

143

189−--------------------------------------------------------------------------------

190−-- Static versions of the functionals --

191−-- (We give these explicit names because they are useful outside this module) --

192−--------------------------------------------------------------------------------

193−

194−-- | Static version of 'const'

195−staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)

196−staticConst = $(mkStatic 'const)

197−

198−-- | Static version of ('Prelude..')

199−staticCompose :: (Typeable a, Typeable b, Typeable c)

200− => Static (b -> c) -> Static (a -> b) -> Static (a -> c)

201−staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x

202−

203−-- | Static version of 'Control.Arrow.first'

204−staticFirst :: (Typeable a, Typeable b, Typeable c)

205− => Static ((a -> b) -> (a, c) -> (b, c))

206−staticFirst = $(mkStatic 'first)

207−

208−-- | Static version of 'Control.Arrow.second'

209−staticSecond :: (Typeable a, Typeable b, Typeable c)

210− => Static ((a -> b) -> (c, a) -> (c, b))

211−staticSecond = $(mkStatic 'second)

212−

213−-- | Static version of ('Control.Arrow.***')

214−staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)

215− => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))

216−staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g

217−

218−--------------------------------------------------------------------------------

219−-- Creating closures --

220−--------------------------------------------------------------------------------

221−

222−staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)

223−staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict

224−

225−staticClosure :: forall a. Typeable a => Static a -> Closure a

226−staticClosure static = Closure decoder empty

227− where

228− decoder :: Static (ByteString -> a)

229− decoder = staticConst `staticApply` static

230−

231−toClosure :: forall a. Serializable a

232− => Static (SerializableDict a) -> a -> Closure a

233−toClosure dict x = Closure decoder (encode x)

234− where

235− decoder :: Static (ByteString -> a)

236− decoder = $(mkStatic 'decodeDict) `staticApply` dict

237−

238--------------------------------------------------------------------------------

144--------------------------------------------------------------------------------

239-- Closure versions of CH primitives --

145-- Closure versions of CH primitives --

240--------------------------------------------------------------------------------

146--------------------------------------------------------------------------------

241

147

242-- | Closure version of 'link'

148-- | Closure version of 'link'

243cpLink :: ProcessId -> Closure (Process ())

149cpLink :: ProcessId -> Closure (Process ())

244−cpLink pid = Closure decoder (encode pid)

150+cpLink = $(mkClosure 'link)

245− where

246− decoder :: Static (ByteString -> Process ())

247− decoder = $(mkStatic 'link)

248− `staticCompose`

249− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))

250

151

251-- | Closure version of 'unlink'

152-- | Closure version of 'unlink'

252cpUnlink :: ProcessId -> Closure (Process ())

153cpUnlink :: ProcessId -> Closure (Process ())

253−cpUnlink pid = Closure decoder (encode pid)

154+cpUnlink = $(mkClosure 'unlink)

254− where

255− decoder :: Static (ByteString -> Process ())

256− decoder = $(mkStatic 'unlink)

257− `staticCompose`

258− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))

259

155

260-- | Closure version of 'send'

156-- | Closure version of 'send'

261cpSend :: forall a. Typeable a

157cpSend :: forall a. Typeable a

@@ -265,7 +161,7 @@ cpSend dict pid = Closure decoder (encode pid)

265 decoder :: Static (ByteString -> a -> Process ())

161 decoder :: Static (ByteString -> a -> Process ())

266 decoder = ($(mkStatic 'sendDict) `staticApply` dict)

162 decoder = ($(mkStatic 'sendDict) `staticApply` dict)

267 `staticCompose`

163 `staticCompose`

268− ($(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictProcessId))

164+ staticDecode $(mkStatic 'sdictProcessId)

269

165

270-- | Closure version of 'expect'

166-- | Closure version of 'expect'

271cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

167cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

@@ -283,7 +179,7 @@ cpReturn dict x = Closure decoder (encode x)

283 decoder :: Static (ByteString -> Process a)

179 decoder :: Static (ByteString -> Process a)

284 decoder = $(mkStatic 'returnProcess)

180 decoder = $(mkStatic 'returnProcess)

285 `staticCompose`

181 `staticCompose`

286− ($(mkStatic 'decodeDict) `staticApply` dict)

182+ staticDecode dict

287

183

288-- | Not-quite-monadic bind ('>>=')

184-- | Not-quite-monadic bind ('>>=')

289cpBind :: forall a b. Typeable b

185cpBind :: forall a b. Typeable b

@@ -303,7 +199,7 @@ cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =

303 aux1

199 aux1

304

200

305 aux1 :: Static (ByteString -> (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep))

201 aux1 :: Static (ByteString -> (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep))

306− aux1 = $(mkStatic 'decodeDict) `staticApply` $(mkStatic 'sdictBind)

202+ aux1 = staticDecode $(mkStatic 'sdictBind)

307

203

308 aux2 :: Static ((StaticLabel, ByteString) -> Process Dynamic)

204 aux2 :: Static ((StaticLabel, ByteString) -> Process Dynamic)

309 aux2 = $(mkStatic 'unClosure)

205 aux2 = $(mkStatic 'unClosure)

@@ -312,7 +208,7 @@ cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =

312 aux3 = aux2 `staticSplit` aux2

208 aux3 = aux2 `staticSplit` aux2

313

209

314 aux4 :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)

210 aux4 :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)

315− aux4 = $(mkStatic 'bindDyn)

211+ aux4 = $(mkStatic 'bindDyn) `staticApply` staticUnit

316

212

317 aux5 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> Process Dynamic)

213 aux5 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> Process Dynamic)

318 aux5 = aux4 `staticCompose` aux3

214 aux5 = aux4 `staticCompose` aux3

distributed-process/src/Control/Distributed/Process/Internal/Closure/MkClosure.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+module Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure) where

4+import Data.Binary (encode)

5+import Language.Haskell.TH (Q, Exp, Name)

6+import Control.Distributed.Process.Internal.Types (Closure(Closure))

7+import Control.Distributed.Process.Internal.Closure.TH

8+ ( mkStatic

9+ , functionSDict

10+ )

11+import Control.Distributed.Process.Internal.Closure.Static

12+ ( staticCompose

13+ , staticDecode

14+ )

15+

16+mkClosure :: Name -> Q Exp

17+mkClosure n =

18+ [| Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))

19+ . encode

20+ |]

distributed-process/src/Control/Distributed/Process/Internal/Closure/Static.hsnew file+153

@@ -0,0 +1,153 @@

1+-- | Combinators on static values

2+{-# LANGUAGE MagicHash #-}

3+module Control.Distributed.Process.Internal.Closure.Static

4+ ( -- * Static functionals

5+ staticConst

6+ , staticCompose

7+ , staticFirst

8+ , staticSecond

9+ , staticSplit

10+ -- * Static constants

11+ , staticUnit

12+ -- * Creating closures

13+ , staticDecode

14+ , staticClosure

15+ , toClosure

16+ -- * Serialization dictionaries (and their static versions)

17+ , sdictUnit

18+ , sdictUnit__static

19+ , sdictProcessId

20+ , sdictProcessId__static

21+ -- * Runtime support

22+ , __remoteTable

23+ ) where

24+

25+import Data.Binary (encode, decode)

26+import Data.ByteString.Lazy (ByteString, empty)

27+import Data.Typeable (Typeable)

28+import Control.Distributed.Process.Serializable (Serializable)

29+import Control.Distributed.Process.Internal.Types

30+ ( Closure(Closure)

31+ , SerializableDict(SerializableDict)

32+ , Static

33+ , staticApply

34+ , ProcessId

35+ )

36+import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)

37+import qualified Control.Arrow as Arrow (first, second, (***))

38+

39+--------------------------------------------------------------------------------

40+-- Setup: A number of functions that we will pass to 'remotable' --

41+--------------------------------------------------------------------------------

42+

43+---- Functionals ---------------------------------------------------------------

44+

45+compose :: (b -> c) -> (a -> b) -> a -> c

46+compose = (.)

47+

48+first :: (a -> b) -> (a, c) -> (b, c)

49+first = Arrow.first

50+

51+second :: (a -> b) -> (c, a) -> (c, b)

52+second = Arrow.second

53+

54+split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')

55+split = (Arrow.***)

56+

57+---- Constants -----------------------------------------------------------------

58+

59+unit :: ()

60+unit = ()

61+

62+---- Variations on standard or CH functions with an explicit dictionary arg ----

63+

64+decodeDict :: SerializableDict a -> ByteString -> a

65+decodeDict SerializableDict = decode

66+

67+---- Serialization dictionaries ------------------------------------------------

68+

69+-- | Serialization dictionary for '()'

70+--

71+-- Use @$(mkStatic sdictUnit)@ (instead of 'sdictUnit__static')

72+-- to refer to the static dictionary.

73+sdictUnit :: SerializableDict ()

74+sdictUnit = SerializableDict

75+

76+-- | Serialization dictionary for 'ProcessId'

77+--

78+-- Use @$(mkStatic sdictProcessId)@ (instead of 'sdictProcessId__static')

79+-- to refer to the static dictionary.

80+sdictProcessId :: SerializableDict ProcessId

81+sdictProcessId = SerializableDict

82+

83+---- Finally, the call to remotable --------------------------------------------

84+

85+remotable [ -- Functionals (predefined)

86+ 'const

87+ -- Functionals (defined above)

88+ , 'compose

89+ , 'first

90+ , 'second

91+ , 'split

92+ -- Constants

93+ , 'unit

94+ -- Explicit dictionaries

95+ , 'decodeDict

96+ -- Serialization dictionaries

97+ , 'sdictUnit

98+ , 'sdictProcessId

99+ ]

100+

101+--------------------------------------------------------------------------------

102+-- Static versions of the functionals --

103+-- (We give these explicit names because they are useful outside this module) --

104+--------------------------------------------------------------------------------

105+

106+-- | Static version of 'const'

107+staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)

108+staticConst = $(mkStatic 'const)

109+

110+-- | Static version of ('Prelude..')

111+staticCompose :: (Typeable a, Typeable b, Typeable c)

112+ => Static (b -> c) -> Static (a -> b) -> Static (a -> c)

113+staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x

114+

115+-- | Static version of 'Control.Arrow.first'

116+staticFirst :: (Typeable a, Typeable b, Typeable c)

117+ => Static ((a -> b) -> (a, c) -> (b, c))

118+staticFirst = $(mkStatic 'first)

119+

120+-- | Static version of 'Control.Arrow.second'

121+staticSecond :: (Typeable a, Typeable b, Typeable c)

122+ => Static ((a -> b) -> (c, a) -> (c, b))

123+staticSecond = $(mkStatic 'second)

124+

125+-- | Static version of ('Control.Arrow.***')

126+staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)

127+ => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))

128+staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g

129+

130+--------------------------------------------------------------------------------

131+-- Constants --

132+--------------------------------------------------------------------------------

133+

134+-- | Static version of '()'

135+staticUnit :: Static ()

136+staticUnit = $(mkStatic 'unit)

137+

138+--------------------------------------------------------------------------------

139+-- Creating closures --

140+--------------------------------------------------------------------------------

141+

142+staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)

143+staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict

144+

145+staticClosure :: forall a. Typeable a => Static a -> Closure a

146+staticClosure static = Closure decoder empty

147+ where

148+ decoder :: Static (ByteString -> a)

149+ decoder = staticConst `staticApply` static

150+

151+toClosure :: forall a. Serializable a

152+ => Static (SerializableDict a) -> a -> Closure a

153+toClosure dict x = Closure (staticDecode dict) (encode x)

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+63−16

@@ -6,6 +6,7 @@ module Control.Distributed.Process.Internal.Closure.TH

6 ( -- * User-level API

7 remotable

8 , mkStatic

9+ , functionSDict

9 ) where

10 ) where

11import Prelude hiding (lookup)

12import Prelude hiding (lookup)

@@ -23,7 +24,7 @@ import Language.Haskell.TH

23 -- Algebraic data types

24 -- Algebraic data types

24 , Dec

25 , Dec

25 , Exp

26 , Exp

26− , Type(AppT, ForallT, VarT)

27+ , Type(AppT, ForallT, VarT, ArrowT)

27 , Info(VarI)

28 , Info(VarI)

28 , TyVarBndr(PlainTV, KindedTV)

29 , TyVarBndr(PlainTV, KindedTV)

29 , Pred(ClassP)

30 , Pred(ClassP)

@@ -42,13 +43,15 @@ import Language.Haskell.TH

42 )

43 )

43import Control.Distributed.Process.Internal.Types

44import Control.Distributed.Process.Internal.Types

44 ( RemoteTable

45 ( RemoteTable

45− , Static(..)

46+ , Static(Static)

46− , StaticLabel(..)

47+ , StaticLabel(StaticLabel)

47 , remoteTableLabel

48 , remoteTableLabel

49+ , SerializableDict(SerializableDict)

48 )

50 )

49import Control.Distributed.Process.Internal.Dynamic

51import Control.Distributed.Process.Internal.Dynamic

50 ( Dynamic(..)

52 ( Dynamic(..)

51 , unsafeCoerce#

53 , unsafeCoerce#

54+ , toDyn

52 )

55 )

54--------------------------------------------------------------------------------

57--------------------------------------------------------------------------------

@@ -60,13 +63,17 @@ import Control.Distributed.Process.Internal.Dynamic

60remotable :: [Name] -> Q [Dec]

63remotable :: [Name] -> Q [Dec]

61remotable ns = do

64remotable ns = do

62 (closures, inserts) <- unzip <$> mapM generateDefs ns

65 (closures, inserts) <- unzip <$> mapM generateDefs ns

63− rtable <- createMetaData inserts

66+ rtable <- createMetaData (concat inserts)

64 return $ concat closures ++ rtable

67 return $ concat closures ++ rtable

66-- | Construct a static value

69-- | Construct a static value

67mkStatic :: Name -> Q Exp

70mkStatic :: Name -> Q Exp

68mkStatic = varE . staticName

71mkStatic = varE . staticName

73+-- | Serialization dictionary for a function argument (see module header)

74+functionSDict :: Name -> Q Exp

75+functionSDict = varE . sdictName

76+

70{-

77{-

71-- | Create a closure

78-- | Create a closure

72--

79--

@@ -87,41 +94,81 @@ createMetaData is =

87 __remoteTable = $(compose is)

94 __remoteTable = $(compose is)

88 |]

95 |]

90−generateDefs :: Name -> Q ([Dec], Q Exp)

97+generateDefs :: Name -> Q ([Dec], [Q Exp])

91generateDefs n = do

98generateDefs n = do

92 mType <- getType n

99 mType <- getType n

93 case mType of

100 case mType of

94 Just (origName, typ) -> do

101 Just (origName, typ) -> do

95 let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)

102 let (typVars, typ') = case typ of ForallT vars [] mono -> (vars, mono)

96 _ -> ([], typ)

103 _ -> ([], typ)

104+ (static, register) <- do

97− (static, label) <- generateStatic origName typVars typ'

105+ static <- generateStatic origName typVars typ'

106+ let dyn = case typVars of

107+ [] -> [| toDyn $(varE origName) |]

98− return (static, [| registerStatic $(stringE label) (Dynamic (error "Polymorphic value") (unsafeCoerce# $(varE origName))) |])

108+ _ -> [| Dynamic (error "Polymorphic value")

109+ (unsafeCoerce# $(varE origName))

110+ |]

111+ return ( static

112+ , [ [| registerStatic $(stringE (show origName)) $dyn |] ]

113+ )

114+

115+ (sdict, registerSDict) <- case (typVars, typ') of

116+ ([], ArrowT `AppT` arg `AppT` _res) -> do

117+ -- TODO: we should check if arg is an instance of Serializable, but we cannot

118+ -- http://hackage.haskell.org/trac/ghc/ticket/7066

119+ sdict <- generateSDict origName arg

120+ let dyn' = [| toDyn (SerializableDict :: SerializableDict $(return arg)) |]

121+ return ( sdict

122+ , [ [| registerStatic $(stringE (show (sdictName origName))) $dyn' |] ]

123+ )

124+ _ ->

125+ return ([], [])

126+

127+ return ( static ++ sdict

128+ , register ++ registerSDict

129+ )

99 _ ->

130 _ ->

100 fail $ "remotable: " ++ show n ++ " not found"

131 fail $ "remotable: " ++ show n ++ " not found"

101−

132+

102registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable

133registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable

103registerStatic label dyn = remoteTableLabel label ^= Just dyn

134registerStatic label dyn = remoteTableLabel label ^= Just dyn

104

135

105-- | Generate a static value

136-- | Generate a static value

106−generateStatic :: Name -> [TyVarBndr] -> Type -> Q ([Dec], String)

137+generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]

107generateStatic n xs typ = do

138generateStatic n xs typ = do

108 staticTyp <- [t| Static |]

139 staticTyp <- [t| Static |]

109− closure <- sequence

140+ sequence

110− [ sigD (staticName n) (return (ForallT xs (map typeable xs) (staticTyp `AppT` typ)) )

141+ [ sigD (staticName n) $ return (ForallT xs

142+ (map typeable xs)

143+ (staticTyp `AppT` typ)

144+ )

111− , sfnD (staticName n) [| Static (StaticLabel $(stringE label) (typeOf (undefined :: $(return typ)))) |]

145+ , sfnD (staticName n) [| Static $ StaticLabel

146+ $(stringE (show n))

147+ (typeOf (undefined :: $(return typ)))

148+ |]

112 ]

149 ]

113− return (closure, label)

114 where

150 where

115− label :: String

116− label = show n

117−

118 typeable :: TyVarBndr -> Pred

151 typeable :: TyVarBndr -> Pred

119 typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]

152 typeable (PlainTV v) = ClassP (mkName "Typeable") [VarT v]

120 typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]

153 typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]

121

154

155+-- | Generate a function serialization dictionary

156+generateSDict :: Name -> Type -> Q [Dec]

157+generateSDict n typ = do

158+ sequence

159+ [ sigD (sdictName n) $ [t| Static (SerializableDict $(return typ)) |]

160+ , sfnD (sdictName n) [| Static $ StaticLabel

161+ $(stringE (show (sdictName n)))

162+ (typeOf (undefined :: SerializableDict $(return typ)))

163+ |]

164+ ]

165+

122staticName :: Name -> Name

166staticName :: Name -> Name

123staticName n = mkName $ nameBase n ++ "__static"

167staticName n = mkName $ nameBase n ++ "__static"

124

168

169+sdictName :: Name -> Name

170+sdictName n = mkName $ nameBase n ++ "__sdict"

171+

125{-

172{-

126-- | Generate the necessary definitions for one function

173-- | Generate the necessary definitions for one function

127--

174--

distributed-process/src/Control/Distributed/Process/Node.hs+4−1

@@ -121,6 +121,7 @@ import Control.Distributed.Process.Internal.Dynamic (fromDynamic)

121import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)

122import Control.Distributed.Process.Internal.Node (runLocalProcess)

123import Control.Distributed.Process.Internal.Primitives (expect, register)

124+import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)

124import qualified Control.Distributed.Process.Internal.Closure.Derived as Derived (__remoteTable)

125import qualified Control.Distributed.Process.Internal.Closure.Derived as Derived (__remoteTable)

125

126

126--------------------------------------------------------------------------------

127--------------------------------------------------------------------------------

@@ -128,7 +129,9 @@ import qualified Control.Distributed.Process.Internal.Closure.Derived as Derived

128--------------------------------------------------------------------------------

129--------------------------------------------------------------------------------

129

130

130initRemoteTable :: RemoteTable

131initRemoteTable :: RemoteTable

132+initRemoteTable = Static.__remoteTable

131−initRemoteTable = Derived.__remoteTable $ RemoteTable Map.empty

133+ . Derived.__remoteTable

134+ $ RemoteTable Map.empty

132

135

133-- | Initialize a new local node.

136-- | Initialize a new local node.

134--

137--

distributed-process/tests/TestClosure.hs+6−22

@@ -1,8 +1,7 @@

1module Main where

3−import Data.ByteString.Lazy (ByteString, empty)

3+import Data.ByteString.Lazy (empty)

4import Data.Typeable (Typeable, typeOf)

5−import Data.Binary (encode)

6import Control.Monad (join, replicateM)

5import Control.Monad (join, replicateM)

7import Control.Exception (IOException, throw)

6import Control.Exception (IOException, throw)

8import Control.Concurrent (forkIO, threadDelay)

7import Control.Concurrent (forkIO, threadDelay)

@@ -46,28 +45,16 @@ remotable [ 'factorial

46 ]

45 ]

48factorialClosure :: Int -> Closure (Process Int)

47factorialClosure :: Int -> Closure (Process Int)

49−factorialClosure n = Closure decoder (encode n)

48+factorialClosure = $(mkClosure 'factorial)

50− where

51− decoder :: Static (ByteString -> Process Int)

52− decoder = $(mkStatic 'factorial) `staticCompose` staticDecode $(mkStatic 'sdictInt)

54addIntClosure :: Int -> Closure (Int -> Int)

50addIntClosure :: Int -> Closure (Int -> Int)

55−addIntClosure n = Closure decoder (encode n)

51+addIntClosure = $(mkClosure 'addInt)

56− where

57− decoder :: Static (ByteString -> Int -> Int)

58− decoder = $(mkStatic 'addInt) `staticCompose` staticDecode $(mkStatic 'sdictInt)

60putIntClosure :: Int -> Closure (MVar Int -> IO ())

53putIntClosure :: Int -> Closure (MVar Int -> IO ())

61−putIntClosure n = Closure decoder (encode n)

54+putIntClosure = $(mkClosure 'putInt)

62− where

63− decoder :: Static (ByteString -> MVar Int -> IO ())

64− decoder = $(mkStatic 'putInt) `staticCompose` staticDecode $(mkStatic 'sdictInt)

66sendPidClosure :: ProcessId -> Closure (Process ())

56sendPidClosure :: ProcessId -> Closure (Process ())

67−sendPidClosure pid = Closure decoder (encode pid)

57+sendPidClosure = $(mkClosure 'sendPid)

68− where

69− decoder :: Static (ByteString -> Process ())

70− decoder = $(mkStatic 'sendPid) `staticCompose` staticDecode $(mkStatic 'sdictProcessId)

72sendFac :: Int -> ProcessId -> Closure (Process ())

59sendFac :: Int -> ProcessId -> Closure (Process ())

73sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid

60sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid

@@ -79,10 +66,7 @@ factorial' :: Int -> Closure (Process Int)

79factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf

66factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf

81waitClosure :: Int -> Closure (Process ())

68waitClosure :: Int -> Closure (Process ())

82−waitClosure n = Closure decoder (encode n)

69+waitClosure = $(mkClosure 'wait)

83− where

84− decoder :: Static (ByteString -> Process ())

85− decoder = $(mkStatic 'wait) `staticCompose` staticDecode $(mkStatic 'sdictInt)

87testUnclosure :: Transport -> RemoteTable -> IO ()

71testUnclosure :: Transport -> RemoteTable -> IO ()

88testUnclosure transport rtable = do

72testUnclosure transport rtable = do