distributed-process 0.2.3.0 → 0.3.0

raw patch · 16 files changed

+457/−1110 lines, 16 filesdep +distributed-staticdep +rank1dynamicdep +sybPVP ok

version bump matches the API change (PVP)

Dependencies added: distributed-static, rank1dynamic, syb

API changes (from Hackage documentation)

Files

• distributed-process.cabal +13/−12
• src/Control/Distributed/Process.hs +27/−27
• src/Control/Distributed/Process/Closure.hs +39/−155
• src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs +237/−0
• src/Control/Distributed/Process/Internal/Closure/CP.hs +0/−330
• src/Control/Distributed/Process/Internal/Closure/MkClosure.hs +0/−25
• src/Control/Distributed/Process/Internal/Closure/Resolution.hs +0/−34
• src/Control/Distributed/Process/Internal/Closure/Static.hs +0/−190
• src/Control/Distributed/Process/Internal/Closure/TH.hs +64/−36
• src/Control/Distributed/Process/Internal/Dynamic.hs +0/−112
• src/Control/Distributed/Process/Internal/Primitives.hs +9/−15
• src/Control/Distributed/Process/Internal/TypeRep.hs +0/−33
• src/Control/Distributed/Process/Internal/Types.hs +6/−107
• src/Control/Distributed/Process/Node.hs +13/−17
• src/Control/Distributed/Process/Serializable.hs +6/−0
• tests/TestClosure.hs +43/−17

@@ -1,5 +1,5 @@ Name:          distributed-process -Version:       0.2.3.0+Version:       0.3.0 Cabal-Version: >=1.8 Build-Type:    Simple License:       BSD3 @@ -43,21 +43,19 @@                      time >= 1.2 && < 1.5,                      template-haskell >= 2.6 && < 2.8,                      random >= 1.0 && < 1.1,-                     ghc-prim >= 0.2 && < 0.3+                     ghc-prim >= 0.2 && < 0.3,+                     distributed-static >= 0.1 && < 0.2,+                     rank1dynamic >= 0.1 && < 0.2,+                     syb >= 0.3 && < 0.4   Exposed-modules:   Control.Distributed.Process,                      Control.Distributed.Process.Serializable,                      Control.Distributed.Process.Closure,                      Control.Distributed.Process.Node,                      Control.Distributed.Process.Internal.Primitives,                      Control.Distributed.Process.Internal.CQueue,-                     Control.Distributed.Process.Internal.Dynamic,-                     Control.Distributed.Process.Internal.TypeRep,                      Control.Distributed.Process.Internal.Types,-                     Control.Distributed.Process.Internal.Closure.Static,-                     Control.Distributed.Process.Internal.Closure.MkClosure,-                     Control.Distributed.Process.Internal.Closure.CP,                      Control.Distributed.Process.Internal.Closure.TH,-                     Control.Distributed.Process.Internal.Closure.Resolution,+                     Control.Distributed.Process.Internal.Closure.BuiltIn,                      Control.Distributed.Process.Internal.Node   Extensions:        RankNTypes,                      ScopedTypeVariables,@@ -67,7 +65,6 @@                      GADTs,                      GeneralizedNewtypeDeriving,                      DeriveDataTypeable,-                     TemplateHaskell,                      CPP   ghc-options:       -Wall   HS-Source-Dirs:    src@@ -90,7 +87,9 @@                      template-haskell >= 2.6 && < 2.8,                      random >= 1.0 && < 1.1,                      ghc-prim >= 0.2 && < 0.3,-                     ansi-terminal >= 0.5 && < 0.6+                     ansi-terminal >= 0.5 && < 0.6,+                     distributed-static >= 0.1 && < 0.2,+                     rank1dynamic >= 0.1 && < 0.2   Extensions:        RankNTypes,                      ScopedTypeVariables,                      FlexibleInstances,@@ -99,7 +98,6 @@                      GADTs,                      GeneralizedNewtypeDeriving,                      DeriveDataTypeable,-                     TemplateHaskell,                      CPP   ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind    HS-Source-Dirs:    tests src@@ -122,7 +120,10 @@                      template-haskell >= 2.6 && < 2.8,                      random >= 1.0 && < 1.1,                      ghc-prim >= 0.2 && < 0.3,-                     ansi-terminal >= 0.5 && < 0.6+                     ansi-terminal >= 0.5 && < 0.6,+                     distributed-static >= 0.1 && < 0.2,+                     rank1dynamic >= 0.1 && < 0.2,+                     syb >= 0.3 && < 0.4   Other-modules:     TestAuxiliary   Extensions:        RankNTypes,                      ScopedTypeVariables,

@@ -100,7 +100,6 @@   , spawnChannelLocal   ) where - #if ! MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif@@ -109,13 +108,15 @@ import Control.Monad.IO.Class (liftIO) import Control.Applicative ((<$>)) import Control.Monad.Reader (ask)+import Control.Distributed.Static +  ( Closure(..)+  , Static+  , RemoteTable+  ) import Control.Distributed.Process.Internal.Types -  ( RemoteTable-  , NodeId(..)+  ( NodeId(..)   , ProcessId(..)   , Process(..)-  , Closure(..)-  , Static   , MonitorRef(..)   , ProcessMonitorNotification(..)   , NodeMonitorNotification(..)@@ -126,29 +127,28 @@   , DiedReason(..)   , SpawnRef(..)   , DidSpawn(..)-  , Closure(..)   , SendPort(..)   , ReceivePort(..)-  , SerializableDict(..)   , SendPortId(..)   , WhereIsReply(..)   , LocalProcess(processNode)   )-import Control.Distributed.Process.Internal.Closure.CP-  ( cpSeq-  , cpBind-  , cpSend -  , cpExpect+import Control.Distributed.Process.Serializable (SerializableDict)+import Control.Distributed.Process.Internal.Closure.BuiltIn+  ( sdictUnit +  , sdictSendPort+  , sndStatic+  , idCP+  , seqCP +  , bindCP +  , splitCP   , cpLink   , cpUnlink+  , cpExpect+  , cpSend   , cpNewChan-  , cpCancelL-  , cpSplit   )-import Control.Distributed.Process.Internal.Closure.Static -  ( sdictUnit-  , sdictSendPort-  )+import Control.Distributed.Static (closureCompose, staticClosure) import Control.Distributed.Process.Internal.Primitives   ( -- Basic messaging     send @@ -289,9 +289,9 @@   -- that was already set up   mRef <- monitorNode nid   sRef <- spawnAsync nid $ cpLink us -                   `cpSeq` cpExpect sdictUnit -                   `cpSeq` cpUnlink us-                   `cpSeq` proc+                   `seqCP` cpExpect sdictUnit +                   `seqCP` cpUnlink us+                   `seqCP` proc   mPid <- receiveWait      [ matchIf (\(DidSpawn ref _) -> ref == sRef)               (\(DidSpawn _ pid) -> return $ Just pid)@@ -333,7 +333,7 @@ call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a call dict nid proc = do    us <- getSelfPid-  (_, mRef) <- spawnMonitor nid (proc `cpBind` cpSend dict us)+  (_, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)   -- We are guaranteed to receive the reply before the monitor notification   -- (if a reply is sent at all)   -- NOTE: This might not be true if we switch to unreliable delivery.@@ -353,7 +353,7 @@                 -> Process (ProcessId, MonitorRef) spawnSupervised nid proc = do   us   <- getSelfPid-  them <- spawn nid (cpLink us `cpSeq` proc) +  them <- spawn nid (cpLink us `seqCP` proc)    ref  <- monitor them   return (them, ref) @@ -370,10 +370,10 @@   where     go :: ProcessId -> Closure (Process ())     go pid = cpNewChan dict -           `cpBind` -             (cpSend (sdictSendPort dict) pid `cpSplit` proc)-           `cpBind`-             cpCancelL+           `bindCP` +             (cpSend (sdictSendPort dict) pid `splitCP` proc)+           `bindCP`+             (idCP `closureCompose` staticClosure sndStatic)   -------------------------------------------------------------------------------- -- Local versions of spawn                                                    --

