38091bb · distributed-process

git.iko.soy/distributed-process

on master help sign in

Add support for 'returnClosure'

38091bbEdsko de Vries14 years ago

distributed-process/distributed-process.cabal+3−3

compare with master

unifiedsplit

@@ -26,7 +26,7 @@ Library

26 Control.Distributed.Process.Serializable,

27 Control.Distributed.Process.Closure,

28 Control.Distributed.Process.Node

29− Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes

29+ Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes, GADTs

30 ghc-options: -Wall

31 HS-Source-Dirs: src

@@ -46,7 +46,7 @@ Test-Suite TestCH

46 stm,

47 ghc-prim,

48 network-transport >= 0.1

49− Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes

49+ Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes, GADTs

50 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

51 HS-Source-Dirs: tests src

@@ -67,6 +67,6 @@ Test-Suite TestClosure

67 template-haskell,

68 stm,

69 network-transport >= 0.1

70− Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes

70+ Extensions: ExplicitForAll, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, TemplateHaskell, ExistentialQuantification, RankNTypes, GADTs

71 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

72 HS-Source-Dirs: tests src

distributed-process/src/Control/Distributed/Process.hs+11−10

@@ -62,7 +62,7 @@ module Control.Distributed.Process

62 ) where

64import Prelude hiding (catch)

65−import Data.Binary (decode, encode)

65+import Data.Binary (decode)

66import Data.Typeable (Typeable, typeOf)

67import Control.Monad.Reader (ask)

68import Control.Monad.IO.Class (MonadIO, liftIO)

@@ -92,7 +92,6 @@ import Control.Distributed.Process.Internal.Types

92 , LocalProcess(..)

93 , Process(..)

94 , Closure(..)

95− , StaticLabel(Call)

96 , Static(..)

95 , Static(..)

97 , Message(..)

96 , Message(..)

98 , MonitorRef(..)

97 , MonitorRef(..)

@@ -108,7 +107,6 @@ import Control.Distributed.Process.Internal.Types

108 , monitorCounter

107 , monitorCounter

109 , spawnCounter

108 , spawnCounter

110 , Closure(..)

109 , Closure(..)

111− , CallReply(..)

112 , SendPort(..)

110 , SendPort(..)

113 , ReceivePort(..)

111 , ReceivePort(..)

114 , channelCounter

112 , channelCounter

@@ -117,6 +115,7 @@ import Control.Distributed.Process.Internal.Types

117 , ChannelId(..)

115 , ChannelId(..)

118 , Identifier(..)

116 , Identifier(..)

119 , procMsg

117 , procMsg

118+ , SerializableDict(..)

120 )

119 )

121import Control.Distributed.Process.Internal.MessageT

120import Control.Distributed.Process.Internal.MessageT

122 ( sendMessage

121 ( sendMessage

@@ -126,8 +125,11 @@ import Control.Distributed.Process.Internal.MessageT

126import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)

125import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)

127import Control.Distributed.Process.Internal.Closure (resolveClosure)

126import Control.Distributed.Process.Internal.Closure (resolveClosure)

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

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

129−import {-# SOURCE #-} Control.Distributed.Process.Internal.Closure.BuiltIn (linkClosure)

128+import {-# SOURCE #-} Control.Distributed.Process.Internal.Closure.BuiltIn

129+ ( linkClosure

130+ , sendClosure

131+ )

130−import Control.Distributed.Process.Internal.Closure.Combinators (cpSeq)

132+import Control.Distributed.Process.Internal.Closure.Combinators (cpSeq, cpBind)

131

133

132-- INTERNAL NOTES

134-- INTERNAL NOTES

133--

135--

@@ -318,12 +320,11 @@ spawn nid proc = do

318 ]

320 ]

319

321

320-- | Run a process remotely and wait for it to reply

322-- | Run a process remotely and wait for it to reply

321−call :: Serializable a => NodeId -> Closure (Process a) -> Process a

323+call :: SerializableDict a -> NodeId -> Closure (Process a) -> Process a

322−call nid (Closure (Static label) env) = do

324+call sdict@(SerializableDict _) nid proc = do

323 us <- getSelfPid

325 us <- getSelfPid

