0328ade · distributed-process

git.iko.soy/distributed-process

Add TH support for polymorphic closures

commit0328adeed7c209f72ccb5f3ac4a4e4f8895915a9 authorEdsko de Vries <edsko@edsko.net> dateTue 10 Jul 2012, 12:21 (14 years ago) parent52c1f77

9 files changed+205−175

compare with master

unifiedsplit

distributed-process/src/Control/Distributed/Process.hs+18−19 distributed-process/src/Control/Distributed/Process/Internal/Closure.hs+18−56 distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+1−1 distributed-process/src/Control/Distributed/Process/Internal/Closure/Combinators.hs+74−51 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+30−3 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+22−1 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+14−41 distributed-process/src/Control/Distributed/Process/Node.hs+12−2 distributed-process/tests/TestClosure.hs+16−1

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

@@ -91,12 +91,7 @@ module Control.Distributed.Process

9191 ) where

9292

9393import Prelude hiding (catch)

94−import Data.Typeable (Typeable, typeOf)

95−import Control.Applicative ((<$>))

96−import Control.Exception (throw)

9794import Control.Monad.IO.Class (liftIO)

98−import Control.Distributed.Process.Internal.MessageT (getLocalNode)

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

10095import Control.Distributed.Process.Internal.Types

10196 ( RemoteTable

10297 , NodeId(..)

@@ -118,8 +113,6 @@ import Control.Distributed.Process.Internal.Types

118113 , SendPort(..)

119114 , ReceivePort(..)

120115 , SerializableDict(..)

121− , procMsg

122− , LocalNode(..)

123116 , SendPortId(..)

124117 , WhereIsReply(..)

125118 )

@@ -130,7 +123,10 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

130123 , expectClosure

131124 , serializableDictUnit

132125 )

133−import Control.Distributed.Process.Internal.Closure.Combinators (cpSeq, cpBind)

126+import Control.Distributed.Process.Internal.Closure.Combinators

127+ ( cpSeq

128+ , cpBind

129+ )

134130import Control.Distributed.Process.Internal.Primitives

135131 ( -- Basic messaging

136132 send

@@ -176,12 +172,13 @@ import Control.Distributed.Process.Internal.Primitives

176172 , whereisRemote

177173 , whereisRemoteAsync

178174 , nsendRemote

175+ -- Closures

176+ , unClosure

179177 -- Auxiliary API

180178 , catch

181179 , expectTimeout

182180 , spawnAsync

183181 )

184−import Control.Distributed.Process.Internal.Closure (resolveClosure)

185182

186183-- INTERNAL NOTES

187184--

@@ -320,14 +317,16 @@ spawnSupervised nid proc = do

320317 ref <- monitor them

321318 return (them, ref)

322319

323−-- | Deserialize a closure

324−unClosure :: forall a. Typeable a => Closure a -> Process a

325−unClosure (Closure (Static label) env) = do

326− rtable <- remoteTable <$> procMsg getLocalNode

327− case resolveClosure rtable label env of

328− Nothing -> throw . userError $ "Unregistered closure " ++ show label

329− Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

320+{-

321+spawnChannel :: forall a. Typeable a

322+ => NodeId

323+ -> Closure (ReceivePort a -> Process ())

324+ -> Process (SendPort a)

325+spawnChannel nid proc = do

326+ us <- getSelfPid

327+ undefined

330328 where

331− typeError dyn = userError $ "lookupStatic type error: "

332− ++ "cannot match " ++ show (dynTypeRep dyn)

333− ++ " against " ++ show (typeOf (undefined :: a))

329+ rproc :: ProcessId -> Closure (Process ((), ReceivePort a))

330+ rproc pid = newChanClosure

331+ `cpBind` cpFirst (sendClosure undefined pid)

332+-}

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

@@ -1,18 +1,16 @@

