61e55d7 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Clean up bind

61e55d7Edsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hs+42−45

compare with master

unifiedsplit

@@ -16,7 +16,7 @@ module Control.Distributed.Process.Internal.Closure.Derived

17import Data.Binary (encode)

18import Data.ByteString.Lazy (ByteString)

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

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

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

21import Control.Monad (join)

22import Control.Distributed.Process.Serializable (Serializable)

@@ -24,9 +24,11 @@ import Control.Distributed.Process.Internal.Types

24 ( Closure(Closure)

25 , SerializableDict(SerializableDict)

26 , Static(Static)

27− , StaticLabel

28 , Process

27 , Process

29 , staticApply

28 , staticApply

29+ , staticDuplicate

30+ , staticTypeOf

31+ , typeOfStaticLabel

30 , ProcessId

32 , ProcessId

31 , LocalNode(remoteTable)

33 , LocalNode(remoteTable)

32 , procMsg

34 , procMsg

@@ -45,7 +47,6 @@ import Control.Distributed.Process.Internal.Closure.Static

45 , staticDecode

47 , staticDecode

46 , staticClosure

48 , staticClosure

47 , staticSplit

49 , staticSplit

48− , staticFirst

49 , staticConst

50 , staticConst

50 , staticUnit

51 , staticUnit

51 , sdictProcessId

52 , sdictProcessId

@@ -85,28 +86,35 @@ expectDict SerializableDict = expect

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

86---- Serialization dictionaries ------------------------------------------------

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

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

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

89+sdictBind :: SerializableDict (ByteString, ByteString)

89sdictBind = SerializableDict

90sdictBind = SerializableDict

91---- Some specialised processes necessary to implement the combinators ---------

92---- Some specialised processes necessary to implement the combinators ---------

94+-- | Resolve a closure

93−unClosure :: (StaticLabel, ByteString) -> Process Dynamic

95+unClosure :: Static a -> ByteString -> Process Dynamic

94−unClosure (label, env) = do

96+unClosure (Static label) env = do

95 rtable <- remoteTable <$> procMsg getLocalNode

97 rtable <- remoteTable <$> procMsg getLocalNode

96 case resolveClosure rtable label env of

98 case resolveClosure rtable label env of

97 Nothing -> fail "Derived.unClosure: resolveClosure failed"

99 Nothing -> fail "Derived.unClosure: resolveClosure failed"

98 Just dyn -> return dyn

100 Just dyn -> return dyn

101

102+-- | Remove a 'Dynamic' constructor, provided that the recorded type matches the

103+-- type of the first static argument (the value of that argument is not used)

100−unDynamic :: (Process Dynamic, TypeRep) -> Process a

104+unDynamic :: Static a -> Process Dynamic -> Process a

101−unDynamic (pdyn, typ) = do

105+unDynamic (Static label) pdyn = do

102− Dynamic typ' val <- pdyn

106+ Dynamic typ val <- pdyn

103− if typ == typ'

107+ if typ == typeOfStaticLabel label

104 then return (unsafeCoerce# val)

108 then return (unsafeCoerce# val)

105 else fail $ "unDynamic: cannot match "

109 else fail $ "unDynamic: cannot match "

106− ++ show typ'

107− ++ " against expected type "

108 ++ show typ

110 ++ show typ

111+ ++ " against expected type "

112+ ++ show (typeOfStaticLabel label)

109

113

114+-- | Dynamic bind

115+--

116+-- The first argument stops remotable from trying to generate a SerializableDict

117+-- for (Process Dynamic, Process Dynamic)

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

118bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic

111bindDyn () (px, pf) = do

119bindDyn () (px, pf) = do

112 x <- px

120 x <- px

@@ -181,47 +189,36 @@ cpReturn dict x = Closure decoder (encode x)

181 `staticCompose`

189 `staticCompose`

182 staticDecode dict

190 staticDecode dict

183

191

192+

193+staticUnclosure :: Typeable a

194+ => Static a -> Static (ByteString -> Process Dynamic)

195+staticUnclosure s =

196+ $(mkStatic 'unClosure) `staticApply` staticDuplicate s

197+

198+staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)

199+staticUndynamic =

200+ $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))

201+

202+staticBindDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)

203+staticBindDyn = $(mkStatic 'bindDyn) `staticApply` staticUnit

204+

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

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

185−cpBind :: forall a b. Typeable b

206+cpBind :: forall a b. (Typeable a, Typeable b)

186 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)

