bcc7a80 · distributed-process

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+1−1

compare with master

unifiedsplit

@@ -79,7 +79,7 @@ encodeToStdout = liftIO . BSL.putStr . encode

79encodeToStdoutDict :: SerializableDict a -> a -> Process ()

80encodeToStdoutDict SerializableDict = encodeToStdout

81

82−remotable ['encodeToStdoutDict]

82+remotable ['encodeToStdout]

83

84-- | Azure backend

85data Backend = Backend {

distributed-process/ChangeLog+3−1

@@ -1,6 +1,8 @@

1−2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.2.1

1+2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0

2

3* Expose the constructors of Closure

4+* Add instance (Typeable a => Serializable (Static a)) and make sure we only

5+use the internal representation of Static where really necessary

4* Improved docs

6* Improved docs

5

7

62012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

82012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

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

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

115 , ProcessId(..)

116 , Process(..)

117 , Closure(..)

118− , Static(..)

118+ , Static

119 , MonitorRef(..)

120 , ProcessMonitorNotification(..)

121 , NodeMonitorNotification(..)

distributed-process/src/Control/Distributed/Process/Internal/Closure/CP.hs+2−2

@@ -117,9 +117,9 @@ sdictComp = SerializableDict

117

118-- | Resolve a closure

119unClosure :: Static a -> ByteString -> Process Dynamic

120−unClosure (Static label) env = do

120+unClosure static env = do

121 rtable <- remoteTable . processNode <$> ask

122− case resolveClosure rtable label env of

122+ case resolveClosure rtable static env of

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

124 Just dyn -> return dyn

125

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

@@ -17,18 +17,18 @@ import Control.Distributed.Process.Internal.Dynamic

17 )

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

19

20−resolveStatic :: RemoteTable -> StaticLabel -> Maybe Dynamic

20+resolveStatic :: RemoteTable -> Static a -> Maybe Dynamic

21−resolveStatic rtable (StaticLabel string typ) = do

21+resolveStatic rtable (Static (StaticLabel string typ)) = do

22 Dynamic _ val <- rtable ^. remoteTableLabel string

23 return (Dynamic typ val)

24−resolveStatic rtable (StaticApply static1 static2) = do

24+resolveStatic rtable (Static (StaticApply static1 static2)) = do

25− f <- resolveStatic rtable static1

25+ f <- resolveStatic rtable (Static static1)

26− x <- resolveStatic rtable static2

26+ x <- resolveStatic rtable (Static static2)

27 f `dynApply` x

28−resolveStatic _rtable (StaticDuplicate static typ) =

28+resolveStatic _rtable (Static (StaticDuplicate static typ)) =

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

30

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

31+resolveClosure :: RemoteTable -> Static a -> ByteString -> Maybe Dynamic

32resolveClosure rtable static env = do

33 decoder <- resolveStatic rtable static

34 decoder `dynApply` toDyn env

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+3−4

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

118 , DidUnlinkPort(..)

119 , WhereIsReply(..)

120 , createMessage

121− , Static(..)

122 , runLocalProcess

121 , runLocalProcess

123 )

122 )

124import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)

123import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary)

@@ -503,10 +502,10 @@ nsendRemote nid label msg =

503

502

504-- | Deserialize a closure

503-- | Deserialize a closure

505unClosure :: forall a. Typeable a => Closure a -> Process a

504unClosure :: forall a. Typeable a => Closure a -> Process a

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

505+unClosure (Closure static env) = do

507 rtable <- remoteTable . processNode <$> ask

506 rtable <- remoteTable . processNode <$> ask

508− case resolveClosure rtable label env of

507+ case resolveClosure rtable static env of

509− Nothing -> error $ "Unregistered closure " ++ show label

508+ Nothing -> error $ "Unregistered closure " ++ show static

510 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

509 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

511 where

510 where

512 typeError dyn = userError $ "lookupStatic type error: "

511 typeError dyn = userError $ "lookupStatic type error: "

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+35−16

@@ -78,7 +78,7 @@ import Data.Map (Map)

78import Data.Int (Int32)

79import Data.Maybe (fromJust)

80import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)

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

81+import Data.Binary (Binary(put, get), putWord8, getWord8, encode, Put, Get)

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

83import qualified Data.ByteString.Lazy as BSL

84 ( ByteString

@@ -109,7 +109,7 @@ import Control.Distributed.Process.Serializable

109 )

110import Control.Distributed.Process.Internal.CQueue (CQueue)

111import Control.Distributed.Process.Internal.Dynamic (Dynamic)

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

112+import Control.Distributed.Process.Internal.TypeRep (compareTypeRep) -- and Binary instances

113

114--------------------------------------------------------------------------------

115-- Node and process identifiers --

@@ -265,7 +265,15 @@ data StaticLabel =

265 | StaticDuplicate StaticLabel TypeRep