324− spawn nid (Closure (Static Call) (encode (label, env, us)))

326+ spawn nid (proc `cpBind` sendClosure sdict us)

325− CallReply a <- expect

327+ expect

326− return a

327

328

328-- | Thrown by 'terminate'

329-- | Thrown by 'terminate'

329data ProcessTerminationException = ProcessTerminationException

330data ProcessTerminationException = ProcessTerminationException

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

@@ -56,12 +56,27 @@

56-- > $ initRemoteTable

57--

58-- See Section 6, /Faking It/, of /Towards Haskell in the Cloud/ for more info.

59+--

60+-- [Serializable Dictionaries]

61+--

62+-- Some functions (such as 'sendClosure' or 'returnClosure') require an

63+-- explicit (reified) serializable dictionary. To create such a dictionary do

64+--

65+-- > serializableDictInt :: SerializableDict Int

66+-- > serializableDictInt = SerializableDict "serializableDictInt"

67+--

68+-- and then pass @'serialiableDictInt@ to 'remotable'. This will fail if the

69+-- type is not serializable. Make sure that the string argument to provide

70+-- in the definition of your dictionary matches the function name.

59module Control.Distributed.Process.Closure

71module Control.Distributed.Process.Closure

60 ( -- * User-defined closures

72 ( -- * User-defined closures

61 remotable

73 remotable

62 , mkClosure

74 , mkClosure

75+ , SerializableDict(..)

63 -- * Built-in closures

76 -- * Built-in closures

64 , linkClosure

77 , linkClosure

78+ , sendClosure

79+ , returnClosure

65 -- * Generic closure combinators

80 -- * Generic closure combinators

66 , closureApply

81 , closureApply

67 , closureConst

82 , closureConst

@@ -90,8 +105,13 @@ module Control.Distributed.Process.Closure

90 , cpSeq

105 , cpSeq

91 ) where

106 ) where

107

108+import Control.Distributed.Process.Internal.Types (SerializableDict(..))

93import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)

109import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)

94−import Control.Distributed.Process.Internal.Closure.BuiltIn (linkClosure)

110+import Control.Distributed.Process.Internal.Closure.BuiltIn

111+ ( linkClosure

112+ , sendClosure

113+ , returnClosure

114+ )

95import Control.Distributed.Process.Internal.Closure.Combinators

115import Control.Distributed.Process.Internal.Closure.Combinators