207 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)

187−cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) fenv) =

208+cpBind (Closure xstatic xenv) (Closure fstatic fenv) =

188− let env :: (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)

189− env = (((xlabel, xenv), (flabel, fenv)), typeOf (undefined :: Process b))

190− in Closure decoder (encode env)

209+ Closure decoder (encode (xenv, fenv))

191 where

210 where

192 decoder :: Static (ByteString -> Process b)

211 decoder :: Static (ByteString -> Process b)

193− decoder = aux8

212+ decoder = $(mkStatic 'joinProcess)

194 `staticCompose`

213 `staticCompose`

195− aux7

214+ staticUndynamic

196 `staticCompose`

215 `staticCompose`

197− aux6

216+ staticBindDyn

198 `staticCompose`

217 `staticCompose`

199− aux1

218+ (staticUnclosure xstatic `staticSplit` staticUnclosure fstatic)

200−

219+ `staticCompose`

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

202− aux1 = staticDecode $(mkStatic 'sdictBind)

220+ staticDecode $(mkStatic 'sdictBind)

203−

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

205− aux2 = $(mkStatic 'unClosure)

206−

207− aux3 :: Static (((StaticLabel, ByteString), (StaticLabel, ByteString)) -> (Process Dynamic, Process Dynamic))

208− aux3 = aux2 `staticSplit` aux2

209−

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

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

212−

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

214− aux5 = aux4 `staticCompose` aux3

215−

216− aux6 :: Static ((((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep) -> (Process Dynamic, TypeRep))

217− aux6 = staticFirst `staticApply` aux5

218−

219− aux7 :: Static ((Process Dynamic, TypeRep) -> Process (Process b))

220− aux7 = $(mkStatic 'unDynamic)

221

222− aux8 :: Static (Process (Process b) -> Process b)

223− aux8 = $(mkStatic 'joinProcess)

224−

225cpIntro :: forall a b. (Typeable a, Typeable b)

222cpIntro :: forall a b. (Typeable a, Typeable b)

226 => Closure (Process b) -> Closure (a -> Process b)

223 => Closure (Process b) -> Closure (a -> Process b)

227cpIntro (Closure static env) = Closure decoder env

224cpIntro (Closure static env) = Closure decoder env

distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs+4

@@ -6,12 +6,14 @@ import Data.ByteString.Lazy (ByteString)

6import Control.Distributed.Process.Internal.Types

7 ( RemoteTable

8 , remoteTableLabel

9+ , Static(Static)

9 , StaticLabel(..)

10 , StaticLabel(..)

10 )

11 )

11import Control.Distributed.Process.Internal.Dynamic

12import Control.Distributed.Process.Internal.Dynamic

12 ( Dynamic(Dynamic)

13 ( Dynamic(Dynamic)

13 , toDyn

14 , toDyn

14 , dynApply

15 , dynApply

16+ , unsafeCoerce#

15 )

17 )

16import Control.Distributed.Process.Internal.TypeRep () -- Binary instances

18import Control.Distributed.Process.Internal.TypeRep () -- Binary instances

@@ -23,6 +25,8 @@ resolveStatic rtable (StaticApply static1 static2) = do

23 f <- resolveStatic rtable static1

25 f <- resolveStatic rtable static1

24 x <- resolveStatic rtable static2

26 x <- resolveStatic rtable static2

25 f `dynApply` x

27 f `dynApply` x

28+resolveStatic _rtable (StaticDuplicate static typ) =

29+ return $ Dynamic typ (unsafeCoerce# (Static static))

27resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic

31resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic

28resolveClosure rtable static env = do

32resolveClosure rtable static env = do

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+22−88

@@ -117,9 +117,14 @@ generateDefs n = 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)) |]

120+ let dyn' = [| toDyn (SerializableDict

121+ :: SerializableDict $(return arg)

122+ )

123+ |]

121 return ( sdict

124 return ( sdict

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

125+ , [ [| registerStatic $(stringE (show (sdictName origName)))

126+ $dyn'

127+ |] ]

123 )

128 )

124 _ ->

129 _ ->

125 return ([], [])

130 return ([], [])

@@ -138,14 +143,16 @@ generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]

138generateStatic n xs typ = do

143generateStatic n xs typ = do

139 staticTyp <- [t| Static |]

144 staticTyp <- [t| Static |]

140 sequence

145 sequence

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

146+ [ sigD (staticName n) $

147+ return (ForallT xs

142− (map typeable xs)

148+ (map typeable xs)

143− (staticTyp `AppT` typ)

149+ (staticTyp `AppT` typ)

144− )

150+ )

151+ , sfnD (staticName n)

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

152+ [| Static $ StaticLabel

146− $(stringE (show n))

153+ $(stringE (show n))

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

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

148− |]

155+ |]

149 ]