266 deriving (Typeable, Show)

267

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

268+-- | A static value is top-level bound or the application of two static values.

269+--

270+-- You construct static values using 'Control.Distributed.Process.Closure.mkStatic'

271+-- or 'staticApply'. 'Static' has a serializable instance for all /Typeable/ 'a':

272+--

273+-- > instance Typeable a => Serializable (Static a)

274+--

275+-- The 'Typeable' constraint (not present in the original Cloud Haskell paper)

276+-- makes it possible to do a type check during deserialization.

269newtype Static a = Static StaticLabel

277newtype Static a = Static StaticLabel

270 deriving (Typeable, Show)

278 deriving (Typeable, Show)

271

279

@@ -518,9 +526,9 @@ instance Binary DiedReason where

518 4 -> return DiedUnknownId

526 4 -> return DiedUnknownId

519 _ -> fail "DiedReason.get: invalid"

527 _ -> fail "DiedReason.get: invalid"

520

528

521−instance Binary (Closure a) where

529+instance Typeable a => Binary (Closure a) where

522− put (Closure (Static label) env) = put label >> put env

530+ put (Closure static env) = put static >> put env

523− get = Closure <$> (Static <$> get) <*> get

531+ get = Closure <$> get <*> get

524

532

525instance Binary DidSpawn where

533instance Binary DidSpawn where

526 put (DidSpawn ref pid) = put ref >> put pid

534 put (DidSpawn ref pid) = put ref >> put pid

@@ -542,17 +550,28 @@ instance Binary Identifier where

542 2 -> SendPortIdentifier <$> get

550 2 -> SendPortIdentifier <$> get

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

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

544

552

545−instance Binary StaticLabel where

553+-- We don't want StaticLabel to be its own Binary instance

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

554+putStaticLabel :: StaticLabel -> Put

547− put (StaticApply label1 label2) = putWord8 1 >> put label1 >> put label2

555+putStaticLabel (StaticLabel string typ) = putWord8 0 >> put string >> put typ

548− put (StaticDuplicate label typ) = putWord8 2 >> put label >> put typ

556+putStaticLabel (StaticApply label1 label2) = putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2

557+putStaticLabel (StaticDuplicate label typ) = putWord8 2 >> putStaticLabel label >> put typ

558+

559+getStaticLabel :: Get StaticLabel

560+getStaticLabel = do

561+ header <- getWord8

562+ case header of

563+ 0 -> StaticLabel <$> get <*> get

564+ 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel

565+ 2 -> StaticDuplicate <$> getStaticLabel <*> get

566+ _ -> fail "StaticLabel.get: invalid"

567+

568+instance Typeable a => Binary (Static a) where

569+ put (Static label) = putStaticLabel label

549 get = do

570 get = do

550− header <- getWord8

571+ label <- getStaticLabel

551− case header of

572+ if typeOfStaticLabel label `compareTypeRep` typeOf (undefined :: a)

552− 0 -> StaticLabel <$> get <*> get

573+ then return $ Static label

553− 1 -> StaticApply <$> get <*> get

574+ else fail "Static.get: type error"

554− 2 -> StaticDuplicate <$> get <*> get

555− _ -> fail "StaticLabel.get: invalid"

556

575

557instance Binary WhereIsReply where

576instance Binary WhereIsReply where

558 put (WhereIsReply label mPid) = put label >> put mPid

577 put (WhereIsReply label mPid) = put label >> put mPid

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

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

99 , SpawnRef

100 , DidSpawn(..)

101 , Closure(..)

102− , Static(..)

103 , Message

102 , Message

104 , TypedChannel(..)

103 , TypedChannel(..)

105 , Identifier(..)

104 , Identifier(..)

@@ -605,9 +604,9 @@ isLocal nid ident = nodeOf ident == localNodeId nid

605

604

606-- | Lookup a local closure

605-- | Lookup a local closure

607unClosure :: Typeable a => Closure a -> NC (Maybe a)

606unClosure :: Typeable a => Closure a -> NC (Maybe a)

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

607+unClosure (Closure static env) = do

609 rtable <- remoteTable <$> ask

608 rtable <- remoteTable <$> ask

610− return (resolveClosure rtable label env >>= fromDynamic)

609+ return (resolveClosure rtable static env >>= fromDynamic)

611

610

612-- | Check if an identifier refers to a valid local object

611-- | Check if an identifier refers to a valid local object

613isValidLocalIdentifier :: Identifier -> NC Bool

612isValidLocalIdentifier :: Identifier -> NC Bool

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

@@ -12,7 +12,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)

12import Control.Distributed.Process

13import Control.Distributed.Process.Closure

14import Control.Distributed.Process.Node

15−import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))

15+import Control.Distributed.Process.Internal.Types (Static(Static), StaticLabel(StaticLabel))

16import TestAuxiliary

17

18sdictInt :: SerializableDict Int