96 ( -- Generic combinators

116 ( -- Generic combinators

97 closureApply

117 closureApply

distributed-process/src/Control/Distributed/Process/Internal/Closure.hs+12−17

@@ -7,25 +7,23 @@ module Control.Distributed.Process.Internal.Closure

8import qualified Data.Map as Map (empty)

9import Data.Accessor ((^.))

10−import Data.Typeable (TyCon, typeRepTyCon, typeOf)

11import Data.ByteString.Lazy (ByteString)

10import Data.ByteString.Lazy (ByteString)

12import Data.Binary (decode)

11import Data.Binary (decode)

13import Control.Distributed.Process.Internal.Types

12import Control.Distributed.Process.Internal.Types

14 ( RemoteTable(RemoteTable)

13 ( RemoteTable(RemoteTable)

15 , remoteTableLabel

14 , remoteTableLabel

16− , remoteTableSender

15+ , remoteTableDict

17 , StaticLabel(..)

16 , StaticLabel(..)

18 , ProcessId

17 , ProcessId

19 , Process

18 , Process

20 , Closure(Closure)

19 , Closure(Closure)

21 , Static(Static)

20 , Static(Static)

21+ , RuntimeSerializableSupport(..)

22 )

23import Control.Distributed.Process.Internal.Dynamic

24 ( Dynamic(Dynamic)

25− , dynTypeRep

26 , toDyn

25 , toDyn

27 , dynApp

26 , dynApp

28− , dynBind

29 , dynApply

27 , dynApply

30 , unsafeCoerce#

28 , unsafeCoerce#

31 )

29 )

@@ -42,16 +40,17 @@ initRemoteTable :: RemoteTable

42initRemoteTable = BuiltIn.remoteTable (RemoteTable Map.empty Map.empty)

40initRemoteTable = BuiltIn.remoteTable (RemoteTable Map.empty Map.empty)

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

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

45−-- Special support for call

43+-- Built-in closures

46−resolveClosure rtable Call env = do

44+resolveClosure rtable ClosureSend env = do

47− proc <- resolveClosure rtable label env'

45+ rss <- rtable ^. remoteTableDict label

48− sender <- rtable ^. remoteTableSender (dynTypeRep proc)

46+ rssSend rss `dynApply` toDyn pid

49− proc `bind` (sender `dynApp` toDyn (pid :: ProcessId))

50 where

47 where

51− (label, env', pid) = decode env

48+ (label, pid) = decode env :: (String, ProcessId)

52− bind = dynBind tyConProcess bindProcess

49+resolveClosure rtable ClosureReturn env = do

53− bindProcess :: Process a -> (a -> Process b) -> Process b

50+ rss <- rtable ^. remoteTableDict label

54− bindProcess = (>>=)

51+ rssReturn rss `dynApply` toDyn arg

52+ where

53+ (label, arg) = decode env :: (String, ByteString)

55-- Generic closure combinators

54-- Generic closure combinators

56resolveClosure rtable ClosureApply env = do

55resolveClosure rtable ClosureApply env = do

57 f <- resolveClosure rtable labelf envf

56 f <- resolveClosure rtable labelf envf

@@ -126,7 +125,3 @@ resolveClosure rtable CpApply env =

126resolveClosure rtable (UserStatic label) env = do

125resolveClosure rtable (UserStatic label) env = do

127 val <- rtable ^. remoteTableLabel label

126 val <- rtable ^. remoteTableLabel label

128 dynApply val (toDyn env)

127 dynApply val (toDyn env)

129−

130−tyConProcess :: TyCon

131−tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))

132−

distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+17

@@ -2,14 +2,21 @@

2module Control.Distributed.Process.Internal.Closure.BuiltIn

3 ( remoteTable

4 , linkClosure

5+ , sendClosure

6+ , returnClosure

5 ) where

7 ) where

9+import Data.Binary (encode)

7import Control.Distributed.Process (link)

10import Control.Distributed.Process (link)

8import Control.Distributed.Process.Internal.Types

11import Control.Distributed.Process.Internal.Types

9 ( ProcessId

12 ( ProcessId

10 , Closure

13 , Closure

11 , Process

14 , Process

12 , RemoteTable

15 , RemoteTable

16+ , SerializableDict(..)

17+ , Closure(..)

18+ , Static(..)

19+ , StaticLabel(..)

13 )

20 )

14import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)

21import Control.Distributed.Process.Internal.Closure.TH (remotable, mkClosure)

@@ -21,3 +28,13 @@ remoteTable = __remoteTable

21-- | Closure version of 'link'

28-- | Closure version of 'link'

22linkClosure :: ProcessId -> Closure (Process ())

29linkClosure :: ProcessId -> Closure (Process ())

23linkClosure = $(mkClosure 'link)

30linkClosure = $(mkClosure 'link)

31+

32+-- | Closure version of 'send'

33+sendClosure :: SerializableDict a -> ProcessId -> Closure (a -> Process ())

34+sendClosure (SerializableDict label) pid =

35+ Closure (Static ClosureSend) (encode (label, pid))

36+

37+-- | Return any value

38+returnClosure :: SerializableDict a -> a -> Closure (Process a)

39+returnClosure (SerializableDict label) val =

40+ Closure (Static ClosureReturn) (encode (label, encode val))

distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs-boot+4−1

@@ -5,8 +5,11 @@ import Control.Distributed.Process.Internal.Types

5 , Closure

6 , Process

7 , RemoteTable

8+ , SerializableDict

8 )

9 )

10remoteTable :: RemoteTable -> RemoteTable

11remoteTable :: RemoteTable -> RemoteTable

13+linkClosure :: ProcessId -> Closure (Process ())

12−linkClosure :: ProcessId -> Closure (Process ())

14+sendClosure :: SerializableDict a -> ProcessId -> Closure (a -> Process ())

15+returnClosure :: SerializableDict a -> a -> Closure (Process a)

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+26−37

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

