mpi-hs 0.5.1.2 → 0.5.2.0

raw patch · 10 files changed

+1260/−162 lines, 10 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +13/−9
• c/include/mpihs.h +0/−4
• c/src/mpihs.c +0/−6
• lib/Control/Distributed/MPI.chs +213/−108
• lib/Control/Distributed/MPI/Storable.hs +397/−0
• mpi-hs.cabal +322/−12
• package.yaml +74/−10
• stack.yaml +2/−1
• tests/mpi/Main.hs +18/−12
• tests/storable/Main.hs +221/−0

@@ -5,9 +5,12 @@ * [GitHub](https://github.com/eschnett/mpi-hs): Source code repository * [Hackage](http://hackage.haskell.org/package/mpi-hs): Haskell   package and documentation-* [CircleCI](https://circleci.com/gh/eschnett/mpi-hs): Continuous-  integration-  [![CircleCI](https://circleci.com/gh/eschnett/mpi-hs.svg?style=svg)](https://circleci.com/gh/eschnett/mpi-hs)+* [Stackage](https://www.stackage.org/package/mpi-hs): Stackage+  snapshots+* [Azure+  Pipelines](https://dev.azure.com/schnetter/ringal/_build):+  Build Status [![Build+  Status](https://dev.azure.com/schnetter/mpi-hs/_apis/build/status/eschnett.mpi-hs?branchName=master)](https://dev.azure.com/schnetter/mpi-hs/_build/latest?definitionId=1&branchName=master)   @@ -157,14 +160,14 @@  ``` stack build-mpirun -np 3 stack exec example && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 stack exec example && echo SUCCESS || echo FAILURE ```  With OpenMPI, and when running on a single node (e.g. on a laptop or a workstation), these additional `mpirun` options might be useful:  ```-mpirun -np 3 --mca btl self,vader --oversubscribe stack exec example && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec example && echo SUCCESS || echo FAILURE ```  The options `--mca btl self,vader` enable the shared memory byte@@ -184,8 +187,9 @@  ``` stack build --test --no-run-tests-mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test/mpi-test && echo SUCCESS || echo FAILURE-mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test-binary/mpi-test-binary && echo SUCCESS || echo FAILURE-mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test-serialize/mpi-test-serialize && echo SUCCESS || echo FAILURE-mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec $(stack path --dist-dir)/build/mpi-test-store/mpi-test-store && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec -- $(stack path --dist-dir)/build/mpi-test/mpi-test && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec -- $(stack path --dist-dir)/build/mpi-test-binary/mpi-test-binary && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec -- $(stack path --dist-dir)/build/mpi-test-serialize/mpi-test-serialize && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec -- $(stack path --dist-dir)/build/mpi-test-storable/mpi-test-storable && echo SUCCESS || echo FAILURE+mpirun-openmpi-mp -np 3 --mca btl self,vader --oversubscribe stack exec -- $(stack path --dist-dir)/build/mpi-test-store/mpi-test-store && echo SUCCESS || echo FAILURE ```

@@ -70,8 +70,4 @@ // Tag int mpihs_get_any_tag(); -// Wrappers-int mpihs_iprobe(int source, int tag, MPI_Comm *comm, int *flag,-                 MPI_Status *status);- #endif // #ifndef MPIHS_H

@@ -67,9 +67,3 @@  // Tag int mpihs_get_any_tag() { return MPI_ANY_TAG; }--// Wrappers-int mpihs_iprobe(int source, int tag, MPI_Comm *comm, int *flag,-                 MPI_Status *status) {-  return MPI_Iprobe(source, tag, *comm, flag, status);-}

@@ -350,12 +350,27 @@ -- Communicators need to be explicitly created and freed by the MPI -- library. 'commWorld' is a communicator that is always available, -- and which includes all processes.-{#pointer *MPI_Comm as Comm foreign newtype#} -deriving instance Eq Comm-deriving instance Ord Comm-deriving instance Show Comm+newtype Comm = Comm CComm+  deriving (Eq, Ord, Show) +type CComm = {#type MPI_Comm#}++-- Pass a communicator directly+fromComm :: Comm -> CComm+fromComm (Comm ccomm) = ccomm++-- Pass a communicator as pointer+withComm :: Comm -> (Ptr CComm -> IO a) -> IO a+withComm (Comm ccomm) f =+  alloca $ \ptr -> do poke ptr ccomm+                      f ptr+-- Read a communicator from a pointer+peekComm :: Ptr CComm -> IO Comm+peekComm ptr =+  do ccomm <- peek ptr+     return (Comm ccomm)+ -- | The result of comparing two MPI communicator (see 'commCompare'). {#enum ComparisonResult {} deriving (Eq, Ord, Read, Show, Generic)#} @@ -391,14 +406,29 @@ -- explicitly created and freed by the MPI library. Predefined -- datatypes exist for most simple C types such as 'CInt' or -- 'CDouble'.-{#pointer *MPI_Datatype as Datatype foreign newtype#} -deriving instance Eq Datatype-deriving instance Ord Datatype-deriving instance Show Datatype+newtype Datatype = Datatype CDatatype+  deriving (Eq, Ord, Show) +type CDatatype = {#type MPI_Datatype#} +-- Pass a datatype directly+fromDatatype :: Datatype -> CDatatype+fromDatatype (Datatype cdatatype) = cdatatype +-- Pass a datatype as pointer+withDatatype :: Datatype -> (Ptr CDatatype -> IO a) -> IO a+withDatatype (Datatype cdatatype) f =+  alloca $ \ptr -> do poke ptr cdatatype+                      f ptr+-- Read a datatype from a pointer+peekDatatype :: Ptr CDatatype -> IO Datatype+peekDatatype ptr =+  do cdatatype <- peek ptr+     return (Datatype cdatatype)+++ -- | An MPI reduction operation, wrapping @MPI_Op@. Reduction -- operations need to be explicitly created and freed by the MPI -- library. Predefined operation exist for simple semigroups such as@@ -406,14 +436,29 @@ -- -- An MPI reduction operation corresponds to a Semigroup, not a -- Monoid, i.e. MPI has no notion of a respective neutral element.-{#pointer *MPI_Op as Op foreign newtype#} -deriving instance Eq Op-deriving instance Ord Op-deriving instance Show Op+newtype Op = Op COp+  deriving (Eq, Ord, Show) +type COp = {#type MPI_Op#} +-- Pass a operator directly+fromOp :: Op -> COp+fromOp (Op cop) = cop +-- Pass a operator as pointer+withOp :: Op -> (Ptr COp -> IO a) -> IO a+withOp (Op cop) f =+  alloca $ \ptr -> do poke ptr cop+                      f ptr+-- Read a operator from a pointer+peekOp :: Ptr COp -> IO Op+peekOp ptr =+  do cop <- peek ptr+     return (Op cop)+++ -- | A newtype wrapper describing the source or destination of a -- message, i.e. a process. Each communicator numbers its processes -- sequentially starting from zero. Use 'toRank' and 'fromRank' to@@ -459,14 +504,34 @@ -- | An MPI request, wrapping @MPI_Request@. A request describes a -- communication that is currently in progress. Each request must be -- explicitly freed via 'cancel', 'test', or 'wait'.-{#pointer *MPI_Request as Request foreign newtype#}+--+-- Some MPI functions modify existing requests. The new requests are+-- never interesting, and will not be returned.+--+-- TODO: Handle 'Comm', 'Datatype' etc. in this way as well (all+-- except 'Status').+newtype Request = Request CRequest+  deriving (Eq, Ord, Show) -deriving instance Eq Request-deriving instance Ord Request-deriving instance Show Request+type CRequest = {#type MPI_Request#} +-- Pass a request directly+fromRequest :: Request -> CRequest+fromRequest (Request creq) = creq +-- Pass a request as pointer+withRequest :: Request -> (Ptr CRequest -> IO a) -> IO a+withRequest (Request creq) f =+  alloca $ \ptr -> do poke ptr creq+                      f ptr+-- Read a request from a pointer+peekRequest :: Ptr CRequest -> IO Request+peekRequest ptr =+  do creq <- peek ptr+     return (Request creq) ++ -- | An MPI status, wrapping @MPI_Status@. The status describes -- certain properties of a message. It contains information such as -- the source of a communication ('getSource'), the message tag@@ -563,15 +628,21 @@   -- | A null (invalid) communicator (@MPI_COMM_NULL@).-{#fun pure mpihs_get_comm_null as commNull {+} -> `Comm'#}+{#fun pure mpihs_get_comm_null as commNull+   { alloca- `Comm' peekComm*+   } -> `()'#}  -- | The self communicator (@MPI_COMM_SELF@). Each process has its own -- self communicator that includes only this process.-{#fun pure mpihs_get_comm_self as commSelf {+} -> `Comm'#}+{#fun pure mpihs_get_comm_self as commSelf+   { alloca- `Comm' peekComm*+   } -> `()'#}  -- | The world communicator, which includes all processes -- (@MPI_COMM_WORLD@).-{#fun pure mpihs_get_comm_world as commWorld {+} -> `Comm'#}+{#fun pure mpihs_get_comm_world as commWorld+    { alloca- `Comm' peekComm*+    } -> `()'#}   @@ -583,47 +654,75 @@   -- | A null (invalid) datatype.-{#fun pure mpihs_get_datatype_null as datatypeNull {+} -> `Datatype'#}+{#fun pure mpihs_get_datatype_null as datatypeNull+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for a byte (essentially 'CUChar') (@MPI_BYTE@).-{#fun pure mpihs_get_byte as datatypeByte {+} -> `Datatype'#}+{#fun pure mpihs_get_byte as datatypeByte+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CChar' (@MPI_CHAR@).-{#fun pure mpihs_get_char as datatypeChar {+} -> `Datatype'#}+{#fun pure mpihs_get_char as datatypeChar+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CDouble' (@MPI_DOUBLE@).-{#fun pure mpihs_get_double as datatypeDouble {+} -> `Datatype'#}+{#fun pure mpihs_get_double as datatypeDouble+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CFloat' (@MPI_FLOAT@).-{#fun pure mpihs_get_float as datatypeFloat {+} -> `Datatype'#}+{#fun pure mpihs_get_float as datatypeFloat+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CInt' (@MPI_INT@).-{#fun pure mpihs_get_int as datatypeInt {+} -> `Datatype'#}+{#fun pure mpihs_get_int as datatypeInt+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CLong' (@MPI_LONG@).-{#fun pure mpihs_get_long as datatypeLong {+} -> `Datatype'#}+{#fun pure mpihs_get_long as datatypeLong+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for the C type 'long double' (@MPI_LONG_DOUBLE@).-{#fun pure mpihs_get_long_double as datatypeLongDouble {+} -> `Datatype'#}+{#fun pure mpihs_get_long_double as datatypeLongDouble+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CLLong' (@MPI_LONG_LONG_INT@). (There is no MPI -- datatype for 'CULLong@).-{#fun pure mpihs_get_long_long_int as datatypeLongLongInt {+} -> `Datatype'#}+{#fun pure mpihs_get_long_long_int as datatypeLongLongInt+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CShort' (@MPI_SHORT@).-{#fun pure mpihs_get_short as datatypeShort {+} -> `Datatype'#}+{#fun pure mpihs_get_short as datatypeShort+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CUInt' (@MPI_UNSIGNED@).-{#fun pure mpihs_get_unsigned as datatypeUnsigned {+} -> `Datatype'#}+{#fun pure mpihs_get_unsigned as datatypeUnsigned+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CUChar' (@MPI_UNSIGNED_CHAR@).-{#fun pure mpihs_get_unsigned_char as datatypeUnsignedChar {+} -> `Datatype'#}+{#fun pure mpihs_get_unsigned_char as datatypeUnsignedChar+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CULong' (@MPI_UNSIGNED_LONG@).-{#fun pure mpihs_get_unsigned_long as datatypeUnsignedLong {+} -> `Datatype'#}+{#fun pure mpihs_get_unsigned_long as datatypeUnsignedLong+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | MPI datatype for 'CUShort' (@MPI_UNSIGNED_SHORT@).-{#fun pure mpihs_get_unsigned_short as datatypeUnsignedShort {+} -> `Datatype'#}+{#fun pure mpihs_get_unsigned_short as datatypeUnsignedShort+    { alloca- `Datatype' peekDatatype*+    } -> `()'#}  -- | A type class mapping Haskell types to MPI datatypes. This is used -- to automatically determine the MPI datatype for communication@@ -644,45 +743,71 @@   -- | A null (invalid) reduction operation (@MPI_OP_NULL@).-{#fun pure mpihs_get_op_null as opNull {+} -> `Op'#}+{#fun pure mpihs_get_op_null as opNull+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The bitwise and @(.&.)@ reduction operation (@MPI_BAND@).-{#fun pure mpihs_get_band as opBand {+} -> `Op'#}+{#fun pure mpihs_get_band as opBand+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The bitwise or @(.|.)@ reduction operation (@MPI_BOR@).-{#fun pure mpihs_get_bor as opBor {+} -> `Op'#}+{#fun pure mpihs_get_bor as opBor+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The bitwise (@xor@) reduction operation (@MPI_BXOR@).-{#fun pure mpihs_get_bxor as opBxor {+} -> `Op'#}+{#fun pure mpihs_get_bxor as opBxor+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The logical and @(&&)@ reduction operation (@MPI_LAND@).-{#fun pure mpihs_get_land as opLand {+} -> `Op'#}+{#fun pure mpihs_get_land as opLand+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The logical or @(||)@ reduction operation (@MPI_LOR@).-{#fun pure mpihs_get_lor as opLor {+} -> `Op'#}+{#fun pure mpihs_get_lor as opLor+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The logical xor reduction operation (@MPI_LXOR@).-{#fun pure mpihs_get_lxor as opLxor {+} -> `Op'#}+{#fun pure mpihs_get_lxor as opLxor+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The 'maximum' reduction operation (@MPI_MAX@).-{#fun pure mpihs_get_max as opMax {+} -> `Op'#}+{#fun pure mpihs_get_max as opMax+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The argmax reduction operation to find the maximum and its rank -- (@MPI_MAXLOC@).-{#fun pure mpihs_get_maxloc as opMaxloc {+} -> `Op'#}+{#fun pure mpihs_get_maxloc as opMaxloc+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The 'minimum' reduction operation (@MPI_MIN@).-{#fun pure mpihs_get_min as opMin {+} -> `Op'#}+{#fun pure mpihs_get_min as opMin+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The argmin reduction operation to find the minimum and its rank -- (@MPI_MINLOC@).-{#fun pure mpihs_get_minloc as opMinloc {+} -> `Op'#}+{#fun pure mpihs_get_minloc as opMinloc+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The (@product@) reduction operation (@MPI_PROD@).-{#fun pure mpihs_get_prod as opProd {+} -> `Op'#}+{#fun pure mpihs_get_prod as opProd+    {alloca- `Op' peekOp*+    } -> `()'#}  -- | The (@sum@) reduction operation (@MPI_SUM@).-{#fun pure mpihs_get_sum as opSum {+} -> `Op'#}+{#fun pure mpihs_get_sum as opSum+    {alloca- `Op' peekOp*+    } -> `()'#}  instance HasDatatype a => HasDatatype (Monoid.Product a) where   getDatatype = getDatatype @a@@ -714,7 +839,9 @@   -- | A null (invalid) request (@MPI_REQUEST_NULL@).-{#fun pure mpihs_get_request_null as requestNull {+} -> `Request'#}+{#fun mpihs_get_request_null as requestNull+    { alloca- `Request' peekRequest*+    } -> `()'#}   @@ -1021,8 +1148,8 @@     , fromCount `Count'     , withDatatype* %`Datatype'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to gather data from all processes and broadcast the result, -- and return a handle to the communication request (collective,@@ -1050,8 +1177,8 @@     , withDatatype* %`Datatype'     , withOp* %`Op'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to reduce data from all processes and broadcast the result, -- and return a handle to the communication request (collective,@@ -1081,8 +1208,8 @@     , fromCount `Count'     , withDatatype* %`Datatype'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to send data from all processes to all processes, and -- return a handle to the communication request (collective,@@ -1109,8 +1236,8 @@ -- The request must be freed by calling 'test', 'wait', or similar. {#fun Ibarrier as ^     { withComm* %`Comm'         -- ^ Communicator-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  {#fun Ibcast as ibcastTyped     { id `Ptr ()'@@ -1118,8 +1245,8 @@     , withDatatype* %`Datatype'     , fromRank `Rank'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to broadcast data from one process to all processes, and -- return a handle to the communication request (collective,@@ -1145,8 +1272,8 @@     , withDatatype* %`Datatype'     , withOp* %`Op'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to reduce data from all processes via an exclusive (prefix) -- scan, and return a handle to the communication request (collective,@@ -1183,8 +1310,8 @@     , withDatatype* %`Datatype'     , fromRank `Rank'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to gather data from all processes to the root process, and -- return a handle to the communication request (collective,@@ -1241,12 +1368,11 @@  iprobeBool :: Rank -> Tag -> Comm -> IO (Bool, Status) iprobeBool rank tag comm =-  withComm comm $ \comm' ->   do st <- Status <$> mallocForeignPtrBytes {#sizeof MPI_Status#}      withStatus st $ \st' ->        do alloca $ \flag ->-            do _ <- {#call mpihs_iprobe as iprobeBool_#}-                    (fromRank rank) (fromTag tag) comm' flag st'+            do _ <- {#call Iprobe as iprobeBool_#}+                    (fromRank rank) (fromTag tag) (fromComm comm) flag st'                b <- peekBool flag                return (b, st) @@ -1269,11 +1395,10 @@         -> Comm                 -- ^ Communicator         -> IO Bool              -- ^ Whether a message is available iprobe_ rank tag comm =-  withComm comm $ \comm' ->   do withStatusIgnore $ \st ->        do alloca $ \flag ->-            do _ <- {#call mpihs_iprobe as iprobe__#}-                    (fromRank rank) (fromTag tag) comm' flag st+            do _ <- {#call Iprobe as iprobe__#}+                    (fromRank rank) (fromTag tag) (fromComm comm) flag st                peekBool flag  {#fun Irecv as irecvTyped@@ -1283,8 +1408,8 @@     , fromRank `Rank'     , fromTag `Tag'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to receive a message, and return a handle to the -- communication request (non-blocking,@@ -1310,8 +1435,8 @@     , withOp* %`Op'     , fromRank `Rank'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to reduce data from all processes, and return a handle to -- the communication request (collective, non-blocking,@@ -1340,8 +1465,8 @@     , withDatatype* %`Datatype'     , withOp* %`Op'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to reduce data from all processes via an (inclusive) scan, -- and return a handle to the communication request (collective,@@ -1372,8 +1497,8 @@     , withDatatype* %`Datatype'     , fromRank `Rank'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to scatter data from the root process to all processes, and -- return a handle to the communication request (collective,@@ -1402,8 +1527,8 @@     , fromRank `Rank'     , fromTag `Tag'     , withComm* %`Comm'-    , +-    } -> `Request' return*#}+    , alloca- `Request' peekRequest*+    } -> `()' return*-#}  -- | Begin to send a message, and return a handle to the -- communication request (non-blocking,@@ -1521,12 +1646,11 @@  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'+               (fromRequest req) flag st'           b <- peekBool flag           return (b, st) @@ -1539,26 +1663,16 @@                                       -- '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 Request_get_status as requestGetStatus_+    { fromRequest `Request'+    , alloca- `Bool' peekBool*+    , withStatusIgnore- `Status'+    } -> `()' return*-#}  {#fun Scan as scanTyped     { id `Ptr ()'@@ -1731,25 +1845,16 @@                           -- else 'Nothing' test req = bool2maybe <$> testBool req --- {#fun Test as test_---     { withRequest* `Request'---     , alloca- `Bool' peekBool*---     , withStatusIgnore- `Status'---     } -> `()' return*-#}- -- | Check whether a communication has completed, and free the -- communication request if so -- (@[MPI_Test](https://www.open-mpi.org/doc/current/man3/MPI_Test.3.php)@). -- This function does not return a status, which might be more -- efficient if the status is not needed.-test_ :: Request                -- ^ Communication request-      -> IO Bool                -- ^ Whether the request had completed-test_ req =-  withRequest req $ \req' ->-  alloca $ \flag ->-  withStatusIgnore $ \st ->-  do _ <- {#call Test as test__#} req' flag st-     peekBool flag+{#fun Test as test_+    { withRequest* `Request'+    , alloca- `Bool' peekBool*+    , withStatusIgnore- `Status'+    } -> `()' return*-#}  -- | Wait for a communication request to complete, then free the --  request

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

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: 2892e584ed19468e7f909cfad89e55d2e462d95a62b97faba37aa84634bfa800+-- hash: bb746d0a792e8c143d590f5127622e58947f2ebf3f393bca193a0d0a34446f72  name:           mpi-hs-version:        0.5.1.2+version:        0.5.2.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@@ -56,11 +56,37 @@   type: git   location: https://github.com/eschnett/mpi-hs +flag mpich-macports+  description: Use MPICH on MacPorts+  manual: True+  default: False++flag mpich-ubuntu+  description: Use MPICH on Ubuntu+  manual: True+  default: False++flag openmpi-debian+  description: Use OpenMPI on Debian+  manual: True+  default: True++flag openmpi-macports+  description: Use OpenMPI on MacPorts+  manual: True+  default: True++flag openmpi-ubuntu+  description: Use OpenMPI on Ubuntu+  manual: True+  default: True+ library   exposed-modules:       Control.Distributed.MPI       Control.Distributed.MPI.Binary       Control.Distributed.MPI.Serialize+      Control.Distributed.MPI.Storable       Control.Distributed.MPI.Store   other-modules:       Paths_mpi_hs@@ -69,17 +95,8 @@   ghc-options: -Wall   include-dirs:       c/include-      /usr/lib/x86_64-linux-gnu/openmpi/include-      /opt/local/include/openmpi-mp-      /usr/lib/openmpi/include   c-sources:       c/src/mpihs.c-  extra-lib-dirs:-      /usr/lib/x86_64-linux-gnu/openmpi/lib-      /opt/local/lib/openmpi-mp-      /usr/lib/openmpi/lib-  extra-libraries:-      mpi   build-tools:       c2hs   build-depends:@@ -89,6 +106,41 @@     , cereal     , monad-loops     , store+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010  executable example@@ -102,6 +154,41 @@       base     , binary     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010  test-suite mpi-test@@ -116,6 +203,41 @@       base     , monad-loops     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010  test-suite mpi-test-binary@@ -129,6 +251,41 @@   build-depends:       base     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010  test-suite mpi-test-serialize@@ -142,8 +299,91 @@   build-depends:       base     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010 +test-suite mpi-test-storable+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_mpi_hs+  hs-source-dirs:+      tests/storable+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich+  default-language: Haskell2010+ test-suite mpi-test-store   type: exitcode-stdio-1.0   main-is: Main.hs@@ -155,6 +395,41 @@   build-depends:       base     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010  benchmark mpi-hs-benchmarks@@ -169,4 +444,39 @@       base     , criterion     , mpi-hs+  if flag(openmpi-debian)+    include-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+        /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+        mpi+  if flag(openmpi-macports)+    include-dirs:+        /opt/local/include/openmpi-mp+    extra-lib-dirs:+        /opt/local/lib/openmpi-mp+    extra-libraries:+        mpi+  if flag(openmpi-ubuntu)+    include-dirs:+        /usr/lib/openmpi/include+    extra-lib-dirs:+        /usr/lib/openmpi/lib+    extra-libraries:+        mpi+  if flag(mpich-macports)+    include-dirs:+        /opt/local/include/mpich-gcc9+    extra-lib-dirs:+        /opt/local/lib/mpich-gcc9+    extra-libraries:+        mpi+  if flag(mpich-ubuntu)+    include-dirs:+        /usr/lib/mpich/include+    extra-lib-dirs:+        /usr/lib/mpich/lib+    extra-libraries:+        mpich   default-language: Haskell2010

@@ -1,5 +1,5 @@ name: mpi-hs-version: '0.5.1.2'+version: '0.5.2.0' github: "eschnett/mpi-hs" license: Apache-2.0 author: "Erik Schnetter <schnetter@gmail.com>"@@ -35,6 +35,28 @@   [Stackage](https://www.stackage.org) should succeed -- if not, there   is an error in this package. +flags:+  openmpi-debian:+    description: Use OpenMPI on Debian+    manual: true+    default: true+  openmpi-macports:+    description: Use OpenMPI on MacPorts+    manual: true+    default: true+  openmpi-ubuntu:+    description: Use OpenMPI on Ubuntu+    manual: true+    default: true+  mpich-macports:+    description: Use MPICH on MacPorts+    manual: true+    default: false+  mpich-ubuntu:+    description: Use MPICH on Ubuntu+    manual: true+    default: false+ extra-source-files:   - LICENSE   - README.md@@ -61,16 +83,44 @@     - c/src/mpihs.c   include-dirs:     - c/include-    - /usr/lib/x86_64-linux-gnu/openmpi/include # Debian-    - /opt/local/include/openmpi-mp             # MacPorts-    - /usr/lib/openmpi/include                  # Ubuntu-  extra-lib-dirs:-    - /usr/lib/x86_64-linux-gnu/openmpi/lib # Debian-    - /opt/local/lib/openmpi-mp             # MacPorts-    - /usr/lib/openmpi/lib                  # Ubuntu-  extra-libraries:-    - mpi +when:+  - condition: flag(openmpi-debian)+    include-dirs:+      - /usr/lib/x86_64-linux-gnu/openmpi/include+    extra-lib-dirs:+      - /usr/lib/x86_64-linux-gnu/openmpi/lib+    extra-libraries:+      - mpi+  - condition: flag(openmpi-macports)+    include-dirs:+      - /opt/local/include/openmpi-mp+    extra-lib-dirs:+      - /opt/local/lib/openmpi-mp+    extra-libraries:+      - mpi+  - condition: flag(openmpi-ubuntu)+    include-dirs:+      - /usr/lib/openmpi/include+    extra-lib-dirs:+      - /usr/lib/openmpi/lib+    extra-libraries:+      - mpi+  - condition: flag(mpich-macports)+    include-dirs:+      - /opt/local/include/mpich-gcc9+    extra-lib-dirs:+      - /opt/local/lib/mpich-gcc9+    extra-libraries:+      - mpi+  - condition: flag(mpich-ubuntu)+    include-dirs:+      - /usr/lib/mpich/include+    extra-lib-dirs:+      - /usr/lib/mpich/lib+    extra-libraries:+      - mpich+ executables:   example:     source-dirs: src@@ -129,6 +179,20 @@       - -with-rtsopts=-N   mpi-test-serialize:     source-dirs: tests/serialize+    main: Main.hs+    dependencies:+      - base+      - mpi-hs+      # - tasty+      # - tasty-hunit+      # - tasty-hspec+      # - unix+    ghc-options:+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N+  mpi-test-storable:+    source-dirs: tests/storable     main: Main.hs     dependencies:       - base

@@ -1,5 +1,6 @@ # Resolver to choose a 'specific' stackage snapshot or a compiler version.-resolver: lts-13.7+resolver: lts-14.4+# resolver: nightly-2019-09-02  # User packages to be built. packages:

@@ -122,21 +122,27 @@ pointToPoint = testGroup "point-to-point"   [ testCase "send and recv" $     do rank <- MPI.commRank MPI.commWorld-+       size <- MPI.commSize 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) @? ""+       +       if rank + 1 < size+         then MPI.send (buf, 1::Int) (rank + 1) MPI.unitTag MPI.commWorld+         else return ()+       +       if rank - 1 >= 0 then+         do buf' <- mallocForeignPtr @CInt+            st <- MPI.recv (buf', 1::Int) (rank - 1) 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 - 1 && tag == MPI.unitTag &&+             count == 1) @? ""+         else True @? ""   , testCase "sendrecv" $     do rank <- MPI.commRank MPI.commWorld        size <- MPI.commSize MPI.commWorld

@@ -0,0 +1,221 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++import Data.String+import Foreign+import System.IO+import System.Exit++import qualified Control.Distributed.MPI.Storable 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+  ]++++data V16 a = V16 a a a a a a a a a a a a a a a a+  deriving (Eq, Ord, Read, Show)++instance Storable a => Storable (V16 a) where+  sizeOf _ = 16 * sizeOf (undefined::a)+  alignment _ = alignment (undefined::a)+  poke ptr (V16 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf) =+    do pokeElemOff (castPtr ptr) 0x0 c0+       pokeElemOff (castPtr ptr) 0x1 c1+       pokeElemOff (castPtr ptr) 0x2 c2+       pokeElemOff (castPtr ptr) 0x3 c3+       pokeElemOff (castPtr ptr) 0x4 c4+       pokeElemOff (castPtr ptr) 0x5 c5+       pokeElemOff (castPtr ptr) 0x6 c6+       pokeElemOff (castPtr ptr) 0x7 c7+       pokeElemOff (castPtr ptr) 0x8 c8+       pokeElemOff (castPtr ptr) 0x9 c9+       pokeElemOff (castPtr ptr) 0xa ca+       pokeElemOff (castPtr ptr) 0xb cb+       pokeElemOff (castPtr ptr) 0xc cc+       pokeElemOff (castPtr ptr) 0xd cd+       pokeElemOff (castPtr ptr) 0xe ce+       pokeElemOff (castPtr ptr) 0xf cf+  peek ptr = do c0 <- peekElemOff (castPtr ptr) 0x0+                c1 <- peekElemOff (castPtr ptr) 0x1+                c2 <- peekElemOff (castPtr ptr) 0x2+                c3 <- peekElemOff (castPtr ptr) 0x3+                c4 <- peekElemOff (castPtr ptr) 0x4+                c5 <- peekElemOff (castPtr ptr) 0x5+                c6 <- peekElemOff (castPtr ptr) 0x6+                c7 <- peekElemOff (castPtr ptr) 0x7+                c8 <- peekElemOff (castPtr ptr) 0x8+                c9 <- peekElemOff (castPtr ptr) 0x9+                ca <- peekElemOff (castPtr ptr) 0xa+                cb <- peekElemOff (castPtr ptr) 0xb+                cc <- peekElemOff (castPtr ptr) 0xc+                cd <- peekElemOff (castPtr ptr) 0xd+                ce <- peekElemOff (castPtr ptr) 0xe+                cf <- peekElemOff (castPtr ptr) 0xf+                return (V16 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf)++type FixedString = V16 Char++instance IsString FixedString where+  fromString s =+    let c0:c1:c2:c3:c4:c5:c6:c7:c8:c9:ca:cb:cc:cd:ce:cf:_ = s ++ repeat '\NUL'+    in (V16 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf)++++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 :: FixedString = "Hello, World!"+       let sendrank = (rank + 1) `mod` size+       let recvrank = (rank - 1) `mod` size+       (status, recvmsg :: FixedString) <-+         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 :: FixedString = "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 :: FixedString) <- 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 :: FixedString = "Hello, World!"+       recvmsg :: FixedString <-+         if rank == MPI.rootRank+         then do MPI.bcastSend sendmsg MPI.rootRank MPI.commWorld+                 return sendmsg+         else do MPI.bcastRecv MPI.rootRank MPI.commWorld+       recvmsg == sendmsg @? ""+  ]++++collectiveNonBlocking :: TestTree+collectiveNonBlocking = testGroup "collective non-blocking"+  [ testCase "barrier" $+    do req <- MPI.ibarrier MPI.commWorld+       MPI.wait_ req+  , testCase "bcast" $+    do rank <- MPI.commRank MPI.commWorld+       let sendmsg :: FixedString = "Hello, World!"+       recvmsg :: FixedString <-+         if rank == MPI.rootRank+         then do req <- MPI.ibcastSend sendmsg MPI.rootRank MPI.commWorld+                 MPI.wait_ req+                 return sendmsg+         else do req <- MPI.ibcastRecv MPI.rootRank MPI.commWorld+                 MPI.wait_ req+       recvmsg == sendmsg @? ""+  ]