diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,15 +8,15 @@ * [Stackage](https://www.stackage.org/package/mpi-hs): Stackage snapshots * [Azure - Pipelines](https://dev.azure.com/schnetter/ringal/_build): + Pipelines](https://dev.azure.com/schnetter/mpi-hs/_build): Build Status [![Build - Status](https://dev.azure.com/schnetter/mpi-hs/_apis/build/status/eschnett.mpi-hs?branchName=master)](https://dev.azure.com/schnetter/mpi-hs/_build/latest?definitionId=1&branchName=master) + Status](https://dev.azure.com/schnetter/mpi-hs/_apis/build/status/eschnett.mpi-hs?branchName=master)](https://dev.azure.com/schnetter/mpi-hs/_build/latest&branchName=master) ## Overview -MPI (the Message Passing Interface) is widely used standard for +MPI (the Message Passing Interface) is a widely used standard for distributed-memory programming on HPC (High Performance Computing) systems. MPI allows exchanging data (_messages_) between programs running in parallel. There are several high-quality open source MPI @@ -28,18 +28,19 @@ This library `mpi-hs` provides Haskell bindings for MPI. It is based on ideas taken from [haskell-mpi](https://github.com/bjpop/haskell-mpi), -[Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html), -and [MPI for Python](https://mpi4py.readthedocs.io/en/stable/). +[Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html) +for C++, and [MPI for +Python](https://mpi4py.readthedocs.io/en/stable/). `mpi-hs` provides two API levels: A low-level API gives rather direct -access to the MPI API, apart from certain "reasonable" mappings from C -to Haskell (e.g. output arguments that are in C stored to a pointer -are in Haskell regular return values). A high-level API simplifies -exchanging arbitrary values that can be serialized. +access to the actual MPI API, apart from certain "reasonable" mappings +from C to Haskell (e.g. output arguments that are in C stored via a +pointer are in Haskell regular return values). A high-level API +simplifies exchanging arbitrary values that can be serialized. -## Example +## Programming Example This is a typical MPI C code: ```C @@ -59,15 +60,15 @@ The Haskell equivalent looks like this: ```Haskell -import Control.Distributed.MPI as MPI +import qualified Control.Distributed.MPI as MPI main :: IO () -main = - do MPI.init - rank <- MPI.commRank MPI.commWorld - size <- MPI.commSize MPI.commWorld - putStrLn $ "This is process " ++ show rank ++ " of " ++ show size - MPI.finalize +main = do + MPI.init + rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + putStrLn $ "This is process " ++ show rank ++ " of " ++ show size + MPI.finalize ``` @@ -89,45 +90,53 @@ such a mismatch.) --> -In many cases, the MPI library will be installed in `/usr/include`, +In some cases, the MPI library will be installed in `/usr/include`, `/usr/lib`, and `/usr/bin`, respectively. In this case, no further configuration is necessary, and `mpi-hs` will build out of the box with `stack build`. -On Ubuntu, one MPI package is `openmpi-dev`. It installs into -`/usr/lib/openmpi/include`, `/usr/lib/openmpi/lib`, and `/usr/bin/`. -You need to ensure that these settings are present in `stack.yaml`: +For convenience, this package offers Cabal flags to handle several +common cases where the MPI library is not installed in a standard +location: -```yaml -extra-include-dirs: - - /usr/lib/openmpi/include -extra-lib-dirs: - - /usr/lib/openmpi/lib +- OpenMPI on Debian Linux (package `openmpi-dev`): use `--flag + mpi-hs:openmpi-debian` +- OpenMPI on Ubuntu Linux (package `openmpi-dev`): use `--flag + mpi-hs:openmpi-ubuntu` +- OpenMPI on macOS with MacPorts (package `openmpi`): use `--flag + mpi-hs:openmpi-macports` +- MPICH on Ubuntu Linux (package `mpich-dev`): use `--flag + mpi-hs:mpich-ubuntu` +- MPICH on macOS with MacPorts (package `mpich`): use `--flag + mpi-hs:mpich-macports` + +For example, using the MPICH MPI implementation installed via MacPorts +on macOS, you build `mpi-hs` like this: + +```sh +stack build --flag mpi-hs:mpich-macports ``` -On MacOS, one MPI package is the [MacPorts](https://www.macports.org) -package `openmpi`. It installs into `/opt/local/include/openmpi-mp`, -`/opt/local/lib/openmpi-mp`, and `/opt/local/bin`. You need to ensure -that these settings are present in `stack.yaml`: +In the general case, if your MPI library/operating system combination +is not supported by a Cabal flag, you need to describe the location of +your MPI library in `stack.yaml`. This might look like: ```yaml extra-include-dirs: - - /opt/local/include/openmpi-mp + - /usr/lib/openmpi/include extra-lib-dirs: - - /opt/local/lib/openmpi-mp + - /usr/lib/openmpi/lib ``` -Both these settings are there by default. - -### Testing the MPI installation +### Testing the MPI installation with a C program To test your MPI installation independently of using Haskell, copy the example MPI C code into a file `mpi-example.c`, and run these commands: ```sh -cc -I/usr/lib/openmpi/include -c mpi-example.c -cc -o mpi-example mpi-example.o -L/usr/lib/openmpi/lib -lmpi -mpirun -np 3 ./mpi-example +mpicc -c mpi-example.c +mpicc -o mpi-example mpi-example.o +mpiexec -n 3 ./mpi-example ``` All three commands must complete without error, and the last command @@ -139,9 +148,9 @@ This is process 2 of 3 ``` -where the order in which the lines are printed can be random. (The -output might even be jumbled, i.e. the characters of the three lines -might be mixed up.) +where the lines will be output in a random order. (The output might +even be jumbled, i.e. the characters in these three lines might be +mixed up.) If these commands do not work, then this needs to be corrected before `mpi-hs` can work. If additional compiler options or libraries are @@ -160,36 +169,33 @@ ``` stack build -mpirun-openmpi-mp -np 3 stack exec example && echo SUCCESS || echo FAILURE +mpiexec -n 3 stack exec example ``` -With OpenMPI, and when running on a single node (e.g. on a laptop or a -workstation), these additional `mpirun` options might be useful: +### Running the tests +There are two test cases provided in `tests`. The first (`mpi-test`) +tests the low-level API, the second (`mpi-test-storable`) tests the +high-level API: + ``` -mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec example && echo SUCCESS || echo FAILURE +stack build --test --no-run-tests +mpiexec -n 3 stack exec -- $(stack path --dist-dir)/build/mpi-test/mpi-test +mpiexec -n 3 stack exec -- $(stack path --dist-dir)/build/mpi-test-storable/mpi-test-storable ``` -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 four test cases provided in `tests`: + diff --git a/lib/Control/Distributed/MPI.chs b/lib/Control/Distributed/MPI.chs --- a/lib/Control/Distributed/MPI.chs +++ b/lib/Control/Distributed/MPI.chs @@ -248,7 +248,6 @@ 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 @@ -372,10 +371,8 @@ -- | The result of comparing two MPI communicator (see 'commCompare'). {#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. @@ -388,8 +385,6 @@ 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) @@ -483,8 +478,6 @@ | 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)) @@ -573,8 +566,6 @@ newtype Tag = Tag CInt 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)) @@ -605,8 +596,6 @@ -- multi-threaded, and different threads might call MPI at the same -- time {#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 diff --git a/lib/Control/Distributed/MPI/Binary.hs b/lib/Control/Distributed/MPI/Binary.hs deleted file mode 100644 --- a/lib/Control/Distributed/MPI/Binary.hs +++ /dev/null @@ -1,403 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeApplications #-} - --- | Module: Control.Distributed.MPI.Binary --- Description: Simplified MPI bindings with automatic serialization --- based on Data.Binary --- Copyright: (C) 2018 Erik Schnetter --- License: Apache-2.0 --- Maintainer: Erik Schnetter --- Stability: experimental --- Portability: Requires an externally installed MPI library - -module Control.Distributed.MPI.Binary - ( -- * 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 - , ibcastRecv - , ibcastSend - ) where - -import Prelude hiding (init) - -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.Loops -import qualified Data.Binary as Binary -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Unsafe as B -import Data.Coerce -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.Binary -type CanSerialize a = Binary.Binary a -serialize :: CanSerialize a => a -> IO B.ByteString -serialize = return . BL.toStrict . Binary.encode -deserialize :: CanSerialize a => B.ByteString -> IO a -deserialize = return . Binary.decode . BL.fromStrict - --- Why is this necessary? Shouldn't 'Data.Binary' already contain --- this? -instance Binary.Binary CInt where - put x = Binary.put @Int32 (coerce x) - get = coerce <$> (Binary.get @Int32) -instance Binary.Binary Rank - - - --- | 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 - -- Use 'unsafeUseAsCStringLen' to ensure 'sendbuf' is not freed - -- too early - B.unsafeUseAsCStringLen sendbuf $ \_ -> - do 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 - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - len <- withForeignPtr lenbuf peek - ptr <- mallocBytes (fromIntegral len) - recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len) - req <- MPI.ibcast recvbuf root comm - whileM_ (not <$> MPI.test_ req) yield - 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)) - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - req <- MPI.ibcast sendbuf root comm - whileM_ (not <$> MPI.test_ req) yield - -ibcastRecv :: CanSerialize a - => Rank - -> Comm - -> IO (Request a) -ibcastRecv root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do recvobj <- bcastRecv root comm - putMVar result (Status root MPI.anyTag, recvobj) - return (Request result) - -ibcastSend :: CanSerialize a - => a - -> Rank - -> Comm - -> IO (Request ()) -ibcastSend sendobj root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do bcastSend sendobj root comm - putMVar result (Status root MPI.anyTag, ()) - return (Request result) - --- | Begin a barrier. Call 'test' or 'wait' to finish the --- communication. -ibarrier :: Comm - -> IO (Request ()) -ibarrier comm = - do result <- newEmptyMVar - _ <- forkIO $ - do req <- MPI.ibarrier comm - whileM_ (not <$> MPI.test_ req) yield - putMVar result (Status MPI.anySource MPI.anyTag, ()) - return (Request result) diff --git a/lib/Control/Distributed/MPI/Serialize.hs b/lib/Control/Distributed/MPI/Serialize.hs deleted file mode 100644 --- a/lib/Control/Distributed/MPI/Serialize.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeApplications #-} - --- | Module: Control.Distributed.MPI.Serialize --- Description: Simplified MPI bindings with automatic serialization --- based on Data.Serialize --- Copyright: (C) 2018 Erik Schnetter --- License: Apache-2.0 --- Maintainer: Erik Schnetter --- Stability: experimental --- Portability: Requires an externally installed MPI library - -module Control.Distributed.MPI.Serialize - ( -- * 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 - , ibcastRecv - , ibcastSend - ) 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.Serialize as Serialize -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 = Serialize.Serialize a -serialize :: CanSerialize a => a -> IO B.ByteString -serialize = return . Serialize.encode -deserialize :: CanSerialize a => B.ByteString -> IO a -deserialize buf = - do let obj = Serialize.decode buf - case obj of - Left str -> throwIO $ - MPIException ("Data.Serialize.decode failed: " ++ str) - Right x -> return x - - - --- | 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 - -- Use 'unsafeUseAsCStringLen' to ensure 'sendbuf' is not freed - -- too early - B.unsafeUseAsCStringLen sendbuf $ \_ -> - do 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 - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - len <- withForeignPtr lenbuf peek - ptr <- mallocBytes (fromIntegral len) - recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len) - req <- MPI.ibcast recvbuf root comm - whileM_ (not <$> MPI.test_ req) yield - 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)) - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - req <- MPI.ibcast sendbuf root comm - whileM_ (not <$> MPI.test_ req) yield - -ibcastRecv :: CanSerialize a - => Rank - -> Comm - -> IO (Request a) -ibcastRecv root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do recvobj <- bcastRecv root comm - putMVar result (Status root MPI.anyTag, recvobj) - return (Request result) - -ibcastSend :: CanSerialize a - => a - -> Rank - -> Comm - -> IO (Request ()) -ibcastSend sendobj root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do bcastSend sendobj root comm - putMVar result (Status root MPI.anyTag, ()) - return (Request result) - --- | Begin a barrier. Call 'test' or 'wait' to finish the --- communication. -ibarrier :: Comm - -> IO (Request ()) -ibarrier comm = - do result <- newEmptyMVar - _ <- forkIO $ - do req <- MPI.ibarrier comm - whileM_ (not <$> MPI.test_ req) yield - putMVar result (Status MPI.anySource MPI.anyTag, ()) - return (Request result) diff --git a/lib/Control/Distributed/MPI/Store.hs b/lib/Control/Distributed/MPI/Store.hs deleted file mode 100644 --- a/lib/Control/Distributed/MPI/Store.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# 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 --- 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 - , ibcastRecv - , ibcastSend - ) 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 - -- Use 'unsafeUseAsCStringLen' to ensure 'sendbuf' is not freed - -- too early - B.unsafeUseAsCStringLen sendbuf $ \_ -> - do 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 - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - len <- withForeignPtr lenbuf peek - ptr <- mallocBytes (fromIntegral len) - recvbuf <- B.unsafePackMallocCStringLen (ptr, fromIntegral len) - req <- MPI.ibcast recvbuf root comm - whileM_ (not <$> MPI.test_ req) yield - 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)) - lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm - whileM_ (not <$> MPI.test_ lenreq) yield - req <- MPI.ibcast sendbuf root comm - whileM_ (not <$> MPI.test_ req) yield - -ibcastRecv :: CanSerialize a - => Rank - -> Comm - -> IO (Request a) -ibcastRecv root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do recvobj <- bcastRecv root comm - putMVar result (Status root MPI.anyTag, recvobj) - return (Request result) - -ibcastSend :: CanSerialize a - => a - -> Rank - -> Comm - -> IO (Request ()) -ibcastSend sendobj root comm = - do result <- newEmptyMVar - _ <- forkIO $ - do bcastSend sendobj root comm - putMVar result (Status root MPI.anyTag, ()) - return (Request result) - --- | Begin a barrier. Call 'test' or 'wait' to finish the --- communication. -ibarrier :: Comm - -> IO (Request ()) -ibarrier comm = - do result <- newEmptyMVar - _ <- forkIO $ - do req <- MPI.ibarrier comm - whileM_ (not <$> MPI.test_ req) yield - putMVar result (Status MPI.anySource MPI.anyTag, ()) - return (Request result) diff --git a/mpi-hs.cabal b/mpi-hs.cabal --- a/mpi-hs.cabal +++ b/mpi-hs.cabal @@ -4,14 +4,14 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ee6f377d4c7367443da512ba5c7dde6e0d0b3b95fa95e877b323a37f99ddba84 +-- hash: 11b62fed3be3a0f857f2e02c4f51e8d2161fe465d5ef830539f21ba83ba7fb5d name: mpi-hs -version: 0.5.3.0 +version: 0.6.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 - Performance Computing) systems. MPI allows exchanging data +description: MPI (the [Message Passinag Interface](https://www.mpi-forum.org)) is + a widely used standard for distributed-memory programming on HPC + (High Performance Computing) systems. MPI allows exchanging data (_messages_) between programs running in parallel. There are several high-quality open source MPI implementations (e.g. MPICH, MVAPICH, OpenMPI) as well as a variety of closed-source implementations. @@ -21,19 +21,20 @@ This library @mpi-hs@ provides Haskell bindings for MPI. It is based on ideas taken from [haskell-mpi](https://github.com/bjpop/haskell-mpi), - [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html), - and [MPI for Python](https://mpi4py.readthedocs.io/en/stable/). + [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html) + for C++, and [MPI for + Python](https://mpi4py.readthedocs.io/en/stable/). . @mpi-hs@ provides two API levels: A low-level API gives rather - direct access to the MPI API, apart from certain "reasonable" + direct access to the actual MPI API, apart from certain "reasonable" mappings from C to Haskell (e.g. output arguments that are in C - stored to a pointer are in Haskell regular return values). A + stored via a pointer are in Haskell regular return values). A high-level API simplifies exchanging arbitrary values that can be serialized. . Note that the automated builds on [Hackage](http://hackage.haskell.org) will currently always fail - since no MPI library is present there. However, builds on + since no system MPI library is present there. However, builds on [Stackage](https://www.stackage.org) should succeed -- if not, there is an error in this package. category: Distributed Computing @@ -69,25 +70,22 @@ flag openmpi-debian description: Use OpenMPI on Debian manual: True - default: True + default: False flag openmpi-macports description: Use OpenMPI on MacPorts manual: True - default: True + default: False flag openmpi-ubuntu description: Use OpenMPI on Ubuntu manual: True - default: True + default: False library exposed-modules: Control.Distributed.MPI - Control.Distributed.MPI.Binary - Control.Distributed.MPI.Serialize Control.Distributed.MPI.Storable - Control.Distributed.MPI.Store other-modules: Paths_mpi_hs hs-source-dirs: @@ -101,11 +99,8 @@ c2hs build-depends: base >=4 && <5 - , binary , bytestring - , cereal , monad-loops - , store if flag(openmpi-debian) include-dirs: /usr/lib/x86_64-linux-gnu/openmpi/include @@ -152,7 +147,6 @@ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base - , binary , mpi-hs if flag(openmpi-debian) include-dirs: @@ -240,102 +234,6 @@ mpich default-language: Haskell2010 -test-suite mpi-test-binary - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_mpi_hs - hs-source-dirs: - tests/binary - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , mpi-hs - if flag(openmpi-debian) - include-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/include - extra-lib-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/lib - extra-libraries: - mpi - if flag(openmpi-macports) - include-dirs: - /opt/local/include/openmpi-mp - extra-lib-dirs: - /opt/local/lib/openmpi-mp - extra-libraries: - mpi - if flag(openmpi-ubuntu) - include-dirs: - /usr/lib/openmpi/include - extra-lib-dirs: - /usr/lib/openmpi/lib - extra-libraries: - mpi - if flag(mpich-macports) - include-dirs: - /opt/local/include/mpich-gcc9 - extra-lib-dirs: - /opt/local/lib/mpich-gcc9 - extra-libraries: - mpi - if flag(mpich-ubuntu) - include-dirs: - /usr/lib/mpich/include - extra-lib-dirs: - /usr/lib/mpich/lib - extra-libraries: - mpich - default-language: Haskell2010 - -test-suite mpi-test-serialize - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_mpi_hs - hs-source-dirs: - tests/serialize - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , mpi-hs - if flag(openmpi-debian) - include-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/include - extra-lib-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/lib - extra-libraries: - mpi - if flag(openmpi-macports) - include-dirs: - /opt/local/include/openmpi-mp - extra-lib-dirs: - /opt/local/lib/openmpi-mp - extra-libraries: - mpi - if flag(openmpi-ubuntu) - include-dirs: - /usr/lib/openmpi/include - extra-lib-dirs: - /usr/lib/openmpi/lib - extra-libraries: - mpi - if flag(mpich-macports) - include-dirs: - /opt/local/include/mpich-gcc9 - extra-lib-dirs: - /opt/local/lib/mpich-gcc9 - extra-libraries: - mpi - if flag(mpich-ubuntu) - include-dirs: - /usr/lib/mpich/include - extra-lib-dirs: - /usr/lib/mpich/lib - extra-libraries: - mpich - default-language: Haskell2010 - test-suite mpi-test-storable type: exitcode-stdio-1.0 main-is: Main.hs @@ -343,54 +241,6 @@ Paths_mpi_hs hs-source-dirs: tests/storable - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , mpi-hs - if flag(openmpi-debian) - include-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/include - extra-lib-dirs: - /usr/lib/x86_64-linux-gnu/openmpi/lib - extra-libraries: - mpi - if flag(openmpi-macports) - include-dirs: - /opt/local/include/openmpi-mp - extra-lib-dirs: - /opt/local/lib/openmpi-mp - extra-libraries: - mpi - if flag(openmpi-ubuntu) - include-dirs: - /usr/lib/openmpi/include - extra-lib-dirs: - /usr/lib/openmpi/lib - extra-libraries: - mpi - if flag(mpich-macports) - include-dirs: - /opt/local/include/mpich-gcc9 - extra-lib-dirs: - /opt/local/lib/mpich-gcc9 - extra-libraries: - mpi - if flag(mpich-ubuntu) - include-dirs: - /usr/lib/mpich/include - extra-lib-dirs: - /usr/lib/mpich/lib - extra-libraries: - mpich - 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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: mpi-hs -version: '0.5.3.0' +version: '0.6.0.0' github: "eschnett/mpi-hs" license: Apache-2.0 author: "Erik Schnetter " @@ -7,31 +7,32 @@ category: Distributed Computing 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 - Performance Computing) systems. MPI allows exchanging data + MPI (the [Message Passinag Interface](https://www.mpi-forum.org)) is + a widely used standard for distributed-memory programming on HPC + (High Performance Computing) systems. MPI allows exchanging data (_messages_) between programs running in parallel. There are several high-quality open source MPI implementations (e.g. MPICH, MVAPICH, OpenMPI) as well as a variety of closed-source implementations. These libraries can typically make use of high-bandwidth low-latency communication hardware such as InfiniBand. - + This library @mpi-hs@ provides Haskell bindings for MPI. It is based on ideas taken from [haskell-mpi](https://github.com/bjpop/haskell-mpi), - [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html), - and [MPI for Python](https://mpi4py.readthedocs.io/en/stable/). - + [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html) + for C++, and [MPI for + Python](https://mpi4py.readthedocs.io/en/stable/). + @mpi-hs@ provides two API levels: A low-level API gives rather - direct access to the MPI API, apart from certain "reasonable" + direct access to the actual MPI API, apart from certain "reasonable" mappings from C to Haskell (e.g. output arguments that are in C - stored to a pointer are in Haskell regular return values). A + stored via a pointer are in Haskell regular return values). A high-level API simplifies exchanging arbitrary values that can be serialized. Note that the automated builds on [Hackage](http://hackage.haskell.org) will currently always fail - since no MPI library is present there. However, builds on + since no system MPI library is present there. However, builds on [Stackage](https://www.stackage.org) should succeed -- if not, there is an error in this package. @@ -39,15 +40,15 @@ openmpi-debian: description: Use OpenMPI on Debian manual: true - default: true + default: false openmpi-macports: description: Use OpenMPI on MacPorts manual: true - default: true + default: false openmpi-ubuntu: description: Use OpenMPI on Ubuntu manual: true - default: true + default: false mpich-macports: description: Use MPICH on MacPorts manual: true @@ -70,12 +71,9 @@ library: dependencies: - - base >=4 && <5 # tested with 4.11 and 4.12 - - binary + - base >=4 && <5 # tested with 4.11, 4.12, 4.13 - bytestring - - cereal - monad-loops - - store build-tools: - c2hs source-dirs: lib @@ -127,7 +125,6 @@ main: Main.hs dependencies: - base - - binary - mpi-hs ghc-options: - -rtsopts @@ -155,66 +152,16 @@ - base - monad-loops - mpi-hs - # - tasty - # - tasty-hunit - # - tasty-hspec - # - unix ghc-options: - -rtsopts - -threaded - -with-rtsopts=-N - mpi-test-binary: - source-dirs: tests/binary - main: Main.hs - dependencies: - - base - - mpi-hs - # - tasty - # - tasty-hunit - # - tasty-hspec - # - unix - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N - mpi-test-serialize: - source-dirs: tests/serialize - main: Main.hs - dependencies: - - base - - mpi-hs - # - tasty - # - tasty-hunit - # - tasty-hspec - # - unix - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N mpi-test-storable: source-dirs: tests/storable main: Main.hs dependencies: - base - 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 - # - tasty-hspec - # - unix ghc-options: - -rtsopts - -threaded diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Resolver to choose a 'specific' stackage snapshot or a compiler version. -resolver: lts-14.4 -# resolver: nightly-2019-09-02 +resolver: lts-15.5 +# resolver: nightly-2020-03-24 # User packages to be built. packages: diff --git a/tests/binary/Main.hs b/tests/binary/Main.hs deleted file mode 100644 --- a/tests/binary/Main.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import System.IO -import System.Exit - -import qualified Control.Distributed.MPI.Binary 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 - , testCase "bcast" $ - do rank <- MPI.commRank MPI.commWorld - let sendmsg :: String = "Hello, World!" - recvmsg :: String <- - if rank == MPI.rootRank - then do req <- MPI.ibcastSend sendmsg MPI.rootRank MPI.commWorld - MPI.wait_ req - return sendmsg - else do req <- MPI.ibcastRecv MPI.rootRank MPI.commWorld - MPI.wait_ req - recvmsg == sendmsg @? "" - ] diff --git a/tests/serialize/Main.hs b/tests/serialize/Main.hs deleted file mode 100644 --- a/tests/serialize/Main.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import System.IO -import System.Exit - -import qualified Control.Distributed.MPI.Serialize 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 - , testCase "bcast" $ - do rank <- MPI.commRank MPI.commWorld - let sendmsg :: String = "Hello, World!" - recvmsg :: String <- - if rank == MPI.rootRank - then do req <- MPI.ibcastSend sendmsg MPI.rootRank MPI.commWorld - MPI.wait_ req - return sendmsg - else do req <- MPI.ibcastRecv MPI.rootRank MPI.commWorld - MPI.wait_ req - recvmsg == sendmsg @? "" - ] diff --git a/tests/store/Main.hs b/tests/store/Main.hs deleted file mode 100644 --- a/tests/store/Main.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# 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 - , testCase "bcast" $ - do rank <- MPI.commRank MPI.commWorld - let sendmsg :: String = "Hello, World!" - recvmsg :: String <- - if rank == MPI.rootRank - then do req <- MPI.ibcastSend sendmsg MPI.rootRank MPI.commWorld - MPI.wait_ req - return sendmsg - else do req <- MPI.ibcastRecv MPI.rootRank MPI.commWorld - MPI.wait_ req - recvmsg == sendmsg @? "" - ]