10import Prelude hiding (lookup)

11import Data.ByteString.Lazy (ByteString)

12import Data.Binary (encode, decode)

13−import Data.Typeable (typeOf, Typeable, TypeRep)

14import Data.Accessor ((^=))

13import Data.Accessor ((^=))

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

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

16import Language.Haskell.TH

15import Language.Haskell.TH

@@ -46,11 +45,12 @@ import Control.Distributed.Process.Internal.Types

46 , StaticLabel(..)

45 , StaticLabel(..)

47 , Process

46 , Process

48 , ProcessId

47 , ProcessId

49− , CallReply(..)

50 , procMsg

48 , procMsg

51 , Identifier(ProcessIdentifier)

49 , Identifier(ProcessIdentifier)

52 , remoteTableLabel

50 , remoteTableLabel

53− , remoteTableSender

51+ , remoteTableDict

52+ , SerializableDict(..)

53+ , RuntimeSerializableSupport(..)

54 )

55import Control.Distributed.Process.Internal.Dynamic (Dynamic, toDyn)

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

@@ -64,10 +64,13 @@ import Control.Distributed.Process.Internal.MessageT (sendMessage)

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

65remotable ns = do

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

67− rtable <- createMetaData (concat inserts)

67+ rtable <- createMetaData inserts

68 return $ concat closures ++ rtable

70-- | Create a closure

71+--

72+-- If @f :: a -> b@ then @mkClosure :: a -> Closure b@. Make sure to pass 'f'

73+-- as an argument to 'remotable' too.

71mkClosure :: Name -> Q Exp

74mkClosure :: Name -> Q Exp

72mkClosure = varE . closureName

75mkClosure = varE . closureName

@@ -90,26 +93,18 @@ createMetaData is =

90--

93--

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

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

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

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

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

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

94generateDefs n = do

97generateDefs n = do

98+ serializableDict <- [t| SerializableDict |]

95 mType <- getType n

99 mType <- getType n

96 case mType of

100 case mType of

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

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

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

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

99 let decoder = generateDecoder origName (return res)

103 let decoder = generateDecoder origName (return res)

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

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

101−

105+ return (closure, insert)

102− -- Generate special closure to support 'call'

106+ Just (origName, sdict `AppT` a) | sdict == serializableDict ->

103− mResult <- processResult res

107+ return ([], [| registerSerializableDict $(varE n) |])

104− insert' <- case mResult of

105− Nothing ->

106− return []

107− Just result -> do

108− let sender = generateSender result

109− return . return $

110− [| registerSender $(typeToTypeRep res) (toDyn $sender) |]

111−

