diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2018 Erik Schnetter +Copyright 2018, 2019, 2020 Erik Schnetter Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,10 +7,9 @@ package and documentation * [Stackage](https://www.stackage.org/package/mpi-hs): Stackage snapshots -* [Azure - Pipelines](https://dev.azure.com/schnetter/mpi-hs/_build): +* [Azure Pipelines](https://dev.azure.com/schnetter/mpi-hs/_build): Build Status [![Build - Status](https://dev.azure.com/schnetter/mpi-hs/_apis/build/status/eschnett.mpi-hs?branchName=master)](https://dev.azure.com/schnetter/mpi-hs/_build/latest&branchName=master) + Status](https://dev.azure.com/schnetter/mpi-hs/_apis/build/status/eschnett.mpi-hs?branchName=master)](https://dev.azure.com/schnetter/mpi-hs/_build/latest?definitionId=8&branchName=master) @@ -40,7 +39,7 @@ -## Programming Example +## Example This is a typical MPI C code: ```C @@ -53,6 +52,9 @@ MPI_Comm_rank(MPI_COMM_WORLD, &rank); MPI_Comm_size(MPI_COMM_WORLD, &size); printf("This is process %d of %d\n", rank, size); + int msg = rank; + MPI_Bcast(&msg, 1, MPI_INT, 0, MPI_COMM_WORLD): + printf("Process %d says hi\n", msg); MPI_Finalize(); return 0; } @@ -60,7 +62,11 @@ The Haskell equivalent looks like this: ```Haskell +{-# LANGUAGE TypeApplications #-} + import qualified Control.Distributed.MPI as MPI +import Foreign +import Foreign.C.Types main :: IO () main = do @@ -68,11 +74,35 @@ rank <- MPI.commRank MPI.commWorld size <- MPI.commSize MPI.commWorld putStrLn $ "This is process " ++ show rank ++ " of " ++ show size + let msg = MPI.fromRank rank + buf <- mallocForeignPtr @CInt + withForeignPtr buf $ \ptr -> poke ptr msg + MPI.bcast (buf, 1::Int) MPI.rootRank MPI.commWorld + msg' <- withForeignPtr buf peek + putStrLn $ "Process " ++ show msg' ++ " says hi" MPI.finalize ``` +The high-level API simplifies exchanging data; no need to allocate a +buffer nor to use poke or peek: +``` +{-# LANGUAGE TypeApplications #-} +import qualified Control.Distributed.MPI as MPI +import qualified Control.Distributed.MPI.Storable as MPI +main :: IO () +main = MPI.mainMPI $ do + rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + putStrLn $ "This is process " ++ show rank ++ " of " ++ show size + let msg = MPI.fromRank rank :: Int + msg' <- MPI.bcast (Just msg) MPI.rootRank MPI.commWorld + putStrLn $ "Process " ++ show msg' ++ " says hi" +``` + + + ## Installing `mpi-hs` requires an external MPI library to be available on the @@ -165,11 +195,13 @@ ### Running the example -To run the example provided in `src/Main.hs`: +To run the example provided in the `src` directory: ``` stack build -mpiexec -n 3 stack exec example +mpiexec stack exec versionn +mpiexec -n 3 stack exec example1 +mpiexec -n 3 stack exec example2 ``` ### Running the tests @@ -186,16 +218,17 @@ - +- [`mpi-hs-binary`](https://github.com/eschnett/mpi-hs-binary), based + on `Data.Binary` in the + [`binary`](https://hackage.haskell.org/package/binary) package +- [`mpi-hs-cereal`](https://github.com/eschnett/mpi-hs-cereal), based + on `Data.Serialize` in the + [`cereal`](https://hackage.haskell.org/package/cereal) package +- [`mpi-hs-store`](https://github.com/eschnett/mpi-hs-store), based on + `Data.Store` in the + [`store`](https://hackage.haskell.org/package/store) package diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ --- You can benchmark your code quickly and effectively with Criterion. See its --- website for help: . -import Criterion.Main - -main :: IO () -main = defaultMain [bench "const" (whnf const ())] diff --git a/c/include/mpihs.h b/c/include/mpihs.h --- a/c/include/mpihs.h +++ b/c/include/mpihs.h @@ -35,11 +35,13 @@ void mpihs_get_int(MPI_Datatype *datatype); void mpihs_get_long(MPI_Datatype *datatype); void mpihs_get_long_double(MPI_Datatype *datatype); +void mpihs_get_long_long(MPI_Datatype *datatype); void mpihs_get_long_long_int(MPI_Datatype *datatype); void mpihs_get_short(MPI_Datatype *datatype); void mpihs_get_unsigned(MPI_Datatype *datatype); void mpihs_get_unsigned_char(MPI_Datatype *datatype); void mpihs_get_unsigned_long(MPI_Datatype *datatype); +void mpihs_get_unsigned_long_long(MPI_Datatype *datatype); void mpihs_get_unsigned_short(MPI_Datatype *datatype); // Op diff --git a/c/src/mpihs.c b/c/src/mpihs.c --- a/c/src/mpihs.c +++ b/c/src/mpihs.c @@ -23,6 +23,7 @@ void mpihs_get_long_double(MPI_Datatype *datatype) { *datatype = MPI_LONG_DOUBLE; } +void mpihs_get_long_long(MPI_Datatype *datatype) { *datatype = MPI_LONG_LONG; } void mpihs_get_long_long_int(MPI_Datatype *datatype) { *datatype = MPI_LONG_LONG_INT; } @@ -33,6 +34,9 @@ } void mpihs_get_unsigned_long(MPI_Datatype *datatype) { *datatype = MPI_UNSIGNED_LONG; +} +void mpihs_get_unsigned_long_long(MPI_Datatype *datatype) { + *datatype = MPI_UNSIGNED_LONG_LONG; } void mpihs_get_unsigned_short(MPI_Datatype *datatype) { *datatype = MPI_UNSIGNED_SHORT; diff --git a/lib/Control/Distributed/MPI.chs b/lib/Control/Distributed/MPI.chs --- a/lib/Control/Distributed/MPI.chs +++ b/lib/Control/Distributed/MPI.chs @@ -20,7 +20,7 @@ -- | Module: Control.Distributed.MPI -- Description: MPI bindings for Haskell --- Copyright: (C) 2018 Erik Schnetter +-- Copyright: (C) 2018, 2019, 2020 Erik Schnetter -- License: Apache-2.0 -- Maintainer: Erik Schnetter -- Stability: experimental @@ -114,11 +114,13 @@ , datatypeInt , datatypeLong , datatypeLongDouble + , datatypeLongLong , datatypeLongLongInt , datatypeShort , datatypeUnsigned , datatypeUnsignedChar , datatypeUnsignedLong + , datatypeUnsignedLongLong , datatypeUnsignedShort , HasDatatype(..) @@ -680,8 +682,12 @@ { alloca- `Datatype' peekDatatype* } -> `()'#} --- | MPI datatype for 'CLLong' (@MPI_LONG_LONG_INT@). (There is no MPI --- datatype for 'CULLong@). +-- | MPI datatype for 'CLLong' (@MPI_LONG_LONG@). +{#fun pure mpihs_get_long_long as datatypeLongLong + { alloca- `Datatype' peekDatatype* + } -> `()'#} + +-- | MPI datatype for 'CLLong' (@MPI_LONG_LONG_INT@). {#fun pure mpihs_get_long_long_int as datatypeLongLongInt { alloca- `Datatype' peekDatatype* } -> `()'#} @@ -706,6 +712,11 @@ { alloca- `Datatype' peekDatatype* } -> `()'#} +-- | MPI datatype for 'CULLong' (@MPI_UNSIGNED_LONG_LONG@). +{#fun pure mpihs_get_unsigned_long_long as datatypeUnsignedLongLong + { alloca- `Datatype' peekDatatype* + } -> `()'#} + -- | MPI datatype for 'CUShort' (@MPI_UNSIGNED_SHORT@). {#fun pure mpihs_get_unsigned_short as datatypeUnsignedShort { alloca- `Datatype' peekDatatype* @@ -719,13 +730,22 @@ 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 CLLong where getDatatype = datatypeLongLong 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 CULLong where getDatatype = datatypeUnsignedLongLong instance HasDatatype CULong where getDatatype = datatypeUnsignedLong instance HasDatatype CUShort where getDatatype = datatypeUnsignedShort +instance HasDatatype Int8 where getDatatype = datatypeChar +instance HasDatatype Int16 where getDatatype = datatypeShort +instance HasDatatype Int32 where getDatatype = datatypeInt +instance HasDatatype Int64 where getDatatype = datatypeLongLong +instance HasDatatype Word8 where getDatatype = datatypeByte +instance HasDatatype Word16 where getDatatype = datatypeUnsignedShort +instance HasDatatype Word32 where getDatatype = datatypeUnsigned +instance HasDatatype Word64 where getDatatype = datatypeUnsignedLongLong @@ -1715,6 +1735,24 @@ scatterTyped (castPtr sendptr) sendcount senddatatype (castPtr recvptr) recvcount recvdatatype root comm + +-- -- | Scatter data from the root process to all processes, allowing +-- -- varying send counts to each process (collective, +-- -- @[MPI_Scatterv](https://www.open-mpi.org/doc/current/man3/MPI_Scatterv.3.php)@). +-- -- The MPI datatypes are determined automatically from the buffer +-- -- pointer types. +-- scatterv :: (Buffer sb, Buffer rb) +-- => sb -- ^ Source buffer (only used on the root process) +-- -> rb -- ^ Destination buffer +-- -> Rank -- ^ Root rank +-- -> Comm -- ^ Communicator +-- -> IO () +-- scatterv 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 { id `Ptr ()' diff --git a/lib/Control/Distributed/MPI/Storable.hs b/lib/Control/Distributed/MPI/Storable.hs --- a/lib/Control/Distributed/MPI/Storable.hs +++ b/lib/Control/Distributed/MPI/Storable.hs @@ -68,13 +68,17 @@ -- ** Collective (blocking) , barrier + , bcast , bcastRecv , bcastSend + , bcastSend_ -- ** Collective (non-blocking) , ibarrier + , ibcast , ibcastRecv , ibcastSend + , ibcastSend_ ) where import Prelude hiding (init) @@ -85,6 +89,7 @@ import Control.Monad.Loops import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B +import Data.Maybe import Data.Typeable import Foreign import Foreign.C.Types @@ -322,6 +327,21 @@ -- | Broadcast a message from one process (the "root") to all other +-- processes in the communicator. The send object must be present +-- (`Just`) on the root, and is ignored on all non-root processes. +bcast :: CanSerialize a + => Maybe a + -> Rank + -> Comm + -> IO a +bcast sendobj root comm = + do rank <- MPI.commRank comm + if rank == root + then do mpiAssert (isJust sendobj) "bcast: expected send object on root" + bcastSend (fromJust sendobj) root comm + else bcastRecv root comm + +-- | 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 @@ -331,7 +351,7 @@ bcastRecv root comm = do rank <- MPI.commRank comm mpiAssert (rank /= root) "bcastRecv: expected rank /= root" - lenbuf <- mallocForeignPtr @CLong + lenbuf <- mallocForeignPtr @CInt lenreq <- MPI.ibcast (lenbuf, 1::Int) root comm whileM_ (not <$> MPI.test_ lenreq) yield len <- withForeignPtr lenbuf peek @@ -345,22 +365,58 @@ -- | 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 = +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 + lenbuf <- mallocForeignPtr @CInt 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 +-- | 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 a +bcastSend sendobj root comm = + do bcastSend_ sendobj root comm + return sendobj + +-- | 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) + +ibcast :: CanSerialize a + => Maybe a + -> Rank + -> Comm + -> IO (Request a) +ibcast sendobj root comm = + do rank <- MPI.commRank comm + if rank == root + then do mpiAssert (isJust sendobj) "ibcast: expected send object on root" + ibcastSend (fromJust sendobj) root comm + else ibcastRecv root comm + ibcastRecv :: CanSerialize a => Rank -> Comm @@ -376,22 +432,52 @@ => a -> Rank -> Comm - -> IO (Request ()) + -> IO (Request a) ibcastSend sendobj root comm = do result <- newEmptyMVar _ <- forkIO $ - do bcastSend sendobj root comm - putMVar result (Status root MPI.anyTag, ()) + do bcastSend_ sendobj root comm + putMVar result (Status root MPI.anyTag, sendobj) return (Request result) --- | Begin a barrier. Call 'test' or 'wait' to finish the --- communication. -ibarrier :: Comm - -> IO (Request ()) -ibarrier comm = +ibcastSend_ :: CanSerialize a + => a + -> Rank + -> Comm + -> IO (Request ()) +ibcastSend_ sendobj root comm = do result <- newEmptyMVar _ <- forkIO $ - do req <- MPI.ibarrier comm - whileM_ (not <$> MPI.test_ req) yield - putMVar result (Status MPI.anySource MPI.anyTag, ()) + do bcastSend_ sendobj root comm + putMVar result (Status root MPI.anyTag, ()) return (Request result) + +-- scatter :: CanSerialize a +-- => Maybe a +-- -> Rank +-- -> Comm +-- -> IO (Request a) +-- scatter msendobj root comm = +-- do rank <- commRank comm +-- sendbuf <- +-- if (rank == root) +-- then do mpiAssert (isJust msendobj) +-- serialize (fromJust sendobj) +-- else return nullPtr +-- lenbuf <- mallocForeignPtr @CInt +-- 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.iscatterv sendbuf root comm +-- whileM_ (not <$> MPI.test_ req) yield +-- +-- scatterRecv :: CanSerialize a +-- => Rank +-- -> Comm +-- -> IO (Request a) +-- +-- scatterSend :: CanSerialize a +-- => a +-- -> Rank +-- -> Comm +-- -> IO (Request a) diff --git a/mpi-hs.cabal b/mpi-hs.cabal --- a/mpi-hs.cabal +++ b/mpi-hs.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 11b62fed3be3a0f857f2e02c4f51e8d2161fe465d5ef830539f21ba83ba7fb5d +-- hash: 538426701e8b2b17467e84727926d3787dccae19f2208fab5e05afde41654712 name: mpi-hs -version: 0.6.0.0 +version: 0.7.0.0 synopsis: MPI bindings for Haskell description: MPI (the [Message Passinag Interface](https://www.mpi-forum.org)) is a widely used standard for distributed-memory programming on HPC @@ -42,6 +42,7 @@ bug-reports: https://github.com/eschnett/mpi-hs/issues author: Erik Schnetter maintainer: Erik Schnetter +copyright: 2018, 2019, 2020 Erik Schnetter license: Apache-2.0 license-file: LICENSE build-type: Simple @@ -50,6 +51,7 @@ README.md package.yaml stack.yaml + stack.yaml.lock c/include/mpihs.h c/src/mpihs.c @@ -132,14 +134,16 @@ if flag(mpich-ubuntu) include-dirs: /usr/lib/mpich/include + /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu extra-libraries: mpich default-language: Haskell2010 -executable example - main-is: Main.hs +executable example1 + main-is: example1.hs other-modules: Paths_mpi_hs hs-source-dirs: @@ -179,23 +183,23 @@ if flag(mpich-ubuntu) include-dirs: /usr/lib/mpich/include + /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu extra-libraries: mpich default-language: Haskell2010 -test-suite mpi-test - type: exitcode-stdio-1.0 - main-is: Main.hs +executable example2 + main-is: example2.hs other-modules: Paths_mpi_hs hs-source-dirs: - tests/mpi + src ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base - , monad-loops , mpi-hs if flag(openmpi-debian) include-dirs: @@ -228,22 +232,74 @@ if flag(mpich-ubuntu) include-dirs: /usr/lib/mpich/include + /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu extra-libraries: mpich default-language: Haskell2010 -test-suite mpi-test-storable +executable version + main-is: version.hs + other-modules: + Paths_mpi_hs + hs-source-dirs: + src + 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 + /usr/include/x86_64-linux-gnu/mpich + extra-lib-dirs: + /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu + extra-libraries: + mpich + default-language: Haskell2010 + +test-suite mpi-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Paths_mpi_hs hs-source-dirs: - tests/storable + tests/mpi ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base + , monad-loops , mpi-hs if flag(openmpi-debian) include-dirs: @@ -276,23 +332,24 @@ if flag(mpich-ubuntu) include-dirs: /usr/lib/mpich/include + /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu extra-libraries: mpich default-language: Haskell2010 -benchmark mpi-hs-benchmarks +test-suite mpi-test-storable type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Paths_mpi_hs hs-source-dirs: - bench + tests/storable ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base - , criterion , mpi-hs if flag(openmpi-debian) include-dirs: @@ -325,8 +382,10 @@ if flag(mpich-ubuntu) include-dirs: /usr/lib/mpich/include + /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: /usr/lib/mpich/lib + /usr/lib/x86_64-linux-gnu extra-libraries: mpich default-language: Haskell2010 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,9 +1,10 @@ name: mpi-hs -version: '0.6.0.0' +version: '0.7.0.0' github: "eschnett/mpi-hs" license: Apache-2.0 author: "Erik Schnetter " maintainer: "Erik Schnetter " +copyright: "2018, 2019, 2020 Erik Schnetter " category: Distributed Computing synopsis: MPI bindings for Haskell description: | @@ -63,6 +64,7 @@ - README.md - package.yaml - stack.yaml + - stack.yaml.lock - c/include/mpihs.h - c/src/mpihs.c @@ -114,15 +116,17 @@ - condition: flag(mpich-ubuntu) include-dirs: - /usr/lib/mpich/include + - /usr/include/x86_64-linux-gnu/mpich extra-lib-dirs: - /usr/lib/mpich/lib + - /usr/lib/x86_64-linux-gnu extra-libraries: - mpich executables: - example: + version: source-dirs: src - main: Main.hs + main: version.hs dependencies: - base - mpi-hs @@ -130,15 +134,22 @@ - -rtsopts - -threaded - -with-rtsopts=-N - -benchmarks: - mpi-hs-benchmarks: - source-dirs: bench - main: Main.hs + example1: + source-dirs: src + main: example1.hs dependencies: - base - mpi-hs - - criterion + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + example2: + source-dirs: src + main: example2.hs + dependencies: + - base + - mpi-hs ghc-options: - -rtsopts - -threaded diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Control.Exception -import Data.Version - -import qualified Control.Distributed.MPI as MPI - -main :: IO () -main = bracket - MPI.init - (\_ -> MPI.finalize) $ - \_ -> do library <- MPI.getLibraryVersion - putStrLn $ "MPI library " ++ library - version <- MPI.getVersion - putStrLn $ "MPI standard " ++ showVersion version - processor <- MPI.getProcessorName - rank <- MPI.commRank MPI.commWorld - size <- MPI.commSize MPI.commWorld - putStrLn $ "MPI processor " ++ processor ++ - " (" ++ show rank ++ "/" ++ show size ++ ")" diff --git a/src/example1.hs b/src/example1.hs new file mode 100644 --- /dev/null +++ b/src/example1.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeApplications #-} + +import qualified Control.Distributed.MPI as MPI +import Foreign +import Foreign.C.Types + +main :: IO () +main = do + MPI.init + rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + putStrLn $ "This is process " ++ show rank ++ " of " ++ show size + let msg = MPI.fromRank rank + buf <- mallocForeignPtr @CInt + withForeignPtr buf $ \ptr -> poke ptr msg + MPI.bcast (buf, 1::Int) MPI.rootRank MPI.commWorld + msg' <- withForeignPtr buf peek + putStrLn $ "Process " ++ show msg' ++ " says hi" + MPI.finalize diff --git a/src/example2.hs b/src/example2.hs new file mode 100644 --- /dev/null +++ b/src/example2.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeApplications #-} + +import qualified Control.Distributed.MPI.Storable as MPI + +main :: IO () +main = MPI.mainMPI $ do + rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + putStrLn $ "This is process " ++ show rank ++ " of " ++ show size + let msg = MPI.fromRank rank :: Int + msg' <- MPI.bcast (Just msg) MPI.rootRank MPI.commWorld + putStrLn $ "Process " ++ show msg' ++ " says hi" diff --git a/src/version.hs b/src/version.hs new file mode 100644 --- /dev/null +++ b/src/version.hs @@ -0,0 +1,16 @@ +import Control.Exception +import Data.Version + +import qualified Control.Distributed.MPI as MPI + +main :: IO () +main = bracket_ MPI.init MPI.finalize $ do + library <- MPI.getLibraryVersion + putStrLn $ "MPI library " ++ library + version <- MPI.getVersion + putStrLn $ "MPI standard " ++ showVersion version + processor <- MPI.getProcessorName + rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + putStrLn $ "MPI processor " ++ processor + ++ " (" ++ show rank ++ "/" ++ show size ++ ")" diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 491372 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml + sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc + original: lts-15.5 diff --git a/tests/storable/Main.hs b/tests/storable/Main.hs --- a/tests/storable/Main.hs +++ b/tests/storable/Main.hs @@ -190,13 +190,9 @@ [ testCase "barrier" $ do MPI.barrier MPI.commWorld , testCase "bcast" $ - do rank <- MPI.commRank MPI.commWorld - let sendmsg :: FixedString = "Hello, World!" + do 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 + MPI.bcast (Just sendmsg) MPI.rootRank MPI.commWorld recvmsg == sendmsg @? "" ] @@ -208,14 +204,9 @@ do req <- MPI.ibarrier MPI.commWorld MPI.wait_ req , testCase "bcast" $ - do rank <- MPI.commRank MPI.commWorld - let sendmsg :: FixedString = "Hello, World!" + do 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 + do req <- MPI.ibcast (Just sendmsg) MPI.rootRank MPI.commWorld + MPI.wait_ req recvmsg == sendmsg @? "" ]