@@ -1,11 +1,14 @@--- | Static values and Closures+-- | /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011)+-- proposes a new type construct called 'static' that characterizes values that+-- are known statically. Cloud Haskell uses the+-- 'Control.Distributed.Static.Static' implementation from+-- "Control.Distributed.Static". That module comes with its own extensive+-- documentation, which you should read if you want to know the details.  Here+-- we explain the Template Haskell support only. -- -- [Static values] ----- /Towards Haskell in the Cloud/ (Epstein et al., Haskell Symposium 2011) --- proposes a new type construct called 'static' that characterizes values that--- are known statically. There is no support for 'static' in ghc yet, however,--- so we emulate it using Template Haskell. Given a top-level definition+-- Given a top-level (possibly polymorphic, but unqualified) definition -- -- > f :: forall a1 .. an. T -- > f = ...@@ -42,55 +45,13 @@ -- -- then you need to enable the @ScopedTypeVariables@ language extension. ----- [Dealing with type class qualifiers]--- --- Although 'mkStatic' supports polymorphic types, it does not support--- qualified types. For instance, you cannot call 'mkStatic' on------ > decode :: Serializable a => ByteString -> a------ Instead, you will need to reify the type class dictionary. Cloud Haskell--- comes with a reified version of 'Serializable':------ > data SerializableDict a where--- >   SerializableDict :: Serializable a => SerializableDict a------ Using the reified dictionary you can define --- --- > decodeDict :: SerializableDict a -> ByteString -> a--- > decodeDict SerializableDict = decode------ where 'decodeDict' is a normal (unqualified) polymorphic value and hence--- can be passed as an argument to remotable:------ > $(mkStatic 'decodeDict) :: Typeable a => Static (SerializableDict a -> ByteString -> a)------ [Composing static values]------ The version of 'static' provided by this implementation of Cloud Haskell is--- strictly more expressive than the one proposed in the paper, and additionally--- supports ------ > staticApply :: Static (a -> b) -> Static a -> Static b------ This is extremely useful. For example, Cloud Haskell comes with--- 'staticDecode' defined as ------ > staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)--- > staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict ------ 'staticDecode' is used when defining closures (see below), and makes--- essential use of 'staticApply'. +-- [Static serialization dictionaries] ----- Support for 'staticApply' also makes it possible to define a rich set of--- combinators on 'static' values, a number of which are provided in this--- module. +-- Some Cloud Haskell primitives require static serialization dictionaries (**): ----- [Static serialization dictionaries]+-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a ----- Many Cloud Haskell primitives (like 'staticDecode', above) require static--- serialization dictionaries. In principle these dictionaries require nothing--- special; for instance, given some serializable type 'T' you can define +-- Given some serializable type 'T' you can define  -- -- > sdictT :: SerializableDict T -- > sdictT = SerializableDict@@ -135,33 +96,10 @@ -- -- > $(mkClosure 'f) :: T1 -> Closure T2 ----- provided that 'T1' is serializable (*).------ [Creating closures manually]------ You don't /need/ to use 'mkClosure', however.  Closures are defined exactly--- as described in /Towards Haskell in the Cloud/:--- --- > data Closure a = Closure (Static (ByteString -> a)) ByteString------ The splice @$(mkClosure 'isPrime)@ above expands to (prettified a bit): --- --- > let decoder :: Static (ByteString -> Process Bool) --- >     decoder = $(mkStatic 'isPrime) --- >             `staticCompose`  --- >               staticDecode $(functionSDict 'isPrime)--- > in Closure decoder (encode n)------ where 'staticCompose' is composition of static functions. Note that--- 'mkClosure' makes use of the static serialization dictionary --- ('functionSDict') created by 'remotable'.------ [Combinators on Closures]+-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable'). ----- Support for 'staticApply' (described above) also means that we can define--- combinators on Closures, and we provide a number of them in this module,--- the most important of which is 'cpBind'. Have a look at the implementation--- of 'Control.Distributed.Process.call' for an example use.+-- (You can also create closures manually--see the documentation of +-- "Control.Distributed.Static" for examples.) -- -- [Example] --@@ -211,119 +149,65 @@ --     a priori if 'T1' is serializable or not due to a bug in the Template --     Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>) ----- (**) Even though 'staticDecode' is passed an explicit serialization ---      dictionary, we still need the 'Typeable' constraint because +-- (**) Even though 'call' is passed an explicit serialization +--      dictionary, we still need the 'Serializable' constraint because  --      'Static' is not the /true/ static. If it was, we could 'unstatic' --      the dictionary and pattern match on it to bring the 'Typeable' --      instance into scope, but unless proper 'static' support is added to --      ghc we need both the type class argument and the explicit dictionary.  module Control.Distributed.Process.Closure -  ( -- * Creating static values+  ( -- * Template Haskell support for creating static values and closures      remotable   , mkStatic-    -- * Template-Haskell support for creating closures   , mkClosure   , functionSDict   , functionTDict-    -- * Primitive operations on static values-  , staticApply-  , staticDuplicate-    -- * Static functionals-  , staticConst-  , staticFlip-  , staticFst-  , staticSnd-  , staticCompose-  , staticFirst-  , staticSecond-  , staticSplit-    -- * Static constants-  , staticUnit-    -- * Creating closures-  , staticDecode-  , staticClosure-  , toClosure     -- * Serialization dictionaries (and their static versions)   , SerializableDict(..)+  , staticDecode   , sdictUnit   , sdictProcessId   , sdictSendPort-    -- * Definition of CP and the generalized arrow combinators+    -- * The CP type and associated combinators    , CP-  , cpIntro-  , cpElim-  , cpId-  , cpComp-  , cpFirst-  , cpSecond-  , cpSplit-  , cpCancelL-  , cpCancelR-    -- * Closure versions of CH primitives+  , idCP+  , splitCP+  , returnCP+  , bindCP +  , seqCP +    -- * CP versions of Cloud Haskell primitives     , cpLink   , cpUnlink   , cpSend   , cpExpect   , cpNewChan-    -- * @Closure (Process a)@ as a not-quite-monad-  , cpReturn -  , cpBind-  , cpSeq   ) where  -import Control.Distributed.Process.Internal.Types -  ( SerializableDict(..)-  , staticApply-  , staticDuplicate-  )+import Control.Distributed.Process.Serializable (SerializableDict(..)) import Control.Distributed.Process.Internal.Closure.TH    ( remotable   , mkStatic   , functionSDict   , functionTDict+  , mkClosure   )-import Control.Distributed.Process.Internal.Closure.Static-  ( -- Static functionals-    staticConst-  , staticFlip-  , staticFst-  , staticSnd-  , staticCompose-  , staticFirst-  , staticSecond-  , staticSplit-    -- Static constants-  , staticUnit-    -- Creating closures-  , staticDecode-  , staticClosure-  , toClosure-    -- Serialization dictionaries (and their static versions)+import Control.Distributed.Process.Internal.Closure.BuiltIn+  ( -- Static dictionaries and associated operations+    staticDecode   , sdictUnit   , sdictProcessId   , sdictSendPort-  )-import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)-import Control.Distributed.Process.Internal.Closure.CP-  ( -- Definition of CP and the generalized arrow combinators-    CP-  , cpIntro-  , cpElim-  , cpId-  , cpComp-  , cpFirst-  , cpSecond-  , cpSplit-  , cpCancelL-  , cpCancelR-    -- Closure versions of CH primitives+    -- The CP type and associated combinators +  , CP+  , idCP+  , splitCP+  , returnCP+  , bindCP +  , seqCP +    -- CP versions of Cloud Haskell primitives     , cpLink   , cpUnlink   , cpSend   , cpExpect   , cpNewChan-    -- @Closure (Process a)@ as a not-quite-monad-  , cpReturn -  , cpBind-  , cpSeq   )