112− return (closure, insert : insert')

113 _ ->

108 _ ->

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

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

115

110

@@ -125,25 +120,10 @@ generateClosure n arg res = do

125 label :: String

120 label :: String

126 label = show $ n

121 label = show $ n

127

122

128−-- | If 't' is of the form 'Process b', return 'Just b'

129−processResult :: Type -> Q (Maybe (Q Type))

130−processResult t = do

131− process <- [t| Process |]

132− case t of

133− p `AppT` a | p == process -> return . Just . return $ a

134− _ -> return Nothing

135−

136-- | Generate the decoder (see 'generateDefs')

123-- | Generate the decoder (see 'generateDefs')

137generateDecoder :: Name -> Q Type -> Q Exp

124generateDecoder :: Name -> Q Type -> Q Exp

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

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

139

126

140−-- | Generate the sender. This is necessary to support 'call'

141−generateSender :: Q Type -> Q Exp

142−generateSender tp =

143− -- This duplicates the functionality of 'Process.send', but gets the TH out

144− -- of the mutually recursive module cycle

145− [| (\pid msg -> procMsg $ sendMessage (ProcessIdentifier pid) (CallReply msg)) :: ProcessId -> $tp -> Process () |]

146−

147-- | The name for the function that generates the closure

127-- | The name for the function that generates the closure

148closureName :: Name -> Name

128closureName :: Name -> Name

149closureName n = mkName $ nameBase n ++ "__closure"

129closureName n = mkName $ nameBase n ++ "__closure"

@@ -151,16 +131,25 @@ closureName n = mkName $ nameBase n ++ "__closure"

151registerLabel :: String -> Dynamic -> RemoteTable -> RemoteTable

131registerLabel :: String -> Dynamic -> RemoteTable -> RemoteTable

152registerLabel label dyn = remoteTableLabel label ^= Just dyn

132registerLabel label dyn = remoteTableLabel label ^= Just dyn

153

133

154−registerSender :: TypeRep -> Dynamic -> RemoteTable -> RemoteTable

134+registerSerializableDict :: forall a. SerializableDict a -> RemoteTable -> RemoteTable

155−registerSender typ dyn = remoteTableSender typ ^= Just dyn

135+registerSerializableDict (SerializableDict label) =

136+ -- TODO: Code duplication with Process

137+ let send :: ProcessId -> a -> Process ()

138+ send pid a = procMsg $ sendMessage (ProcessIdentifier pid) a

139+

140+ ret :: ByteString -> Process a

141+ ret = return . decode

142+

143+ rss = RuntimeSerializableSupport {

144+ rssSend = toDyn send

145+ , rssReturn = toDyn ret

146+ }

147+ in remoteTableDict label ^= Just rss

156

148

157--------------------------------------------------------------------------------

149--------------------------------------------------------------------------------

158-- Generic Template Haskell auxiliary functions --

150-- Generic Template Haskell auxiliary functions --

159--------------------------------------------------------------------------------

151--------------------------------------------------------------------------------

160

152

161−typeToTypeRep :: Type -> Q Exp

162−typeToTypeRep tp = [| typeOf (undefined :: $(return tp)) |]

163−

164-- | Compose a set of expressions

153-- | Compose a set of expressions

165compose :: [Q Exp] -> Q Exp

154compose :: [Q Exp] -> Q Exp

166compose [] = [| id |]

155compose [] = [| id |]

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+57−41

@@ -27,8 +27,9 @@ module Control.Distributed.Process.Internal.Types

27 , StaticLabel(..)

28 , Static(..)

29 , Closure(..)

30− , CallReply(..)

31 , RemoteTable(..)

30 , RemoteTable(..)

31+ , SerializableDict(..)

32+ , RuntimeSerializableSupport(..)

32 -- * Messages

33 -- * Messages

33 , Message(..)

34 , Message(..)

34 -- * Node controller user-visible data types

35 -- * Node controller user-visible data types

@@ -57,14 +58,14 @@ module Control.Distributed.Process.Internal.Types

57 , typedChannels

58 , typedChannels

58 , typedChannelWithId

59 , typedChannelWithId

59 , remoteTableLabels

60 , remoteTableLabels

60− , remoteTableSenders

61+ , remoteTableDicts

61 , remoteTableLabel

62 , remoteTableLabel

62− , remoteTableSender

63+ , remoteTableDict

63 ) where

64 ) where

65import Data.Map (Map)

66import Data.Map (Map)

66import Data.Int (Int32)

67import Data.Int (Int32)

67−import Data.Typeable (Typeable, TypeRep)

68+import Data.Typeable (Typeable)

68import Data.Binary (Binary(put, get), putWord8, getWord8)

69import Data.Binary (Binary(put, get), putWord8, getWord8)

69import Data.ByteString.Lazy (ByteString)

70import Data.ByteString.Lazy (ByteString)

70import Data.Accessor (Accessor, accessor)

71import Data.Accessor (Accessor, accessor)

@@ -208,8 +209,9 @@ data ReceivePort a =

208

209

209data StaticLabel =

210data StaticLabel =

210 UserStatic String

211 UserStatic String

211− -- Special support for 'call'

212+ -- Built-in closures

212− | Call

213+ | ClosureReturn

214+ | ClosureSend

213 -- Generic closure combinators

215 -- Generic closure combinators

214 | ClosureApply

216 | ClosureApply

215 | ClosureConst

217 | ClosureConst

@@ -234,16 +236,28 @@ newtype Static a = Static StaticLabel

234data Closure a = Closure (Static (ByteString -> a)) ByteString

236data Closure a = Closure (Static (ByteString -> a)) ByteString

235 deriving (Typeable, Show)

