mpi-hs-binary (empty) → 0.1.0.0
raw patch · 12 files changed
+1169/−0 lines, 12 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, monad-loops, mpi-hs, mpi-hs-binary
Files
- LICENSE +217/−0
- README.md +37/−0
- Setup.hs +7/−0
- lib/Control/Distributed/MPI/Binary.hs +459/−0
- mpi-hs-binary.cabal +122/−0
- package.yaml +104/−0
- src/example1.hs +19/−0
- src/example2.hs +12/−0
- src/version.hs +16/−0
- stack.yaml +7/−0
- stack.yaml.lock +12/−0
- tests/binary/Main.hs +157/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 [](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+```
+ Setup.hs view
@@ -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: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ lib/Control/Distributed/MPI/Binary.hs view
@@ -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 <schnetter@gmail.com>+-- 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)
+ mpi-hs-binary.cabal view
@@ -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 <schnetter@gmail.com>+maintainer: Erik Schnetter <schnetter@gmail.com>+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
+ package.yaml view
@@ -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 <schnetter@gmail.com>"+maintainer: "Erik Schnetter <schnetter@gmail.com>"+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
+ src/example1.hs view
@@ -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
+ src/example2.hs view
@@ -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"
+ src/version.hs view
@@ -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 ++ ")"
+ stack.yaml view
@@ -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:+ - .
+ stack.yaml.lock view
@@ -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
+ tests/binary/Main.hs view
@@ -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 @? ""+ ]