@@ -0,0 +1,237 @@+module Control.Distributed.Process.Internal.Closure.BuiltIn +  ( -- * Remote table +    remoteTable+    -- * Static dictionaries and associated operations+  , staticDecode+  , sdictUnit+  , sdictProcessId+  , sdictSendPort+    -- * Some static values+  , sndStatic+    -- * The CP type and associated combinators +  , CP+  , idCP+  , splitCP+  , returnCP+  , bindCP +  , seqCP +    -- * CP versions of Cloud Haskell primitives  +  , cpLink+  , cpUnlink+  , cpSend+  , cpExpect+  , cpNewChan+  ) where++import Data.ByteString.Lazy (ByteString)  +import Data.Binary (decode, encode)+import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)+import Data.Rank1Dynamic (toDynamic)+import Control.Distributed.Static +  ( RemoteTable+  , registerStatic+  , Static+  , staticLabel+  , staticApply+  , Closure(Closure)+  , closureApplyStatic+  , closureApply+  , staticCompose+  , staticClosure+  )+import Control.Distributed.Process.Serializable +  ( SerializableDict(..)+  , Serializable+  )+import Control.Distributed.Process.Internal.Types +  ( Process+  , ProcessId+  , SendPort+  , ReceivePort+  )+import Control.Distributed.Process.Internal.Primitives +  ( link+  , unlink+  , send+  , expect+  , newChan+  )++--------------------------------------------------------------------------------+-- Remote table                                                               --+--------------------------------------------------------------------------------++remoteTable :: RemoteTable -> RemoteTable+remoteTable = +      registerStatic "$decodeDict"      (toDynamic (decodeDict       :: SerializableDict ANY -> ByteString -> ANY))+    . registerStatic "$sdictUnit"       (toDynamic (SerializableDict :: SerializableDict ()))+    . registerStatic "$sdictProcessId"  (toDynamic (SerializableDict :: SerializableDict ProcessId)) +    . registerStatic "$sdictSendPort_"  (toDynamic (sdictSendPort_   :: SerializableDict ANY -> SerializableDict (SendPort ANY)))+    . registerStatic "$returnProcess"   (toDynamic (return           :: ANY -> Process ANY))+    . registerStatic "$seqProcess"      (toDynamic ((>>)             :: Process ANY1 -> Process ANY2 -> Process ANY2))+    . registerStatic "$bindProcess"     (toDynamic ((>>=)            :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2))+    . registerStatic "$decodeProcessId" (toDynamic (decode           :: ByteString -> ProcessId))+    . registerStatic "$link"            (toDynamic link)+    . registerStatic "$unlink"          (toDynamic unlink)+    . registerStatic "$sendDict"        (toDynamic (sendDict         :: SerializableDict ANY -> ProcessId -> ANY -> Process ()))+    . registerStatic "$expectDict"      (toDynamic (expectDict       :: SerializableDict ANY -> Process ANY))+    . registerStatic "$newChanDict"     (toDynamic (newChanDict      :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)))+    . registerStatic "$cpSplit"         (toDynamic (cpSplit          :: (ANY1 -> Process ANY3) -> (ANY2 -> Process ANY4) -> (ANY1, ANY2) -> Process (ANY3, ANY4)))+    . registerStatic "$snd"             (toDynamic (snd              :: (ANY1, ANY2) -> ANY2))+  where+    decodeDict :: forall a. SerializableDict a -> ByteString -> a+    decodeDict SerializableDict = decode++    sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a)+    sdictSendPort_ SerializableDict = SerializableDict++    sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process ()+    sendDict SerializableDict = send++    expectDict :: forall a. SerializableDict a -> Process a+    expectDict SerializableDict = expect++    newChanDict :: forall a. SerializableDict a -> Process (SendPort a, ReceivePort a)+    newChanDict SerializableDict = newChan++    cpSplit :: forall a b c d. (a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d)+    cpSplit f g (a, b) = do+      c <- f a+      d <- g b+      return (c, d)++--------------------------------------------------------------------------------+-- Static dictionaries and associated operations                              --+--------------------------------------------------------------------------------++-- | Static decoder, given a static serialization dictionary.+--+-- See module documentation of "Control.Distributed.Process.Closure" for an+-- example.+staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)+staticDecode dict = decodeDictStatic `staticApply` dict +  where+    decodeDictStatic :: Typeable a => Static (SerializableDict a -> ByteString -> a)+    decodeDictStatic = staticLabel "$decodeDict"++-- | Serialization dictionary for '()' +sdictUnit :: Static (SerializableDict ())+sdictUnit = staticLabel "$sdictUnit" ++-- | Serialization dictionary for 'ProcessId' +sdictProcessId :: Static (SerializableDict ProcessId)+sdictProcessId = staticLabel "$sdictProcessId" ++-- | Serialization dictionary for 'SendPort'+sdictSendPort :: Typeable a +              => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))+sdictSendPort = staticApply (staticLabel "$sdictSendPort_") ++--------------------------------------------------------------------------------+-- Static values                                                              --+--------------------------------------------------------------------------------++sndStatic :: Static ((a, b) -> b)+sndStatic = staticLabel "$snd"++--------------------------------------------------------------------------------+-- The CP type and associated combinators                                     --+--------------------------------------------------------------------------------++-- | @CP a b@ is a process with input of type @a@ and output of type @b@+type CP a b = Closure (a -> Process b)++returnProcessStatic :: Typeable a => Static (a -> Process a)+returnProcessStatic = staticLabel "$returnProcess"++-- | 'CP' version of 'Control.Category.id' +idCP :: Typeable a => CP a a+idCP = staticClosure returnProcessStatic++-- | 'CP' version of ('Control.Arrow.***')+splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d) +        => CP a c -> CP b d -> CP (a, b) (c, d)+splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q+  where+    cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d))+    cpSplitStatic = staticLabel "$cpSplit" ++-- | 'CP' version of 'Control.Monad.return'+returnCP :: forall a. Serializable a +         => Static (SerializableDict a) -> a -> Closure (Process a)+returnCP dict x = Closure decoder (encode x)+  where+    decoder :: Static (ByteString -> Process a)+    decoder = returnProcessStatic+            `staticCompose`+              staticDecode dict++-- | 'CP' version of ('Control.Monad.>>')+seqCP :: (Typeable a, Typeable b)+      => Closure (Process a) -> Closure (Process b) -> Closure (Process b)+seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q +  where+    seqProcessStatic :: (Typeable a, Typeable b)+                     => Static (Process a -> Process b -> Process b)+    seqProcessStatic = staticLabel "$seqProcess"++-- | (Not quite the) 'CP' version of ('Control.Monad.>>=') +bindCP :: forall a b. (Typeable a, Typeable b)+       => Closure (Process a) -> CP a b -> Closure (Process b)+bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f +  where+    bindProcessStatic :: (Typeable a, Typeable b) +                      => Static (Process a -> (a -> Process b) -> Process b)+    bindProcessStatic = staticLabel "$bindProcess"++--------------------------------------------------------------------------------+-- CP versions of Cloud Haskell primitives                                    --+--------------------------------------------------------------------------------++decodeProcessIdStatic :: Static (ByteString -> ProcessId)+decodeProcessIdStatic = staticLabel "$decodeProcessId"++-- | 'CP' version of 'link'+cpLink :: ProcessId -> Closure (Process ())+cpLink = Closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode +  where+    linkStatic :: Static (ProcessId -> Process ())+    linkStatic = staticLabel "$link"++-- | 'CP' version of 'unlink'+cpUnlink :: ProcessId -> Closure (Process ())+cpUnlink = Closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode+  where+    unlinkStatic :: Static (ProcessId -> Process ())+    unlinkStatic = staticLabel "$unlink"++-- | 'CP' version of 'send'+cpSend :: forall a. Typeable a +       => Static (SerializableDict a) -> ProcessId -> CP a () +cpSend dict pid = Closure decoder (encode pid)+  where+    decoder :: Static (ByteString -> a -> Process ())+    decoder = (sendDictStatic `staticApply` dict)+            `staticCompose` +              decodeProcessIdStatic ++    sendDictStatic :: Typeable a +                   => Static (SerializableDict a -> ProcessId -> a -> Process ())+    sendDictStatic = staticLabel "$sendDict" ++-- | 'CP' version of 'expect'+cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)+cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)+  where+    expectDictStatic :: Typeable a => Static (SerializableDict a -> Process a)+    expectDictStatic = staticLabel "$expectDict"++-- | 'CP' version of 'newChan'+cpNewChan :: Typeable a +          => Static (SerializableDict a) +          -> Closure (Process (SendPort a, ReceivePort a))+cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)+  where+    newChanDictStatic :: Typeable a +                      => Static (SerializableDict a -> Process (SendPort a, ReceivePort a))+    newChanDictStatic = staticLabel "$newChanDict"                  