237 deriving (Typeable, Show)

236

238

237−-- | Used for the implementation of 'call'

238−newtype CallReply a = CallReply a

239− deriving (Typeable, Binary)

240−

241-- | Used to fake 'static' (see paper)

239-- | Used to fake 'static' (see paper)

242data RemoteTable = RemoteTable {

240data RemoteTable = RemoteTable {

241+ -- | If the user creates a closure of type @a -> Closure b@ from a function

242+ -- @f : a -> b@, then '_remoteTableLabels' should have an entry for "f"

243+ -- of type @ByteString -> b@ (basically, @f . encode@)

243 _remoteTableLabels :: Map String Dynamic

244 _remoteTableLabels :: Map String Dynamic

244− , _remoteTableSenders :: Map TypeRep Dynamic

245+ -- | Runtime counterpart to SerializableDict

246+ , _remoteTableDicts :: Map String RuntimeSerializableSupport

245 }

247 }

246

248

249+-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")

250+data SerializableDict a where

251+ SerializableDict :: Serializable a => String -> SerializableDict a

252+ deriving (Typeable)

253+

254+-- | Runtime support for implementing "polymorphic" functions with a

255+-- Serializable qualifier (sendClosure, returnClosure, ..).

256+data RuntimeSerializableSupport = RuntimeSerializableSupport {

257+ rssSend :: Dynamic

258+ , rssReturn :: Dynamic

259+ }

260+

247--------------------------------------------------------------------------------

261--------------------------------------------------------------------------------

248-- Messages --

262-- Messages --

249--------------------------------------------------------------------------------

263--------------------------------------------------------------------------------

@@ -413,36 +427,38 @@ instance Binary Identifier where

413

427

414instance Binary StaticLabel where

428instance Binary StaticLabel where

415 put (UserStatic string) = putWord8 0 >> put string

429 put (UserStatic string) = putWord8 0 >> put string

416− put Call = putWord8 1

430+ put ClosureReturn = putWord8 1

431+ put ClosureSend = putWord8 2

417− put ClosureApply = putWord8 2

432+ put ClosureApply = putWord8 3

418− put ClosureConst = putWord8 3

433+ put ClosureConst = putWord8 4

419− put ClosureUnit = putWord8 4

434+ put ClosureUnit = putWord8 5

420− put CpId = putWord8 5

435+ put CpId = putWord8 6

421− put CpComp = putWord8 6

436+ put CpComp = putWord8 7

422− put CpFirst = putWord8 7

423− put CpSwap = putWord8 8

437+ put CpFirst = putWord8 8

438+ put CpSwap = putWord8 9

424− put CpCopy = putWord8 9

439+ put CpCopy = putWord8 10

425− put CpLeft = putWord8 10

426− put CpMirror = putWord8 11

440+ put CpLeft = putWord8 11

427− put CpUntag = putWord8 12

441+ put CpMirror = putWord8 12

428− put CpApply = putWord8 13

442+ put CpUntag = putWord8 13

443+ put CpApply = putWord8 14

429 get = do

444 get = do

430 header <- getWord8

445 header <- getWord8

431 case header of

446 case header of

432 0 -> UserStatic <$> get

447 0 -> UserStatic <$> get

433− 1 -> return Call

448+ 1 -> return ClosureReturn

434− 2 -> return ClosureApply

449+ 2 -> return ClosureSend

435− 3 -> return ClosureConst

450+ 3 -> return ClosureApply

436− 4 -> return ClosureUnit

451+ 4 -> return ClosureConst

437− 5 -> return CpId

452+ 5 -> return ClosureUnit

453+ 6 -> return CpId

438− 6 -> return CpComp

454+ 7 -> return CpComp

439− 7 -> return CpFirst

455+ 8 -> return CpFirst

440− 8 -> return CpSwap

441− 9 -> return CpCopy

456+ 9 -> return CpSwap

442− 10 -> return CpLeft

457+ 10 -> return CpCopy

443− 11 -> return CpMirror

458+ 11 -> return CpLeft

459+ 12 -> return CpMirror

444− 12 -> return CpUntag

460+ 13 -> return CpUntag

