mpi-hs 0.3.1.0 → 0.4.0.0

raw patch · 13 files changed

+1792/−1251 lines, 13 filesdep +binarydep +packmandep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: binary, packman

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +42/−0
• lib/Control/Distributed/MPI.chs +18/−88
• lib/Control/Distributed/MPI/Packing.hs +364/−0
• lib/Control/Distributed/MPI/Simple.hs +0/−348
• lib/Control/Distributed/MPI/Store.hs +362/−0
• mpi-hs.cabal +29/−13
• package.yaml +21/−6
• stack.yaml +8/−3
• test/mpi/Main.hs +0/−638
• test/simple/Main.hs +0/−155
• tests/mpi/Main.hs +638/−0
• tests/packing/Main.hs +155/−0
• tests/store/Main.hs +155/−0

@@ -145,3 +145,45 @@ file (for include and library paths; see `extra-include-dirs` and `extra-lib-dirs` there) or the `package.yaml` configuration file (for additional libraries; see `extra-libraries` there).++++## Examples and Tests++### Running the example++To run the example provided in `src/Main.hs`:++```+stack build+mpirun -np 3 stack exec example && echo SUCCESS || echo FAILURE+```++With OpenMPI, and when running on a single node (e.g. on a laptop or a+workstation), these additional `mpirun` options might be useful:++```+mpirun -np 3 --mca btl self,vader --oversubscribe stack exec example && echo SUCCESS || echo FAILURE+```++The options `--mca btl self,vader` enable the shared memory byte+transfer layer (called "vader"), and also disable any network+communication.++The option `--oversubscribe` lets you run as many MPI processes on the+local node as you want, without being limited by the physical number+of cores. This is convenient for testing.++Other MPI implementations should have equivalent (but differently+named) options.++### Running the tests++There are three test cases provided in `tests`:++```+stack build --test --no-run-tests+mpirun -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test/mpi-test && echo SUCCESS || echo FAILURE+mpirun -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test-packing/mpi-test-packing && echo SUCCESS || echo FAILURE+mpirun -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test-store/mpi-test-store && echo SUCCESS || echo FAILURE+```

