mpi-hs 0.1.0.1 → 0.3.0.0

raw patch · 9 files changed

+1556/−979 lines, 9 filesdep +bytestringdep +storedep −tastydep −tasty-hspecdep −tasty-hunitdep ~basenew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, store

Dependencies removed: tasty, tasty-hspec, tasty-hunit, unix

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +86/−2
• lib/Control/Distributed/MPI.chs +280/−275
• lib/Control/Distributed/MPI/Simple.hs +327/−48
• mpi-hs.cabal +31/−12
• package.yaml +36/−13
• stack.yaml +3/−0
• test/Main.hs +0/−629
• test/mpi/Main.hs +638/−0
• test/simple/Main.hs +155/−0

@@ -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)+* [<img alt="Github" src="share/GitHub_Logo.png" height="25"+  align="middle">](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.++<!---+(It is important that the MPI library's include files, libraries, and+executables are installed consistently. A common source of problems is+that there are several MPI implementations available on a system, and+that the default include file `mpi.h`, the library `libmpi.a`, and/or+the executable `mpirun` are provided by different implementations.+This will lead to various problems, often segfaults, since neither the+operating system nor these libraries provide any protection against+such a mismatch.)+-->++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).

@@ -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 <mpi.h>@@ -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)

@@ -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 <schnetter@gmail.com>+-- 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)

@@ -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 <schnetter@gmail.com>+maintainer:     Erik Schnetter <schnetter@gmail.com> 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

@@ -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 <schnetter@gmail.com>"+maintainer: "Erik Schnetter <schnetter@gmail.com>" 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

@@ -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

@@ -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-  ]

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

@@ -0,0 +1,155 @@+{-# LANGUAGE ScopedTypeVariables #-}++import System.IO+import System.Exit++import qualified Control.Distributed.MPI.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+  ]