git.iko.soy/distributed-process
on master help sign in
Clean up bind
commit61e55d7b410d2ace3433fe3defa107471dcfbf55 authorEdsko de Vries <edsko@edsko.net> dateWed 11 Jul 2012, 17:23 (14 years ago) parent6c76227
4 files changed+93−135
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hs+42−45 distributed-process/src/Control/Distributed/Process/Internal/Closure/Resolution.hs+4 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+22−88 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+25−2
distributed-process/src/Control/Distributed/Process/Internal/Closure/Derived.hs+42−45
@@ -16,7 +16,7 @@ module Control.Distributed.Process.Internal.Closure.Derived
1616
1717import Data.Binary (encode)
1818import Data.ByteString.Lazy (ByteString)
19−import Data.Typeable (Typeable, typeOf, TypeRep, typeRepTyCon, TyCon)
19+import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)
2020import Control.Applicative ((<$>))
2121import Control.Monad (join)
2222import Control.Distributed.Process.Serializable (Serializable)
@@ -24,9 +24,11 @@ import Control.Distributed.Process.Internal.Types
2424 ( Closure(Closure)
2525 , SerializableDict(SerializableDict)
2626 , Static(Static)
27− , StaticLabel
2827 , Process
2928 , staticApply
29+ , staticDuplicate
30+ , staticTypeOf
31+ , typeOfStaticLabel
3032 , ProcessId
3133 , LocalNode(remoteTable)
3234 , procMsg
@@ -45,7 +47,6 @@ import Control.Distributed.Process.Internal.Closure.Static
4547 , staticDecode
4648 , staticClosure
4749 , staticSplit
48− , staticFirst
4950 , staticConst
5051 , staticUnit
5152 , sdictProcessId
@@ -85,28 +86,35 @@ expectDict SerializableDict = expect
8586---- Serialization dictionaries ------------------------------------------------
8687
8788-- | Specialized serialization dictionary required in 'cpBind'
88−sdictBind :: SerializableDict (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep)
89+sdictBind :: SerializableDict (ByteString, ByteString)
8990sdictBind = SerializableDict
9091
9192---- Some specialised processes necessary to implement the combinators ---------
9293
93−unClosure :: (StaticLabel, ByteString) -> Process Dynamic
94−unClosure (label, env) = do
94+-- | Resolve a closure
95+unClosure :: Static a -> ByteString -> Process Dynamic
96+unClosure (Static label) env = do
9597 rtable <- remoteTable <$> procMsg getLocalNode
9698 case resolveClosure rtable label env of
9799 Nothing -> fail "Derived.unClosure: resolveClosure failed"
98100 Just dyn -> return dyn
99101
100−unDynamic :: (Process Dynamic, TypeRep) -> Process a
101−unDynamic (pdyn, typ) = do
102− Dynamic typ' val <- pdyn
103− if typ == typ'
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)
104+unDynamic :: Static a -> Process Dynamic -> Process a
105+unDynamic (Static label) pdyn = do
106+ Dynamic typ val <- pdyn
107+ if typ == typeOfStaticLabel label
104108 then return (unsafeCoerce# val)
105109 else fail $ "unDynamic: cannot match "
106− ++ show typ'
107− ++ " against expected type "
108110 ++ show typ
111+ ++ " against expected type "
112+ ++ show (typeOfStaticLabel label)
109113
114+-- | Dynamic bind
115+--
116+-- The first argument stops remotable from trying to generate a SerializableDict
117+-- for (Process Dynamic, Process Dynamic)
110118bindDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic
111119bindDyn () (px, pf) = do
112120 x <- px
@@ -181,47 +189,36 @@ cpReturn dict x = Closure decoder (encode x)
181189 `staticCompose`
182190 staticDecode dict
183191
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+
184205-- | Not-quite-monadic bind ('>>=')
185−cpBind :: forall a b. Typeable b
206+cpBind :: forall a b. (Typeable a, Typeable b)
186207 => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)
187−cpBind (Closure (Static xlabel) xenv) (Closure (Static flabel) 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)
208+cpBind (Closure xstatic xenv) (Closure fstatic fenv) =
209+ Closure decoder (encode (xenv, fenv))
191210 where
192211 decoder :: Static (ByteString -> Process b)
193− decoder = aux8
212+ decoder = $(mkStatic 'joinProcess)
194213 `staticCompose`
195− aux7
214+ staticUndynamic
196215 `staticCompose`
197− aux6
216+ staticBindDyn
198217 `staticCompose`
199− aux1
200−
201− aux1 :: Static (ByteString -> (((StaticLabel, ByteString), (StaticLabel, ByteString)), TypeRep))
202− aux1 = 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)
218+ (staticUnclosure xstatic `staticSplit` staticUnclosure fstatic)
219+ `staticCompose`
220+ staticDecode $(mkStatic 'sdictBind)
221221
222− aux8 :: Static (Process (Process b) -> Process b)
223− aux8 = $(mkStatic 'joinProcess)
224−
225222cpIntro :: forall a b. (Typeable a, Typeable b)
226223 => Closure (Process b) -> Closure (a -> Process b)
227224cpIntro (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)
66import Control.Distributed.Process.Internal.Types
77 ( RemoteTable
88 , remoteTableLabel
9+ , Static(Static)
910 , StaticLabel(..)
1011 )
1112import Control.Distributed.Process.Internal.Dynamic
1213 ( Dynamic(Dynamic)
1314 , toDyn
1415 , dynApply
16+ , unsafeCoerce#
1517 )
1618import Control.Distributed.Process.Internal.TypeRep () -- Binary instances
1719
@@ -23,6 +25,8 @@ resolveStatic rtable (StaticApply static1 static2) = do
2325 f <- resolveStatic rtable static1
2426 x <- resolveStatic rtable static2
2527 f `dynApply` x
28+resolveStatic _rtable (StaticDuplicate static typ) =
29+ return $ Dynamic typ (unsafeCoerce# (Static static))
2630
2731resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
2832resolveClosure rtable static env = do
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+22−88
@@ -117,9 +117,14 @@ generateDefs n = do
117117 -- TODO: we should check if arg is an instance of Serializable, but we cannot
118118 -- http://hackage.haskell.org/trac/ghc/ticket/7066
119119 sdict <- generateSDict origName arg
120− let dyn' = [| toDyn (SerializableDict :: SerializableDict $(return arg)) |]
120+ let dyn' = [| toDyn (SerializableDict
121+ :: SerializableDict $(return arg)
122+ )
123+ |]
121124 return ( sdict
122− , [ [| registerStatic $(stringE (show (sdictName origName))) $dyn' |] ]
125+ , [ [| registerStatic $(stringE (show (sdictName origName)))
126+ $dyn'
127+ |] ]
123128 )
124129 _ ->
125130 return ([], [])
@@ -138,14 +143,16 @@ generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
138143generateStatic n xs typ = do
139144 staticTyp <- [t| Static |]
140145 sequence
141− [ sigD (staticName n) $ return (ForallT xs
142− (map typeable xs)
143− (staticTyp `AppT` typ)
144− )
145− , sfnD (staticName n) [| Static $ StaticLabel
146− $(stringE (show n))
147− (typeOf (undefined :: $(return typ)))
148− |]
146+ [ sigD (staticName n) $
147+ return (ForallT xs
148+ (map typeable xs)
149+ (staticTyp `AppT` typ)
150+ )
151+ , sfnD (staticName n)
152+ [| Static $ StaticLabel
153+ $(stringE (show n))
154+ (typeOf (undefined :: $(return typ)))
155+ |]
149156 ]
150157 where
151158 typeable :: TyVarBndr -> Pred
@@ -157,10 +164,11 @@ generateSDict :: Name -> Type -> Q [Dec]
157164generateSDict n typ = do
158165 sequence
159166 [ 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− |]
167+ , sfnD (sdictName n)
168+ [| Static $ StaticLabel
169+ $(stringE (show (sdictName n)))
170+ (typeOf (undefined :: SerializableDict $(return typ)))
171+ |]
164172 ]
165173
166174staticName :: Name -> Name
@@ -169,80 +177,6 @@ staticName n = mkName $ nameBase n ++ "__static"
169177sdictName :: Name -> Name
170178sdictName n = mkName $ nameBase n ++ "__sdict"
171179
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−
246180--------------------------------------------------------------------------------
247181-- Generic Template Haskell auxiliary functions --
248182--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+25−2
@@ -28,6 +28,9 @@ module Control.Distributed.Process.Internal.Types
2828 , StaticLabel(..)
2929 , Static(..)
3030 , staticApply
31+ , staticDuplicate
32+ , staticTypeOf
33+ , typeOfStaticLabel
3134 , Closure(..)
3235 , RemoteTable(..)
3336 , SerializableDict(..)
@@ -74,7 +77,8 @@ module Control.Distributed.Process.Internal.Types
7477
7578import Data.Map (Map)
7679import Data.Int (Int32)
77−import Data.Typeable (Typeable, TypeRep)
80+import Data.Maybe (fromJust)
81+import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)
7882import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
7983import qualified Data.ByteString as BSS (ByteString, concat)
8084import qualified Data.ByteString.Lazy as BSL
@@ -261,6 +265,7 @@ data ReceivePort a =
261265data StaticLabel =
262266 StaticLabel String TypeRep
263267 | StaticApply StaticLabel StaticLabel
268+ | StaticDuplicate StaticLabel TypeRep
264269 deriving (Typeable, Show)
265270
266271-- | A static value is top-level bound or the application of two static values
@@ -271,6 +276,22 @@ newtype Static a = Static StaticLabel
271276staticApply :: Static (a -> b) -> Static a -> Static b
272277staticApply (Static f) (Static x) = Static (StaticApply f x)
273278
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+
274295-- | A closure is a static value and an encoded environment
275296data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString
276297 deriving (Typeable, Show)
@@ -525,13 +546,15 @@ instance Binary Identifier where
525546 _ -> fail "Identifier.get: invalid"
526547
527548instance 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
529550 put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2
551+ put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ
530552 get = do
531553 header <- getWord8
532554 case header of
533555 0 -> StaticLabel <$> get <*> get
534556 1 -> StaticApply <$> get <*> get
557+ 2 -> StaticDuplicate <$> get <*> get
535558 _ -> fail "StaticLabel.get: invalid"
536559
537560instance Binary WhereIsReply where