@@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+ {-# OPTIONS_GHC -Wno-type-defaults #-}  #include <mpi.h>@@ -122,7 +123,6 @@   , datatypeUnsignedLong   , datatypeUnsignedShort   , HasDatatype(..)-  -- , datatypeOf      -- ** Reduction operations   , Op(..)@@ -250,11 +250,13 @@ import Data.Ix import qualified Data.Monoid as Monoid import qualified Data.Semigroup as Semigroup+import qualified Data.Store as Store import Data.Version import Foreign import Foreign.C.String import Foreign.C.Types import GHC.Arr (indexError)+import GHC.Generics hiding (Datatype, from, to) import System.IO.Unsafe (unsafePerformIO)  default (Int)@@ -355,15 +357,17 @@ deriving instance Show Comm  -- | The result of comparing two MPI communicator (see 'commCompare').-{#enum ComparisonResult {} deriving (Eq, Ord, Read, Show)#}+{#enum ComparisonResult {} deriving (Eq, Ord, Read, Show, Generic)#} +instance Store.Store ComparisonResult  + -- | A newtype wrapper describing the size of a message. Use 'toCount' -- and 'fromCount' to convert between 'Count' and other integral -- types. newtype Count = Count CInt-  deriving (Eq, Ord, Enum, Integral, Num, Real, Storable)+  deriving (Eq, Ord, Enum, Generic, Integral, Num, Real, Storable)  instance Read Count where   readsPrec p = map (\(c, s) -> (Count c, s)) . readsPrec p@@ -371,6 +375,8 @@ instance Show Count where   showsPrec p (Count c) = showsPrec p c +instance Store.Store Count+ -- | Convert an integer to a count. toCount :: Integral i => i -> Count toCount i = Count (fromIntegral i)@@ -419,8 +425,7 @@ -- same rank might correspond to different processes in different -- communicators. newtype Rank = Rank CInt-  deriving (Eq, Ord, Enum, Integral, Num, Real, Storable)-+  deriving (Eq, Ord, Enum, Integral, Num, Real, Storable, Generic) instance Read Rank where   readsPrec p = map (\(r, s) -> (Rank r, s)) . readsPrec p @@ -435,6 +440,8 @@     | otherwise   = indexError b i "MPI.Rank"   inRange (Rank rmin, Rank rmax) (Rank r) = rmin <= r && r <= rmax +instance Store.Store Rank+ -- | Convert an enum to a rank. toRank :: Enum e => e -> Rank toRank e = Rank (fromIntegral (fromEnum e))@@ -501,8 +508,10 @@ -- 'fromTag' to convert between 'Count' and other enum types. -- 'unitTag' defines a standard tag that can be used as default. newtype Tag = Tag CInt-  deriving (Eq, Ord, Read, Show, Enum, Num, Storable)+  deriving (Eq, Ord, Read, Show, Generic, Enum, Num, Storable) +instance Store.Store Tag+ -- | Convert an enum to a tag. toTag :: Enum e => e -> Tag toTag e = Tag (fromIntegral (fromEnum e))@@ -532,8 +541,10 @@ -- * 'ThreadMultiple' (@MPI_THREAD_MULTIPLE@): The application is --   multi-threaded, and different threads might call MPI at the same --   time-{#enum ThreadSupport {} deriving (Eq, Ord, Read, Show)#}+{#enum ThreadSupport {} deriving (Eq, Ord, Read, Show, Generic)#} +instance Store.Store ThreadSupport+ -- | When MPI is initialized with this library, then it will remember -- the provided level of thread support. (This might be less than the -- requested level.)@@ -629,87 +640,6 @@ instance HasDatatype CUInt where getDatatype = datatypeUnsigned instance HasDatatype CULong where getDatatype = datatypeUnsignedLong instance HasDatatype CUShort where getDatatype = datatypeUnsignedShort---- instance Coercible Int CChar => HasDatatype Int where---   datatype = datatype @CChar--- instance Coercible Int CShort => HasDatatype Int where---   datatype = datatype @CShort--- instance Coercible Int CInt => HasDatatype Int where---   datatype = datatype @CInt--- instance Coercible Int CLong => HasDatatype Int where---   datatype = datatype @CLong--- instance Coercible Int CLLong => HasDatatype Int where---   datatype = datatype @CLLong---- instance HasDatatype Int where---   datatype = if | coercible @Int @CChar -> datatype @CChar---                 | coercible @Int @CShort -> datatype @CShort---                 | coercible @Int @CInt -> datatype @CInt---                 | coercible @Int @CLong -> datatype @CLong---                 | coercible @Int @CLLong -> datatype @CLLong--- instance HasDatatype Int8 where---   datatype = if | coercible @Int @CChar -> datatype @CChar---                 | coercible @Int @CShort -> datatype @CShort---                 | coercible @Int @CInt -> datatype @CInt---                 | coercible @Int @CLong -> datatype @CLong---                 | coercible @Int @CLLong -> datatype @CLLong--- instance HasDatatype Int16 where---   datatype = if | coercible @Int @CChar -> datatype @CChar---                 | coercible @Int @CShort -> datatype @CShort---                 | coercible @Int @CInt -> datatype @CInt---                 | coercible @Int @CLong -> datatype @CLong---                 | coercible @Int @CLLong -> datatype @CLLong--- instance HasDatatype Int32 where---   datatype = if | coercible @Int @CChar -> datatype @CChar---                 | coercible @Int @CShort -> datatype @CShort---                 | coercible @Int @CInt -> datatype @CInt---                 | coercible @Int @CLong -> datatype @CLong---                 | coercible @Int @CLLong -> datatype @CLLong--- instance HasDatatype Int64 where---   datatype = if | coercible @Int @CChar -> datatype @CChar---                 | coercible @Int @CShort -> datatype @CShort---                 | coercible @Int @CInt -> datatype @CInt---                 | coercible @Int @CLong -> datatype @CLong---                 | coercible @Int @CLLong -> datatype @CLLong--- instance HasDatatype Word where---   datatype = if | coercible @Int @CUChar -> datatype @CUChar---                 | coercible @Int @CUShort -> datatype @CUShort---                 | coercible @Int @CUInt -> datatype @CUInt---                 | coercible @Int @CULong -> datatype @CULong---                 -- | coercible @Int @CULLong -> datatype @CULLong--- instance HasDatatype Word8 where---   datatype = if | coercible @Int @CUChar -> datatype @CUChar---                 | coercible @Int @CUShort -> datatype @CUShort---                 | coercible @Int @CUInt -> datatype @CUInt---                 | coercible @Int @CULong -> datatype @CULong---                 -- | coercible @Int @CULLong -> datatype @CULLong--- instance HasDatatype Word16 where---   datatype = if | coercible @Int @CUChar -> datatype @CUChar---                 | coercible @Int @CUShort -> datatype @CUShort---                 | coercible @Int @CUInt -> datatype @CUInt---                 | coercible @Int @CULong -> datatype @CULong---                 -- | coercible @Int @CULLong -> datatype @CULLong--- instance HasDatatype Word32 where---   datatype = if | coercible @Int @CUChar -> datatype @CUChar---                 | coercible @Int @CUShort -> datatype @CUShort---                 | coercible @Int @CUInt -> datatype @CUInt---                 | coercible @Int @CULong -> datatype @CULong---                 -- | coercible @Int @CULLong -> datatype @CULLong--- instance HasDatatype Word64 where---   datatype = if | coercible @Int @CUChar -> datatype @CUChar---                 | coercible @Int @CUShort -> datatype @CUShort---                 | coercible @Int @CUInt -> datatype @CUInt---                 | coercible @Int @CULong -> datatype @CULong---                 -- | coercible @Int @CULLong -> datatype @CULLong--- instance HasDatatype Float where---   datatype = if | coercible @Float @CFloat -> datatype @CFloat---                 | coercible @Float @CDouble -> datatype @CDouble--- instance HasDatatype Double where---   datatype = if | coercible @Double @CFloat -> datatype @CFloat---                 | coercible @Double @CDouble -> datatype @CDouble---- datatypeOf :: forall a p. HasDatatype a => p a -> Datatype--- datatypeOf _ = datatype @a   

@@ -0,0 +1,364 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}++-- | Module: Control.Distributed.MPI.Packing+-- Description: Simplified MPI bindings with automatic serialization+--              based on GHC.Packing+-- Copyright: (C) 2018 Erik Schnetter+-- License: Apache-2.0+-- Maintainer: Erik Schnetter <schnetter@gmail.com>+-- Stability: experimental+-- Portability: Requires an externally installed MPI library++module Control.Distributed.MPI.Packing+  ( -- * Types, and associated functions and constants+    MPIException(..)++    -- ** Communicators+  , Comm(..)+  , commSelf+  , commWorld++    -- ** Message sizes+  , Count(..)+  , fromCount+  , toCount++    -- ** Process ranks+  , Rank(..)+  , anySource+  , commRank+  , commSize+  , fromRank+  , rootRank+  , toRank++    -- ** Message status+  , Status(..)++    -- ** Message tags+  , Tag(..)+  , anyTag+  , fromTag+  , toTag+  , unitTag++  , Request++    -- * Functions++    -- ** Initialization and shutdown+  , abort+  , mainMPI++    -- ** Point-to-point (blocking)+  , recv+  , recv_+  , send+  , sendrecv+  , sendrecv_++    -- ** Point-to-point (non-blocking)+  , irecv+  , isend+  , test+  , test_+  , wait+  , wait_++    -- ** Collective (blocking)+  , barrier+  , bcastRecv+  , bcastSend++    -- ** Collective (non-blocking)+  , ibarrier+  ) where++import Prelude hiding (init)++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Binary as Binary+import Data.Typeable+import Foreign+import Foreign.C.Types+import qualified GHC.Packing as Packing++import qualified Control.Distributed.MPI as MPI+import Control.Distributed.MPI+  ( Comm(..)+  , commSelf+  , commWorld+  , Count(..)+  , fromCount+  , toCount+  , Rank(..)+  , anySource+  , commRank+  , commSize+  , fromRank+  , rootRank+  , toRank+  , Tag(..)+  , anyTag+  , fromTag+  , toTag+  , unitTag+  , abort+  , barrier+  )++++-- Serialization, based on GHC.Packing+type CanSerialize a = Typeable a+serialize :: CanSerialize a => a -> IO B.ByteString+serialize = fmap (BL.toStrict . Binary.encode) . Packing.trySerialize+deserialize :: CanSerialize a => B.ByteString -> IO a+deserialize = Packing.deserialize . Binary.decode . BL.fromStrict++++-- | Run the supplied Maybe computation repeatedly while it returns+-- Nothing. If it returns a value, then returns that value.+whileNothing :: Monad m => m (Maybe a) -> m () -> m a+whileNothing cond loop = go+  where go = do mx <- cond+                case mx of+                  Nothing -> do loop+                                go+                  Just x -> return x++++-- | Exception type indicating an error in a call to MPI+newtype MPIException = MPIException String+  deriving (Eq, Ord, Read, Show, Typeable)+instance Exception MPIException++mpiAssert :: Bool -> String -> IO ()+mpiAssert cond msg =+  do when (not cond) $ throw (MPIException msg)+     return ()++++data DidInit = DidInit | DidNotInit++initMPI :: IO DidInit+initMPI =+  do isInit <- MPI.initialized+     if isInit+       then return DidNotInit+       else do ts <- MPI.initThread MPI.ThreadMultiple+               mpiAssert (ts >= MPI.ThreadMultiple)+                 ("MPI.init: Insufficient thread support: requiring " +++                  show MPI.ThreadMultiple +++                  ", but MPI library provided only " ++ show ts)+               return DidInit++finalizeMPI :: DidInit -> IO ()+finalizeMPI DidInit =+  do isFinalized <- MPI.finalized+     if isFinalized+       then return ()+       else do MPI.finalize+finalizeMPI DidNotInit = return ()++-- | Convenience function to initialize and finalize MPI. This+-- initializes MPI with 'ThreadMultiple' thread support.+mainMPI :: IO () -- ^ action to run with MPI, typically the whole program+        -> IO ()+mainMPI action = bracket initMPI finalizeMPI (\_ -> action)++++-- | A communication request, usually created by a non-blocking+-- communication function.+newtype Request a = Request (MVar (Status, a))++-- | The status of a finished communication, indicating rank and tag+-- of the other communication end point.+data Status = Status { msgRank :: !Rank+                     , msgTag :: !Tag+                     }+  deriving (Eq, Ord, Read, Show)++++-- | Receive an object.+recv :: CanSerialize a+     => Rank                    -- ^ Source rank+     -> Tag                     -- ^ Source tag+     -> Comm                    -- ^ Communicator+     -> IO (Status, a)          -- ^ Message status and received object+recv recvrank recvtag comm =+  do status <- whileNothing (MPI.iprobe recvrank recvtag comm) yield+     source <- MPI.getSource status+     tag <- MPI.getTag status+     count <- MPI.getCount status MPI.datatypeByte+     let len = MPI.fromCount count+     ptr <- mallocBytes len+     buffer <- B.unsafePackMallocCStringLen (ptr, len)+     req <- MPI.irecv buffer source tag comm+     whileM_ (not <$> MPI.test_ req) yield+     recvobj <- deserialize buffer+     return (Status source tag, recvobj)++-- | Receive an object without returning a status.+recv_ :: CanSerialize a+      => Rank                   -- ^ Source rank+      -> Tag                    -- ^ Source tag+      -> Comm                   -- ^ Communicator+      -> IO a                   -- ^ Received object+recv_ recvrank recvtag comm =+  snd <$> recv recvrank recvtag comm++-- | Send an object.+send :: CanSerialize a+     => a                     -- ^ Object to send+     -> Rank                  -- ^ Destination rank+     -> Tag                   -- ^ Message tag+     -> Comm                  -- ^ Communicator+     -> IO ()+send sendobj sendrank sendtag comm =+  do sendbuf <- serialize sendobj+     req <- MPI.isend sendbuf sendrank sendtag comm+     whileM_ (not <$> MPI.test_ req) yield++-- | Send and receive objects simultaneously.+sendrecv :: (CanSerialize a, CanSerialize b)+         => a                   -- ^ Object to send+         -> Rank                -- ^ Destination rank+         -> Tag                 -- ^ Send message tag+         -> Rank                -- ^ Source rank+         -> Tag                 -- ^ Receive message tag+         -> Comm                -- ^ Communicator+         -> IO (Status, b)      -- ^ Message status and received object+sendrecv sendobj sendrank sendtag recvrank recvtag comm =+  do recvreq <- irecv recvrank recvtag comm+     send sendobj sendrank sendtag comm+     wait recvreq++-- | Send and receive objects simultaneously, without returning a+-- status for the received message.+sendrecv_ :: (CanSerialize a, CanSerialize b)+          => a                  -- ^ Object to send+          -> Rank               -- ^ Destination rank+          -> Tag                -- ^ Send message tag+          -> Rank               -- ^ Source rank+          -> Tag                -- ^ Receive message tag+          -> Comm               -- ^ Communicator+          -> IO b               -- ^ Received object+sendrecv_ sendobj sendrank sendtag recvrank recvtag comm =+  snd <$> sendrecv sendobj sendrank sendtag recvrank recvtag comm++-- | Begin to receive an object. Call `test` or `wait` to finish the+-- communication, and to obtain the received object.+irecv :: CanSerialize a+      => Rank                   -- ^ Source rank+      -> Tag                    -- ^ Source tag+      -> Comm                   -- ^ Communicator+      -> IO (Request a)         -- ^ Communication request+irecv recvrank recvtag comm =+  do result <- newEmptyMVar+     _ <- forkIO $+       do res <- recv recvrank recvtag comm+          putMVar result res+     return (Request result)++-- | Begin to send an object. Call 'test' or 'wait' to finish the+-- communication.+isend :: CanSerialize a+      => a                     -- ^ Object to send+      -> Rank                  -- ^ Destination rank+      -> Tag                   -- ^ Message tag+      -> Comm                  -- ^ Communicator+      -> IO (Request ())       -- ^ Communication request+isend sendobj sendrank sendtag comm =+  do result <- newEmptyMVar+     _ <- forkIO $ do send sendobj sendrank sendtag comm+                      putMVar result (Status sendrank sendtag, ())+     return (Request result)++-- | Check whether a communication has finished, and return the+-- communication result if so.+test :: Request a               -- ^ Communication request+     -> IO (Maybe (Status, a))  -- ^ 'Just' communication result, if+                                -- communication has finished, else 'Nothing'+test (Request result) = tryTakeMVar result++-- | Check whether a communication has finished, and return the+-- communication result if so, without returning a message status.+test_ :: Request a       -- ^ Communication request+      -> IO (Maybe a)    -- ^ 'Just' communication result, if+                         -- communication has finished, else 'Nothing'+test_ req = fmap snd <$> test req++-- | Wait for a communication to finish and return the communication+-- result.+wait :: Request a               -- ^ Communication request+     -> IO (Status, a)          -- ^ Message status and communication result+wait (Request result) = takeMVar result++-- | Wait for a communication to finish and return the communication+-- result, without returning a message status.+wait_ :: Request a              -- ^ Communication request+      -> IO a                   -- ^ Communication result+wait_ req = snd <$> wait req++++-- | Broadcast a message from one process (the "root") to all other+-- processes in the communicator. Call this function on all non-root+-- processes. Call 'bcastSend' instead on the root process.+bcastRecv :: CanSerialize a+          => Rank+          -> Comm+          -> IO a+bcastRecv root comm =+  do rank <- MPI.commRank comm+     mpiAssert (rank /= root) "bcastRecv: expected rank /= root"+     lenbuf <- mallocForeignPtr @CLong+     MPI.bcast (lenbuf, 1::Int) root comm+     len <- withForeignPtr lenbuf peek+     ptr <- mallocBytes (fromIntegral len)+     recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len)+     MPI.bcast recvbuf root comm               +     recvobj <- deserialize recvbuf+     return recvobj++-- | Broadcast a message from one process (the "root") to all other+-- processes in the communicator. Call this function on the root+-- process. Call 'bcastRecv' instead on all non-root processes.+bcastSend :: CanSerialize a+          => a+          -> Rank+          -> Comm+          -> IO ()+bcastSend sendobj root comm =+  do rank <- MPI.commRank comm+     mpiAssert (rank == root) "bcastSend: expected rank == root"+     sendbuf <- serialize sendobj+     lenbuf <- mallocForeignPtr @CLong+     withForeignPtr lenbuf $ \ptr -> poke ptr (fromIntegral (B.length sendbuf))+     MPI.bcast (lenbuf, 1::Int) root comm+     MPI.bcast sendbuf root comm++-- | Begin a barrier. Call 'test' or 'wait' to finish the+-- communication.+ibarrier :: Comm+         -> IO (Request ())+ibarrier comm =+  do result <- newEmptyMVar+     req <- MPI.ibarrier comm+     _ <- forkIO $+       do whileM_ (not <$> MPI.test_ req) yield+          putMVar result (Status MPI.anySource MPI.anyTag, ())+     return (Request result)