445− 13 -> return CpApply

461+ 14 -> return CpApply

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

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

447

463

448

464

@@ -481,14 +497,14 @@ typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid

481remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)

497remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)

482remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })

498remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })

483

499

484−remoteTableSenders :: Accessor RemoteTable (Map TypeRep Dynamic)

500+remoteTableDicts :: Accessor RemoteTable (Map String RuntimeSerializableSupport)

485−remoteTableSenders = accessor _remoteTableSenders (\es tbl -> tbl { _remoteTableSenders = es })

501+remoteTableDicts = accessor _remoteTableDicts (\ds tbl -> tbl { _remoteTableDicts = ds })

486

502

487remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)

503remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)

488remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label

504remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label

489

505

490−remoteTableSender :: TypeRep -> Accessor RemoteTable (Maybe Dynamic)

506+remoteTableDict :: String -> Accessor RemoteTable (Maybe RuntimeSerializableSupport)

491−remoteTableSender typ = remoteTableSenders >>> DAC.mapMaybe typ

507+remoteTableDict label = remoteTableDicts >>> DAC.mapMaybe label

492

508

493--------------------------------------------------------------------------------

509--------------------------------------------------------------------------------

494-- MessageT monad --

510-- MessageT monad --

distributed-process/tests/TestClosure.hs+7−7

@@ -13,6 +13,9 @@ import Control.Distributed.Process.Closure

13import Control.Distributed.Process.Node

14import TestAuxiliary

16+serializableDictInt :: SerializableDict Int

17+serializableDictInt = SerializableDict "serializableDictInt"

18+

16addInt :: Int -> Int -> Int

19addInt :: Int -> Int -> Int

17addInt x y = x + y

20addInt x y = x + y

@@ -34,16 +37,13 @@ factorial n = (n *) <$> factorial (n - 1)

34factorialOf :: () -> Int -> Process Int

37factorialOf :: () -> Int -> Process Int

35factorialOf () = factorial

38factorialOf () = factorial

37−returnInt :: Int -> Process Int

38−returnInt = return

39−

40returnForTestApply :: (Closure (Int -> Process Int), Int) -> (Closure (Int -> Process Int), Int)

41returnForTestApply = id

43wait :: Int -> Process ()

44wait = liftIO . threadDelay

46−$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial, 'factorialOf, 'returnInt, 'returnForTestApply, 'wait])

46+$(remotable ['addInt, 'putInt, 'sendInt, 'sendPid, 'factorial, 'factorialOf, 'returnForTestApply, 'wait, 'serializableDictInt])

48testSendPureClosure :: Transport -> RemoteTable -> IO ()

49testSendPureClosure transport rtable = do

@@ -148,7 +148,7 @@ testCall transport rtable = do

148 node <- newLocalNode transport rtable

149 nid <- readMVar serverNodeAddr

150 runProcess node $ do

151− (120 :: Int) <- call nid ($(mkClosure 'factorial) 5)

151+ (120 :: Int) <- call serializableDictInt nid ($(mkClosure 'factorial) 5)

152 liftIO $ putMVar clientDone ()

153

154 takeMVar clientDone

@@ -157,7 +157,7 @@ sendFac :: Int -> ProcessId -> Closure (Process ())

157sendFac n pid = $(mkClosure 'factorial) n `cpBind` $(mkClosure 'sendInt) pid

158

159factorial' :: Int -> Closure (Process Int)

160−factorial' n = $(mkClosure 'returnInt) n `cpBind` $(mkClosure 'factorialOf) ()

160+factorial' n = returnClosure serializableDictInt n `cpBind` $(mkClosure 'factorialOf) ()

161

162testBind :: Transport -> RemoteTable -> IO ()

163testBind transport rtable = do

@@ -181,7 +181,7 @@ testCallBind transport rtable = do

181 node <- newLocalNode transport rtable

182 nid <- readMVar serverNodeAddr

183 runProcess node $ do

184− (120 :: Int) <- call nid (factorial' 5)

184+ (120 :: Int) <- call serializableDictInt nid (factorial' 5)

185 liftIO $ putMVar clientDone ()

186

187 takeMVar clientDone