@@ -1,330 +0,0 @@--- | Combinator for process closures -{-# LANGUAGE MagicHash #-}-module Control.Distributed.Process.Internal.Closure.CP-  ( -- * Definition of CP and the generalized arrow combinators-    CP-  , cpIntro-  , cpElim-  , cpId-  , cpComp-  , cpFirst-  , cpSecond-  , cpSplit-  , cpCancelL-  , cpCancelR-    -- * Closure versions of CH primitives-  , cpLink-  , cpUnlink-  , cpSend-  , cpExpect-  , cpNewChan-    -- * @Closure (Process a)@ as a not-quite-monad-  , cpReturn -  , cpBind-  , cpSeq-    -- * Runtime support-  , __remoteTable-  ) where--import Data.Binary (encode)-import Data.ByteString.Lazy (ByteString)-import Data.Typeable (Typeable, typeOf, typeRepTyCon, TyCon)-import Control.Applicative ((<$>))-import Control.Monad ((>=>))-import Control.Monad.Reader (ask)-import Control.Distributed.Process.Serializable (Serializable)-import Control.Distributed.Process.Internal.Types-  ( Closure(Closure)-  , SerializableDict(SerializableDict)-  , Static(Static)-  , Process-  , staticApply-  , staticDuplicate-  , staticTypeOf-  , typeOfStaticLabel-  , ProcessId-  , LocalNode(remoteTable)-  , LocalProcess(processNode)-  , SendPort-  , ReceivePort-  )-import Control.Distributed.Process.Internal.Primitives -  ( link-  , unlink-  , send-  , expect-  , newChan-  )-import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)-import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)-import Control.Distributed.Process.Internal.Closure.Static -  ( staticCompose-  , staticDecode-  , staticClosure-  , staticSplit-  , staticConst-  , staticUnit-  , staticFlip-  , staticFst-  , staticSnd-  , sdictProcessId-  )-import Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure)-import Control.Distributed.Process.Internal.Dynamic -  ( Dynamic(Dynamic)-  , unsafeCoerce#-  , dynTypeRep-  , dynKleisli-  )-import Control.Distributed.Process.Internal.TypeRep (compareTypeRep)------------------------------------------------------------------------------------- Setup: A number of functions that we will pass to 'remotable'              ----------------------------------------------------------------------------------------- Type specializations of monadic operations on Processes ---------------------returnProcess :: a -> Process a-returnProcess = return--bindProcess :: Process a -> (a -> Process b) -> Process b-bindProcess = (>>=) --kleisliProcess :: (a -> Process b) -> (b -> Process c) -> a -> Process c-kleisliProcess = (>=>)--parJoinProcess :: Process (a -> Process b) -> a -> Process b-parJoinProcess proc a = proc >>= ($ a)------ Variations on standard or CH functions with an explicit dictionary arg ------sendDict :: SerializableDict a -> ProcessId -> a -> Process ()-sendDict SerializableDict = send--expectDict :: SerializableDict a -> Process a-expectDict SerializableDict = expect--newChanDict :: SerializableDict a -> Process (SendPort a, ReceivePort a)-newChanDict SerializableDict = newChan------ Serialization dictionaries ---------------------------------------------------- | Specialized serialization dictionary required in 'cpBind'-sdictComp :: SerializableDict (ByteString, ByteString)-sdictComp = SerializableDict------ Some specialised processes necessary to implement the combinators ------------- | Resolve a closure-unClosure :: Static a -> ByteString -> Process Dynamic-unClosure static env = do-  rtable <- remoteTable . processNode <$> ask -  case resolveClosure rtable static env of-    Nothing  -> fail "Derived.unClosure: resolveClosure failed"-    Just dyn -> return dyn---- | Remove a 'Dynamic' constructor, provided that the recorded type matches the--- type of the first static argument (the value of that argument is not used)-unDynamic :: Static a -> Process Dynamic -> Process a-unDynamic (Static label) pdyn = do-  Dynamic typ val <- pdyn-  if typ `compareTypeRep` typeOfStaticLabel label -    then return (unsafeCoerce# val)-    else fail $ "unDynamic: cannot match " -             ++ show typ-             ++ " against expected type " -             ++ show (typeOfStaticLabel label)---- | Dynamic kleisli composition------ The first argument stops remotable from trying to generate a SerializableDict--- for (Process Dynamic, Process Dynamic)-kleisliCompDyn :: () -> (Process Dynamic, Process Dynamic) -> Process Dynamic-kleisliCompDyn () (pf, pg) = do-    f <- pf -- a -> Process b-    g <- pg -- b -> Process c-    case dynKleisli tyConProcess kleisliProcess f g of-      Just dyn -> return dyn-      Nothing  -> fail $ "kleisliCompDyn: could not compose "-                      ++ show (dynTypeRep f)-                      ++ " with "-                      ++ show (dynTypeRep g)-  where-    tyConProcess :: TyCon-    tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))--cpFirstAux :: (a -> Process b) -> (a, c) -> Process (b, c)-cpFirstAux f (a, c) = f a >>= \b -> return (b, c) --cpSecondAux :: (a -> Process b) -> (c, a) -> Process (c, b)-cpSecondAux f (c, a) = f a >>= \b -> return (c, b) ------ Finally, the call to remotable ----------------------------------------------remotable [ -- Monadic operations-            'returnProcess-          , 'bindProcess-          , 'parJoinProcess-            -- CH primitives -          , 'link-          , 'unlink-            -- Explicit dictionaries-          , 'sendDict-          , 'expectDict-          , 'newChanDict-            -- Serialization dictionaries-          , 'sdictComp-            -- Specialized processes-          , 'unClosure-          , 'unDynamic-          , 'kleisliCompDyn-          , 'cpFirstAux-          , 'cpSecondAux-          ]------------------------------------------------------------------------------------- Some derived static functions                                              -------------------------------------------------------------------------------------staticUndynamic :: Typeable a => Static (Process Dynamic -> Process a)-staticUndynamic = -  $(mkStatic 'unDynamic) `staticApply` staticDuplicate (staticTypeOf (undefined :: a))--staticKleisliCompDyn :: Static ((Process Dynamic, Process Dynamic) -> Process Dynamic)-staticKleisliCompDyn = $(mkStatic 'kleisliCompDyn) `staticApply` staticUnit ------------------------------------------------------------------------------------- Definition of CP and the generalized arrow combinators                     --------------------------------------------------------------------------------------- | 'CP a b' represents the closure of a process parameterized by 'a' and--- returning 'b'. 'CP a b' forms a (restricted) generalized arrow--- (<http://www.cs.berkeley.edu/~megacz/garrows/>)-type CP a b = Closure (a -> Process b)---- | 'CP' introduction form -cpIntro :: forall a b. (Typeable a, Typeable b)-        => Closure (Process b) -> Closure (a -> Process b)-cpIntro (Closure static env) = Closure decoder env -  where-    decoder :: Static (ByteString -> a -> Process b)-    decoder = staticConst `staticCompose` static---- | 'CP' elimination form-cpElim :: forall a. Typeable a => CP () a -> Closure (Process a)-cpElim (Closure static env) = Closure decoder env-  where-    decoder :: Static (ByteString -> Process a)-    decoder = staticFlip static `staticApply` staticUnit ---- | Identity ('Closure' version of 'return')-cpId :: Typeable a => CP a a-cpId = staticClosure $(mkStatic 'returnProcess)---- | Left-to-right composition ('Closure' version of '>=>')-cpComp :: forall a b c. (Typeable a, Typeable b, Typeable c)-       => CP a b -> CP b c -> CP a c-cpComp (Closure fstatic fenv) (Closure gstatic genv) =-    Closure decoder (encode (fenv, genv))-  where-    decoder :: Static (ByteString -> a -> Process c)-    decoder = $(mkStatic 'parJoinProcess)-            `staticCompose`-              staticUndynamic-            `staticCompose`-              staticKleisliCompDyn-            `staticCompose`-              (staticUnclosure fstatic `staticSplit` staticUnclosure gstatic)-            `staticCompose`-              staticDecode $(mkStatic 'sdictComp)    ---- | First-cpFirst :: forall a b c. (Typeable a, Typeable b, Typeable c)-        => CP a b -> CP (a, c) (b, c)-cpFirst (Closure static env) = Closure decoder env-  where-    decoder :: Static (ByteString -> (a, c) -> Process (b, c))-    decoder = $(mkStatic 'cpFirstAux) `staticCompose` static---- | Second -cpSecond :: forall a b c. (Typeable a, Typeable b, Typeable c)-        => CP a b -> CP (c, a) (c, b)-cpSecond (Closure static env) = Closure decoder env-  where-    decoder :: Static (ByteString -> (c, a) -> Process (c, b))-    decoder = $(mkStatic 'cpSecondAux) `staticCompose` static---- | Split (Like 'Control.Arrow.***')-cpSplit :: (Typeable a, Typeable b, Typeable c, Typeable d)-        => CP a c -> CP b d -> CP (a, b) (c, d)-cpSplit f g = cpFirst f `cpComp` cpSecond g---- | Left cancellation-cpCancelL :: Typeable a => CP ((), a) a--- Closure (((), a) -> Process a)-cpCancelL = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticSnd) ---- | Right cancellation-cpCancelR :: Typeable a => CP (a, ()) a-cpCancelR = staticClosure ($(mkStatic 'returnProcess) `staticCompose` staticFst)------------------------------------------------------------------------------------- Closure versions of CH primitives                                          --------------------------------------------------------------------------------------- | Closure version of 'link'-cpLink :: ProcessId -> Closure (Process ())-cpLink = $(mkClosure 'link)---- | Closure version of 'unlink'-cpUnlink :: ProcessId -> Closure (Process ())-cpUnlink = $(mkClosure 'unlink)---- | Closure version of 'send'-cpSend :: forall a. Typeable a -       => Static (SerializableDict a) -> ProcessId -> Closure (a -> Process ())-cpSend dict pid = Closure decoder (encode pid)-  where-    decoder :: Static (ByteString -> a -> Process ())-    decoder = ($(mkStatic 'sendDict) `staticApply` dict)-            `staticCompose` -              staticDecode sdictProcessId ---- | Closure version of 'expect'-cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)-cpExpect dict = staticClosure ($(mkStatic 'expectDict) `staticApply` dict)---- | Closure version of 'newChan'-cpNewChan :: Typeable a -          => Static (SerializableDict a) -          -> Closure (Process (SendPort a, ReceivePort a))-cpNewChan dict = staticClosure ($(mkStatic 'newChanDict) `staticApply` dict)------------------------------------------------------------------------------------- (Closure . Process) as a not-quite-monad                                   --------------------------------------------------------------------------------------- | Not-quite-monadic 'return'-cpReturn :: forall a. Serializable a -         => Static (SerializableDict a) -> a -> Closure (Process a)-cpReturn dict x = Closure decoder (encode x)-  where-    decoder :: Static (ByteString -> Process a)-    decoder = $(mkStatic 'returnProcess) -            `staticCompose`-              staticDecode dict---staticUnclosure :: Typeable a -                => Static a -> Static (ByteString -> Process Dynamic)-staticUnclosure s = -  $(mkStatic 'unClosure) `staticApply` staticDuplicate s ---- | Not-quite-monadic bind ('>>=')-cpBind :: forall a b. (Typeable a, Typeable b)-       => Closure (Process a) -> Closure (a -> Process b) -> Closure (Process b)-cpBind x f = cpElim (cpIntro x `cpComp` f)---- | Monadic sequencing ('>>')-cpSeq :: Closure (Process ()) -> Closure (Process ()) -> Closure (Process ())-cpSeq p q = p `cpBind` cpIntro q

@@ -1,25 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Control.Distributed.Process.Internal.Closure.MkClosure (mkClosure) where--import Data.Binary (encode)-import Language.Haskell.TH (Q, Exp, Name)-import Control.Distributed.Process.Internal.Types (Closure(Closure))-import Control.Distributed.Process.Internal.Closure.TH -  ( mkStatic-  , functionSDict-  )-import Control.Distributed.Process.Internal.Closure.Static -  ( staticCompose-  , staticDecode-  )---- | Create a closure------ If @f : T1 -> T2@ is a /monomorphic/ function --- then @$(mkClosure 'f) :: T1 -> Closure T2@.--- Be sure to pass 'f' to 'remotable'. -mkClosure :: Name -> Q Exp-mkClosure n = -  [|   Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n)) -     . encode-  |]

@@ -1,34 +0,0 @@-{-# LANGUAGE MagicHash #-}-module Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure) where--import Data.Accessor ((^.))-import Data.ByteString.Lazy (ByteString)-import Control.Distributed.Process.Internal.Types-  ( RemoteTable-  , remoteTableLabel-  , Static(Static)-  , StaticLabel(..)-  )-import Control.Distributed.Process.Internal.Dynamic-  ( Dynamic(Dynamic)-  , toDyn-  , dynApply-  , unsafeCoerce#-  )-import Control.Distributed.Process.Internal.TypeRep () -- Binary instances  --resolveStatic :: RemoteTable -> Static a -> Maybe Dynamic-resolveStatic rtable (Static (StaticLabel string typ)) = do-  Dynamic _ val <- rtable ^. remoteTableLabel string-  return (Dynamic typ val)-resolveStatic rtable (Static (StaticApply static1 static2)) = do-  f <- resolveStatic rtable (Static static1)-  x <- resolveStatic rtable (Static static2)-  f `dynApply` x-resolveStatic _rtable (Static (StaticDuplicate static typ)) = -  return $ Dynamic typ (unsafeCoerce# (Static static))--resolveClosure :: RemoteTable -> Static a -> ByteString -> Maybe Dynamic-resolveClosure rtable static env = do-  decoder <- resolveStatic rtable static-  decoder `dynApply` toDyn env

@@ -1,190 +0,0 @@--- | Combinators on static values -{-# LANGUAGE MagicHash #-}-module Control.Distributed.Process.Internal.Closure.Static-  ( -- * Static functionals-    staticConst-  , staticFlip-  , staticFst-  , staticSnd-  , staticCompose-  , staticFirst-  , staticSecond-  , staticSplit-    -- * Static constants-  , staticUnit-    -- * Creating closures-  , staticDecode-  , staticClosure-  , toClosure-    -- * Serialization dictionaries (and their static versions)-  , sdictUnit-  , sdictProcessId-  , sdictSendPort-    -- * Runtime support-  , __remoteTable-  ) where--import Data.Binary (encode, decode)-import Data.ByteString.Lazy (ByteString, empty)-import Data.Typeable (Typeable)-import Control.Distributed.Process.Serializable (Serializable)-import Control.Distributed.Process.Internal.Types-  ( Closure(Closure)-  , SerializableDict(SerializableDict)-  , Static-  , staticApply-  , ProcessId-  , SendPort-  )-import Control.Distributed.Process.Internal.Closure.TH (remotable, mkStatic)-import qualified Control.Arrow as Arrow (first, second, (***))------------------------------------------------------------------------------------- Setup: A number of functions that we will pass to 'remotable'              ----------------------------------------------------------------------------------------- Functionals -----------------------------------------------------------------compose :: (b -> c) -> (a -> b) -> a -> c-compose = (.)--first :: (a -> b) -> (a, c) -> (b, c)-first = Arrow.first --second :: (a -> b) -> (c, a) -> (c, b)-second = Arrow.second--split :: (a -> b) -> (a' -> b') -> (a, a') -> (b, b')-split = (Arrow.***)------ Constants -------------------------------------------------------------------unit :: ()-unit = ()------ Variations on standard or CH functions with an explicit dictionary arg ------decodeDict :: SerializableDict a -> ByteString -> a-decodeDict SerializableDict = decode------ Serialization dictionaries --------------------------------------------------sdictUnit_ :: SerializableDict ()-sdictUnit_ = SerializableDict--sdictProcessId_ :: SerializableDict ProcessId-sdictProcessId_ = SerializableDict--sdictSendPort_ :: SerializableDict a -> SerializableDict (SendPort a)-sdictSendPort_ SerializableDict = SerializableDict------ Finally, the call to remotable ----------------------------------------------remotable [ -- Functionals (predefined)-            'const-          , 'flip-          , 'fst-          , 'snd-            -- Functionals (defined above)-          , 'compose-          , 'first-          , 'second-          , 'split-            -- Constants-          , 'unit-            -- Explicit dictionaries-          , 'decodeDict-            -- Serialization dictionaries-          , 'sdictUnit_-          , 'sdictProcessId_-          , 'sdictSendPort_-          ]------------------------------------------------------------------------------------- Static versions of the functionals                                         -- --- (We give these explicit names because they are useful outside this module) --------------------------------------------------------------------------------------- | Static version of 'const'-staticConst :: (Typeable a, Typeable b) => Static (a -> b -> a)-staticConst = $(mkStatic 'const)---- | Static version of 'flip'-staticFlip :: (Typeable a, Typeable b, Typeable c) -           => Static (a -> b -> c) -> Static (b -> a -> c)-staticFlip f = $(mkStatic 'flip) `staticApply` f           ---- | Static version of 'fst'-staticFst :: (Typeable a, Typeable b)-          => Static ((a, b) -> a)-staticFst = $(mkStatic 'fst)---- | Static version of 'snd'-staticSnd :: (Typeable a, Typeable b)-          => Static ((a, b) -> b)-staticSnd = $(mkStatic 'snd)---- | Static version of ('Prelude..')-staticCompose :: (Typeable a, Typeable b, Typeable c) -              => Static (b -> c) -> Static (a -> b) -> Static (a -> c)-staticCompose f x = $(mkStatic 'compose) `staticApply` f `staticApply` x ---- | Static version of 'Control.Arrow.first'-staticFirst :: (Typeable a, Typeable b, Typeable c)-            => Static ((a -> b) -> (a, c) -> (b, c))-staticFirst = $(mkStatic 'first)---- | Static version of 'Control.Arrow.second'-staticSecond :: (Typeable a, Typeable b, Typeable c)-             => Static ((a -> b) -> (c, a) -> (c, b))-staticSecond = $(mkStatic 'second)---- | Static version of ('Control.Arrow.***')-staticSplit :: (Typeable a, Typeable b, Typeable c, Typeable d) -            => Static (a -> c) -> Static (b -> d) -> Static ((a, b) -> (c, d))-staticSplit f g = $(mkStatic 'split) `staticApply` f `staticApply` g ------------------------------------------------------------------------------------- Constants                                                                  --------------------------------------------------------------------------------------- | Static version of '()'-staticUnit :: Static ()-staticUnit = $(mkStatic 'unit)------------------------------------------------------------------------------------- Dictionaries                                                               --------------------------------------------------------------------------------------- | Serialization dictionary for '()' -sdictUnit :: Static (SerializableDict ())-sdictUnit = $(mkStatic 'sdictUnit_)---- | Serialization dictionary for 'ProcessId' -sdictProcessId :: Static (SerializableDict ProcessId)-sdictProcessId = $(mkStatic 'sdictProcessId_)---- | Serialization dictionary for 'SendPort'-sdictSendPort :: Typeable a -              => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))-sdictSendPort = staticApply $(mkStatic 'sdictSendPort_) ------------------------------------------------------------------------------------- Creating closures                                                          --------------------------------------------------------------------------------------- | Static decoder, given a static serialization dictionary.------ See module documentation of "Control.Distributed.Process.Closure" for an--- example.-staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)-staticDecode dict = $(mkStatic 'decodeDict) `staticApply` dict ---- | Convert a static value into a closure.-staticClosure :: forall a. Typeable a => Static a -> Closure a-staticClosure static = Closure (staticConst `staticApply` static) empty---- | Convert a serializable value into a closure.-toClosure :: forall a. Serializable a -          => Static (SerializableDict a) -> a -> Closure a-toClosure dict x = Closure (staticDecode dict) (encode x) 

@@ -1,18 +1,15 @@ -- | Template Haskell support------ (In a separate file for convenience)-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-} module Control.Distributed.Process.Internal.Closure.TH    ( -- * User-level API     remotable   , mkStatic   , functionSDict   , functionTDict+  , mkClosure   ) where -import Prelude hiding (lookup)-import Data.Accessor ((^=))-import Data.Typeable (typeOf)+import Prelude hiding (succ, any) import Control.Applicative ((<$>)) import Language.Haskell.TH    ( -- Q monad and operations@@ -42,19 +39,27 @@   , funD   , sigD   )-import Control.Distributed.Process.Internal.Types+import Data.Binary (encode)+import Data.Generics (everywhereM, mkM, gmapM)+import Data.Rank1Dynamic (toDynamic)+import Data.Rank1Typeable+  ( Zero+  , Succ+  , TypVar+  )+import Control.Distributed.Static    ( RemoteTable-  , Static(Static)-  , StaticLabel(StaticLabel)-  , remoteTableLabel-  , SerializableDict(SerializableDict)-  , Process+  , registerStatic+  , Static+  , staticLabel+  , Closure(Closure)+  , staticCompose   )-import Control.Distributed.Process.Internal.Dynamic -  ( Dynamic(..)-  , unsafeCoerce#-  , toDyn+import Control.Distributed.Process.Internal.Types (Process)+import Control.Distributed.Process.Serializable +  ( SerializableDict(SerializableDict)   )+import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)  -------------------------------------------------------------------------------- -- User-level API                                                             --@@ -90,6 +95,12 @@ functionTDict :: Name -> Q Exp functionTDict = varE . tdictName +mkClosure :: Name -> Q Exp+mkClosure n = +  [|   Closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n)) +     . encode+  |]+ -------------------------------------------------------------------------------- -- Internal (Template Haskell)                                                -- --------------------------------------------------------------------------------@@ -140,10 +151,8 @@     makeStatic origName typVars typ = do        static <- generateStatic origName typVars typ       let dyn = case typVars of -                  [] -> [| toDyn $(varE origName) |]-                  _  -> [| Dynamic (error "Polymorphic value") -                                   (unsafeCoerce# $(varE origName)) -                         |]+                  [] -> [| toDynamic $(varE origName) |]+                  _  -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]       return ( static              , [ [| registerStatic $(stringE (show origName)) $dyn |] ]              )@@ -151,15 +160,38 @@     makeDict :: Name -> Type -> Q ([Dec], [Q Exp])      makeDict dictName typ = do       sdict <- generateDict dictName typ -      let dyn = [| toDyn (SerializableDict :: SerializableDict $(return typ)) |]+      let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]       return ( sdict              , [ [| registerStatic $(stringE (show dictName)) $dyn |] ]               )-       -registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable-registerStatic label dyn = remoteTableLabel label ^= Just dyn +-- | Turn a polymorphic type into a monomorphic type using ANY and co+monomorphize :: [TyVarBndr] -> Type -> Q Type+monomorphize tvs = +    let subst = zip (map tyVarBndrName tvs) anys +    in everywhereM (mkM (applySubst subst))+  where+    anys :: [Q Type]+    anys = map typVar (iterate succ zero) +    typVar :: Q Type -> Q Type+    typVar t = [t| TypVar $t |]++    zero :: Q Type+    zero = [t| Zero |]+    +    succ :: Q Type -> Q Type+    succ t = [t| Succ $t |]+ +    applySubst :: [(Name, Q Type)] -> Type -> Q Type+    applySubst s (VarT n) = +      case lookup n s of  +        Nothing -> return (VarT n)+        Just t  -> t+    applySubst s t = gmapM (mkM (applySubst s)) t++    + -- | Generate a static value  generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec] generateStatic n xs typ = do@@ -170,27 +202,18 @@                   (map typeable xs)                    (staticTyp `AppT` typ)           )-      , sfnD (staticName n) -          [| Static $ StaticLabel -               $(stringE (show n)) -               (typeOf (undefined :: $(return typ)))-           |]+      , sfnD (staticName n) [| staticLabel $(stringE (show n)) |]       ]   where     typeable :: TyVarBndr -> Pred-    typeable (PlainTV v)    = ClassP (mkName "Typeable") [VarT v] -    typeable (KindedTV v _) = ClassP (mkName "Typeable") [VarT v]+    typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]   -- | Generate a serialization dictionary with name 'n' for type 'typ'  generateDict :: Name -> Type -> Q [Dec] generateDict n typ = do     sequence       [ sigD n $ [t| Static (SerializableDict $(return typ)) |]-      , sfnD n -         [| Static $ StaticLabel -              $(stringE (show n)) -              (typeOf (undefined :: SerializableDict $(return typ)))-          |]+      , sfnD n [| staticLabel $(stringE (show n))  |]       ]  staticName :: Name -> Name@@ -227,3 +250,8 @@ -- | Variation on 'funD' which takes a single expression to define the function sfnD :: Name -> Q Exp -> Q Dec sfnD n e = funD n [clause [] (normalB e) []] +    +-- | The name of a type variable binding occurrence    +tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV n)    = n+tyVarBndrName (KindedTV n _) = n

@@ -1,112 +0,0 @@--- | Reimplementation of Dynamic that supports dynBind------ We don't have access to the internal representation of Dynamic, otherwise--- we would not have to redefine it completely. Note that we use this only--- internally, so the incompatibility with "our" Dynamic from the standard --- Dynamic is not important.-{-# LANGUAGE MagicHash #-}-module Control.Distributed.Process.Internal.Dynamic -  ( Dynamic(..)-  , toDyn-  , fromDyn-  , fromDynamic-  , dynTypeRep-  , dynApply-  , dynApp-  , dynBind-  , dynBind'-  , dynKleisli-  , GHC.unsafeCoerce#-  ) where--import Data.Typeable -  ( Typeable-  , TypeRep-  , typeOf-  , funResultTy-  , TyCon-  , splitTyConApp-  , mkFunTy-  )-import Data.Typeable.Internal (funTc)-import qualified GHC.Prim as GHC (Any, unsafeCoerce#)-import Data.Maybe (fromMaybe)--data Dynamic = Dynamic TypeRep GHC.Any-  deriving Typeable--toDyn :: Typeable a => a -> Dynamic-toDyn x = Dynamic (typeOf x) (GHC.unsafeCoerce# x)--fromDyn :: Typeable a => Dynamic -> a -> a-fromDyn (Dynamic rep val) a =-  if rep == typeOf a -    then GHC.unsafeCoerce# val-    else a--fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a-fromDynamic (Dynamic rep val) = -  if rep == typeOf (undefined :: a)-    then Just (GHC.unsafeCoerce# val)-    else Nothing--dynTypeRep :: Dynamic -> TypeRep-dynTypeRep (Dynamic t _) = t--instance Show Dynamic where-  show = show . dynTypeRep--dynApply :: Dynamic -> Dynamic -> Maybe Dynamic-dynApply (Dynamic t1 f) (Dynamic t2 x) =-  case funResultTy t1 t2 of-    Just t3 -> Just (Dynamic t3 (GHC.unsafeCoerce# f x))-    Nothing -> Nothing--dynApp :: Dynamic -> Dynamic -> Dynamic-dynApp f x = fromMaybe (error typeError) (dynApply f x)-  where-    typeError  = "Type error in dynamic application.\n" -              ++ "Can't apply function " ++ show f-              ++ " to argument " ++ show x--dynBind :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Maybe Dynamic-dynBind m bind (Dynamic t1 x) (Dynamic t2 f) = -  case splitTyConApp t1 of-    (m', [a]) | m' == m ->-      case funResultTy t2 a of-        Just mb -> Just (Dynamic mb (GHC.unsafeCoerce# bind x f))-        _  -> Nothing-    _ -> Nothing --dynBind' :: TyCon -> (forall a b. m a -> (a -> m b) -> m b) -> Dynamic -> Dynamic -> Dynamic-dynBind' m bind x f = fromMaybe (error typeError) (dynBind m bind x f)-  where-    typeError = "Type error in dynamic bind.\nCan't bind " ++ show x ++ " to " ++ show f------- | Dynamically typed Kleisli composition-dynKleisli :: TyCon  -           -> (forall a b c. (a -> m b) -> (b -> m c) -> a -> m c) -           -> Dynamic -           -> Dynamic -           -> Maybe Dynamic-dynKleisli m comp (Dynamic tf f) (Dynamic tg g) = -  case splitTyConApp tf of-    (arr1, [a, mb]) | arr1 == funTc -> -      case splitTyConApp tg of-        (arr2, [b, mc]) | arr2 == funTc ->-          case splitTyConApp mb of-            (m', [b']) | m' == m && b' == b ->-              case splitTyConApp mc of-                (m'', [_c]) | m'' == m ->-                  Just (Dynamic (mkFunTy a mc) (GHC.unsafeCoerce# comp f g))  -                _ -> -                  Nothing-            _ ->-              Nothing-        _ ->-          Nothing-    _ ->-      Nothing

@@ -66,14 +66,13 @@ #endif  import Data.Binary (decode)-import Data.Typeable (Typeable, typeOf) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) import System.Locale (defaultTimeLocale) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Applicative ((<$>))-import Control.Exception (Exception, throw, throwIO, SomeException)+import Control.Exception (Exception, throwIO, SomeException) import qualified Control.Exception as Ex (catch, mask) import Control.Concurrent.MVar (modifyMVar) import Control.Concurrent.Chan (writeChan)@@ -90,13 +89,15 @@ import Control.Distributed.Process.Internal.CQueue (dequeue, BlockSpec(..)) import Control.Distributed.Process.Serializable (Serializable, fingerprint) import Data.Accessor ((^.), (^:), (^=))+import Control.Distributed.Static (Closure)+import Data.Rank1Typeable (Typeable)+import qualified Control.Distributed.Static as Static (unclosure) import Control.Distributed.Process.Internal.Types    ( NodeId(..)   , ProcessId(..)   , LocalNode(..)   , LocalProcess(..)   , Process(..)-  , Closure(..)   , Message(..)   , MonitorRef(..)   , SpawnRef(..)@@ -104,7 +105,6 @@   , ProcessSignal(..)   , monitorCounter    , spawnCounter-  , Closure(..)   , SendPort(..)   , ReceivePort(..)   , channelCounter@@ -121,8 +121,6 @@   , runLocalProcess   ) import Control.Distributed.Process.Internal.Node (sendMessage, sendBinary) -import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)-import Control.Distributed.Process.Internal.Dynamic (fromDyn, dynTypeRep)  -------------------------------------------------------------------------------- -- Basic messaging                                                            --@@ -502,15 +500,11 @@  -- | Deserialize a closure unClosure :: forall a. Typeable a => Closure a -> Process a-unClosure (Closure static env) = do-    rtable <- remoteTable . processNode <$> ask -    case resolveClosure rtable static env of-      Nothing  -> error $ "Unregistered closure " ++ show static -      Just dyn -> return $ fromDyn dyn (throw (typeError dyn))-  where-    typeError dyn = userError $ "lookupStatic type error: " -                 ++ "cannot match " ++ show (dynTypeRep dyn) -                 ++ " against " ++ show (typeOf (undefined :: a))+unClosure closure = do+  rtable <- remoteTable . processNode <$> ask +  case Static.unclosure rtable closure of+    Left err -> fail $ "Could not resolve closure: " ++ err +    Right x  -> return x  -------------------------------------------------------------------------------- -- Auxiliary functions                                                        --

@@ -1,33 +0,0 @@--- | 'Binary' instances for 'TypeRep', and 'TypeRep' equality (bug workaround)-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Control.Distributed.Process.Internal.TypeRep (compareTypeRep) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary(get, put))-import Data.Typeable.Internal (TypeRep(..), TyCon(..))-import GHC.Fingerprint.Type (Fingerprint(..))--instance Binary Fingerprint where-  put (Fingerprint hi lo) = put hi >> put lo-  get = Fingerprint <$> get <*> get --instance Binary TypeRep where-  put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts-  get = TypeRep <$> get <*> get <*> get--instance Binary TyCon where-  put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name-  get = TyCon <$> get <*> get <*> get <*> get---- | Compare two type representations------ For base >= 4.6 this compares fingerprints, but older versions of base--- have a bug in the fingerprint construction --- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)-compareTypeRep :: TypeRep -> TypeRep -> Bool-#if ! MIN_VERSION_base(4,6,0)-compareTypeRep (TypeRep _ con ts) (TypeRep _ con' ts') -  = con == con' && all (uncurry compareTypeRep) (zip ts ts')-#else-compareTypeRep = (==)-#endif

@@ -3,7 +3,6 @@ -- We collect all types used internally in a single module because  -- many of these data types are mutually recursive and cannot be split across -- modules.-{-# LANGUAGE MagicHash #-} module Control.Distributed.Process.Internal.Types   ( -- * Node and process identifiers      NodeId(..)@@ -24,16 +23,6 @@   , TypedChannel(..)   , SendPort(..)   , ReceivePort(..)-    -- * Closures-  , StaticLabel(..)-  , Static(..) -  , staticApply-  , staticDuplicate-  , staticTypeOf-  , typeOfStaticLabel-  , Closure(..)-  , RemoteTable(..)-  , SerializableDict(..)     -- * Messages    , Message(..)   , createMessage@@ -70,15 +59,12 @@   , channelCounter   , typedChannels   , typedChannelWithId-  , remoteTableLabels-  , remoteTableLabel   ) where  import Data.Map (Map) import Data.Int (Int32)-import Data.Maybe (fromJust)-import Data.Typeable (Typeable, TypeRep, typeOf, funResultTy)-import Data.Binary (Binary(put, get), putWord8, getWord8, encode, Put, Get)+import Data.Typeable (Typeable)+import Data.Binary (Binary(put, get), putWord8, getWord8, encode) import qualified Data.ByteString as BSS (ByteString, concat) import qualified Data.ByteString.Lazy as BSL    ( ByteString@@ -108,9 +94,11 @@   , showFingerprint   ) import Control.Distributed.Process.Internal.CQueue (CQueue)-import Control.Distributed.Process.Internal.Dynamic (Dynamic) -import Control.Distributed.Process.Internal.TypeRep (compareTypeRep) -- and Binary instances+import Control.Distributed.Static (RemoteTable, Closure) +-- import Control.Distributed.Process.Internal.Dynamic (Dynamic) +-- import Control.Distributed.Process.Internal.TypeRep (compareTypeRep) -- and Binary instances+ -------------------------------------------------------------------------------- -- Node and process identifiers                                               -- --------------------------------------------------------------------------------@@ -256,62 +244,6 @@   deriving Typeable  ----------------------------------------------------------------------------------- Closures                                                                   -------------------------------------------------------------------------------------data StaticLabel =-    StaticLabel String TypeRep-  | StaticApply StaticLabel StaticLabel-  | StaticDuplicate StaticLabel TypeRep-  deriving (Typeable, Show)---- | A static value is top-level bound or the application of two static values.------ You construct static values using 'Control.Distributed.Process.Closure.mkStatic'--- or 'staticApply'. 'Static' has a serializable instance for all /Typeable/ 'a':------ > instance Typeable a => Serializable (Static a) ------ The 'Typeable' constraint (not present in the original Cloud Haskell paper)--- makes it possible to do a type check during deserialization.-newtype Static a = Static StaticLabel -  deriving (Typeable, Show)---- | Apply two static values-staticApply :: Static (a -> b) -> Static a -> Static b-staticApply (Static f) (Static x) = Static (StaticApply f x)---- | Co-monadic 'duplicate' for static values-staticDuplicate :: forall a. Typeable a => Static a -> Static (Static a)-staticDuplicate (Static x) = -  Static (StaticDuplicate x (typeOf (undefined :: Static a)))--staticTypeOf :: forall a. Typeable a => a -> Static a -staticTypeOf _ = Static (StaticLabel "undefined" (typeOf (undefined :: a)))--typeOfStaticLabel :: StaticLabel -> TypeRep-typeOfStaticLabel (StaticLabel _ typ) -  = typ -typeOfStaticLabel (StaticApply f x) -  = fromJust $ funResultTy (typeOfStaticLabel f) (typeOfStaticLabel x)-typeOfStaticLabel (StaticDuplicate _ typ)-  = typ---- | A closure is a static value and an encoded environment-data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString-  deriving (Typeable, Show)---- | Runtime dictionary for 'unstatic' lookups -data RemoteTable = RemoteTable {-    _remoteTableLabels :: Map String Dynamic -  }---- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")-data SerializableDict a where-    SerializableDict :: Serializable a => SerializableDict a-  deriving (Typeable)---------------------------------------------------------------------------------- -- Messages                                                                   -- -------------------------------------------------------------------------------- @@ -526,10 +458,6 @@       4 -> return DiedUnknownId        _ -> fail "DiedReason.get: invalid" -instance Typeable a => Binary (Closure a) where-  put (Closure static env) = put static >> put env-  get = Closure <$> get <*> get - instance Binary DidSpawn where   put (DidSpawn ref pid) = put ref >> put pid   get = DidSpawn <$> get <*> get@@ -550,29 +478,6 @@       2 -> SendPortIdentifier <$> get        _ -> fail "Identifier.get: invalid" --- We don't want StaticLabel to be its own Binary instance-putStaticLabel :: StaticLabel -> Put-putStaticLabel (StaticLabel string typ)    = putWord8 0 >> put string >> put typ -putStaticLabel (StaticApply label1 label2) = putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2-putStaticLabel (StaticDuplicate label typ) = putWord8 2 >> putStaticLabel label >> put typ--getStaticLabel :: Get StaticLabel-getStaticLabel = do-  header <- getWord8-  case header of-    0 -> StaticLabel <$> get <*> get-    1 -> StaticApply <$> getStaticLabel <*> getStaticLabel-    2 -> StaticDuplicate <$> getStaticLabel <*> get-    _ -> fail "StaticLabel.get: invalid" --instance Typeable a => Binary (Static a) where-  put (Static label) = putStaticLabel label-  get = do-    label <- getStaticLabel-    if typeOfStaticLabel label `compareTypeRep` typeOf (undefined :: a)-      then return $ Static label -      else fail "Static.get: type error"- instance Binary WhereIsReply where   put (WhereIsReply label mPid) = put label >> put mPid   get = WhereIsReply <$> get <*> get@@ -613,9 +518,3 @@  typedChannelWithId :: LocalSendPortId -> Accessor LocalProcessState (Maybe TypedChannel) typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid--remoteTableLabels :: Accessor RemoteTable (Map String Dynamic)-remoteTableLabels = accessor _remoteTableLabels (\ls tbl -> tbl { _remoteTableLabels = ls })--remoteTableLabel :: String -> Accessor RemoteTable (Maybe Dynamic)-remoteTableLabel label = remoteTableLabels >>> DAC.mapMaybe label

@@ -9,7 +9,6 @@   , localNodeId   ) where - #if ! MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif@@ -31,7 +30,7 @@ import Data.Set (Set) import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList) import Data.Foldable (forM_)-import Data.Maybe (isJust, fromMaybe)+import Data.Maybe (isJust) import Data.Typeable (Typeable) import Control.Category ((>>>)) import Control.Applicative ((<$>))@@ -69,9 +68,10 @@ import Data.Accessor (Accessor, accessor, (^.), (^=), (^:)) import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe) import System.Random (randomIO)+import Control.Distributed.Static (RemoteTable, Closure)+import qualified Control.Distributed.Static as Static (unclosure) import Control.Distributed.Process.Internal.Types -  ( RemoteTable-  , NodeId(..)+  ( NodeId(..)   , LocalProcessId(..)   , ProcessId(..)   , LocalNode(..)@@ -98,7 +98,6 @@   , DidUnlinkPort(..)   , SpawnRef   , DidSpawn(..)-  , Closure(..)   , Message   , TypedChannel(..)   , Identifier(..)@@ -107,31 +106,26 @@   , typedChannelWithId   , WhereIsReply(..)   , messageToPayload-  , RemoteTable(..)   , payloadToMessage   , createMessage   , runLocalProcess   ) import Control.Distributed.Process.Serializable (Serializable)-import Control.Distributed.Process.Internal.Dynamic (fromDynamic)-import Control.Distributed.Process.Internal.Closure.Resolution (resolveClosure)  import Control.Distributed.Process.Internal.Node    ( sendBinary   , sendMessage   , sendPayload   ) import Control.Distributed.Process.Internal.Primitives (expect, register, finally)-import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)-import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)+import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)+import qualified Control.Distributed.Static as Static (initRemoteTable)  -------------------------------------------------------------------------------- -- Initialization                                                             -- --------------------------------------------------------------------------------  initRemoteTable :: RemoteTable-initRemoteTable = Static.__remoteTable-                . CP.__remoteTable -                $ RemoteTable Map.empty+initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable   -- | Initialize a new local node.  newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode@@ -509,7 +503,9 @@   mProc <- unClosure cProc   -- If the closure does not exist, we spawn a process that throws an exception   -- This allows the remote node to find out what's happening-  let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc+  let proc = case mProc of+               Left err -> fail $ "Error: Could not resolve closure: " ++ err+               Right p  -> p   node <- ask   pid' <- liftIO $ forkProcess node proc   liftIO $ sendMessage node@@ -603,10 +599,10 @@ isLocal nid ident = nodeOf ident == localNodeId nid  -- | Lookup a local closure -unClosure :: Typeable a => Closure a -> NC (Maybe a)-unClosure (Closure static env) = do+unClosure :: Typeable a => Closure a -> NC (Either String a)+unClosure closure = do   rtable <- remoteTable <$> ask-  return (resolveClosure rtable static env >>= fromDynamic)+  return (Static.unclosure rtable closure)  -- | Check if an identifier refers to a valid local object isValidLocalIdentifier :: Identifier -> NC Bool

@@ -6,6 +6,7 @@   , sizeOfFingerprint   , Fingerprint   , showFingerprint+  , SerializableDict(SerializableDict)   ) where  import Data.Binary (Binary)@@ -22,6 +23,11 @@                                                  ) import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf) import Foreign.ForeignPtr (withForeignPtr)++-- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure")+data SerializableDict a where+    SerializableDict :: Serializable a => SerializableDict a+  deriving (Typeable)  -- | Objects that can be sent across the network class (Binary a, Typeable a) => Serializable a

