diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,13 +2,17 @@ [MPI](https://www.mpi-forum.org) bindings for Haskell -[![CircleCI](https://circleci.com/gh/eschnett/mpi-hs.svg?style=svg)](https://circleci.com/gh/eschnett/mpi-hs) +* [Github](https://github.com/eschnett/mpi-hs) +* [[Hackage]](http://hackage.haskell.org/package/mpi-hs) Haskell + package and documentation +* [![CircleCI](https://circleci.com/gh/eschnett/mpi-hs.svg?style=svg)](https://circleci.com/gh/eschnett/mpi-hs) ## Overview -MPI (the _Message Passing Interface_) is widely used standard for +MPI (the Message Passing Interface) is 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 @@ -61,3 +65,83 @@ putStrLn $ "This is process " ++ show rank ++ " of " ++ show size MPI.finalize ``` + + + +## Installing + +`mpi-hs` requires an external MPI library to be available on the +system. How to install such a library is beyond the scope of these +instructions. + + + +In many 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`: + +```yaml +extra-include-dirs: + - /usr/lib/openmpi/include +extra-lib-dirs: + - /usr/lib/openmpi/lib +``` + +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`: + +```yaml +extra-include-dirs: + - /opt/local/include/openmpi-mp +extra-lib-dirs: + - /opt/local/lib/openmpi-mp +``` + +Both these settings are there by default. + +### Testing the MPI installation + +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 +``` + +All three commands must complete without error, and the last command +must output something like + +``` +This is process 0 of 3 +This is process 1 of 3 +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.) + +If these commands do not work, then this needs to be corrected before +`mpi-hs` can work. If additional compiler options or libraries are +needed, then these need to be added to the `stack.yaml` configuration +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). 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 @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} @@ -8,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-type-defaults #-} #include @@ -81,10 +83,13 @@ -- functions could be exposed as well when needed.) module Control.Distributed.MPI - ( -- * Types, and associated functions constants + ( -- * Types, and associated functions and constants + -- ** Communication buffers + Buffer(..) + -- ** Communicators - Comm(..) + , Comm(..) , ComparisonResult(..) , commCompare , commRank @@ -101,7 +106,6 @@ -- ** Datatypes , Datatype(..) - , Pointer(..) -- TODO: use a module for this namespace , datatypeNull , datatypeByte @@ -200,6 +204,8 @@ , iprobe_ , irecv , isend + , requestGetStatus + , requestGetStatus_ , test , test_ @@ -235,7 +241,10 @@ import Prelude hiding (fromEnum, fst, init, toEnum) import qualified Prelude -import Control.Monad (liftM) +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B import Data.Coerce import Data.IORef import Data.Ix @@ -304,22 +313,36 @@ --- | A generic pointer-like type that supports converting to a 'Ptr'. --- This class describes the buffers used to send and receive messages. -class Pointer p where - withPtr :: Storable a => p a -> (Ptr a -> IO b) -> IO b +-- | A generic pointer-like type that supports converting to a 'Ptr', +-- and which knows the type and number of its elements. This class +-- describes the MPI buffers used to send and receive messages. +class Buffer buf where + type Elem buf + withPtrLenType :: buf -> (Ptr (Elem buf) -> Count -> Datatype -> IO a) -> IO a -instance Pointer Ptr where - withPtr p f = f p +instance (Storable a, HasDatatype a, Integral i) => Buffer (Ptr a, i) where + type Elem (Ptr a, i) = a + withPtrLenType (ptr, len) f = f ptr (toCount len) (getDatatype @a) -instance Pointer ForeignPtr where - withPtr = withForeignPtr +instance (Storable a, HasDatatype a, Integral i) => Buffer (ForeignPtr a, i) + where + type Elem (ForeignPtr a, i) = a + withPtrLenType (fptr, len) f = + withForeignPtr fptr $ \ptr -> f ptr (toCount len) (getDatatype @a) -instance Pointer StablePtr where - withPtr p f = f (castPtr (castStablePtrToPtr p)) +instance (Storable a, HasDatatype a, Integral i) => Buffer (StablePtr a, i) + where + type Elem (StablePtr a, i) = a + withPtrLenType (ptr, len) f = + f (castPtr (castStablePtrToPtr ptr)) (toCount len) (getDatatype @a) +instance Buffer B.ByteString where + type Elem B.ByteString = CChar + withPtrLenType bs f = + B.unsafeUseAsCStringLen bs $ \(ptr, len) -> f ptr (toCount len) datatypeByte + -- | An MPI communicator, wrapping @MPI_Comm@. A communicator defines -- an independent communication channel between a group of processes. -- Communicators need to be explicitly created and freed by the MPI @@ -594,18 +617,18 @@ -- | A type class mapping Haskell types to MPI datatypes. This is used -- to automatically determine the MPI datatype for communication -- buffers. -class HasDatatype a where datatype :: Datatype -instance HasDatatype CChar where datatype = datatypeChar -instance HasDatatype CDouble where datatype = datatypeDouble -instance HasDatatype CFloat where datatype = datatypeFloat -instance HasDatatype CInt where datatype = datatypeInt -instance HasDatatype CLLong where datatype = datatypeLongLongInt -instance HasDatatype CLong where datatype = datatypeLong -instance HasDatatype CShort where datatype = datatypeShort -instance HasDatatype CUChar where datatype = datatypeUnsignedChar -instance HasDatatype CUInt where datatype = datatypeUnsigned -instance HasDatatype CULong where datatype = datatypeUnsignedLong -instance HasDatatype CUShort where datatype = datatypeUnsignedShort +class HasDatatype a where getDatatype :: Datatype +instance HasDatatype CChar where getDatatype = datatypeChar +instance HasDatatype CDouble where getDatatype = datatypeDouble +instance HasDatatype CFloat where getDatatype = datatypeFloat +instance HasDatatype CInt where getDatatype = datatypeInt +instance HasDatatype CLLong where getDatatype = datatypeLongLongInt +instance HasDatatype CLong where getDatatype = datatypeLong +instance HasDatatype CShort where getDatatype = datatypeShort +instance HasDatatype CUChar where getDatatype = datatypeUnsignedChar +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 @@ -732,13 +755,13 @@ {#fun pure mpihs_get_sum as opSum {+} -> `Op'#} instance HasDatatype a => HasDatatype (Monoid.Product a) where - datatype = datatype @a + getDatatype = getDatatype @a instance HasDatatype a => HasDatatype (Monoid.Sum a) where - datatype = datatype @a + getDatatype = getDatatype @a instance HasDatatype a => HasDatatype (Semigroup.Max a) where - datatype = datatype @a + getDatatype = getDatatype @a instance HasDatatype a => HasDatatype (Semigroup.Min a) where - datatype = datatype @a + getDatatype = getDatatype @a -- class (Monoid a, HasDatatype a) => HasOp a where op :: Op -- instance (Num a, HasDatatype a) => HasOp (Monoid.Product a) where @@ -807,22 +830,16 @@ -- | Gather data from all processes and broadcast the result -- (collective, -- @[MPI_Allgather](https://www.open-mpi.org/doc/current/man3/MPI_Allgather.3.php)@). --- The MPI datatypes are determined automatically from the buffer --- pointer types. -allgather :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +allgather :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Comm -- ^ Communicator -> IO () -allgather sendbuf sendcount recvbuf recvcount comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - allgatherTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +allgather sendbuf recvbuf comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + allgatherTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype comm {#fun Allreduce as allreduceTyped @@ -839,18 +856,17 @@ -- @[MPI_Allreduce](https://www.open-mpi.org/doc/current/man3/MPI_Allreduce.3.php)@). -- The MPI datatype is determined automatically from the buffer -- pointer types. -allreduce :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +allreduce :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO () -allreduce sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - allreduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op +allreduce sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + allreduceTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op comm {#fun Alltoall as alltoallTyped @@ -867,20 +883,16 @@ -- @[MPI_Alltoall](https://www.open-mpi.org/doc/current/man3/MPI_Alltoall.php)@). -- The MPI datatypes are determined automatically from the buffer -- pointer types. -alltoall :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +alltoall :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Comm -- ^ Communicator -> IO () -alltoall sendbuf sendcount recvbuf recvcount comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - alltoallTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +alltoall sendbuf recvbuf comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + alltoallTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype comm -- | Barrier (collective, @@ -901,16 +913,15 @@ -- @[MPI_Bcast](https://www.open-mpi.org/doc/current/man3/MPI_Bcast.3.php)@). -- The MPI datatype is determined automatically from the buffer -- pointer type. -bcast :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Buffer pointer (read on the root process, written on - -- all other processes) - -> Count -- ^ Number of elements +bcast :: Buffer b + => b -- ^ Buffer (read on the root process, written on all other + -- processes) -> Rank -- ^ Root rank (sending process) -> Comm -- ^ Communicator -> IO () -bcast buf count root comm = - withPtr buf $ \buf' -> - bcastTyped (castPtr buf') count (datatype @a) root comm +bcast buf root comm = + withPtrLenType buf $ \ptr count datatype -> + bcastTyped (castPtr ptr) count datatype root comm -- | Compare two communicators -- (@[MPI_Comm_compare](https://www.open-mpi.org/doc/current/man3/MPI_Comm_compare.3.php)@). @@ -954,18 +965,17 @@ -- -- The MPI datatype is determined automatically from the buffer -- pointer type. -exscan :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +exscan :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO () -exscan sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - exscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm +exscan sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + exscanTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op comm -- | Finalize (shut down) the MPI library (collective, @[MPI_Finalize](https://www.open-mpi.org/doc/current/man3/MPI_Finalize.3.php)@). {#fun Finalize as ^ {} -> `()' return*-#} @@ -989,22 +999,17 @@ -- @[MPI_Gather](https://www.open-mpi.org/doc/current/man3/MPI_Gather.3.php)@). -- The MPI datatypes are determined automatically from the buffer -- pointer types. -gather :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer (only used on the root process) - -> Count -- ^ Number of destination elements (only used on the - -- root process) +gather :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer (only used on the root process) -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO () -gather sendbuf sendcount recvbuf recvcount root comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - gatherTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +gather sendbuf recvbuf root comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + gatherTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype root comm -- | Get the size of a message, in terms of objects of type 'Datatype' @@ -1014,7 +1019,7 @@ {#fun unsafe Get_count as ^ { withStatus* `Status' -- ^ Message status , withDatatype* %`Datatype' -- ^ MPI datatype - , alloca- `Int' peekInt* + , alloca- `Count' peekCoerce* } -> `()' return*-#} -- | Get the number of elements in message, in terms of sub-object of @@ -1096,20 +1101,16 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatypes are determined automatically from the buffer -- pointer types. -iallgather :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +iallgather :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -iallgather sendbuf sendcount recvbuf recvcount comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - iallgatherTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +iallgather sendbuf recvbuf comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + iallgatherTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype comm {#fun Iallreduce as iallreduceTyped @@ -1129,18 +1130,17 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatype is determined automatically from the buffer -- pointer types. -iallreduce :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +iallreduce :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -iallreduce sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - iallreduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op +iallreduce sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + iallreduceTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op comm {#fun Ialltoall as ialltoallTyped @@ -1161,20 +1161,16 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatypes are determined automatically from the buffer -- pointer types. -ialltoall :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +ialltoall :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -ialltoall sendbuf sendcount recvbuf recvcount comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - ialltoallTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +ialltoall sendbuf recvbuf comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + ialltoallTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype comm -- | Start a barrier, and return a handle to the communication request @@ -1202,16 +1198,15 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatype is determined automatically from the buffer -- pointer type. -ibcast :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Buffer pointer (read on the root process, written on - -- all other processes) - -> Count -- ^ Number of elements +ibcast :: Buffer b + => b -- ^ Buffer (read on the root process, written on all + -- other processes) -> Rank -- ^ Root rank (sending process) -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -ibcast buf count root comm = - withPtr buf $ \buf' -> - ibcastTyped (castPtr buf') count (datatype @a) root comm +ibcast buf root comm = + withPtrLenType buf $ \ptr count datatype-> + ibcastTyped (castPtr ptr) count datatype root comm {#fun Iexscan as iexscanTyped { id `Ptr ()' @@ -1236,18 +1231,18 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatype is determined automatically from the buffer -- pointer type. -iexscan :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +iexscan :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -iexscan sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - iexscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm +iexscan sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + iexscanTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op + comm {#fun Igather as igatherTyped { id `Ptr ()' @@ -1268,23 +1263,17 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatypes are determined automatically from the buffer -- pointer types. -igather :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer - -> Count -- ^ Number of source elements - -> q b -- ^ Destination buffer (relevant only - -- on the root process) - -> Count -- ^ Number of destination elements - -- (relevant only on the root process) +igather :: (Buffer rb, Buffer sb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer (relevant only on the root process) -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -igather sendbuf sendcount recvbuf recvcount root comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - igatherTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +igather sendbuf recvbuf root comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + igatherTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype root comm -- | Return whether the MPI library has been initialized @@ -1373,16 +1362,15 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatype is determined automatically from the buffer -- pointer type. -irecv :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Receive buffer - -> Count -- ^ Number of elements to receive +irecv :: Buffer rb + => rb -- ^ Receive buffer -> Rank -- ^ Source rank (may be 'anySource') -> Tag -- ^ Message tag (may be 'anyTag') -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -irecv recvbuf recvcount recvrank recvtag comm = - withPtr recvbuf $ \recvbuf' -> - irecvTyped (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm +irecv recvbuf recvrank recvtag comm = + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + irecvTyped (castPtr recvptr) recvcount recvdatatype recvrank recvtag comm {#fun Ireduce as ireduceTyped { id `Ptr ()' @@ -1401,20 +1389,19 @@ -- The result is only available on the root process. The request must -- be freed by calling 'test', 'wait', or similar. The MPI datatypes -- are determined automatically from the buffer pointer types. -ireduce :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +ireduce :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -ireduce sendbuf recvbuf count op rank comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - ireduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op rank - comm +ireduce sendbuf recvbuf op rank comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + ireduceTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op + rank comm {#fun Iscan as iscanTyped { id `Ptr ()' @@ -1434,18 +1421,17 @@ -- from rank @0@ to rank @r@ (inclusive). The request must be freed by -- calling 'test', 'wait', or similar. The MPI datatype is determined -- automatically from the buffer pointer type. -iscan :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +iscan :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -iscan sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - iscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm +iscan sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + iscanTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op comm {#fun Iscatter as iscatterTyped { id `Ptr ()' @@ -1466,21 +1452,17 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatypes are determined automatically from the buffer -- pointer types. -iscatter :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer (only used on the root process) - -> Count -- ^ Number of source elements (only used on the root process) - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +iscatter :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer (only used on the root process) + -> rb -- ^ Destination buffer -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -iscatter sendbuf sendcount recvbuf recvcount root comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - iscatterTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +iscatter sendbuf recvbuf root comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + iscatterTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype root comm {#fun Isend as isendTyped @@ -1499,16 +1481,15 @@ -- The request must be freed by calling 'test', 'wait', or similar. -- The MPI datatype is determined automatically from the buffer -- pointer type. -isend :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Send buffer - -> Count -- ^ Number of elements to send +isend :: Buffer sb + => sb -- ^ Send buffer -> Rank -- ^ Destination rank -> Tag -- ^ Message tag -> Comm -- ^ Communicator -> IO Request -- ^ Communication request -isend sendbuf sendcount sendrank sendtag comm = - withPtr sendbuf $ \sendbuf' -> - isendTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag comm +isend sendbuf sendrank sendtag comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + isendTyped (castPtr sendptr) sendcount senddatatype sendrank sendtag comm -- | Probe (wait) for an incoming message -- (@[MPI_Probe](https://www.open-mpi.org/doc/current/man3/MPI_Probe.3.php)@). @@ -1545,16 +1526,15 @@ -- (@[MPI_Recv](https://www.open-mpi.org/doc/current/man3/MPI_Recv.3.php)@). -- The MPI datatypeis determined automatically from the buffer -- pointer type. -recv :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Receive buffer - -> Count -- ^ Number of elements to receive +recv :: Buffer rb + => rb -- ^ Receive buffer -> Rank -- ^ Source rank (may be 'anySource') -> Tag -- ^ Message tag (may be 'anyTag') -> Comm -- ^ Communicator -> IO Status -- ^ Message status -recv recvbuf recvcount recvrank recvtag comm = - withPtr recvbuf $ \recvbuf' -> - recvTyped (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm +recv recvbuf recvrank recvtag comm = + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + recvTyped (castPtr recvptr) recvcount recvdatatype recvrank recvtag comm {#fun Recv as recvTyped_ { id `Ptr ()' @@ -1571,16 +1551,15 @@ -- The MPI datatype is determined automatically from the buffer -- pointer type. This function does not return a status, which might -- be more efficient if the status is not needed. -recv_ :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Receive buffer - -> Count -- ^ Number of elements to receive +recv_ :: Buffer rb + => rb -- ^ Receive buffer -> Rank -- ^ Source rank (may be 'anySource') -> Tag -- ^ Message tag (may be 'anyTag') -> Comm -- ^ Communicator -> IO () -recv_ recvbuf recvcount recvrank recvtag comm = - withPtr recvbuf $ \recvbuf' -> - recvTyped_ (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm +recv_ recvbuf recvrank recvtag comm = + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + recvTyped_ (castPtr recvptr) recvcount recvdatatype recvrank recvtag comm {#fun Reduce as reduceTyped { id `Ptr ()' @@ -1596,21 +1575,61 @@ -- @[MPI_Reduce](https://www.open-mpi.org/doc/current/man3/MPI_Reduce.3.php)@). -- The result is only available on the root process. The MPI datatypes -- are determined automatically from the buffer pointer types. -reduce :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +reduce :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO () -reduce sendbuf recvbuf count op rank comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - reduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op rank +reduce sendbuf recvbuf op rank comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + reduceTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op rank comm +requestGetStatusBool :: Request -> IO (Bool, Status) +requestGetStatusBool req = + withRequest req $ \req' -> + alloca $ \flag -> + do st <- Status <$> mallocForeignPtrBytes {#sizeof MPI_Status#} + withStatus st $ \st' -> + do _ <- {#call Request_get_status as requestGetStatusBool_#} + (castPtr req') flag st' + b <- peekBool flag + return (b, st) + +-- | Check whether a communication has completed without freeing the +-- communication request +-- (@[MPI_Request_get_status](https://www.open-mpi.org/doc/current/man3/MPI_Request_get_status.3.php)@). +requestGetStatus :: Request -- ^ Communication request + -> IO (Maybe Status) -- ^ 'Just' 'Status' if the + -- request has completed, else + -- 'Nothing' +requestGetStatus req = bool2maybe <$> requestGetStatusBool req + +-- {#fun Request_get_status as requestGetStatus_ +-- { withRequest* `Request' +-- , alloca- `Bool' peekBool* +-- , withStatusIgnore- `Status' +-- } -> `()' return*-#} + +-- | Check whether a communication has completed without freeing the +-- communication request +-- (@[MPI_Request_get_status](https://www.open-mpi.org/doc/current/man3/MPI_Request_get_status.3.php)@). +-- This function does not return a status, which might be more +-- efficient if the status is not needed. +requestGetStatus_ :: Request -- ^ Communication request + -> IO Bool -- ^ Whether the request had completed +requestGetStatus_ req = + withRequest req $ \req' -> + alloca $ \flag -> + withStatusIgnore $ \st -> + do _ <- {#call MPI_Request_get_status as requestGetStatus__#} + (castPtr req') flag st + peekBool flag + {#fun Scan as scanTyped { id `Ptr ()' , id `Ptr ()' @@ -1626,18 +1645,17 @@ -- Each process with rank @r@ receives the result of reducing data -- from rank @0@ to rank @r@ (inclusive). The MPI datatype is -- determined automatically from the buffer pointer type. -scan :: forall a p q. - ( Pointer p, Pointer q, Storable a, HasDatatype a) - => p a -- ^ Source buffer - -> q a -- ^ Destination buffer - -> Count -- ^ Number of elements +scan :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer + -> rb -- ^ Destination buffer -> Op -- ^ Reduction operation -> Comm -- ^ Communicator -> IO () -scan sendbuf recvbuf count op comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - scanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm +scan sendbuf recvbuf op comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + assert (sendcount == recvcount && senddatatype == recvdatatype) $ + scanTyped (castPtr sendptr) (castPtr recvptr) sendcount senddatatype op comm {#fun Scatter as scatterTyped { id `Ptr ()' @@ -1654,21 +1672,17 @@ -- @[MPI_Scatter](https://www.open-mpi.org/doc/current/man3/MPI_Scatter.3.php)@). -- The MPI datatypes are determined automatically from the buffer -- pointer types. -scatter :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Source buffer (only used on the root process) - -> Count -- ^ Number of source elements (only used on the root process) - -> q b -- ^ Destination buffer - -> Count -- ^ Number of destination elements +scatter :: (Buffer sb, Buffer rb) + => sb -- ^ Source buffer (only used on the root process) + -> rb -- ^ Destination buffer -> Rank -- ^ Root rank -> Comm -- ^ Communicator -> IO () -scatter sendbuf sendcount recvbuf recvcount root comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - scatterTyped (castPtr sendbuf') sendcount (datatype @a) - (castPtr recvbuf') recvcount (datatype @b) +scatter sendbuf recvbuf root comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + scatterTyped (castPtr sendptr) sendcount senddatatype + (castPtr recvptr) recvcount recvdatatype root comm {#fun Send as sendTyped @@ -1684,16 +1698,15 @@ -- (@[MPI_Send](https://www.open-mpi.org/doc/current/man3/MPI_Send.3.php)@). -- The MPI datatype is determined automatically from the buffer -- pointer type. -send :: forall a p. (Pointer p, Storable a, HasDatatype a) - => p a -- ^ Send buffer - -> Count -- ^ Number of elements to send +send :: Buffer sb + => sb -- ^ Send buffer -> Rank -- ^ Destination rank -> Tag -- ^ Message tag -> Comm -- ^ Communicator -> IO () -send sendbuf sendcount sendrank sendtag comm = - withPtr sendbuf $ \sendbuf' -> - sendTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag comm +send sendbuf sendrank sendtag comm = + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + sendTyped (castPtr sendptr) sendcount senddatatype sendrank sendtag comm {#fun Sendrecv as sendrecvTyped { id `Ptr ()' @@ -1714,26 +1727,22 @@ -- (@[MPI_Sendrecv](https://www.open-mpi.org/doc/current/man3/MPI_Sendrecv.3.php)@). -- The MPI datatypes are determined automatically from the buffer -- pointer types. -sendrecv :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Send buffer - -> Count -- ^ Number of elements to send +sendrecv :: (Buffer sb, Buffer rb) + => sb -- ^ Send buffer -> Rank -- ^ Destination rank -> Tag -- ^ Sent message tag - -> q b -- ^ Receive buffer - -> Count -- ^ Number of elements to receive + -> rb -- ^ Receive buffer -> Rank -- ^ Source rank (may be 'anySource') -> Tag -- ^ Received message tag (may be 'anyTag') -> Comm -- ^ Communicator -> IO Status -- ^ Status for received message -sendrecv sendbuf sendcount sendrank sendtag - recvbuf recvcount recvrank recvtag +sendrecv sendbuf sendrank sendtag + recvbuf recvrank recvtag comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - sendrecvTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag - (castPtr recvbuf') recvcount (datatype @b) recvrank recvtag + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + sendrecvTyped (castPtr sendptr) sendcount senddatatype sendrank sendtag + (castPtr recvptr) recvcount recvdatatype recvrank recvtag comm {#fun Sendrecv as sendrecvTyped_ @@ -1756,26 +1765,22 @@ -- The MPI datatypes are determined automatically from the buffer -- pointer types. This function does not return a status, which might -- be more efficient if the status is not needed. -sendrecv_ :: forall a b p q. - ( Pointer p, Pointer q - , Storable a, HasDatatype a, Storable b, HasDatatype b) - => p a -- ^ Send buffer - -> Count -- ^ Number of elements to send +sendrecv_ :: (Buffer sb, Buffer rb) + => sb -- ^ Send buffer -> Rank -- ^ Destination rank -> Tag -- ^ Sent message tag - -> q a -- ^ Receive buffer - -> Count -- ^ Number of elements to receive + -> rb -- ^ Receive buffer -> Rank -- ^ Source rank (may be 'anySource') -> Tag -- ^ Received message tag (may be 'anyTag') -> Comm -- ^ Communicator -> IO () -sendrecv_ sendbuf sendcount sendrank sendtag - recvbuf recvcount recvrank recvtag +sendrecv_ sendbuf sendrank sendtag + recvbuf recvrank recvtag comm = - withPtr sendbuf $ \sendbuf' -> - withPtr recvbuf $ \recvbuf' -> - sendrecvTyped_ (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag - (castPtr recvbuf') recvcount (datatype @b) recvrank recvtag + withPtrLenType sendbuf $ \sendptr sendcount senddatatype -> + withPtrLenType recvbuf $ \recvptr recvcount recvdatatype -> + sendrecvTyped_ (castPtr sendptr) sendcount senddatatype sendrank sendtag + (castPtr recvptr) recvcount recvdatatype recvrank recvtag comm testBool :: Request -> IO (Bool, Status) diff --git a/lib/Control/Distributed/MPI/Simple.hs b/lib/Control/Distributed/MPI/Simple.hs --- a/lib/Control/Distributed/MPI/Simple.hs +++ b/lib/Control/Distributed/MPI/Simple.hs @@ -1,69 +1,348 @@ +{-# 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 +-- Stability: experimental +-- Portability: Requires an externally installed MPI library + module Control.Distributed.MPI.Simple - ( MPIException(..) - , finalize - , init - , initThread + ( -- * 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 System.IO.Unsafe +import Foreign +import Foreign.C.Types import qualified Control.Distributed.MPI as MPI - - - -didInit :: MVar Bool -didInit = unsafePerformIO newEmptyMVar +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 () -finalize :: IO () -finalize = - do e <- isEmptyMVar didInit - if e - then throw (MPIException "Control flow error") - else return () - did <- takeMVar didInit - if did - then MPI.finalize - else return () -init :: IO () -init = - do e <- isEmptyMVar didInit - if not e - then throw (MPIException "Control flow error") - else return () - i <- MPI.initialized - if not i - then do MPI.init - putMVar didInit True - else putMVar didInit False +data DidInit = DidInit | DidNotInit -initThread :: MPI.ThreadSupport -> IO () -initThread threadSupport = - do e <- isEmptyMVar didInit - if not e - then throw (MPIException "Control flow error") - else return () - i <- MPI.initialized - if not i - then do ts <- MPI.initThread threadSupport - if ts < threadSupport - then throw $ MPIException - ("Insufficient thread support: caller required " ++ - show threadSupport ++ ", MPI library provided only " ++ - show ts) - else return () - putMVar didInit True - else putMVar didInit False +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) diff --git a/mpi-hs.cabal b/mpi-hs.cabal --- a/mpi-hs.cabal +++ b/mpi-hs.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a7b4d3931ec548e76111da431f03030741d23d3e21f765d151c2455add19efe5 +-- hash: 56b0d5d26cff8ef0c8754f17c3ab3709be1da2be1a0567c8d8a5b779b4b44e01 name: mpi-hs -version: 0.1.0.1 +version: 0.3.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 @@ -28,11 +28,17 @@ stored to 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 + [Stackage](https://www.stackage.org) should succeed -- if not, there + is an error in this package. category: Distributed Computing homepage: https://github.com/eschnett/mpi-hs#readme bug-reports: https://github.com/eschnett/mpi-hs/issues -author: Erik Schnetter -maintainer: Erik Schnetter +author: Erik Schnetter +maintainer: Erik Schnetter license: Apache-2.0 license-file: LICENSE build-type: Simple @@ -65,12 +71,15 @@ extra-libraries: mpi build-depends: - base >=4.11 && <4.12 + base >=4 && <5 + , bytestring + , monad-loops + , store build-tools: c2hs default-language: Haskell2010 -executable mpi-hs +executable example main-is: Main.hs other-modules: Paths_mpi_hs @@ -82,22 +91,32 @@ , mpi-hs default-language: Haskell2010 -test-suite mpi-hs-test-suite +test-suite mpi-simple-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Paths_mpi_hs hs-source-dirs: - test + test/simple ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base , monad-loops , mpi-hs - , tasty - , tasty-hspec - , tasty-hunit - , unix + default-language: Haskell2010 + +test-suite mpi-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_mpi_hs + hs-source-dirs: + test/mpi + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , monad-loops + , mpi-hs default-language: Haskell2010 benchmark mpi-hs-benchmarks diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,9 +1,9 @@ name: mpi-hs -version: '0.1.0.1' +version: '0.3.0.0' github: "eschnett/mpi-hs" license: Apache-2.0 -author: "Erik Schnetter" -maintainer: "Erik Schnetter" +author: "Erik Schnetter " +maintainer: "Erik Schnetter " category: Distributed Computing synopsis: MPI bindings for Haskell description: | @@ -29,6 +29,12 @@ 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 + [Stackage](https://www.stackage.org) should succeed -- if not, there + is an error in this package. + extra-source-files: - LICENSE - README.md @@ -42,11 +48,13 @@ library: dependencies: - - base >=4.11 && <4.12 + - base >=4 && <5 # tested with 4.11 and 4.12 + - bytestring + - monad-loops + - store build-tools: - c2hs - source-dirs: - - lib + source-dirs: lib c-sources: - c/src/mpihs.c include-dirs: @@ -55,7 +63,7 @@ - mpi executables: - mpi-hs: + example: source-dirs: src main: Main.hs dependencies: @@ -80,17 +88,32 @@ - -with-rtsopts=-N tests: - mpi-hs-test-suite: - source-dirs: test + mpi-tests: + source-dirs: test/mpi main: Main.hs dependencies: - base - monad-loops - mpi-hs - - tasty - - tasty-hunit - - tasty-hspec - - unix + # - tasty + # - tasty-hunit + # - tasty-hspec + # - unix + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + mpi-simple-tests: + source-dirs: test/simple + main: Main.hs + dependencies: + - base + - monad-loops + - 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,8 +1,11 @@ +# Resolver to choose a 'specific' stackage snapshot or a compiler version. resolver: lts-12.13 +# User packages to be built. packages: - . +# Extra directories used by stack for building extra-include-dirs: - /opt/local/include/openmpi-mp - /usr/lib/openmpi/include diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,629 +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 rank MPI.unitTag MPI.commWorld - - buf' <- mallocForeignPtr @CInt - st <- MPI.recv buf' 1 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 ((rank + 1) `mod` size) MPI.unitTag - buf' 1 ((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 rank MPI.unitTag MPI.commWorld - - buf' <- mallocForeignPtr @CInt - req' <- MPI.irecv buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 buf' 1 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 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 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 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 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 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 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 - ] diff --git a/test/mpi/Main.hs b/test/mpi/Main.hs new file mode 100644 --- /dev/null +++ b/test/mpi/Main.hs @@ -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 + ] diff --git a/test/simple/Main.hs b/test/simple/Main.hs new file mode 100644 --- /dev/null +++ b/test/simple/Main.hs @@ -0,0 +1,155 @@ +{-# 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 + ]