156 ]

150 where

157 where

151 typeable :: TyVarBndr -> Pred

158 typeable :: TyVarBndr -> Pred

@@ -157,10 +164,11 @@ generateSDict :: Name -> Type -> Q [Dec]

157generateSDict n typ = do

164generateSDict n typ = do

158 sequence

165 sequence

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

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

167+ , sfnD (sdictName n)

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

168+ [| Static $ StaticLabel

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

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

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

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

163− |]

171+ |]

164 ]

172 ]

165

173

166staticName :: Name -> Name

174staticName :: Name -> Name

@@ -169,80 +177,6 @@ staticName n = mkName $ nameBase n ++ "__static"

169sdictName :: Name -> Name

177sdictName :: Name -> Name

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

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

171

179

172−{-

173−-- | Generate the necessary definitions for one function

174−--

175−-- Given an (f :: a -> b) in module M, create:

176−-- 1. f__closure :: a -> Closure b,

177−-- 2. registerLabel "M.f" (toDyn ((f . enc) :: ByteString -> b))

178−--

179−-- Moreover, if b is of the form Process c, then additionally create

180−-- 3. registerSender (Process c) (send :: ProcessId -> c -> Process ())

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

182−generateDefs n = do

183− serializableDict <- [t| SerializableDict |]

184− mType <- getType n

185− case mType of

186− Just (origName, ArrowT `AppT` arg `AppT` res) -> do

187− (closure, label) <- generateClosure origName (return arg) (return res)

188− let decoder = generateDecoder origName (return res)

189− insert = [| registerLabel $(stringE label) (toDyn $decoder) |]

190− return (closure, insert)

191− Just (origName, sdict `AppT` a) | sdict == serializableDict ->

192− return ([], [| registerSerializableDict $(varE n) |])

193− Just (origName, ForallT vars [] tp) -> do

194− (closure, label) <- generatePolyClosure origName vars tp

195− return (closure, [| registerLabel $(stringE label) (Dynamic (error "Polymorphic closure") (unsafeCoerce# $(varE origName))) |])

196− _ ->

197− fail $ "remotable: " ++ show n ++ " is not a function"

198−

199−-- | Generate the closure creator (see 'generateDefs')

200−generateClosure :: Name -> Q Type -> Q Type -> Q ([Dec], String)

201−generateClosure n arg res = do

202− closure <- sequence

203− [ sigD (closureName n) [t| $arg -> Closure $res |]

204− , sfnD (closureName n) [| Closure (Static (UserStatic ($(stringE label)))) . encode |]

205− ]

206− return (closure, label)

207− where

208− label :: String

209− label = show n

210−

211−-- | Generate a polymorphic closure

212−generatePolyClosure :: Name -> [TyVarBndr] -> Type -> Q ([Dec], String)

213−generatePolyClosure n xs typ = do

214− closureTyp <- [t| Closure |]

215− closure <- sequence

216− [ sigD (closureName n) (return (ForallT xs (map typeable xs) (closureTyp `AppT` typ)) )

217− , sfnD (closureName n) [| Closure (Static (PolyStatic ($(stringE label)))) (encode (typeOf (undefined :: $(return typ)))) |]

218− ]

219− return (closure, label)

220− where

221− label :: String

222− label = show n

223−

224− typeable :: TyVarBndr -> Pred

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

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

227−

228−-- | Generate the decoder (see 'generateDefs')

229−generateDecoder :: Name -> Q Type -> Q Exp

230−generateDecoder n res = [| $(varE n) . decode :: ByteString -> $res |]

231−

232−-- | The name for the function that generates the closure

233−closureName :: Name -> Name

234−closureName n = mkName $ nameBase n ++ "__closure"

235−

236−registerSerializableDict :: forall a. SerializableDict a -> RemoteTable -> RemoteTable

237−registerSerializableDict SerializableDict =

238− let rss = RuntimeSerializableSupport {

239− rssSend = toDyn (send :: ProcessId -> a -> Process ())

240− , rssReturn = toDyn (return . decode :: ByteString -> Process a)

241− , rssExpect = toDyn (expect :: Process a)

242− }

243− in remoteTableDict (typeOf (undefined :: a)) ^= Just rss

244−-}

245−

246--------------------------------------------------------------------------------

180--------------------------------------------------------------------------------

247-- Generic Template Haskell auxiliary functions --

181-- Generic Template Haskell auxiliary functions --

248--------------------------------------------------------------------------------

182--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+25−2

@@ -28,6 +28,9 @@ module Control.Distributed.Process.Internal.Types

28 , StaticLabel(..)

29 , Static(..)

30 , staticApply

31+ , staticDuplicate

32+ , staticTypeOf

33+ , typeOfStaticLabel

31 , Closure(..)

34 , Closure(..)

32 , RemoteTable(..)

35 , RemoteTable(..)

33 , SerializableDict(..)

36 , SerializableDict(..)

@@ -74,7 +77,8 @@ module Control.Distributed.Process.Internal.Types

75import Data.Map (Map)

78import Data.Map (Map)

76import Data.Int (Int32)

79import Data.Int (Int32)

80+import Data.Maybe (fromJust)

77−import Data.Typeable (Typeable, TypeRep)

81+import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)

78import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

82import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

79import qualified Data.ByteString as BSS (ByteString, concat)

83import qualified Data.ByteString as BSS (ByteString, concat)

80import qualified Data.ByteString.Lazy as BSL

84import qualified Data.ByteString.Lazy as BSL

@@ -261,6 +265,7 @@ data ReceivePort a =

261data StaticLabel =

265data StaticLabel =

262 StaticLabel String TypeRep

266 StaticLabel String TypeRep

263 | StaticApply StaticLabel StaticLabel

267 | StaticApply StaticLabel StaticLabel

268+ | StaticDuplicate StaticLabel TypeRep

264 deriving (Typeable, Show)

269 deriving (Typeable, Show)

265

270

266-- | A static value is top-level bound or the application of two static values

271-- | A static value is top-level bound or the application of two static values

@@ -271,6 +276,22 @@ newtype Static a = Static StaticLabel

271staticApply :: Static (a -> b) -> Static a -> Static b

276staticApply :: Static (a -> b) -> Static a -> Static b

272staticApply (Static f) (Static x) = Static (StaticApply f x)

277staticApply (Static f) (Static x) = Static (StaticApply f x)

273

278

279+-- | Co-monadic 'duplicate' for static values

280+staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)

281+staticDuplicate (Static x) =

282+ Static (StaticDuplicate x (typeOf (undefined :: Static a)))

283+

284+staticTypeOf :: forall a. Typeable a => a -> Static a

285+staticTypeOf _ = Static (StaticLabel "undefined" (typeOf (undefined :: a)))

286+

287+typeOfStaticLabel :: StaticLabel -> TypeRep

288+typeOfStaticLabel (StaticLabel _ typ)

289+ = typ

290+typeOfStaticLabel (StaticApply f x)

291+ = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)

292+typeOfStaticLabel (StaticDuplicate _ typ)

293+ = typ

294+

274-- | A closure is a static value and an encoded environment

295-- | A closure is a static value and an encoded environment

275data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString

296data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString

276 deriving (Typeable, Show)

297 deriving (Typeable, Show)

@@ -525,13 +546,15 @@ instance Binary Identifier where

525 _ -> fail "Identifier.get: invalid"

546 _ -> fail "Identifier.get: invalid"

526

547

527instance Binary StaticLabel where

548instance Binary StaticLabel where

528− put (StaticLabel string typ) = putWord8 0 >> put string >> put typ

549+ put (StaticLabel string typ) = putWord8 0 >> put string >> put typ

529 put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2

550 put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2

551+ put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ

530 get = do

552 get = do

531 header <- getWord8

553 header <- getWord8

532 case header of

554 case header of

533 0 -> StaticLabel <$> get <*> get

555 0 -> StaticLabel <$> get <*> get

534 1 -> StaticApply <$> get <*> get

556 1 -> StaticApply <$> get <*> get

557+ 2 -> StaticDuplicate <$> get <*> get

535 _ -> fail "StaticLabel.get: invalid"

558 _ -> fail "StaticLabel.get: invalid"

536

559

537instance Binary WhereIsReply where

560instance Binary WhereIsReply where