@@ -1,7 +1,7 @@ module Main where  import Data.ByteString.Lazy (empty)-import Data.Typeable (Typeable, typeOf)+import Data.Typeable (Typeable) import Control.Monad (join, replicateM, forever) import Control.Exception (IOException, throw) import Control.Concurrent (forkIO, threadDelay)@@ -12,9 +12,12 @@ import Control.Distributed.Process import Control.Distributed.Process.Closure import Control.Distributed.Process.Node-import Control.Distributed.Process.Internal.Types (Static(Static), StaticLabel(StaticLabel))+import Control.Distributed.Static (staticLabel, staticClosure) import TestAuxiliary +quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)+quintuple a b c d e = (a, b, c, d, e)+ sdictInt :: SerializableDict Int sdictInt = SerializableDict @@ -41,6 +44,7 @@   where     sieve :: [Integer] -> [Integer]     sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]+    sieve [] = error "Uh oh -- we've run out of primes"  -- | First argument indicates empty closure environment typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()@@ -56,8 +60,14 @@           , 'wait           , 'typedPingServer           , 'isPrime+          , 'quintuple           ] +-- Just try creating a static polymorphic value+staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)+                => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))+staticQuintuple = $(mkStatic 'quintuple)+ factorialClosure :: Int -> Closure (Process Int) factorialClosure = $(mkClosure 'factorial)  @@ -71,13 +81,13 @@ sendPidClosure = $(mkClosure 'sendPid)   sendFac :: Int -> ProcessId -> Closure (Process ())-sendFac n pid = factorialClosure n `cpBind` cpSend $(mkStatic 'sdictInt) pid +sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid   factorialOf :: Closure (Int -> Process Int) factorialOf = staticClosure $(mkStatic 'factorial)  factorial' :: Int -> Closure (Process Int)-factorial' n = cpReturn $(mkStatic 'sdictInt) n `cpBind` factorialOf +factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf   waitClosure :: Int -> Closure (Process ()) waitClosure = $(mkClosure 'wait) @@ -85,18 +95,22 @@ testUnclosure :: Transport -> RemoteTable -> IO () testUnclosure transport rtable = do   node <- newLocalNode transport rtable-  runProcess node $ do+  done <- newEmptyMVar+  forkProcess node $ do     120 <- join . unClosure $ factorialClosure 5-    return ()+    liftIO $ putMVar done ()+  takeMVar done  testBind :: Transport -> RemoteTable -> IO () testBind transport rtable = do   node <- newLocalNode transport rtable+  done <- newEmptyMVar   runProcess node $ do     us <- getSelfPid     join . unClosure $ sendFac 6 us      (720 :: Int) <- expect -    return ()+    liftIO $ putMVar done ()+  takeMVar done  testSendPureClosure :: Transport -> RemoteTable -> IO () testSendPureClosure transport rtable = do@@ -227,12 +241,14 @@ testSeq :: Transport -> RemoteTable -> IO () testSeq transport rtable = do   node <- newLocalNode transport rtable+  done <- newEmptyMVar   runProcess node $ do     us <- getSelfPid-    join . unClosure $ sendFac 5 us `cpSeq` sendFac 6 us+    join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us     120 :: Int <- expect     720 :: Int <- expect-    return ()+    liftIO $ putMVar done ()+  takeMVar done  -- Test 'spawnSupervised' --@@ -272,29 +288,34 @@ testSpawnInvalid :: Transport -> RemoteTable -> IO () testSpawnInvalid transport rtable = do   node <- newLocalNode transport rtable-  runProcess node $ do-    (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (StaticLabel "ThisDoesNotExist" (typeOf ()))) empty)+  done <- newEmptyMVar+  forkProcess node $ do+    (pid, ref) <- spawnMonitor (localNodeId node) (Closure (staticLabel "ThisDoesNotExist") empty)     ProcessMonitorNotification ref' pid' _reason <- expect      -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure     True <- return $ ref' == ref && pid == pid'  -    return ()+    liftIO $ putMVar done ()+  takeMVar done  testClosureExpect :: Transport -> RemoteTable -> IO () testClosureExpect transport rtable = do   node <- newLocalNode transport rtable+  done <- newEmptyMVar   runProcess node $ do     nodeId <- getSelfNode     us     <- getSelfPid-    them   <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `cpBind` cpSend $(mkStatic 'sdictInt) us+    them   <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us     send them (1234 :: Int)     (1234 :: Int) <- expect-    return ()+    liftIO $ putMVar done ()+  takeMVar done  testSpawnChannel :: Transport -> RemoteTable -> IO () testSpawnChannel transport rtable = do+  done <- newEmptyMVar   [node1, node2] <- replicateM 2 $ newLocalNode transport rtable -  runProcess node1 $ do+  forkProcess node1 $ do     pingServer <- spawnChannel                      (sdictSendPort sdictUnit)                     (localNodeId node2)  @@ -302,13 +323,18 @@     (sendReply, receiveReply) <- newChan     sendChan pingServer sendReply     receiveChan receiveReply+    liftIO $ putMVar done () +  takeMVar done+ testTDict :: Transport -> RemoteTable -> IO () testTDict transport rtable = do+  done <- newEmptyMVar   [node1, node2] <- replicateM 2 $ newLocalNode transport rtable-  runProcess node1 $ do+  forkProcess node1 $ do     True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))-    return ()+    liftIO $ putMVar done ()+  takeMVar done  main :: IO () main = do