diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,217 @@ +Copyright 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. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + + + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS + +APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + +Copyright [yyyy] [name of copyright owner] + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,37 @@ +# [mpi-hs-binary](https://github.com/eschnett/mpi-hs-binary) + +[MPI](https://www.mpi-forum.org) bindings for Haskell + +* [GitHub](https://github.com/eschnett/mpi-hs-binary): Source code repository +* [Hackage](http://hackage.haskell.org/package/mpi-hs-binary): Haskell + package and documentation +* [Stackage](https://www.stackage.org/package/mpi-hs-binary): Stackage + snapshots +* [Azure + Pipelines](https://dev.azure.com/schnetter/mpi-hs-binary/_build): + Build Status [![Build + Status](https://dev.azure.com/schnetter/mpi-hs-binary/_apis/build/status/eschnett.mpi-hs-binary?branchName=master)](https://dev.azure.com/schnetter/mpi-hs-binary/_build/latest?definitionId=8&branchName=master) + + + +## Overview + +This is a companion package to +[`mpi-hs`](https://github.com/eschnett/mpi-hs). Read the documentation +there. + +This package `mpi-hs-binary` provides a high-level interface based on +`Data.Binary` in the +[`binary`](https://hackage.haskell.org/package/binary) package. This +is a separate package to reduce dependencies for `mpi-hs`. Note that +`mpi-hs` has a similar high-level interface based on `Data.Storable` +already built in. + +### Running the tests + +There is one test case provided in `tests`: + +``` +stack build --test --no-run-tests +mpiexec -n 3 stack exec -- $(stack path --dist-dir)/build/mpi-test-binary/mpi-test-binary +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/lib/Control/Distributed/MPI/Binary.hs b/lib/Control/Distributed/MPI/Binary.hs new file mode 100644 --- /dev/null +++ b/lib/Control/Distributed/MPI/Binary.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} + +-- | Module: Control.Distributed.MPI.Binary +-- Description: Simplified MPI bindings with automatic serialization +-- based on Data.Binary +-- Copyright: (C) 2020 Erik Schnetter +-- License: Apache-2.0 +-- Maintainer: Erik Schnetter +-- Stability: experimental +-- Portability: Requires an externally installed MPI library + +module Control.Distributed.MPI.Binary + ( -- * Types, and associated functions and constants + MPIException(..) + + -- ** Communicators + , Comm(..) + , commSelf + , commWorld + + -- ** Message sizes + , Count(..) + , fromCount + , toCount + + -- ** Process ranks + , Rank(..) + , anySource + , commRank + , commSize + , fromRank + , rootRank + , toRank + + -- ** Message status + , Status(..) + + -- ** Message tags + , Tag(..) + , anyTag + , fromTag + , toTag + , unitTag + + , Request + + -- * Functions + + -- ** Initialization and shutdown + , abort + , mainMPI + + -- ** Point-to-point (blocking) + , recv + , recv_ + , send + , sendrecv + , sendrecv_ + + -- ** Point-to-point (non-blocking) + , irecv + , isend + , test + , test_ + , wait + , wait_ + + -- ** Collective (blocking) + , barrier + , bcast + , bcastRecv + , bcastSend + , bcastSend_ + + -- ** Collective (non-blocking) + , ibarrier + , ibcast + , ibcastRecv + , ibcastSend + , ibcastSend_ + ) where + +import Prelude hiding (init) + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Loops +import qualified Data.Binary as Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Unsafe as B +import Data.Coerce +import Data.Maybe +import Data.Typeable +import Foreign +import Foreign.C.Types + +import qualified Control.Distributed.MPI as MPI +import Control.Distributed.MPI + ( Comm(..) + , commSelf + , commWorld + , Count(..) + , fromCount + , toCount + , Rank(..) + , anySource + , commRank + , commSize + , fromRank + , rootRank + , toRank + , Tag(..) + , anyTag + , fromTag + , toTag + , unitTag + , abort + , barrier + ) + + + +-- Serialization, based on Data.Binary +type CanSerialize a = Binary.Binary a +serialize :: CanSerialize a => a -> IO B.ByteString +serialize = return . BL.toStrict . Binary.encode +deserialize :: CanSerialize a => B.ByteString -> IO a +deserialize = return . Binary.decode . BL.fromStrict + +-- Why is this necessary? Shouldn't 'Data.Binary' already contain +-- this? +instance Binary.Binary CInt where + put x = Binary.put @Int32 (coerce x) + get = coerce <$> (Binary.get @Int32) +instance Binary.Binary Rank + + + +-- | Run the supplied Maybe computation repeatedly while it returns +-- Nothing. If it returns a value, then returns that value. +whileNothing :: Monad m => m (Maybe a) -> m () -> m a +whileNothing cond loop = go + where go = do mx <- cond + case mx of + Nothing -> do loop + go + Just x -> return x + + + +-- | Exception type indicating an error in a call to MPI +newtype MPIException = MPIException String + deriving (Eq, Ord, Read, Show, Typeable) +instance Exception MPIException + +mpiAssert :: Bool -> String -> IO () +mpiAssert cond msg = + do when (not cond) $ throw (MPIException msg) + return () + + + +data DidInit = DidInit | DidNotInit + +initMPI :: IO DidInit +initMPI = + do isInit <- MPI.initialized + if isInit + then return DidNotInit + else do ts <- MPI.initThread MPI.ThreadMultiple + mpiAssert (ts >= MPI.ThreadMultiple) + ("MPI.init: Insufficient thread support: requiring " ++ + show MPI.ThreadMultiple ++ + ", but MPI library provided only " ++ show ts) + return DidInit + +finalizeMPI :: DidInit -> IO () +finalizeMPI DidInit = + do isFinalized <- MPI.finalized + if isFinalized + then return () + else do MPI.finalize +finalizeMPI DidNotInit = return () + +-- | Convenience function to initialize and finalize MPI. This +-- initializes MPI with 'ThreadMultiple' thread support. +mainMPI :: IO () -- ^ action to run with MPI, typically the whole program + -> IO () +mainMPI action = bracket initMPI finalizeMPI (\_ -> action) + + + +-- | A communication request, usually created by a non-blocking +-- communication function. +newtype Request a = Request (MVar (Status, a)) + +-- | The status of a finished communication, indicating rank and tag +-- of the other communication end point. +data Status = Status { msgRank :: !Rank + , msgTag :: !Tag + } + deriving (Eq, Ord, Read, Show) + + + +-- | Receive an object. +recv :: CanSerialize a + => Rank -- ^ Source rank + -> Tag -- ^ Source tag + -> Comm -- ^ Communicator + -> IO (Status, a) -- ^ Message status and received object +recv recvrank recvtag comm = + do status <- whileNothing (MPI.iprobe recvrank recvtag comm) yield + source <- MPI.getSource status + tag <- MPI.getTag status + count <- MPI.getCount status MPI.datatypeByte + let len = MPI.fromCount count + ptr <- mallocBytes len + buffer <- B.unsafePackMallocCStringLen (ptr, len) + req <- MPI.irecv buffer source tag comm + whileM_ (not <$> MPI.test_ req) yield + recvobj <- deserialize buffer + return (Status source tag, recvobj) + +-- | Receive an object without returning a status. +recv_ :: CanSerialize a + => Rank -- ^ Source rank + -> Tag -- ^ Source tag + -> Comm -- ^ Communicator + -> IO a -- ^ Received object +recv_ recvrank recvtag comm = + snd <$> recv recvrank recvtag comm + +-- | Send an object. +send :: CanSerialize a + => a -- ^ Object to send + -> Rank -- ^ Destination rank + -> Tag -- ^ Message tag + -> Comm -- ^ Communicator + -> IO () +send sendobj sendrank sendtag comm = + do sendbuf <- serialize sendobj + -- Use 'unsafeUseAsCStringLen' to ensure 'sendbuf' is not freed + -- too early + B.unsafeUseAsCStringLen sendbuf $ \_ -> + do req <- MPI.isend sendbuf sendrank sendtag comm + whileM_ (not <$> MPI.test_ req) yield + +-- | Send and receive objects simultaneously. +sendrecv :: (CanSerialize a, CanSerialize b) + => a -- ^ Object to send + -> Rank -- ^ Destination rank + -> Tag -- ^ Send message tag + -> Rank -- ^ Source rank + -> Tag -- ^ Receive message tag + -> Comm -- ^ Communicator + -> IO (Status, b) -- ^ Message status and received object +sendrecv sendobj sendrank sendtag recvrank recvtag comm = + do recvreq <- irecv recvrank recvtag comm + send sendobj sendrank sendtag comm + wait recvreq + +-- | Send and receive objects simultaneously, without returning a +-- status for the received message. +sendrecv_ :: (CanSerialize a, CanSerialize b) + => a -- ^ Object to send + -> Rank -- ^ Destination rank + -> Tag -- ^ Send message tag + -> Rank -- ^ Source rank + -> Tag -- ^ Receive message tag + -> Comm -- ^ Communicator + -> IO b -- ^ Received object +sendrecv_ sendobj sendrank sendtag recvrank recvtag comm = + snd <$> sendrecv sendobj sendrank sendtag recvrank recvtag comm + +-- | Begin to receive an object. Call `test` or `wait` to finish the +-- communication, and to obtain the received object. +irecv :: CanSerialize a + => Rank -- ^ Source rank + -> Tag -- ^ Source tag + -> Comm -- ^ Communicator + -> IO (Request a) -- ^ Communication request +irecv recvrank recvtag comm = + do result <- newEmptyMVar + _ <- forkIO $ + do res <- recv recvrank recvtag comm + putMVar result res + return (Request result) + +-- | Begin to send an object. Call 'test' or 'wait' to finish the +-- communication. +isend :: CanSerialize a + => a -- ^ Object to send + -> Rank -- ^ Destination rank + -> Tag -- ^ Message tag + -> Comm -- ^ Communicator + -> IO (Request ()) -- ^ Communication request +isend sendobj sendrank sendtag comm = + do result <- newEmptyMVar + _ <- forkIO $ do send sendobj sendrank sendtag comm + putMVar result (Status sendrank sendtag, ()) + return (Request result) + +-- | Check whether a communication has finished, and return the +-- communication result if so. +test :: Request a -- ^ Communication request + -> IO (Maybe (Status, a)) -- ^ 'Just' communication result, if + -- communication has finished, else 'Nothing' +test (Request result) = tryTakeMVar result + +-- | Check whether a communication has finished, and return the +-- communication result if so, without returning a message status. +test_ :: Request a -- ^ Communication request + -> IO (Maybe a) -- ^ 'Just' communication result, if + -- communication has finished, else 'Nothing' +test_ req = fmap snd <$> test req + +-- | Wait for a communication to finish and return the communication +-- result. +wait :: Request a -- ^ Communication request + -> IO (Status, a) -- ^ Message status and communication result +wait (Request result) = takeMVar result + +-- | Wait for a communication to finish and return the communication +-- result, without returning a message status. +wait_ :: Request a -- ^ Communication request + -> IO a -- ^ Communication result +wait_ req = snd <$> wait req + + + +-- | Broadcast a message from one process (the "root") to all other +-- processes in the communicator. 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 + => 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 + +-- | 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 + -> 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 a) +ibcastSend sendobj root comm = + do result <- newEmptyMVar + _ <- forkIO $ + do bcastSend_ sendobj root comm + putMVar result (Status root MPI.anyTag, sendobj) + 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) diff --git a/mpi-hs-binary.cabal b/mpi-hs-binary.cabal new file mode 100644 --- /dev/null +++ b/mpi-hs-binary.cabal @@ -0,0 +1,122 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 87dc4ba3e823a829e1c1155618c4fd1510ab3d34dced3865ee15f4b46b448a0c + +name: mpi-hs-binary +version: 0.1.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 + (High Performance Computing) systems. MPI allows exchanging data + (_messages_) between programs running in parallel. There are several + high-quality open source MPI implementations (e.g. MPICH, MVAPICH, + OpenMPI) as well as a variety of closed-source implementations. + These libraries can typically make use of high-bandwidth low-latency + communication hardware such as InfiniBand. + . + This library @mpi-hs@ provides Haskell bindings for MPI. It is based + on ideas taken from + [haskell-mpi](https://github.com/bjpop/haskell-mpi), + [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html) + for C++, and [MPI for + Python](https://mpi4py.readthedocs.io/en/stable/). + . + @mpi-hs@ provides two API levels: A low-level API gives rather + direct access to the actual MPI API, apart from certain "reasonable" + mappings from C to Haskell (e.g. output arguments that are in C + stored via a pointer are in Haskell regular return values). A + high-level API simplifies exchanging arbitrary values that can be + serialized. + . + Note that the automated builds on + [Hackage](http://hackage.haskell.org) will currently always fail + since no system MPI library is present there. However, builds on + [Stackage](https://www.stackage.org) should succeed -- if not, there + is an error in this package. +category: Distributed Computing +homepage: https://github.com/eschnett/mpi-hs-binary#readme +bug-reports: https://github.com/eschnett/mpi-hs-binary/issues +author: Erik Schnetter +maintainer: Erik Schnetter +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + LICENSE + README.md + package.yaml + stack.yaml + stack.yaml.lock + +source-repository head + type: git + location: https://github.com/eschnett/mpi-hs-binary + +library + exposed-modules: + Control.Distributed.MPI.Binary + other-modules: + Paths_mpi_hs_binary + hs-source-dirs: + lib + ghc-options: -Wall + build-depends: + base >=4 && <5 + , binary + , bytestring + , monad-loops + , mpi-hs >=0.6.0.0 + default-language: Haskell2010 + +executable example1 + main-is: example1.hs + other-modules: + Paths_mpi_hs_binary + hs-source-dirs: + src + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , mpi-hs + default-language: Haskell2010 + +executable example2 + main-is: example2.hs + other-modules: + Paths_mpi_hs_binary + hs-source-dirs: + src + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , mpi-hs-binary + default-language: Haskell2010 + +executable version + main-is: version.hs + other-modules: + Paths_mpi_hs_binary + hs-source-dirs: + src + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , mpi-hs + default-language: Haskell2010 + +test-suite mpi-test-binary + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_mpi_hs_binary + hs-source-dirs: + tests/binary + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , mpi-hs-binary + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,104 @@ +name: mpi-hs-binary +version: '0.1.0.0' +github: "eschnett/mpi-hs-binary" +license: Apache-2.0 +author: "Erik Schnetter " +maintainer: "Erik Schnetter " +category: Distributed Computing +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 + (High Performance Computing) systems. MPI allows exchanging data + (_messages_) between programs running in parallel. There are several + high-quality open source MPI implementations (e.g. MPICH, MVAPICH, + OpenMPI) as well as a variety of closed-source implementations. + These libraries can typically make use of high-bandwidth low-latency + communication hardware such as InfiniBand. + + This library @mpi-hs@ provides Haskell bindings for MPI. It is based + on ideas taken from + [haskell-mpi](https://github.com/bjpop/haskell-mpi), + [Boost.MPI](https://www.boost.org/doc/libs/1_64_0/doc/html/mpi.html) + for C++, and [MPI for + Python](https://mpi4py.readthedocs.io/en/stable/). + + @mpi-hs@ provides two API levels: A low-level API gives rather + direct access to the actual MPI API, apart from certain "reasonable" + mappings from C to Haskell (e.g. output arguments that are in C + stored via a pointer are in Haskell regular return values). A + high-level API simplifies exchanging arbitrary values that can be + serialized. + + Note that the automated builds on + [Hackage](http://hackage.haskell.org) will currently always fail + since no system MPI library is present there. However, builds on + [Stackage](https://www.stackage.org) should succeed -- if not, there + is an error in this package. + +extra-source-files: + - LICENSE + - README.md + - package.yaml + - stack.yaml + - stack.yaml.lock + +ghc-options: + - -Wall + +library: + dependencies: + - base >=4 && <5 # tested with 4.11, 4.12, 4.13 + - binary + - bytestring + - monad-loops + - mpi-hs >=0.6.0.0 + source-dirs: lib + +executables: + version: + source-dirs: src + main: version.hs + dependencies: + - base + - mpi-hs + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + example1: + source-dirs: src + main: example1.hs + dependencies: + - base + - mpi-hs + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + example2: + source-dirs: src + main: example2.hs + dependencies: + - base + - mpi-hs-binary + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + +tests: + mpi-test-binary: + source-dirs: tests/binary + main: Main.hs + dependencies: + - base + - mpi-hs-binary + # - tasty + # - tasty-hunit + # - tasty-hspec + # - unix + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N 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.Binary 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 b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,7 @@ +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# resolver: lts-15.8 +resolver: nightly-2020-04-18 + +# User packages to be built. +packages: + - . 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: 513207 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/4/18.yaml + sha256: 4a5cabc1856fdcb16da22374500213ccb850d608eadbe8130ff66de4614a66ff + original: nightly-2020-04-18 diff --git a/tests/binary/Main.hs b/tests/binary/Main.hs new file mode 100644 --- /dev/null +++ b/tests/binary/Main.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import System.IO +import System.Exit + +import qualified Control.Distributed.MPI.Binary as MPI + +default (Int) + + + +-------------------------------------------------------------------------------- + +infix 1 @? +(@?) :: Bool -> String -> IO () +x @? msg = if not x then die msg else return () + +infix 1 @?= +(@?=) :: Eq a => a -> a -> IO () +x @?= y = x == y @? "test failed" + + + +type TestTree = IO () + +testCase :: String -> IO () -> TestTree +testCase name test = + do rank <- MPI.commRank MPI.commWorld + if rank == 0 + then do putStrLn $ " " ++ name ++ "..." + hFlush stdout + else return () + MPI.barrier MPI.commWorld + test + MPI.barrier MPI.commWorld + + + +testGroup :: String -> [TestTree] -> TestTree +testGroup name cases = + do rank <- MPI.commRank MPI.commWorld + if rank == 0 + then do putStrLn $ name ++ ":" + hFlush stdout + else return () + sequence_ cases + + + +defaultMain :: TestTree -> IO () +defaultMain tree = + do rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + if rank == 0 + then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes" + hFlush stdout + else return () + tree + + + +-------------------------------------------------------------------------------- + + + +main :: IO () +main = MPI.mainMPI $ defaultMain tests + +tests :: TestTree +tests = testGroup "MPI" + [ rankSize + , pointToPoint + , pointToPointNonBlocking + , collective + , collectiveNonBlocking + ] + + + +rankSize :: TestTree +rankSize = testGroup "rank and size" + [ testCase "commSelf" $ + do rank <- MPI.commRank MPI.commSelf + size <- MPI.commSize MPI.commSelf + rank == 0 && size == 1 @? "" + , testCase "commWorld" $ + do rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + rank >= 0 && rank < size @? "" + ] + + + +pointToPoint :: TestTree +pointToPoint = testGroup "point-to-point" + [ testCase "sendrecv" $ + do rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + let sendmsg :: String = "Hello, World!" + let sendrank = (rank + 1) `mod` size + let recvrank = (rank - 1) `mod` size + (status, recvmsg :: String) <- + MPI.sendrecv sendmsg sendrank MPI.unitTag recvrank MPI.unitTag + MPI.commWorld + (recvmsg == sendmsg && + MPI.msgRank status == recvrank && + MPI.msgTag status == MPI.unitTag) @? "" + ] + + + +pointToPointNonBlocking :: TestTree +pointToPointNonBlocking = testGroup "point-to-point non-blocking" + [ testCase "send and recv" $ + do rank <- MPI.commRank MPI.commWorld + size <- MPI.commSize MPI.commWorld + let sendmsg :: String = "Hello, World!" + let sendrank = (rank + 1) `mod` size + sendreq <- MPI.isend sendmsg sendrank MPI.unitTag MPI.commWorld + let recvrank = (rank - 1) `mod` size + recvreq <- MPI.irecv recvrank MPI.unitTag MPI.commWorld + (sendstatus, ()) <- MPI.wait sendreq + (recvstatus, recvmsg :: String) <- MPI.wait recvreq + (recvmsg == sendmsg && + MPI.msgRank sendstatus == sendrank && + MPI.msgTag sendstatus == MPI.unitTag && + MPI.msgRank recvstatus == recvrank && + MPI.msgTag recvstatus == MPI.unitTag) @? "" + ] + + + +collective :: TestTree +collective = testGroup "collective" + [ testCase "barrier" $ + do MPI.barrier MPI.commWorld + , testCase "bcast" $ + do let sendmsg :: String = "Hello, World!" + recvmsg :: String <- + MPI.bcast (Just sendmsg) 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 let sendmsg :: String = "Hello, World!" + recvmsg :: String <- + do req <- MPI.ibcast (Just sendmsg) MPI.rootRank MPI.commWorld + MPI.wait_ req + recvmsg == sendmsg @? "" + ]