@@ -1,348 +0,0 @@-{-# LANGUAGE TypeApplications #-}---- | Module: Control.Distributed.MPI.Simple--- Description: Simplified MPI bindings with automatic serialization--- Copyright: (C) 2018 Erik Schnetter--- License: Apache-2.0--- Maintainer: Erik Schnetter <schnetter@gmail.com>--- Stability: experimental--- Portability: Requires an externally installed MPI library--module Control.Distributed.MPI.Simple-  ( -- * Types, and associated functions constants-    MPIException(..)--    -- ** Communicators-  , Comm(..)-  , commSelf-  , commWorld--    -- ** Message sizes-  , Count(..)-  , fromCount-  , toCount--    -- ** Process ranks-  , Rank(..)-  , anySource-  , commRank-  , commSize-  , rootRank--    -- ** Message status-  , Status(..)--    -- ** Message tags-  , Tag(..)-  , anyTag-  , fromTag-  , toTag-  , unitTag--  , Request--    -- * Functions--    -- ** Initialization and shutdown-  , abort-  , mainMPI--    -- ** Point-to-point (blocking)-  , recv-  , recv_-  , send-  , sendrecv-  , sendrecv_--    -- ** Point-to-point (non-blocking)-  , irecv-  , isend-  , test-  , test_-  , wait-  , wait_--    -- ** Collective (blocking)-  , barrier-  , bcastRecv-  , bcastSend--    -- ** Collective (non-blocking)-  , ibarrier-  ) where--import Prelude hiding (init)--import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.Loops-import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import Data.Store hiding (peek, poke)-import Data.Typeable-import Foreign-import Foreign.C.Types--import qualified Control.Distributed.MPI as MPI-import Control.Distributed.MPI-  ( Comm(..)-  , commSelf-  , commWorld-  , Count(..)-  , fromCount-  , toCount-  , Rank(..)-  , anySource-  , commRank-  , commSize-  , rootRank-  , Tag(..)-  , anyTag-  , fromTag-  , toTag-  , unitTag-  , abort-  , barrier-  )------ | Exception type indicating an error in a call to MPI-newtype MPIException = MPIException String-  deriving (Eq, Ord, Read, Show, Typeable)-instance Exception MPIException--mpiAssert :: Bool -> String -> IO ()-mpiAssert cond msg =-  do when (not cond) $ throw (MPIException msg)-     return ()----data DidInit = DidInit | DidNotInit--initMPI :: IO DidInit-initMPI =-  do isInit <- MPI.initialized-     if isInit-       then return DidNotInit-       else do ts <- MPI.initThread MPI.ThreadMultiple-               mpiAssert (ts >= MPI.ThreadMultiple)-                 ("MPI.init: Insufficient thread support: requiring " ++-                  show MPI.ThreadMultiple ++-                  ", but MPI library provided only " ++ show ts)-               return DidInit--finalizeMPI :: DidInit -> IO ()-finalizeMPI DidInit =-  do isFinalized <- MPI.finalized-     if isFinalized-       then return ()-       else do MPI.finalize-finalizeMPI DidNotInit = return ()---- | Convenience function to initialize and finalize MPI. This--- initializes MPI with 'ThreadMultiple' thread support.-mainMPI :: IO () -- ^ action to run with MPI, typically the whole program-        -> IO ()-mainMPI action = bracket initMPI finalizeMPI (\_ -> action)------ | A communication request, usually created by a non-blocking--- communication function.-newtype Request a = Request (MVar (Status, a))---- | The status of a finished communication, indicating rank and tag--- of the other communication end point.-data Status = Status { msgRank :: !Rank-                     , msgTag :: !Tag-                     }-  deriving (Eq, Ord, Read, Show)------ | Receive an object.-recv :: Store a-     => Rank                    -- ^ Source rank-     -> Tag                     -- ^ Source tag-     -> Comm                    -- ^ Communicator-     -> IO (Status, a)          -- ^ Message status and received object-recv recvrank recvtag comm =-  do status <- untilJust $-       do yield-          MPI.iprobe recvrank recvtag comm-     source <- MPI.getSource status-     tag <- MPI.getTag status-     count <- MPI.getCount status MPI.datatypeByte-     let len = MPI.fromCount count-     ptr <- mallocBytes len-     buffer <- B.unsafePackMallocCStringLen (ptr, len)-     req <- MPI.irecv buffer source tag comm-     whileM_ (not <$> MPI.test_ req) yield-     return (Status source tag, decodeEx buffer)---- | Receive an object without returning a status.-recv_ :: Store a-      => Rank                   -- ^ Source rank-      -> Tag                    -- ^ Source tag-      -> Comm                   -- ^ Communicator-      -> IO a                   -- ^ Received object-recv_ recvrank recvtag comm =-  snd <$> recv recvrank recvtag comm---- | Send an object.-send :: Store a-     => a                     -- ^ Object to send-     -> Rank                  -- ^ Destination rank-     -> Tag                   -- ^ Message tag-     -> Comm                  -- ^ Communicator-     -> IO ()-send sendobj sendrank sendtag comm =-  do let sendbuf = encode sendobj-     MPI.send sendbuf sendrank sendtag comm---- | Send and receive objects simultaneously.-sendrecv :: (Store a, Store b)-         => a                   -- ^ Object to send-         -> Rank                -- ^ Destination rank-         -> Tag                 -- ^ Send message tag-         -> Rank                -- ^ Source rank-         -> Tag                 -- ^ Receive message tag-         -> Comm                -- ^ Communicator-         -> IO (Status, b)      -- ^ Message status and received object-sendrecv sendobj sendrank sendtag recvrank recvtag comm =-  do sendreq <- isend sendobj sendrank sendtag comm-     recvreq <- irecv recvrank recvtag comm-     wait_ sendreq-     wait recvreq---- | Send and receive objects simultaneously, without returning a--- status for the received message.-sendrecv_ :: (Store a, Store b)-          => a                  -- ^ Object to send-          -> Rank               -- ^ Destination rank-          -> Tag                -- ^ Send message tag-          -> Rank               -- ^ Source rank-          -> Tag                -- ^ Receive message tag-          -> Comm               -- ^ Communicator-          -> IO b               -- ^ Received object-sendrecv_ sendobj sendrank sendtag recvrank recvtag comm =-  snd <$> sendrecv sendobj sendrank sendtag recvrank recvtag comm---- | Begin to receive an object. Call `test` or `wait` to finish the--- communication, and to obtain the received object.-irecv :: Store a-      => Rank                   -- ^ Source rank-      -> Tag                    -- ^ Source tag-      -> Comm                   -- ^ Communicator-      -> IO (Request a)         -- ^ Communication request-irecv recvrank recvtag comm =-  do result <- newEmptyMVar-     _ <- forkIO $-       do status <- untilJust $-            do yield-               MPI.iprobe recvrank recvtag comm-          source <- MPI.getSource status-          tag <- MPI.getTag status-          count <- MPI.getCount status MPI.datatypeByte-          let len = MPI.fromCount count-          ptr <- mallocBytes len-          buffer <- B.unsafePackMallocCStringLen (ptr, len)-          req <- MPI.irecv buffer source tag comm-          whileM_ (not <$> MPI.test_ req) yield-          putMVar result (Status source tag, decodeEx buffer)-     return (Request result)---- | Begin to send an object. Call 'test' or 'wait' to finish the--- communication.-isend :: Store a-      => a                     -- ^ Object to send-      -> Rank                  -- ^ Destination rank-      -> Tag                   -- ^ Message tag-      -> Comm                  -- ^ Communicator-      -> IO (Request ())       -- ^ Communication request-isend sendobj sendrank sendtag comm =-  do let sendbuf = encode sendobj-     req <- MPI.isend sendbuf sendrank sendtag comm-     result <- newEmptyMVar-     _ <- forkIO $ B.unsafeUseAsCString sendbuf $ \_ ->-       do whileM_ (not <$> MPI.test_ req) yield-          putMVar result (Status sendrank sendtag, ())-     return (Request result)---- | Check whether a communication has finished, and return the--- communication result if so.-test :: Request a               -- ^ Communication request-     -> IO (Maybe (Status, a))  -- ^ 'Just' communication result, if-                                -- communication has finished, else 'Nothing'-test (Request result) = tryTakeMVar result---- | Check whether a communication has finished, and return the--- communication result if so, without returning a message status.-test_ :: Request a       -- ^ Communication request-      -> IO (Maybe a) -- ^ 'Just' communication result, if-                      -- communication has finished, else 'Nothing'-test_ req = fmap snd <$> test req---- | Wait for a communication to finish and return the communication--- result.-wait :: Request a               -- ^ Communication request-     -> IO (Status, a)          -- ^ Message status and communication result-wait (Request result) = takeMVar result---- | Wait for a communication to finish and return the communication--- result, without returning a message status.-wait_ :: Request a              -- ^ Communication request-      -> IO a                   -- ^ Communication result-wait_ req = snd <$> wait req------ | Broadcast a message from one process (the "root") to all other--- processes in the communicator. Call this function on all non-root--- processes. Call 'bcastSend' instead on the root process.-bcastRecv :: Store a-          => Rank-          -> Comm-          -> IO a-bcastRecv root comm =-  do rank <- MPI.commRank comm-     mpiAssert (rank /= root) "bcastRecv: expected rank /= root"-     buf <- mallocForeignPtr @CLong-     MPI.bcast (buf, 1::Int) root comm-     len <- withForeignPtr buf peek-     ptr <- mallocBytes (fromIntegral len)-     recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len)-     MPI.bcast recvbuf root comm               -     return (decodeEx recvbuf)---- | Broadcast a message from one process (the "root") to all other--- processes in the communicator. Call this function on the root--- process. Call 'bcastRecv' instead on all non-root processes.-bcastSend :: Store a-          => a-          -> Rank-          -> Comm-          -> IO ()-bcastSend sendobj root comm =-  do rank <- MPI.commRank comm-     mpiAssert (rank == root) "bcastSend: expected rank == root"-     let sendbuf = encode sendobj-     buf <- mallocForeignPtr @CLong-     withForeignPtr buf $ \ptr -> poke ptr (fromIntegral (B.length sendbuf))-     MPI.bcast (buf, 1::Int) root comm-     MPI.bcast sendbuf root comm---- | Begin a barrier. Call 'test' or 'wait' to finish the--- communication.-ibarrier :: Comm-         -> IO (Request ())-ibarrier comm =-  do result <- newEmptyMVar-     req <- MPI.ibarrier comm-     _ <- forkIO $-       do whileM_ (not <$> MPI.test_ req) yield-          putMVar result (Status MPI.anySource MPI.anyTag, ())-     return (Request result)

@@ -0,0 +1,362 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}++-- | Module: Control.Distributed.MPI.Store+-- Description: Simplified MPI bindings with automatic serialization+--              based on Data.Store+-- Copyright: (C) 2018 Erik Schnetter+-- License: Apache-2.0+-- Maintainer: Erik Schnetter <schnetter@gmail.com>+-- Stability: experimental+-- Portability: Requires an externally installed MPI library++module Control.Distributed.MPI.Store+  ( -- * Types, and associated functions and constants+    MPIException(..)++    -- ** Communicators+  , Comm(..)+  , commSelf+  , commWorld++    -- ** Message sizes+  , Count(..)+  , fromCount+  , toCount++    -- ** Process ranks+  , Rank(..)+  , anySource+  , commRank+  , commSize+  , fromRank+  , rootRank+  , toRank++    -- ** Message status+  , Status(..)++    -- ** Message tags+  , Tag(..)+  , anyTag+  , fromTag+  , toTag+  , unitTag++  , Request++    -- * Functions++    -- ** Initialization and shutdown+  , abort+  , mainMPI++    -- ** Point-to-point (blocking)+  , recv+  , recv_+  , send+  , sendrecv+  , sendrecv_++    -- ** Point-to-point (non-blocking)+  , irecv+  , isend+  , test+  , test_+  , wait+  , wait_++    -- ** Collective (blocking)+  , barrier+  , bcastRecv+  , bcastSend++    -- ** Collective (non-blocking)+  , ibarrier+  ) where++import Prelude hiding (init)++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Store as Store+import Data.Typeable+import Foreign+import Foreign.C.Types++import qualified Control.Distributed.MPI as MPI+import Control.Distributed.MPI+  ( Comm(..)+  , commSelf+  , commWorld+  , Count(..)+  , fromCount+  , toCount+  , Rank(..)+  , anySource+  , commRank+  , commSize+  , fromRank+  , rootRank+  , toRank+  , Tag(..)+  , anyTag+  , fromTag+  , toTag+  , unitTag+  , abort+  , barrier+  )++++-- Serialization, based on Data.Store+type CanSerialize a = Store.Store a+serialize :: CanSerialize a => a -> IO B.ByteString+serialize = return . Store.encode+deserialize :: CanSerialize a => B.ByteString -> IO a+deserialize = return . Store.decodeEx++++-- | Run the supplied Maybe computation repeatedly while it returns+-- Nothing. If it returns a value, then returns that value.+whileNothing :: Monad m => m (Maybe a) -> m () -> m a+whileNothing cond loop = go+  where go = do mx <- cond+                case mx of+                  Nothing -> do loop+                                go+                  Just x -> return x++++-- | Exception type indicating an error in a call to MPI+newtype MPIException = MPIException String+  deriving (Eq, Ord, Read, Show, Typeable)+instance Exception MPIException++mpiAssert :: Bool -> String -> IO ()+mpiAssert cond msg =+  do when (not cond) $ throw (MPIException msg)+     return ()++++data DidInit = DidInit | DidNotInit++initMPI :: IO DidInit+initMPI =+  do isInit <- MPI.initialized+     if isInit+       then return DidNotInit+       else do ts <- MPI.initThread MPI.ThreadMultiple+               mpiAssert (ts >= MPI.ThreadMultiple)+                 ("MPI.init: Insufficient thread support: requiring " +++                  show MPI.ThreadMultiple +++                  ", but MPI library provided only " ++ show ts)+               return DidInit++finalizeMPI :: DidInit -> IO ()+finalizeMPI DidInit =+  do isFinalized <- MPI.finalized+     if isFinalized+       then return ()+       else do MPI.finalize+finalizeMPI DidNotInit = return ()++-- | Convenience function to initialize and finalize MPI. This+-- initializes MPI with 'ThreadMultiple' thread support.+mainMPI :: IO () -- ^ action to run with MPI, typically the whole program+        -> IO ()+mainMPI action = bracket initMPI finalizeMPI (\_ -> action)++++-- | A communication request, usually created by a non-blocking+-- communication function.+newtype Request a = Request (MVar (Status, a))++-- | The status of a finished communication, indicating rank and tag+-- of the other communication end point.+data Status = Status { msgRank :: !Rank+                     , msgTag :: !Tag+                     }+  deriving (Eq, Ord, Read, Show)++++-- | Receive an object.+recv :: CanSerialize a+     => Rank                    -- ^ Source rank+     -> Tag                     -- ^ Source tag+     -> Comm                    -- ^ Communicator+     -> IO (Status, a)          -- ^ Message status and received object+recv recvrank recvtag comm =+  do status <- whileNothing (MPI.iprobe recvrank recvtag comm) yield+     source <- MPI.getSource status+     tag <- MPI.getTag status+     count <- MPI.getCount status MPI.datatypeByte+     let len = MPI.fromCount count+     ptr <- mallocBytes len+     buffer <- B.unsafePackMallocCStringLen (ptr, len)+     req <- MPI.irecv buffer source tag comm+     whileM_ (not <$> MPI.test_ req) yield+     recvobj <- deserialize buffer+     return (Status source tag, recvobj)++-- | Receive an object without returning a status.+recv_ :: CanSerialize a+      => Rank                   -- ^ Source rank+      -> Tag                    -- ^ Source tag+      -> Comm                   -- ^ Communicator+      -> IO a                   -- ^ Received object+recv_ recvrank recvtag comm =+  snd <$> recv recvrank recvtag comm++-- | Send an object.+send :: CanSerialize a+     => a                     -- ^ Object to send+     -> Rank                  -- ^ Destination rank+     -> Tag                   -- ^ Message tag+     -> Comm                  -- ^ Communicator+     -> IO ()+send sendobj sendrank sendtag comm =+  do sendbuf <- serialize sendobj+     req <- MPI.isend sendbuf sendrank sendtag comm+     whileM_ (not <$> MPI.test_ req) yield++-- | Send and receive objects simultaneously.+sendrecv :: (CanSerialize a, CanSerialize b)+         => a                   -- ^ Object to send+         -> Rank                -- ^ Destination rank+         -> Tag                 -- ^ Send message tag+         -> Rank                -- ^ Source rank+         -> Tag                 -- ^ Receive message tag+         -> Comm                -- ^ Communicator+         -> IO (Status, b)      -- ^ Message status and received object+sendrecv sendobj sendrank sendtag recvrank recvtag comm =+  do recvreq <- irecv recvrank recvtag comm+     send sendobj sendrank sendtag comm+     wait recvreq++-- | Send and receive objects simultaneously, without returning a+-- status for the received message.+sendrecv_ :: (CanSerialize a, CanSerialize b)+          => a                  -- ^ Object to send+          -> Rank               -- ^ Destination rank+          -> Tag                -- ^ Send message tag+          -> Rank               -- ^ Source rank+          -> Tag                -- ^ Receive message tag+          -> Comm               -- ^ Communicator+          -> IO b               -- ^ Received object+sendrecv_ sendobj sendrank sendtag recvrank recvtag comm =+  snd <$> sendrecv sendobj sendrank sendtag recvrank recvtag comm++-- | Begin to receive an object. Call `test` or `wait` to finish the+-- communication, and to obtain the received object.+irecv :: CanSerialize a+      => Rank                   -- ^ Source rank+      -> Tag                    -- ^ Source tag+      -> Comm                   -- ^ Communicator+      -> IO (Request a)         -- ^ Communication request+irecv recvrank recvtag comm =+  do result <- newEmptyMVar+     _ <- forkIO $+       do res <- recv recvrank recvtag comm+          putMVar result res+     return (Request result)++-- | Begin to send an object. Call 'test' or 'wait' to finish the+-- communication.+isend :: CanSerialize a+      => a                     -- ^ Object to send+      -> Rank                  -- ^ Destination rank+      -> Tag                   -- ^ Message tag+      -> Comm                  -- ^ Communicator+      -> IO (Request ())       -- ^ Communication request+isend sendobj sendrank sendtag comm =+  do result <- newEmptyMVar+     _ <- forkIO $ do send sendobj sendrank sendtag comm+                      putMVar result (Status sendrank sendtag, ())+     return (Request result)++-- | Check whether a communication has finished, and return the+-- communication result if so.+test :: Request a               -- ^ Communication request+     -> IO (Maybe (Status, a))  -- ^ 'Just' communication result, if+                                -- communication has finished, else 'Nothing'+test (Request result) = tryTakeMVar result++-- | Check whether a communication has finished, and return the+-- communication result if so, without returning a message status.+test_ :: Request a       -- ^ Communication request+      -> IO (Maybe a)    -- ^ 'Just' communication result, if+                         -- communication has finished, else 'Nothing'+test_ req = fmap snd <$> test req++-- | Wait for a communication to finish and return the communication+-- result.+wait :: Request a               -- ^ Communication request+     -> IO (Status, a)          -- ^ Message status and communication result+wait (Request result) = takeMVar result++-- | Wait for a communication to finish and return the communication+-- result, without returning a message status.+wait_ :: Request a              -- ^ Communication request+      -> IO a                   -- ^ Communication result+wait_ req = snd <$> wait req++++-- | Broadcast a message from one process (the "root") to all other+-- processes in the communicator. Call this function on all non-root+-- processes. Call 'bcastSend' instead on the root process.+bcastRecv :: CanSerialize a+          => Rank+          -> Comm+          -> IO a+bcastRecv root comm =+  do rank <- MPI.commRank comm+     mpiAssert (rank /= root) "bcastRecv: expected rank /= root"+     lenbuf <- mallocForeignPtr @CLong+     MPI.bcast (lenbuf, 1::Int) root comm+     len <- withForeignPtr lenbuf peek+     ptr <- mallocBytes (fromIntegral len)+     recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len)+     MPI.bcast recvbuf root comm               +     recvobj <- deserialize recvbuf+     return recvobj++-- | Broadcast a message from one process (the "root") to all other+-- processes in the communicator. Call this function on the root+-- process. Call 'bcastRecv' instead on all non-root processes.+bcastSend :: CanSerialize a+          => a+          -> Rank+          -> Comm+          -> IO ()+bcastSend sendobj root comm =+  do rank <- MPI.commRank comm+     mpiAssert (rank == root) "bcastSend: expected rank == root"+     sendbuf <- serialize sendobj+     lenbuf <- mallocForeignPtr @CLong+     withForeignPtr lenbuf $ \ptr -> poke ptr (fromIntegral (B.length sendbuf))+     MPI.bcast (lenbuf, 1::Int) root comm+     MPI.bcast sendbuf root comm++-- | Begin a barrier. Call 'test' or 'wait' to finish the+-- communication.+ibarrier :: Comm+         -> IO (Request ())+ibarrier comm =+  do result <- newEmptyMVar+     req <- MPI.ibarrier comm+     _ <- forkIO $+       do whileM_ (not <$> MPI.test_ req) yield+          putMVar result (Status MPI.anySource MPI.anyTag, ())+     return (Request result)

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack ----- hash: 761b31486948877bf0190f33f0275f4bd5e03c3bc4b5ee323afbe6fe1324f05e+-- hash: 5c902ab43e71de0472124cd5087d38762a8c74caf1bf2af33a04eb72da015285  name:           mpi-hs-version:        0.3.1.0+version:        0.4.0.0 synopsis:       MPI bindings for Haskell description:    MPI (the [Message Passing Interface](https://www.mpi-forum.org)) is                 widely used standard for distributed-memory programming on HPC (High@@ -42,14 +44,13 @@ license:        Apache-2.0 license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:-    c/include/mpihs.h-    c/src/mpihs.c     LICENSE-    package.yaml     README.md+    package.yaml     stack.yaml+    c/include/mpihs.h+    c/src/mpihs.c  source-repository head   type: git@@ -58,7 +59,8 @@ library   exposed-modules:       Control.Distributed.MPI-      Control.Distributed.MPI.Simple+      Control.Distributed.MPI.Packing+      Control.Distributed.MPI.Store   other-modules:       Paths_mpi_hs   hs-source-dirs:@@ -72,8 +74,10 @@       mpi   build-depends:       base >=4 && <5+    , binary     , bytestring     , monad-loops+    , packman     , store   build-tools:       c2hs@@ -91,13 +95,13 @@     , mpi-hs   default-language: Haskell2010 -test-suite mpi-simple-tests+test-suite mpi-test   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:       Paths_mpi_hs   hs-source-dirs:-      test/simple+      tests/mpi   ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N   build-depends:       base@@ -105,17 +109,29 @@     , mpi-hs   default-language: Haskell2010 -test-suite mpi-tests+test-suite mpi-test-packing   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:       Paths_mpi_hs   hs-source-dirs:-      test/mpi+      tests/packing   ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N   build-depends:       base-    , monad-loops+    , mpi-hs+  default-language: Haskell2010++test-suite mpi-test-store+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_mpi_hs+  hs-source-dirs:+      tests/store+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base     , mpi-hs   default-language: Haskell2010 

@@ -1,5 +1,5 @@ name: mpi-hs-version: '0.3.1.0'+version: '0.4.0.0' github: "eschnett/mpi-hs" license: Apache-2.0 author: "Erik Schnetter <schnetter@gmail.com>"@@ -49,8 +49,10 @@ library:   dependencies:     - base >=4 && <5            # tested with 4.11 and 4.12+    - binary     - bytestring     - monad-loops+    - packman     - store   build-tools:     - c2hs@@ -88,8 +90,8 @@       - -with-rtsopts=-N  tests:-  mpi-tests:-    source-dirs: test/mpi+  mpi-test:+    source-dirs: tests/mpi     main: Main.hs     dependencies:       - base@@ -103,12 +105,25 @@       - -rtsopts       - -threaded       - -with-rtsopts=-N-  mpi-simple-tests:-    source-dirs: test/simple+  mpi-test-packing:+    source-dirs: tests/packing     main: Main.hs     dependencies:       - base-      - monad-loops+      - mpi-hs+      # - tasty+      # - tasty-hunit+      # - tasty-hspec+      # - unix+    ghc-options:+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N+  mpi-test-store:+    source-dirs: tests/store+    main: Main.hs+    dependencies:+      - base       - mpi-hs       # - tasty       # - tasty-hunit

@@ -1,14 +1,19 @@ # Resolver to choose a 'specific' stackage snapshot or a compiler version.-resolver: lts-12.14+resolver: lts-12.16  # User packages to be built. packages:   - . +extra-deps:+  - packman-0.5.0+ # Extra directories used by stack for building extra-include-dirs:-  - /opt/local/include/openmpi-mp-  - /usr/lib/openmpi/include+  - /opt/local/include/openmpi-mp             # MacPorts+  - /usr/lib/openmpi/include                  # Ubuntu+  - /usr/lib/x86_64-linux-gnu/openmpi/include # Debian extra-lib-dirs:   - /opt/local/lib/openmpi-mp   - /usr/lib/openmpi/lib+  - /usr/lib/x86_64-linux-gnu/openmpi/lib

@@ -1,638 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.Loops-import Data.IORef-import Foreign-import Foreign.C.Types-import System.Exit-import System.IO--- import Test.Tasty--- import Test.Tasty.HUnit--import qualified Control.Distributed.MPI as MPI--------------------------------------------------------------------------------------infix 1 @?-(@?) :: Bool -> String -> IO ()-x @? msg = if not x then die msg else return ()--infix 1 @?=-(@?=) :: Eq a => a -> a -> IO ()-x @?= y = x == y @? "test failed"----type TestTree = IO ()--testCase :: String -> IO () -> TestTree-testCase name test =-  do rank <- MPI.commRank MPI.commWorld-     if rank == 0-       then do putStrLn $ "  " ++ name ++ "..."-               hFlush stdout-       else return ()-     MPI.barrier MPI.commWorld-     test-     MPI.barrier MPI.commWorld----testGroup :: String -> [TestTree] -> TestTree-testGroup name cases =-  do rank <- MPI.commRank MPI.commWorld-     if rank == 0-       then do putStrLn $ name ++ ":"-               hFlush stdout-       else return ()-     sequence_ cases----defaultMain :: TestTree -> IO ()-defaultMain tree =-  do rank <- MPI.commRank MPI.commWorld-     size <- MPI.commSize MPI.commWorld-     if rank == 0-       then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"-               hFlush stdout-       else return ()-     tree----------------------------------------------------------------------------------------main :: IO ()-main = bracket-  (do _ <- MPI.initThread MPI.ThreadMultiple-      return ())-  (\_ -> MPI.finalize)-  (\_ -> defaultMain tests)--tests :: TestTree-tests = testGroup "MPI"-  [ initialized-  , rankSize-  , pointToPoint-  , pointToPointNonBlocking-  , collective-  , collectiveNonBlocking-  , reductions-  , dynamic-  ]----initialized :: TestTree-initialized = testGroup "initialized"-  [ testCase "initialized" $-      do isInit <- MPI.initialized-         isInit @?= True-  , testCase "finalized" $-      do isFini <- MPI.finalized-         isFini @?= False-  ]----rankSize :: TestTree-rankSize = testGroup "rank and size"-  [ testCase "commSelf" $-    do rank <- MPI.commRank MPI.commSelf-       size <- MPI.commSize MPI.commSelf-       rank == 0 && size == 1 @? ""-  , testCase "commWorld" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       rank >= 0 && rank < size @? ""-  ]----pointToPoint :: TestTree-pointToPoint = testGroup "point-to-point"-  [ testCase "send and recv" $-    do rank <- MPI.commRank MPI.commWorld--       let msg = 42-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg--       MPI.send (buf, 1::Int) rank MPI.unitTag MPI.commWorld--       buf' <- mallocForeignPtr @CInt-       st <- MPI.recv (buf', 1::Int) rank MPI.unitTag MPI.commWorld-       msg' <- withForeignPtr buf' peek--       source <- MPI.getSource st-       tag <- MPI.getTag st-       count <- MPI.getCount st MPI.datatypeInt-       (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""-  , testCase "sendrecv" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld--       let msg = 42 + MPI.fromRank rank-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg--       buf' <- mallocForeignPtr @CInt--       st <- MPI.sendrecv-             (buf, 1::Int) ((rank + 1) `mod` size) MPI.unitTag-             (buf', 1::Int) ((rank - 1) `mod` size) MPI.unitTag-             MPI.commWorld--       msg' <- withForeignPtr buf' peek--       source <- MPI.getSource st-       tag <- MPI.getTag st-       count <- MPI.getCount st MPI.datatypeInt-       (msg' == 42 + MPI.fromRank ((rank - 1) `mod` size) &&-        source == (rank - 1) `mod` size &&-        tag == MPI.unitTag &&-        count == 1) @? ""-  ]----pointToPointNonBlocking :: TestTree-pointToPointNonBlocking = testGroup "point-to-point non-blocking"-  [ testCase "send and recv" $-    do rank <- MPI.commRank MPI.commWorld--       let msg = 42-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg--       req <- MPI.isend (buf, 1::Int) rank MPI.unitTag MPI.commWorld--       buf' <- mallocForeignPtr @CInt-       req' <- MPI.irecv (buf', 1::Int) rank MPI.unitTag MPI.commWorld--       MPI.wait_ req-       st <- MPI.wait req'--       touchForeignPtr buf-       msg' <- withForeignPtr buf' peek--       source <- MPI.getSource st-       tag <- MPI.getTag st-       count <- MPI.getCount st MPI.datatypeInt-       (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""-  ]----collective :: TestTree-collective = testGroup "collective"-  [ testCase "allgather" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtrArray @CInt sz-       MPI.allgather (buf, 1::Int) (buf', 1::Int) MPI.commWorld-       msgs' <- withForeignPtr buf' (peekArray sz)-       msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""-  , testCase "allreduce" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.allreduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld-       msg' <- withForeignPtr buf' peek-       msg' == sum [42 .. 42 + (sz-1)] @? ""-  , testCase "alltoall" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]-       buf <- mallocForeignPtrArray @CInt sz-       withForeignPtr buf $ \ptr -> pokeArray ptr msgs-       buf' <- mallocForeignPtrArray @CInt sz-       MPI.alltoall (buf, 1::Int) (buf', 1::Int) MPI.commWorld-       msgs' <- withForeignPtr buf' (peekArray sz)-       msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""-  , testCase "barrier" $-    MPI.barrier MPI.commWorld-  , testCase "bcast" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       MPI.bcast (buf, 1::Int) MPI.rootRank MPI.commWorld-       msg' <- withForeignPtr buf peek-       msg' == 42 @? ""-  , testCase "exscan" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.exscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld-       msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)-       msg' == sum [42 .. 42 + rk-1] @? ""-  , testCase "gather" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)-       MPI.gather (buf, 1::Int) (buf', 1::Int) MPI.rootRank MPI.commWorld-       msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)-       (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""-  , testCase "reduce" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank-         MPI.commWorld-       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0-       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""-  , testCase "scan" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.scan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld-       msg' <- withForeignPtr buf' peek-       msg' == sum [42 .. 42 + rk] @? ""-  , testCase "scatter" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msgs =-             if isroot then [42 + fromIntegral i | i <- [0 .. sz-1]] else []-       buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)-       withForeignPtr buf $-         \ptr -> if isroot then pokeArray ptr msgs else return ()-       buf' <- mallocForeignPtr @CInt-       MPI.scatter (buf, 1::Int) (buf', 1::Int) MPI.rootRank MPI.commWorld-       msg' <- withForeignPtr buf' peek-       msg' == 42 + rk @? ""-  ]----reductions :: TestTree-reductions = testGroup "reduction operations"-  [ testCase "max" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opMax MPI.rootRank-         MPI.commWorld-       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0-       (if isroot then msg' == maximum [42 .. 42 + sz-1] else True) @? ""-  , testCase "min" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opMin MPI.rootRank-         MPI.commWorld-       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0-       (if isroot then msg' == minimum [42 .. 42 + sz-1] else True) @? ""-  , testCase "sum" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank-         MPI.commWorld-       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0-       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""-  ]----collectiveNonBlocking :: TestTree-collectiveNonBlocking = testGroup "collective non-blocking"-  [ testCase "iallgather" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtrArray @CInt sz-       req <- MPI.iallgather (buf, 1::Int) (buf', 1::Int) MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msgs' <- withForeignPtr buf' (peekArray sz)-       msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""-  , testCase "iallreduce" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       req <- MPI.iallreduce (buf, 1::Int) (buf', 1::Int) MPI.opSum-              MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf' peek-       msg' == sum [42 .. 42 + (sz-1)] @? ""-  , testCase "ialltoall" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]-       buf <- mallocForeignPtrArray @CInt sz-       withForeignPtr buf $ \ptr -> pokeArray ptr msgs-       buf' <- mallocForeignPtrArray @CInt sz-       req <- MPI.ialltoall (buf, 1::Int) (buf', 1::Int) MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msgs' <- withForeignPtr buf' (peekArray sz)-       msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""-  , testCase "ibarrier" $-    do req <- MPI.ibarrier MPI.commWorld-       MPI.wait_ req-  , testCase "ibcast" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       req <- MPI.ibcast (buf, 1::Int) MPI.rootRank MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf peek-       msg' == 42 @? ""-  , testCase "iexscan" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       req <- MPI.iexscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)-       msg' == sum [42 .. 42 + rk-1] @? ""-  , testCase "igather" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)-       req <- MPI.igather (buf, 1::Int) (buf', 1::Int) MPI.rootRank-              MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)-       (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""-  , testCase "ireduce" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       req <- MPI.ireduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank-              MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0-       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""-  , testCase "iscan" $-    do rank <- MPI.commRank MPI.commWorld-       let rk = MPI.fromRank rank-       let msg = 42 + rk-       buf <- mallocForeignPtr @CInt-       withForeignPtr buf $ \ptr -> poke ptr msg-       buf' <- mallocForeignPtr @CInt-       req <- MPI.iscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf' peek-       msg' == sum [42 .. 42 + rk] @? ""-  , testCase "iscatter" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let rk = MPI.fromRank rank-       let sz = MPI.fromRank size-       let isroot = rank == MPI.rootRank-       let msgs = [42 + fromIntegral i | i <- [0 .. sz-1]]-       buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)-       withForeignPtr buf $ \ptr -> pokeArray ptr msgs-       buf' <- mallocForeignPtr @CInt-       req <- MPI.iscatter (buf, 1::Int) (buf', 1::Int) MPI.rootRank-              MPI.commWorld-       MPI.wait_ req-       touchForeignPtr buf-       msg' <- withForeignPtr buf' peek-       msg' == 42 + rk @? ""-  ]----dynamic :: TestTree-dynamic = testGroup "dynamic"-  [ testCase "sequential" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld--       breq <- newIORef Nothing-       let signalDone =-             do r <- MPI.ibarrier MPI.commWorld-                writeIORef breq (Just r)-       let checkDone =-             do mreq <- readIORef breq-                case mreq of-                  Nothing -> return False-                  Just req -> MPI.test_ req--       sendreqs <- newIORef []-       let sendMsg dst =-             when (dst < size) $-             do buf <- mallocForeignPtr @CInt-                withForeignPtr buf $ \ptr -> poke ptr 42-                r <- MPI.isend (buf, 1::Int) dst MPI.unitTag MPI.commWorld-                modifyIORef' sendreqs ((buf, r) :)-       let drainSendQueue =-             do srs <- readIORef sendreqs-                srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs-                writeIORef sendreqs srs'-       let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld-       let recvMsg st =-             do src <- MPI.getSource st-                buf <- mallocForeignPtr @CInt-                MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld--       -- each rank sends to the next-       when (rank == 0) $-         do sendMsg (rank + 1)-            signalDone--       untilM_-         (do drainSendQueue-             mst <- checkForMsg-             case mst of-               Nothing -> return ()-               Just st -> do recvMsg st-                             sendMsg (rank + 1)-                             signalDone-         )-         checkDone-  , testCase "tree" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld--       breq <- newIORef Nothing-       let signalDone =-             do r <- MPI.ibarrier MPI.commWorld-                writeIORef breq (Just r)-       let checkDone =-             do mreq <- readIORef breq-                case mreq of-                  Nothing -> return False-                  Just req -> MPI.test_ req--       sendreqs <- newIORef []-       let sendMsg dst =-             when (dst < size) $-             do buf <- mallocForeignPtr @CInt-                withForeignPtr buf $ \ptr -> poke ptr 42-                r <- MPI.isend (buf, 1::Int) dst MPI.unitTag MPI.commWorld-                modifyIORef' sendreqs ((buf, r) :)-       let drainSendQueue =-             do srs <- readIORef sendreqs-                srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs-                writeIORef sendreqs srs'-       let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld-       let recvMsg st =-             do src <- MPI.getSource st-                buf <- mallocForeignPtr @CInt-                MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld--       -- rank r sends to 2*r+1 and 2*r+2-       when (rank == 0) $-         do sendMsg (2 * rank + 1)-            sendMsg (2 * rank + 2)-            signalDone--       untilM_-         (do drainSendQueue-             mst <- checkForMsg-             case mst of-               Nothing -> return ()-               Just st -> do recvMsg st-                             sendMsg (2 * rank + 1)-                             sendMsg (2 * rank + 2)-                             signalDone-         )-         checkDone-  , testCase "multi-threaded" $-    do mts <- MPI.threadSupport-       let Just ts = mts-       when (ts >= MPI.ThreadMultiple) $-         do rank <- MPI.commRank MPI.commWorld-            size <- MPI.commSize MPI.commWorld-     -            breq <- newEmptyMVar-            let signalDone =-                  do _ <- forkIO $-                       do req <- MPI.ibarrier MPI.commWorld-                          whileM_ (not <$> MPI.test_ req) yield-                          putMVar breq ()-                     return ()-            let checkDone = not <$> isEmptyMVar breq-     -            let sendMsg dst =-                  when (dst < size) $-                  do _ <- forkIO $-                       do buf <- mallocForeignPtr @CInt-                          withForeignPtr buf $ \ptr -> poke ptr 42-                          req <- MPI.isend (buf, 1::Int) dst MPI.unitTag-                                 MPI.commWorld-                          whileM_ (not <$> MPI.test_ req) yield-                     return ()-            let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld-            let recvMsg st =-                  do src <- MPI.getSource st-                     buf <- mallocForeignPtr @CInt-                     MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld-     -            -- rank r sends to 2*r+1 and 2*r+2-            when (rank == 0) $-              do sendMsg (2 * rank + 1)-                 sendMsg (2 * rank + 2)-                 signalDone-     -            untilM_-              (do mst <- checkForMsg-                  case mst of-                    Nothing -> return ()-                    Just st -> do recvMsg st-                                  sendMsg (2 * rank + 1)-                                  sendMsg (2 * rank + 2)-                                  signalDone-                  yield-              )-              checkDone-  ]

@@ -1,155 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--import System.IO-import System.Exit--import qualified Control.Distributed.MPI.Simple as MPI--default (Int)--------------------------------------------------------------------------------------infix 1 @?-(@?) :: Bool -> String -> IO ()-x @? msg = if not x then die msg else return ()--infix 1 @?=-(@?=) :: Eq a => a -> a -> IO ()-x @?= y = x == y @? "test failed"----type TestTree = IO ()--testCase :: String -> IO () -> TestTree-testCase name test =-  do rank <- MPI.commRank MPI.commWorld-     if rank == 0-       then do putStrLn $ "  " ++ name ++ "..."-               hFlush stdout-       else return ()-     MPI.barrier MPI.commWorld-     test-     MPI.barrier MPI.commWorld----testGroup :: String -> [TestTree] -> TestTree-testGroup name cases =-  do rank <- MPI.commRank MPI.commWorld-     if rank == 0-       then do putStrLn $ name ++ ":"-               hFlush stdout-       else return ()-     sequence_ cases----defaultMain :: TestTree -> IO ()-defaultMain tree =-  do rank <- MPI.commRank MPI.commWorld-     size <- MPI.commSize MPI.commWorld-     if rank == 0-       then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"-               hFlush stdout-       else return ()-     tree----------------------------------------------------------------------------------------main :: IO ()-main = MPI.mainMPI $ defaultMain tests--tests :: TestTree-tests = testGroup "MPI"-  [ rankSize-  , pointToPoint-  , pointToPointNonBlocking-  , collective-  , collectiveNonBlocking-  ]----rankSize :: TestTree-rankSize = testGroup "rank and size"-  [ testCase "commSelf" $-    do rank <- MPI.commRank MPI.commSelf-       size <- MPI.commSize MPI.commSelf-       rank == 0 && size == 1 @? ""-  , testCase "commWorld" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       rank >= 0 && rank < size @? ""-  ]----pointToPoint :: TestTree-pointToPoint = testGroup "point-to-point"-  [ testCase "sendrecv" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let sendmsg :: String = "Hello, World!"-       let sendrank = (rank + 1) `mod` size-       let recvrank = (rank - 1) `mod` size-       (status, recvmsg :: String) <--         MPI.sendrecv sendmsg sendrank MPI.unitTag recvrank MPI.unitTag-         MPI.commWorld-       (recvmsg == sendmsg &&-        MPI.msgRank status == recvrank &&-        MPI.msgTag status == MPI.unitTag) @? ""-  ]----pointToPointNonBlocking :: TestTree-pointToPointNonBlocking = testGroup "point-to-point non-blocking"-  [ testCase "send and recv" $-    do rank <- MPI.commRank MPI.commWorld-       size <- MPI.commSize MPI.commWorld-       let sendmsg :: String = "Hello, World!"-       let sendrank = (rank + 1) `mod` size-       sendreq <- MPI.isend sendmsg sendrank MPI.unitTag MPI.commWorld-       let recvrank = (rank - 1) `mod` size-       recvreq <- MPI.irecv recvrank MPI.unitTag MPI.commWorld-       (sendstatus, ()) <- MPI.wait sendreq-       (recvstatus, recvmsg :: String) <- MPI.wait recvreq-       (recvmsg == sendmsg &&-        MPI.msgRank sendstatus == sendrank &&-        MPI.msgTag sendstatus == MPI.unitTag &&-        MPI.msgRank recvstatus == recvrank &&-        MPI.msgTag recvstatus == MPI.unitTag) @? ""-  ]----collective :: TestTree-collective = testGroup "collective"-  [ testCase "barrier" $-    do MPI.barrier MPI.commWorld-  , testCase "bcast" $-    do rank <- MPI.commRank MPI.commWorld-       let sendmsg :: String = "Hello, World!"-       recvmsg :: String <--         if rank == MPI.rootRank-         then do MPI.bcastSend sendmsg MPI.rootRank MPI.commWorld-                 return sendmsg-         else do MPI.bcastRecv MPI.rootRank MPI.commWorld-       recvmsg == sendmsg @? ""-  ]----collectiveNonBlocking :: TestTree-collectiveNonBlocking = testGroup "collective non-blocking"-  [ testCase "barrier" $-    do req <- MPI.ibarrier MPI.commWorld-       MPI.wait_ req-  ]

@@ -0,0 +1,638 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import Data.IORef+import Foreign+import Foreign.C.Types+import System.Exit+import System.IO+-- import Test.Tasty+-- import Test.Tasty.HUnit++import qualified Control.Distributed.MPI as MPI++++--------------------------------------------------------------------------------++infix 1 @?+(@?) :: Bool -> String -> IO ()+x @? msg = if not x then die msg else return ()++infix 1 @?=+(@?=) :: Eq a => a -> a -> IO ()+x @?= y = x == y @? "test failed"++++type TestTree = IO ()++testCase :: String -> IO () -> TestTree+testCase name test =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ "  " ++ name ++ "..."+               hFlush stdout+       else return ()+     MPI.barrier MPI.commWorld+     test+     MPI.barrier MPI.commWorld++++testGroup :: String -> [TestTree] -> TestTree+testGroup name cases =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ name ++ ":"+               hFlush stdout+       else return ()+     sequence_ cases++++defaultMain :: TestTree -> IO ()+defaultMain tree =+  do rank <- MPI.commRank MPI.commWorld+     size <- MPI.commSize MPI.commWorld+     if rank == 0+       then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"+               hFlush stdout+       else return ()+     tree++++--------------------------------------------------------------------------------++++main :: IO ()+main = bracket+  (do _ <- MPI.initThread MPI.ThreadMultiple+      return ())+  (\_ -> MPI.finalize)+  (\_ -> defaultMain tests)++tests :: TestTree+tests = testGroup "MPI"+  [ initialized+  , rankSize+  , pointToPoint+  , pointToPointNonBlocking+  , collective+  , collectiveNonBlocking+  , reductions+  , dynamic+  ]++++initialized :: TestTree+initialized = testGroup "initialized"+  [ testCase "initialized" $+      do isInit <- MPI.initialized+         isInit @?= True+  , testCase "finalized" $+      do isFini <- MPI.finalized+         isFini @?= False+  ]++++rankSize :: TestTree+rankSize = testGroup "rank and size"+  [ testCase "commSelf" $+    do rank <- MPI.commRank MPI.commSelf+       size <- MPI.commSize MPI.commSelf+       rank == 0 && size == 1 @? ""+  , testCase "commWorld" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       rank >= 0 && rank < size @? ""+  ]++++pointToPoint :: TestTree+pointToPoint = testGroup "point-to-point"+  [ testCase "send and recv" $+    do rank <- MPI.commRank MPI.commWorld++       let msg = 42+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg++       MPI.send (buf, 1::Int) rank MPI.unitTag MPI.commWorld++       buf' <- mallocForeignPtr @CInt+       st <- MPI.recv (buf', 1::Int) rank MPI.unitTag MPI.commWorld+       msg' <- withForeignPtr buf' peek++       source <- MPI.getSource st+       tag <- MPI.getTag st+       count <- MPI.getCount st MPI.datatypeInt+       (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""+  , testCase "sendrecv" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld++       let msg = 42 + MPI.fromRank rank+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg++       buf' <- mallocForeignPtr @CInt++       st <- MPI.sendrecv+             (buf, 1::Int) ((rank + 1) `mod` size) MPI.unitTag+             (buf', 1::Int) ((rank - 1) `mod` size) MPI.unitTag+             MPI.commWorld++       msg' <- withForeignPtr buf' peek++       source <- MPI.getSource st+       tag <- MPI.getTag st+       count <- MPI.getCount st MPI.datatypeInt+       (msg' == 42 + MPI.fromRank ((rank - 1) `mod` size) &&+        source == (rank - 1) `mod` size &&+        tag == MPI.unitTag &&+        count == 1) @? ""+  ]++++pointToPointNonBlocking :: TestTree+pointToPointNonBlocking = testGroup "point-to-point non-blocking"+  [ testCase "send and recv" $+    do rank <- MPI.commRank MPI.commWorld++       let msg = 42+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg++       req <- MPI.isend (buf, 1::Int) rank MPI.unitTag MPI.commWorld++       buf' <- mallocForeignPtr @CInt+       req' <- MPI.irecv (buf', 1::Int) rank MPI.unitTag MPI.commWorld++       MPI.wait_ req+       st <- MPI.wait req'++       touchForeignPtr buf+       msg' <- withForeignPtr buf' peek++       source <- MPI.getSource st+       tag <- MPI.getTag st+       count <- MPI.getCount st MPI.datatypeInt+       (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""+  ]++++collective :: TestTree+collective = testGroup "collective"+  [ testCase "allgather" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtrArray @CInt sz+       MPI.allgather (buf, 1::Int) (buf', 1::Int) MPI.commWorld+       msgs' <- withForeignPtr buf' (peekArray sz)+       msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""+  , testCase "allreduce" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.allreduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld+       msg' <- withForeignPtr buf' peek+       msg' == sum [42 .. 42 + (sz-1)] @? ""+  , testCase "alltoall" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]+       buf <- mallocForeignPtrArray @CInt sz+       withForeignPtr buf $ \ptr -> pokeArray ptr msgs+       buf' <- mallocForeignPtrArray @CInt sz+       MPI.alltoall (buf, 1::Int) (buf', 1::Int) MPI.commWorld+       msgs' <- withForeignPtr buf' (peekArray sz)+       msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""+  , testCase "barrier" $+    MPI.barrier MPI.commWorld+  , testCase "bcast" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       MPI.bcast (buf, 1::Int) MPI.rootRank MPI.commWorld+       msg' <- withForeignPtr buf peek+       msg' == 42 @? ""+  , testCase "exscan" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.exscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld+       msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)+       msg' == sum [42 .. 42 + rk-1] @? ""+  , testCase "gather" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+       MPI.gather (buf, 1::Int) (buf', 1::Int) MPI.rootRank MPI.commWorld+       msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)+       (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""+  , testCase "reduce" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank+         MPI.commWorld+       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+  , testCase "scan" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.scan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld+       msg' <- withForeignPtr buf' peek+       msg' == sum [42 .. 42 + rk] @? ""+  , testCase "scatter" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msgs =+             if isroot then [42 + fromIntegral i | i <- [0 .. sz-1]] else []+       buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+       withForeignPtr buf $+         \ptr -> if isroot then pokeArray ptr msgs else return ()+       buf' <- mallocForeignPtr @CInt+       MPI.scatter (buf, 1::Int) (buf', 1::Int) MPI.rootRank MPI.commWorld+       msg' <- withForeignPtr buf' peek+       msg' == 42 + rk @? ""+  ]++++reductions :: TestTree+reductions = testGroup "reduction operations"+  [ testCase "max" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opMax MPI.rootRank+         MPI.commWorld+       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+       (if isroot then msg' == maximum [42 .. 42 + sz-1] else True) @? ""+  , testCase "min" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opMin MPI.rootRank+         MPI.commWorld+       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+       (if isroot then msg' == minimum [42 .. 42 + sz-1] else True) @? ""+  , testCase "sum" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       MPI.reduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank+         MPI.commWorld+       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+  ]++++collectiveNonBlocking :: TestTree+collectiveNonBlocking = testGroup "collective non-blocking"+  [ testCase "iallgather" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtrArray @CInt sz+       req <- MPI.iallgather (buf, 1::Int) (buf', 1::Int) MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msgs' <- withForeignPtr buf' (peekArray sz)+       msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""+  , testCase "iallreduce" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       req <- MPI.iallreduce (buf, 1::Int) (buf', 1::Int) MPI.opSum+              MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf' peek+       msg' == sum [42 .. 42 + (sz-1)] @? ""+  , testCase "ialltoall" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]+       buf <- mallocForeignPtrArray @CInt sz+       withForeignPtr buf $ \ptr -> pokeArray ptr msgs+       buf' <- mallocForeignPtrArray @CInt sz+       req <- MPI.ialltoall (buf, 1::Int) (buf', 1::Int) MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msgs' <- withForeignPtr buf' (peekArray sz)+       msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""+  , testCase "ibarrier" $+    do req <- MPI.ibarrier MPI.commWorld+       MPI.wait_ req+  , testCase "ibcast" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       req <- MPI.ibcast (buf, 1::Int) MPI.rootRank MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf peek+       msg' == 42 @? ""+  , testCase "iexscan" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       req <- MPI.iexscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)+       msg' == sum [42 .. 42 + rk-1] @? ""+  , testCase "igather" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+       req <- MPI.igather (buf, 1::Int) (buf', 1::Int) MPI.rootRank+              MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)+       (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""+  , testCase "ireduce" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       req <- MPI.ireduce (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.rootRank+              MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+       (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+  , testCase "iscan" $+    do rank <- MPI.commRank MPI.commWorld+       let rk = MPI.fromRank rank+       let msg = 42 + rk+       buf <- mallocForeignPtr @CInt+       withForeignPtr buf $ \ptr -> poke ptr msg+       buf' <- mallocForeignPtr @CInt+       req <- MPI.iscan (buf, 1::Int) (buf', 1::Int) MPI.opSum MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf' peek+       msg' == sum [42 .. 42 + rk] @? ""+  , testCase "iscatter" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let rk = MPI.fromRank rank+       let sz = MPI.fromRank size+       let isroot = rank == MPI.rootRank+       let msgs = [42 + fromIntegral i | i <- [0 .. sz-1]]+       buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+       withForeignPtr buf $ \ptr -> pokeArray ptr msgs+       buf' <- mallocForeignPtr @CInt+       req <- MPI.iscatter (buf, 1::Int) (buf', 1::Int) MPI.rootRank+              MPI.commWorld+       MPI.wait_ req+       touchForeignPtr buf+       msg' <- withForeignPtr buf' peek+       msg' == 42 + rk @? ""+  ]++++dynamic :: TestTree+dynamic = testGroup "dynamic"+  [ testCase "sequential" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld++       breq <- newIORef Nothing+       let signalDone =+             do r <- MPI.ibarrier MPI.commWorld+                writeIORef breq (Just r)+       let checkDone =+             do mreq <- readIORef breq+                case mreq of+                  Nothing -> return False+                  Just req -> MPI.test_ req++       sendreqs <- newIORef []+       let sendMsg dst =+             when (dst < size) $+             do buf <- mallocForeignPtr @CInt+                withForeignPtr buf $ \ptr -> poke ptr 42+                r <- MPI.isend (buf, 1::Int) dst MPI.unitTag MPI.commWorld+                modifyIORef' sendreqs ((buf, r) :)+       let drainSendQueue =+             do srs <- readIORef sendreqs+                srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs+                writeIORef sendreqs srs'+       let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+       let recvMsg st =+             do src <- MPI.getSource st+                buf <- mallocForeignPtr @CInt+                MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld++       -- each rank sends to the next+       when (rank == 0) $+         do sendMsg (rank + 1)+            signalDone++       untilM_+         (do drainSendQueue+             mst <- checkForMsg+             case mst of+               Nothing -> return ()+               Just st -> do recvMsg st+                             sendMsg (rank + 1)+                             signalDone+         )+         checkDone+  , testCase "tree" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld++       breq <- newIORef Nothing+       let signalDone =+             do r <- MPI.ibarrier MPI.commWorld+                writeIORef breq (Just r)+       let checkDone =+             do mreq <- readIORef breq+                case mreq of+                  Nothing -> return False+                  Just req -> MPI.test_ req++       sendreqs <- newIORef []+       let sendMsg dst =+             when (dst < size) $+             do buf <- mallocForeignPtr @CInt+                withForeignPtr buf $ \ptr -> poke ptr 42+                r <- MPI.isend (buf, 1::Int) dst MPI.unitTag MPI.commWorld+                modifyIORef' sendreqs ((buf, r) :)+       let drainSendQueue =+             do srs <- readIORef sendreqs+                srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs+                writeIORef sendreqs srs'+       let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+       let recvMsg st =+             do src <- MPI.getSource st+                buf <- mallocForeignPtr @CInt+                MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld++       -- rank r sends to 2*r+1 and 2*r+2+       when (rank == 0) $+         do sendMsg (2 * rank + 1)+            sendMsg (2 * rank + 2)+            signalDone++       untilM_+         (do drainSendQueue+             mst <- checkForMsg+             case mst of+               Nothing -> return ()+               Just st -> do recvMsg st+                             sendMsg (2 * rank + 1)+                             sendMsg (2 * rank + 2)+                             signalDone+         )+         checkDone+  , testCase "multi-threaded" $+    do mts <- MPI.threadSupport+       let Just ts = mts+       when (ts >= MPI.ThreadMultiple) $+         do rank <- MPI.commRank MPI.commWorld+            size <- MPI.commSize MPI.commWorld+     +            breq <- newEmptyMVar+            let signalDone =+                  do _ <- forkIO $+                       do req <- MPI.ibarrier MPI.commWorld+                          whileM_ (not <$> MPI.test_ req) yield+                          putMVar breq ()+                     return ()+            let checkDone = not <$> isEmptyMVar breq+     +            let sendMsg dst =+                  when (dst < size) $+                  do _ <- forkIO $+                       do buf <- mallocForeignPtr @CInt+                          withForeignPtr buf $ \ptr -> poke ptr 42+                          req <- MPI.isend (buf, 1::Int) dst MPI.unitTag+                                 MPI.commWorld+                          whileM_ (not <$> MPI.test_ req) yield+                     return ()+            let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+            let recvMsg st =+                  do src <- MPI.getSource st+                     buf <- mallocForeignPtr @CInt+                     MPI.recv_ (buf, 1::Int) src MPI.unitTag MPI.commWorld+     +            -- rank r sends to 2*r+1 and 2*r+2+            when (rank == 0) $+              do sendMsg (2 * rank + 1)+                 sendMsg (2 * rank + 2)+                 signalDone+     +            untilM_+              (do mst <- checkForMsg+                  case mst of+                    Nothing -> return ()+                    Just st -> do recvMsg st+                                  sendMsg (2 * rank + 1)+                                  sendMsg (2 * rank + 2)+                                  signalDone+                  yield+              )+              checkDone+  ]

@@ -0,0 +1,155 @@+{-# LANGUAGE ScopedTypeVariables #-}++import System.IO+import System.Exit++import qualified Control.Distributed.MPI.Packing as MPI++default (Int)++++--------------------------------------------------------------------------------++infix 1 @?+(@?) :: Bool -> String -> IO ()+x @? msg = if not x then die msg else return ()++infix 1 @?=+(@?=) :: Eq a => a -> a -> IO ()+x @?= y = x == y @? "test failed"++++type TestTree = IO ()++testCase :: String -> IO () -> TestTree+testCase name test =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ "  " ++ name ++ "..."+               hFlush stdout+       else return ()+     MPI.barrier MPI.commWorld+     test+     MPI.barrier MPI.commWorld++++testGroup :: String -> [TestTree] -> TestTree+testGroup name cases =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ name ++ ":"+               hFlush stdout+       else return ()+     sequence_ cases++++defaultMain :: TestTree -> IO ()+defaultMain tree =+  do rank <- MPI.commRank MPI.commWorld+     size <- MPI.commSize MPI.commWorld+     if rank == 0+       then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"+               hFlush stdout+       else return ()+     tree++++--------------------------------------------------------------------------------++++main :: IO ()+main = MPI.mainMPI $ defaultMain tests++tests :: TestTree+tests = testGroup "MPI"+  [ rankSize+  , pointToPoint+  , pointToPointNonBlocking+  , collective+  , collectiveNonBlocking+  ]++++rankSize :: TestTree+rankSize = testGroup "rank and size"+  [ testCase "commSelf" $+    do rank <- MPI.commRank MPI.commSelf+       size <- MPI.commSize MPI.commSelf+       rank == 0 && size == 1 @? ""+  , testCase "commWorld" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       rank >= 0 && rank < size @? ""+  ]++++pointToPoint :: TestTree+pointToPoint = testGroup "point-to-point"+  [ testCase "sendrecv" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       let sendrank = (rank + 1) `mod` size+       let recvrank = (rank - 1) `mod` size+       (status, recvmsg :: String) <-+         MPI.sendrecv sendmsg sendrank MPI.unitTag recvrank MPI.unitTag+         MPI.commWorld+       (recvmsg == sendmsg &&+        MPI.msgRank status == recvrank &&+        MPI.msgTag status == MPI.unitTag) @? ""+  ]++++pointToPointNonBlocking :: TestTree+pointToPointNonBlocking = testGroup "point-to-point non-blocking"+  [ testCase "send and recv" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       let sendrank = (rank + 1) `mod` size+       sendreq <- MPI.isend sendmsg sendrank MPI.unitTag MPI.commWorld+       let recvrank = (rank - 1) `mod` size+       recvreq <- MPI.irecv recvrank MPI.unitTag MPI.commWorld+       (sendstatus, ()) <- MPI.wait sendreq+       (recvstatus, recvmsg :: String) <- MPI.wait recvreq+       (recvmsg == sendmsg &&+        MPI.msgRank sendstatus == sendrank &&+        MPI.msgTag sendstatus == MPI.unitTag &&+        MPI.msgRank recvstatus == recvrank &&+        MPI.msgTag recvstatus == MPI.unitTag) @? ""+  ]++++collective :: TestTree+collective = testGroup "collective"+  [ testCase "barrier" $+    do MPI.barrier MPI.commWorld+  , testCase "bcast" $+    do rank <- MPI.commRank MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       recvmsg :: String <-+         if rank == MPI.rootRank+         then do MPI.bcastSend sendmsg MPI.rootRank MPI.commWorld+                 return sendmsg+         else do MPI.bcastRecv MPI.rootRank MPI.commWorld+       recvmsg == sendmsg @? ""+  ]++++collectiveNonBlocking :: TestTree+collectiveNonBlocking = testGroup "collective non-blocking"+  [ testCase "barrier" $+    do req <- MPI.ibarrier MPI.commWorld+       MPI.wait_ req+  ]

@@ -0,0 +1,155 @@+{-# LANGUAGE ScopedTypeVariables #-}++import System.IO+import System.Exit++import qualified Control.Distributed.MPI.Store as MPI++default (Int)++++--------------------------------------------------------------------------------++infix 1 @?+(@?) :: Bool -> String -> IO ()+x @? msg = if not x then die msg else return ()++infix 1 @?=+(@?=) :: Eq a => a -> a -> IO ()+x @?= y = x == y @? "test failed"++++type TestTree = IO ()++testCase :: String -> IO () -> TestTree+testCase name test =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ "  " ++ name ++ "..."+               hFlush stdout+       else return ()+     MPI.barrier MPI.commWorld+     test+     MPI.barrier MPI.commWorld++++testGroup :: String -> [TestTree] -> TestTree+testGroup name cases =+  do rank <- MPI.commRank MPI.commWorld+     if rank == 0+       then do putStrLn $ name ++ ":"+               hFlush stdout+       else return ()+     sequence_ cases++++defaultMain :: TestTree -> IO ()+defaultMain tree =+  do rank <- MPI.commRank MPI.commWorld+     size <- MPI.commSize MPI.commWorld+     if rank == 0+       then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"+               hFlush stdout+       else return ()+     tree++++--------------------------------------------------------------------------------++++main :: IO ()+main = MPI.mainMPI $ defaultMain tests++tests :: TestTree+tests = testGroup "MPI"+  [ rankSize+  , pointToPoint+  , pointToPointNonBlocking+  , collective+  , collectiveNonBlocking+  ]++++rankSize :: TestTree+rankSize = testGroup "rank and size"+  [ testCase "commSelf" $+    do rank <- MPI.commRank MPI.commSelf+       size <- MPI.commSize MPI.commSelf+       rank == 0 && size == 1 @? ""+  , testCase "commWorld" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       rank >= 0 && rank < size @? ""+  ]++++pointToPoint :: TestTree+pointToPoint = testGroup "point-to-point"+  [ testCase "sendrecv" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       let sendrank = (rank + 1) `mod` size+       let recvrank = (rank - 1) `mod` size+       (status, recvmsg :: String) <-+         MPI.sendrecv sendmsg sendrank MPI.unitTag recvrank MPI.unitTag+         MPI.commWorld+       (recvmsg == sendmsg &&+        MPI.msgRank status == recvrank &&+        MPI.msgTag status == MPI.unitTag) @? ""+  ]++++pointToPointNonBlocking :: TestTree+pointToPointNonBlocking = testGroup "point-to-point non-blocking"+  [ testCase "send and recv" $+    do rank <- MPI.commRank MPI.commWorld+       size <- MPI.commSize MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       let sendrank = (rank + 1) `mod` size+       sendreq <- MPI.isend sendmsg sendrank MPI.unitTag MPI.commWorld+       let recvrank = (rank - 1) `mod` size+       recvreq <- MPI.irecv recvrank MPI.unitTag MPI.commWorld+       (sendstatus, ()) <- MPI.wait sendreq+       (recvstatus, recvmsg :: String) <- MPI.wait recvreq+       (recvmsg == sendmsg &&+        MPI.msgRank sendstatus == sendrank &&+        MPI.msgTag sendstatus == MPI.unitTag &&+        MPI.msgRank recvstatus == recvrank &&+        MPI.msgTag recvstatus == MPI.unitTag) @? ""+  ]++++collective :: TestTree+collective = testGroup "collective"+  [ testCase "barrier" $+    do MPI.barrier MPI.commWorld+  , testCase "bcast" $+    do rank <- MPI.commRank MPI.commWorld+       let sendmsg :: String = "Hello, World!"+       recvmsg :: String <-+         if rank == MPI.rootRank+         then do MPI.bcastSend sendmsg MPI.rootRank MPI.commWorld+                 return sendmsg+         else do MPI.bcastRecv MPI.rootRank MPI.commWorld+       recvmsg == sendmsg @? ""+  ]++++collectiveNonBlocking :: TestTree+collectiveNonBlocking = testGroup "collective non-blocking"+  [ testCase "barrier" $+    do req <- MPI.ibarrier MPI.commWorld+       MPI.wait_ req+  ]