11{-# LANGUAGE MagicHash #-}

22module Control.Distributed.Process.Internal.Closure

33 ( -- * Runtime support

4− initRemoteTable

5− , resolveClosure

4+ resolveClosure

65 ) where

8−import qualified Data.Map as Map (empty)

97import Data.Accessor ((^.))

108import Data.ByteString.Lazy (ByteString)

119import Data.Binary (decode)

1210import Data.Typeable (TypeRep)

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

1412import Control.Distributed.Process.Internal.Types

15− ( RemoteTable(RemoteTable)

13+ ( RemoteTable

1614 , remoteTableLabel

1715 , remoteTableDict

1816 , StaticLabel(..)

@@ -30,17 +28,24 @@ import Control.Distributed.Process.Internal.Dynamic

3028 , unsafeCoerce#

3129 )

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

31+

32+{-

3333import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn

3434 (remoteTable)

35+import qualified Control.Distributed.Process.Internal.Closure.Combinators as Combinators

36+ (remoteTable)

37+

38+-- | Initial (empty) remote-call meta data

39+initRemoteTable :: RemoteTable

40+initRemoteTable = BuiltIn.remoteTable

41+ . Combinators.remoteTable

42+ $ RemoteTable Map.empty Map.empty

43+-}

3544

3645--------------------------------------------------------------------------------

3746-- Runtime support for closures --

3847--------------------------------------------------------------------------------

3948

40−-- | Initial (empty) remote-call meta data

41−initRemoteTable :: RemoteTable

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

43−

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

4550-- Built-in closures

4651resolveClosure rtable ClosureSend env = do

@@ -64,54 +69,6 @@ resolveClosure rtable ClosureApply env = do

6469 f `dynApply` x

6570 where

6671 (labelf, envf, labelx, envx) = decode env

67−resolveClosure _rtable ClosureConst env =

68− return $ Dynamic (decode env) (unsafeCoerce# const)

69−resolveClosure _rtable ClosureUnit _env =

70− return $ toDyn ()

71−-- Arrow combinators

72−resolveClosure _rtable CpId env =

73− return $ Dynamic (decode env) (unsafeCoerce# cpId)

74− where

75− cpId :: forall a. a -> Process a

76− cpId = return

77−resolveClosure _rtable CpComp env =

78− return $ Dynamic (decode env) (unsafeCoerce# cpComp)

79− where

80− cpComp :: forall a b c. (a -> Process b) -> (b -> Process c) -> a -> Process c

81− cpComp p q a = p a >>= q

82−resolveClosure _rtable CpFirst env =

83− return $ Dynamic (decode env) (unsafeCoerce# cpFirst)

84− where

85− cpFirst :: forall a b c. (a -> Process b) -> (a, c) -> Process (b, c)

86− cpFirst p (a, c) = do b <- p a ; return (b, c)

87−resolveClosure _rtable CpSwap env =

88− return $ Dynamic (decode env) (unsafeCoerce# cpSwap)

89− where

90− cpSwap :: forall a b. (a, b) -> Process (b, a)

91− cpSwap (a, b) = return (b, a)

92−resolveClosure _rtable CpCopy env =

93− return $ Dynamic (decode env) (unsafeCoerce# cpCopy)

94− where

95− cpCopy :: forall a. a -> Process (a, a)

96− cpCopy a = return (a, a)

97−resolveClosure _rtable CpLeft env =

98− return $ Dynamic (decode env) (unsafeCoerce# cpLeft)

99− where

100− cpLeft :: forall a b c. (a -> Process b) -> Either a c -> Process (Either b c)

101− cpLeft p (Left a) = do b <- p a ; return (Left b)

102− cpLeft _ (Right c) = return (Right c)

103−resolveClosure _rtable CpMirror env =

104− return $ Dynamic (decode env) (unsafeCoerce# cpMirror)

105− where

106− cpMirror :: forall a b. Either a b -> Process (Either b a)

107− cpMirror (Left a) = return (Right a)

108− cpMirror (Right b) = return (Left b)

109−resolveClosure _rtable CpUntag env =

110− return $ Dynamic (decode env) (unsafeCoerce# cpUntag)

111− where

112− cpUntag :: forall a. Either a a -> Process a

113− cpUntag (Left a) = return a

114− cpUntag (Right a) = return a

11572resolveClosure rtable CpApply env =

11673 return $ Dynamic typApply (unsafeCoerce# cpApply)

11774 where

@@ -131,3 +88,8 @@ resolveClosure rtable CpApply env =

13188resolveClosure rtable (UserStatic label) env = do

13289 val <- rtable ^. remoteTableLabel label

13390 dynApply val (toDyn env)

91+

92+-- User-defined polymorphic closures

93+resolveClosure rtable (PolyStatic label) env = do

94+ Dynamic _ val <- rtable ^. remoteTableLabel label

95+ return (Dynamic (decode env) val)

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

@@ -13,7 +13,7 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn

1313 ) where

1414

1515import Data.Binary (encode)

16−import Data.Typeable (typeOf)

16+import Data.Typeable (Typeable, typeOf)

1717import Control.Distributed.Process.Internal.Primitives (link, unlink)

1818import Control.Distributed.Process.Internal.Types

1919 ( ProcessId

distributed-process/src/Control/Distributed/Process/Internal/Closure/Combinators.hs+74−51

@@ -1,6 +1,7 @@

11module Control.Distributed.Process.Internal.Closure.Combinators

2− ( -- * Generic combinators

3− closureApply

2+ ( remoteTable

3+ -- * Generic combinators

4+ , closureApply

45 , closureConst

56 , closureUnit

67 -- * Arrow combinators for processes

@@ -28,16 +29,75 @@ module Control.Distributed.Process.Internal.Closure.Combinators

2829 ) where

2930

3031import Prelude hiding (lookup)

31−import qualified Data.ByteString.Lazy as BS (empty)

3232import Data.Binary (encode)

3333import Data.Typeable (typeOf, Typeable)

34+import Data.Tuple (swap)

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

36+import Control.Monad ((>=>))

3437import Control.Distributed.Process.Internal.Types

3538 ( Closure(..)

3639 , Static(..)

3740 , StaticLabel(..)

3841 , Process

42+ , RemoteTable

3943 )

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

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

46+import Control.Distributed.Process.Internal.Primitives (unClosure)

47+

48+--------------------------------------------------------------------------------

49+-- TH stuff --

50+--------------------------------------------------------------------------------

51+

52+idUnit :: () -> ()

53+idUnit = id

54+

55+returnProcess :: a -> Process a

56+returnProcess = return

57+

58+kleisliComposeProcess :: (a -> Process b) -> (b -> Process c) -> a -> Process c

59+kleisliComposeProcess = (>=>)

60+

61+firstProcess :: (a -> Process b) -> (a, c) -> Process (b, c)

62+firstProcess f (a, c) = f a >>= \b -> return (b, c)

63+

64+swapProcess :: (a, b) -> Process (b, a)

65+swapProcess = return . swap

66+

67+copyProcess :: a -> Process (a, a)

68+copyProcess x = return (x, x)

69+

70+leftProcess :: (a -> Process b) -> Either a c -> Process (Either b c)

71+leftProcess f (Left a) = Left <$> f a

72+leftProcess _ (Right b) = Right <$> return b

73+

74+mirrorProcess :: Either a b -> Process (Either b a)

75+mirrorProcess (Left x) = Right <$> return x

76+mirrorProcess (Right y) = Left <$> return y

77+

78+untagProcess :: Either a a -> Process a

79+untagProcess (Left x) = return x

80+untagProcess (Right y) = return y

81+

82+applyClosureProcess :: (Typeable a, Typeable b) => (Closure (a -> Process b), a) -> Process b

83+applyClosureProcess (procClosure, a) = do

84+ proc <- unClosure procClosure

85+ proc a

86+

87+remotable [ 'const

88+ , 'idUnit

89+ , 'returnProcess

90+ , 'kleisliComposeProcess

91+ , 'firstProcess

92+ , 'swapProcess

93+ , 'copyProcess

94+ , 'leftProcess

95+ , 'mirrorProcess

96+ , 'untagProcess

97+ ]

98+

99+remoteTable :: RemoteTable -> RemoteTable

100+remoteTable = __remoteTable

41101

42102--------------------------------------------------------------------------------

43103-- Generic closure combinators --

@@ -47,15 +107,11 @@ closureApply :: Closure (a -> b) -> Closure a -> Closure b

47107closureApply (Closure (Static labelf) envf) (Closure (Static labelx) envx) =

48108 Closure (Static ClosureApply) $ encode (labelf, envf, labelx, envx)

49109

50−closureConst :: forall a b. (Typeable a, Typeable b)

51− => Closure (a -> b -> a)

52−closureConst = Closure (Static ClosureConst) (encode $ typeOf aux)

53− where

54− aux :: a -> b -> a

55− aux = undefined

110+closureConst :: (Typeable a, Typeable b) => Closure (a -> b -> a)

111+closureConst = $(mkClosure 'const)

56112

57113closureUnit :: Closure ()

58−closureUnit = Closure (Static ClosureUnit) BS.empty

114+closureUnit = $(mkClosure 'idUnit) ()

59115

60116--------------------------------------------------------------------------------

61117-- Arrow combinators for processes --

@@ -73,37 +129,19 @@ cpElim = flip closureApply closureUnit

73129

74130cpId :: forall a. Typeable a

75131 => CP a a

76−cpId = Closure (Static CpId) (encode $ typeOf aux)

77− where

78− aux :: a -> Process a

79− aux = undefined

132+cpId = $(mkClosure 'returnProcess)

80133

81134cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)

82135 => CP a b -> CP b c -> CP a c

83−cpComp f g = comp `closureApply` f `closureApply` g

84− where

85− comp :: Closure ((a -> Process b) -> (b -> Process c) -> a -> Process c)

86− comp = Closure (Static CpComp) (encode $ typeOf aux)

87−

88− aux :: (a -> Process b) -> (b -> Process c) -> a -> Process c

89− aux = undefined

136+cpComp f g = $(mkClosure 'kleisliComposeProcess) `closureApply` f `closureApply` g

90137

91138cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)

92139 => CP a b -> CP (a, c) (b, c)

93−cpFirst = closureApply first

94− where

95− first :: Closure ((a -> Process b) -> (a, c) -> Process (b, c))

96− first = Closure (Static CpFirst) (encode $ typeOf aux)

97−

98− aux :: (a -> Process b) -> (a, c) -> Process (b, c)

99− aux = undefined

140+cpFirst = closureApply $(mkClosure 'firstProcess)

100141

101142cpSwap :: forall a b. (Typeable a, Typeable b)

102143 => CP (a, b) (b, a)

103−cpSwap = Closure (Static CpSwap) (encode $ typeOf aux)

104− where

105− aux :: (a, b) -> Process (b, a)

106− aux = undefined

144+cpSwap = $(mkClosure 'swapProcess)

107145

108146cpSecond :: (Typeable a, Typeable b, Typeable c)

109147 => CP a b -> CP (c, a) (c, b)

@@ -115,10 +153,7 @@ cpPair f g = cpFirst f `cpComp` cpSecond g

115153

116154cpCopy :: forall a. Typeable a

117155 => CP a (a, a)

118−cpCopy = Closure (Static CpCopy) (encode $ typeOf aux)

119− where

120− aux :: a -> Process (a, a)

121− aux = undefined

156+cpCopy = $(mkClosure 'copyProcess)

122157

123158cpFanOut :: (Typeable a, Typeable b, Typeable c)

124159 => CP a b -> CP a c -> CP a (b, c)

@@ -126,20 +161,11 @@ cpFanOut f g = cpCopy `cpComp` (f `cpPair` g)

126161

127162cpLeft :: forall a b c. (Typeable a, Typeable b, Typeable c)

128163 => CP a b -> CP (Either a c) (Either b c)

129−cpLeft = closureApply left

130− where

131− left :: Closure ((a -> Process b) -> Either a c -> Process (Either b c))

132− left = Closure (Static CpLeft) (encode $ typeOf aux)

133−

134− aux :: (a -> Process b) -> Either a c -> Process (Either b c)

135− aux = undefined

164+cpLeft = closureApply $(mkClosure 'leftProcess)

136165

137166cpMirror :: forall a b. (Typeable a, Typeable b)

138167 => CP (Either a b) (Either b a)

139−cpMirror = Closure (Static CpMirror) (encode $ typeOf aux)

140− where

141− aux :: Either a b -> Process (Either b a)

142− aux = undefined

168+cpMirror = $(mkClosure 'mirrorProcess)

143169

144170cpRight :: forall a b c. (Typeable a, Typeable b, Typeable c)

145171 => CP a b -> CP (Either c a) (Either c b)

@@ -151,10 +177,7 @@ cpEither f g = cpLeft f `cpComp` cpRight g

151177

152178cpUntag :: forall a. Typeable a

153179 => CP (Either a a) a

154−cpUntag = Closure (Static CpUntag) (encode $ typeOf aux)

155− where

156− aux :: Either a a -> Process a

157− aux = undefined

180+cpUntag = $(mkClosure 'untagProcess)

158181

159182cpFanIn :: (Typeable a, Typeable b, Typeable c)

160183 => CP a c -> CP b c -> CP (Either a b) c

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+30−3

@@ -1,6 +1,7 @@

11-- | Template Haskell support

22--

33-- (In a separate file for convenience)

4+{-# LANGUAGE MagicHash #-}

45module Control.Distributed.Process.Internal.Closure.TH

56 ( -- * User-level API

67 remotable

@@ -24,8 +25,10 @@ import Language.Haskell.TH

2425 -- Algebraic data types

2526 , Dec

2627 , Exp

27− , Type(AppT, ArrowT)

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

2829 , Info(VarI)

30+ , TyVarBndr(PlainTV, KindedTV)

31+ , Pred(ClassP)

2932 -- Lifted constructors

3033 -- .. Literals

3134 , stringL

@@ -51,7 +54,11 @@ import Control.Distributed.Process.Internal.Types

5154 , SerializableDict(..)

5255 , RuntimeSerializableSupport(..)

5356 )

54−import Control.Distributed.Process.Internal.Dynamic (Dynamic, toDyn)

57+import Control.Distributed.Process.Internal.Dynamic

58+ ( Dynamic(..)

59+ , toDyn

60+ , unsafeCoerce#

61+ )

5562import Control.Distributed.Process.Internal.Primitives (send, expect)

5663

5764--------------------------------------------------------------------------------

@@ -104,6 +111,9 @@ generateDefs n = do

104111 return (closure, insert)

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

106113 return ([], [| registerSerializableDict $(varE n) |])

114+ Just (origName, ForallT vars [] tp) -> do

115+ (closure, label) <- generatePolyClosure origName vars tp

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

107117 _ ->

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

109119

@@ -117,7 +127,24 @@ generateClosure n arg res = do

117127 return (closure, label)

118128 where

119129 label :: String

120− label = show $ n

130+ label = show n

131+

132+-- | Generate a polymorphic closure

133+generatePolyClosure :: Name -> [TyVarBndr] -> Type -> Q ([Dec], String)

134+generatePolyClosure n xs typ = do

135+ closureTyp <- [t| Closure |]

136+ closure <- sequence

137+ [ sigD (closureName n) (return (ForallT xs (map typeable xs) (closureTyp `AppT` typ)) )

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

139+ ]

140+ return (closure, label)

141+ where

142+ label :: String

143+ label = show n

144+

145+ typeable :: TyVarBndr -> Pred

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

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

121148

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

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

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+22−1

@@ -41,6 +41,8 @@ module Control.Distributed.Process.Internal.Primitives

4141 , whereisRemote

4242 , whereisRemoteAsync

4343 , nsendRemote

44+ -- * Closures

45+ , unClosure

4446 -- * Auxiliary API

4547 , catch

4648 , expectTimeout

@@ -55,7 +57,7 @@ module Control.Distributed.Process.Internal.Primitives

5557

5658import Prelude hiding (catch)

5759import Data.Binary (decode)

58−import Data.Typeable (Typeable)

60+import Data.Typeable (Typeable, typeOf)

5961import Data.Time.Clock (getCurrentTime)

6062import Data.Time.Format (formatTime)

6163import System.Locale (defaultTimeLocale)

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

108110 , DidUnlinkPort(..)

109111 , WhereIsReply(..)

110112 , createMessage

113+ , Static(..)

111114 )

112115import Control.Distributed.Process.Internal.MessageT

113116 ( sendMessage

@@ -115,6 +118,8 @@ import Control.Distributed.Process.Internal.MessageT

115118 , getLocalNode

116119 )

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

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

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

118123

119124--------------------------------------------------------------------------------

120125-- Basic messaging --

@@ -445,6 +450,22 @@ nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

445450nsendRemote nid label msg =

446451 sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

447452

453+--------------------------------------------------------------------------------

454+-- Closures --

455+--------------------------------------------------------------------------------

456+

457+-- | Deserialize a closure

458+unClosure :: forall a. Typeable a => Closure a -> Process a

459+unClosure (Closure (Static label) env) = do

460+ rtable <- remoteTable <$> procMsg getLocalNode

461+ case resolveClosure rtable label env of

462+ Nothing -> throw . userError $ "Unregistered closure " ++ show label

463+ Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

464+ where

465+ typeError dyn = userError $ "lookupStatic type error: "

466+ ++ "cannot match " ++ show (dynTypeRep dyn)

467+ ++ " against " ++ show (typeOf (undefined :: a))

468+

448469--------------------------------------------------------------------------------

449470-- Auxiliary functions --

450471--------------------------------------------------------------------------------

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

@@ -253,6 +253,7 @@ data ReceivePort a =

253253 | ReceivePortBiased [ReceivePort a]

254254 -- | A round-robin combination of receive ports

255255 | ReceivePortRR (TVar [ReceivePort a])

256+ deriving Typeable

256257

257258--------------------------------------------------------------------------------

258259-- Closures --

@@ -260,23 +261,13 @@ data ReceivePort a =

260261

261262data StaticLabel =

262263 UserStatic String

264+ | PolyStatic String

263265 -- Built-in closures

264266 | ClosureReturn

265267 | ClosureSend

266268 | ClosureExpect

267269 -- Generic closure combinators

268270 | ClosureApply

269− | ClosureConst

270− | ClosureUnit

271− -- Arrow combinators for processes

272− | CpId

273− | CpComp

274− | CpFirst

275− | CpSwap

276− | CpCopy

277− | CpLeft

278− | CpMirror

279− | CpUntag

280271 | CpApply

281272 deriving (Typeable, Show)

282273

@@ -555,40 +546,22 @@ instance Binary Identifier where

555546

556547instance Binary StaticLabel where

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

558− put ClosureReturn = putWord8 1

559− put ClosureSend = putWord8 2

560− put ClosureExpect = putWord8 3

561− put ClosureApply = putWord8 4

562− put ClosureConst = putWord8 5

563− put ClosureUnit = putWord8 6

564− put CpId = putWord8 7

565− put CpComp = putWord8 8

566− put CpFirst = putWord8 9

567− put CpSwap = putWord8 10

568− put CpCopy = putWord8 11

569− put CpLeft = putWord8 12

570− put CpMirror = putWord8 13

571− put CpUntag = putWord8 14

572− put CpApply = putWord8 15

549+ put (PolyStatic string) = putWord8 1 >> put string

550+ put ClosureReturn = putWord8 2

551+ put ClosureSend = putWord8 3

552+ put ClosureExpect = putWord8 4

553+ put ClosureApply = putWord8 6

554+ put CpApply = putWord8 17

573555 get = do

574556 header <- getWord8

575557 case header of

576558 0 -> UserStatic <$> get

577− 1 -> return ClosureReturn

578− 2 -> return ClosureSend

579− 3 -> return ClosureExpect

580− 4 -> return ClosureApply

581− 5 -> return ClosureConst

582− 6 -> return ClosureUnit

583− 7 -> return CpId

584− 8 -> return CpComp

585− 9 -> return CpFirst

586− 10 -> return CpSwap

587− 11 -> return CpCopy

588− 12 -> return CpLeft

589− 13 -> return CpMirror

590− 14 -> return CpUntag

591− 15 -> return CpApply

559+ 1 -> PolyStatic <$> get

560+ 2 -> return ClosureReturn

561+ 3 -> return ClosureSend

562+ 4 -> return ClosureExpect

563+ 6 -> return ClosureApply

564+ 17 -> return CpApply

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

593566

594567instance Binary WhereIsReply where

distributed-process/src/Control/Distributed/Process/Node.hs+12−2

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

105105 , typedChannelWithId

106106 , WhereIsReply(..)

107107 , messageToPayload

108+ , RemoteTable(..)

108109 )

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

110111import Control.Distributed.Process.Internal.MessageT

@@ -118,16 +119,25 @@ import Control.Distributed.Process.Internal.MessageT

118119 )

119120import Control.Distributed.Process.Internal.Dynamic (fromDynamic)

120121import Control.Distributed.Process.Internal.Closure

121− ( initRemoteTable

122− , resolveClosure

122+ (

123+ resolveClosure

123124 )

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

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

127+import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn

128+ (remoteTable)

129+import qualified Control.Distributed.Process.Internal.Closure.Combinators as Combinators

130+ (remoteTable)

126131

127132--------------------------------------------------------------------------------

128133-- Initialization --

129134--------------------------------------------------------------------------------

130135

136+initRemoteTable :: RemoteTable

137+initRemoteTable = BuiltIn.remoteTable

138+ . Combinators.remoteTable

139+ $ RemoteTable Map.empty Map.empty

140+

131141-- | Initialize a new local node.

132142--

133143-- Note that proper Cloud Haskell initialization and configuration is still

distributed-process/tests/TestClosure.hs+16−1

@@ -1,6 +1,7 @@

11module Main where

33import qualified Data.ByteString.Lazy as BSL (empty)

4+import Data.Typeable (Typeable)

45import Control.Monad (join, replicateM)

56import Control.Exception (IOException, throw)

67import Control.Concurrent (forkIO, threadDelay)

@@ -44,7 +45,21 @@ returnForTestApply = id

4445wait :: Int -> Process ()

4546wait = liftIO . threadDelay

4647

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

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

49+first (x, _) = x

50+

51+$(remotable

52+ [ 'addInt

53+ , 'putInt

54+ , 'sendInt

55+ , 'sendPid

56+ , 'factorial

57+ , 'factorialOf

58+ , 'returnForTestApply

59+ , 'wait

60+ , 'serializableDictInt

61+ , 'first

62+ ])

4863

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

5065testSendPureClosure transport rtable = do