diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2015-06-15 Facundo Domínguez 0.5.5 + +* Fix dependencies. +* Add compatibility with GHC-7.10. +* Fix various race conditions (DP-99, DP-103). + 2014-12-09 Tim Watson 0.5.2 * Fix docstring for `register` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright Well-Typed LLP, 2011-2012 +Copyright Tweag I/O Limited, 2015 All rights reserved. diff --git a/distributed-process.cabal b/distributed-process.cabal --- a/distributed-process.cabal +++ b/distributed-process.cabal @@ -1,12 +1,12 @@ Name: distributed-process -Version: 0.5.4 +Version: 0.5.5 Cabal-Version: >=1.8 Build-Type: Simple License: BSD3 License-File: LICENSE -Copyright: Well-Typed LLP +Copyright: Well-Typed LLP, Tweag I/O Limited Author: Duncan Coutts, Nicolas Wu, Edsko de Vries -Maintainer: watson.timothy@gmail.com, edsko@well-typed.com, duncan@well-typed.com +Maintainer: Facundo Domínguez Stability: experimental Homepage: http://haskell-distributed.github.com/ Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues @@ -21,7 +21,7 @@ You will probably also want to install a Cloud Haskell backend such as distributed-process-simplelocalnet. -Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2 GHC==7.6.2 +Tested-With: GHC==7.4.2 GHC==7.6.3 GHC==7.8.4 GHC==7.10.1 Category: Control extra-source-files: ChangeLog @@ -38,6 +38,13 @@ description: Compiling with profiling enabled default: False + +flag old-locale + description: If false then depend on time >= 1.5. + . + If true then depend on time < 1.5 together with old-locale. + default: False + Library Build-Depends: base >= 4.4 && < 5, binary >= 0.6.3 && < 0.8, @@ -45,15 +52,13 @@ network-transport >= 0.4.1.0 && < 0.5, stm >= 2.4 && < 2.5, transformers >= 0.2 && < 0.5, - mtl >= 2.0 && < 2.3, + mtl >= 2.0 && < 2.4, data-accessor >= 0.2 && < 0.3, bytestring >= 0.9 && < 0.11, - old-locale >= 1.0 && < 1.1, - time >= 1.2 && < 1.5, random >= 1.0 && < 1.2, - ghc-prim >= 0.2 && < 0.4, + ghc-prim >= 0.2 && < 0.5, distributed-static >= 0.2 && < 0.4, - rank1dynamic >= 0.1 && < 0.3, + rank1dynamic >= 0.1 && < 0.4, syb >= 0.3 && < 0.5 Exposed-modules: Control.Distributed.Process, Control.Distributed.Process.Closure, @@ -89,12 +94,16 @@ deepseq == 1.3.0.0 else Build-Depends: containers >= 0.4 && < 0.6, - deepseq >= 1.3.0.1 && < 1.4 + deepseq >= 1.3.0.1 && < 1.6 + if flag(old-locale) + Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1 + else + Build-Depends: time >= 1.5 if flag(th) if impl(ghc <= 7.4.2) Build-Depends: template-haskell >= 2.7 && < 2.8 else - Build-Depends: template-haskell >= 2.6 && < 2.10 + Build-Depends: template-haskell >= 2.6 && < 2.11 Exposed-modules: Control.Distributed.Process.Internal.Closure.TH CPP-Options: -DTemplateHaskellSupport diff --git a/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs b/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs --- a/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs +++ b/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs @@ -28,7 +28,7 @@ , cpExpect , cpNewChan -- * Support for some CH operations - , cpDelay + , cpDelayed , cpEnableTraceRemote ) where @@ -295,19 +295,20 @@ -- | @delay them p@ is a process that waits for a signal (a message of type @()@) -- from 'them' (origin is not verified) before proceeding as @p@. In order to -- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a --- monitor message instead it simply terminates. +-- monitor message instead, it proceeds as @p@ too. delay :: ProcessId -> Process () -> Process () delay them p = do ref <- monitor them let sameRef (ProcessMonitorNotification ref' _ _) = ref == ref' receiveWait [ - match $ \() -> unmonitor ref >> p + match $ \() -> unmonitor ref , matchIf sameRef $ \_ -> return () ] + p -- | 'CP' version of 'delay' -cpDelay :: ProcessId -> Closure (Process ()) -> Closure (Process ()) -cpDelay = closureApply . cpDelay' +cpDelayed :: ProcessId -> Closure (Process ()) -> Closure (Process ()) +cpDelayed = closureApply . cpDelay' where cpDelay' :: ProcessId -> Closure (Process () -> Process ()) cpDelay' pid = closure decoder (encode pid) diff --git a/src/Control/Distributed/Process/Internal/Closure/TH.hs b/src/Control/Distributed/Process/Internal/Closure/TH.hs --- a/src/Control/Distributed/Process/Internal/Closure/TH.hs +++ b/src/Control/Distributed/Process/Internal/Closure/TH.hs @@ -1,5 +1,5 @@ -- | Template Haskell support -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, CPP #-} module Control.Distributed.Process.Internal.Closure.TH ( -- * User-level API remotable @@ -29,7 +29,11 @@ , Type(AppT, ForallT, VarT, ArrowT) , Info(VarI) , TyVarBndr(PlainTV, KindedTV) - , Pred(ClassP) +#if ! MIN_VERSION_template_haskell(2,10,0) + , Pred +#endif + , varT + , classP -- Lifted constructors -- .. Literals , stringL @@ -67,6 +71,10 @@ ) import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode) +#if MIN_VERSION_template_haskell(2,10,0) +type Pred = Type +#endif + -------------------------------------------------------------------------------- -- User-level API -- -------------------------------------------------------------------------------- @@ -244,16 +252,16 @@ generateStatic n xs typ = do staticTyp <- [t| Static |] sequence - [ sigD (staticName n) $ + [ sigD (staticName n) $ do + txs <- sequence $ map typeable xs return (ForallT xs - (map typeable xs) - (staticTyp `AppT` typ) - ) + txs + (staticTyp `AppT` typ)) , sfnD (staticName n) [| staticLabel $(showFQN n) |] ] where - typeable :: TyVarBndr -> Pred - typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)] + typeable :: TyVarBndr -> Q Pred + typeable tv = classP (mkName "Typeable") [varT (tyVarBndrName tv)] -- | Generate a serialization dictionary with name 'n' for type 'typ' generateDict :: Name -> Type -> Q [Dec] diff --git a/src/Control/Distributed/Process/Internal/Primitives.hs b/src/Control/Distributed/Process/Internal/Primitives.hs --- a/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/src/Control/Distributed/Process/Internal/Primitives.hs @@ -123,7 +123,11 @@ import Data.Binary (decode) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else import System.Locale (defaultTimeLocale) +#endif import System.Timeout (timeout) import Control.Monad (when) import Control.Monad.Reader (ask) diff --git a/src/Control/Distributed/Process/Internal/Spawn.hs b/src/Control/Distributed/Process/Internal/Spawn.hs --- a/src/Control/Distributed/Process/Internal/Spawn.hs +++ b/src/Control/Distributed/Process/Internal/Spawn.hs @@ -37,7 +37,9 @@ , cpLink , cpSend , cpNewChan - , cpDelay + , cpDelayed + , returnCP + , sdictUnit ) import Control.Distributed.Process.Internal.Primitives ( -- Basic messaging @@ -65,7 +67,7 @@ spawn nid proc = do us <- getSelfPid mRef <- monitorNode nid - sRef <- spawnAsync nid (cpDelay us proc) + sRef <- spawnAsync nid (cpDelayed us proc) receiveWait [ matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do unmonitor mRef @@ -109,12 +111,14 @@ -> Process a call dict nid proc = do us <- getSelfPid - (pid, 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. + (pid, mRef) <- spawnMonitor nid (proc `bindCP` + cpSend dict us `seqCP` + -- Delay so the process does not terminate + -- before the response arrives. + cpDelayed us (returnCP sdictUnit ()) + ) mResult <- receiveWait - [ match (return . Right) + [ match $ \a -> send pid () >> return (Right a) , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) (\(ProcessMonitorNotification _ _ reason) -> return (Left reason)) ] diff --git a/src/Control/Distributed/Process/Internal/Types.hs b/src/Control/Distributed/Process/Internal/Types.hs --- a/src/Control/Distributed/Process/Internal/Types.hs +++ b/src/Control/Distributed/Process/Internal/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} -- | Types used throughout the Cloud Haskell framework -- @@ -136,7 +137,7 @@ newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress } deriving (Eq, Ord, Typeable, Data, Generic) instance Binary NodeId where -instance NFData NodeId +instance NFData NodeId where rnf (NodeId a) = rnf a `seq` () instance Hashable NodeId where instance Show NodeId where show (NodeId addr) = "nid://" ++ show addr @@ -161,7 +162,7 @@ deriving (Eq, Ord, Typeable, Data, Generic) instance Binary ProcessId where -instance NFData ProcessId where +instance NFData ProcessId where rnf (ProcessId n _) = rnf n `seq` () instance Hashable ProcessId where instance Show ProcessId where @@ -176,6 +177,10 @@ deriving (Eq, Ord, Generic) instance Hashable Identifier where +instance NFData Identifier where + rnf (NodeIdentifier n) = rnf n `seq` () + rnf (ProcessIdentifier n) = rnf n `seq` () + rnf n@SendPortIdentifier{} = n `seq` () instance Show Identifier where show (NodeIdentifier nid) = show nid @@ -316,6 +321,9 @@ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid) = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid +instance NFData SendPortId where + rnf (SendPortId p _) = rnf p `seq` () + data TypedChannel = forall a. Serializable a => TypedChannel (Weak (TQueue a)) -- | The send send of a typed channel (serializable) @@ -327,7 +335,7 @@ instance (Serializable a) => Binary (SendPort a) where instance (Hashable a) => Hashable (SendPort a) where -instance (NFData a) => NFData (SendPort a) where +instance (NFData a) => NFData (SendPort a) where rnf (SendPort x) = x `seq` () -- | The receive end of a typed channel (not serializable) -- @@ -365,6 +373,14 @@ } deriving (Typeable) +instance NFData Message where +#if MIN_VERSION_bytestring(0,10,0) + rnf (EncodedMessage _ e) = rnf e `seq` () +#else + rnf (EncodedMessage _ e) = BSL.length e `seq` () +#endif + rnf (UnencodedMessage _ a) = a `seq` () -- forced to WHNF only + instance Show Message where show (EncodedMessage fp enc) = show enc ++ " :: " ++ showFingerprint fp [] show (UnencodedMessage _ uenc) = "[unencoded message] :: " ++ (show $ typeOf uenc) @@ -428,8 +444,11 @@ , monitorRefCounter :: !Int32 } deriving (Eq, Ord, Show, Typeable, Generic) -instance Hashable MonitorRef where +instance Hashable MonitorRef +instance NFData MonitorRef where + rnf (MonitorRef i _) = rnf i `seq` () + -- | Message sent by process monitors data ProcessMonitorNotification = ProcessMonitorNotification !MonitorRef !ProcessId !DiedReason @@ -496,6 +515,10 @@ | DiedUnknownId deriving (Show, Eq) +instance NFData DiedReason where + rnf (DiedException s) = rnf s `seq` () + rnf x = x `seq` () + -- | (Asynchronous) reply from unmonitor newtype DidUnmonitor = DidUnmonitor MonitorRef deriving (Typeable, Binary) @@ -673,9 +696,6 @@ instance Binary SendPortId where put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid) get = SendPortId <$> get <*> get - -instance NFData SendPortId where - rnf cid = (sendPortProcessId cid) `seq` (sendPortLocalId cid) `seq` () instance Binary Identifier where put (ProcessIdentifier pid) = putWord8 0 >> put pid diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs --- a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs +++ b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs @@ -88,7 +88,11 @@ , hPutStrLn , hSetBuffering ) +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else import System.Locale (defaultTimeLocale) +#endif import System.Mem.Weak ( Weak ) diff --git a/src/Control/Distributed/Process/Serializable.hs b/src/Control/Distributed/Process/Serializable.hs --- a/src/Control/Distributed/Process/Serializable.hs +++ b/src/Control/Distributed/Process/Serializable.hs @@ -73,7 +73,11 @@ -- | The fingerprint of the typeRep of the argument fingerprint :: Typeable a => a -> Fingerprint +#if MIN_VERSION_base(4,8,0) +fingerprint a = let TypeRep fp _ _ _ = typeOf a in fp +#else fingerprint a = let TypeRep fp _ _ = typeOf a in fp +#endif -- | Show fingerprint (for debugging purposes) showFingerprint :: Fingerprint -> ShowS