mpi-hs (empty) → 0.1.0.1
raw patch · 13 files changed
+3226/−0 lines, 13 filesdep +basedep +criteriondep +monad-loopssetup-changed
Dependencies added: base, criterion, monad-loops, mpi-hs, tasty, tasty-hspec, tasty-hunit, unix
Files
- LICENSE +217/−0
- README.md +63/−0
- Setup.hs +7/−0
- bench/Main.hs +6/−0
- c/include/mpihs.h +77/−0
- c/src/mpihs.c +75/−0
- lib/Control/Distributed/MPI.chs +1842/−0
- lib/Control/Distributed/MPI/Simple.hs +69/−0
- mpi-hs.cabal +115/−0
- package.yaml +97/−0
- src/Main.hs +18/−0
- stack.yaml +11/−0
- test/Main.hs +629/−0
+ LICENSE view
@@ -0,0 +1,217 @@+Copyright 2018 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,63 @@+# [mpi-hs](https://github.com/eschnett/mpi-hs)++[MPI](https://www.mpi-forum.org) bindings for Haskell++[](https://circleci.com/gh/eschnett/mpi-hs)++++## Overview++MPI (the _Message Passing Interface_) is widely used standard for+distributed-memory programming on HPC (High Performance Computing)+systems. MPI allows exchanging data (_messages_) between programs+running in parallel. There are several high-quality open source MPI+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),+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 MPI API, apart from certain "reasonable" mappings from C+to Haskell (e.g. output arguments that are in C stored to a pointer+are in Haskell regular return values). A high-level API simplifies+exchanging arbitrary values that can be serialized.++++## Example++This is a typical MPI C code:+```C+#include <stdio.h>+#include <mpi.h>++int main(int argc, char** argv) {+ MPI_Init(&argc, &argv);+ int rank, size;+ MPI_Comm_rank(MPI_COMM_WORLD, &rank);+ MPI_Comm_size(MPI_COMM_WORLD, &size);+ printf("This is process %d of %d\n", rank, size);+ MPI_Finalize();+ return 0;+}+```++The Haskell equivalent looks like this:+```Haskell+import Control.Distributed.MPI as MPI++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+ MPI.finalize+```
+ 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
+ bench/Main.hs view
@@ -0,0 +1,6 @@+-- You can benchmark your code quickly and effectively with Criterion. See its+-- website for help: <http://www.serpentine.com/criterion/>.+import Criterion.Main++main :: IO ()+main = defaultMain [bench "const" (whnf const ())]
+ c/include/mpihs.h view
@@ -0,0 +1,77 @@+#ifndef MPIHS_H+#define MPIHS_H++#include <mpi.h>++enum ComparisonResult {+ Identical = MPI_IDENT,+ Congruent = MPI_CONGRUENT,+ Similar = MPI_SIMILAR,+ Unequal = MPI_UNEQUAL+};++enum ThreadSupport {+ ThreadSingle = MPI_THREAD_SINGLE,+ ThreadFunneled = MPI_THREAD_FUNNELED,+ ThreadSerialized = MPI_THREAD_SERIALIZED,+ ThreadMultiple = MPI_THREAD_MULTIPLE+};++// Comm+void mpihs_get_comm_null(MPI_Comm *comm);+void mpihs_get_comm_self(MPI_Comm *comm);+void mpihs_get_comm_world(MPI_Comm *comm);++// Count+int mpihs_get_undefined();++// Datatype+void mpihs_get_datatype_null(MPI_Datatype *datatype);++void mpihs_get_byte(MPI_Datatype *datatype);+void mpihs_get_char(MPI_Datatype *datatype);+void mpihs_get_double(MPI_Datatype *datatype);+void mpihs_get_float(MPI_Datatype *datatype);+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_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_short(MPI_Datatype *datatype);++// Op+void mpihs_get_op_null(MPI_Op *op);++void mpihs_get_band(MPI_Op *op);+void mpihs_get_bor(MPI_Op *op);+void mpihs_get_bxor(MPI_Op *op);+void mpihs_get_land(MPI_Op *op);+void mpihs_get_lor(MPI_Op *op);+void mpihs_get_lxor(MPI_Op *op);+void mpihs_get_max(MPI_Op *op);+void mpihs_get_maxloc(MPI_Op *op);+void mpihs_get_min(MPI_Op *op);+void mpihs_get_minloc(MPI_Op *op);+void mpihs_get_prod(MPI_Op *op);+void mpihs_get_sum(MPI_Op *op);++// Rank+int mpihs_get_any_source();++// Request+void mpihs_get_request_null(MPI_Request *request);++// Status+MPI_Status *mpihs_get_status_ignore();++// Tag+int mpihs_get_any_tag();++// Wrappers+int mpihs_iprobe(int source, int tag, MPI_Comm *comm, int *flag,+ MPI_Status *status);++#endif // #ifndef MPIHS_H
+ c/src/mpihs.c view
@@ -0,0 +1,75 @@+#include <mpi.h>+#include <mpihs.h>++// Comm+void mpihs_get_comm_null(MPI_Comm *comm) { *comm = MPI_COMM_NULL; }+void mpihs_get_comm_self(MPI_Comm *comm) { *comm = MPI_COMM_SELF; }+void mpihs_get_comm_world(MPI_Comm *comm) { *comm = MPI_COMM_WORLD; }++// Count+int mpihs_get_undefined() { return MPI_UNDEFINED; }++// Datatype+void mpihs_get_datatype_null(MPI_Datatype *datatype) {+ *datatype = MPI_DATATYPE_NULL;+}++void mpihs_get_byte(MPI_Datatype *datatype) { *datatype = MPI_BYTE; }+void mpihs_get_char(MPI_Datatype *datatype) { *datatype = MPI_CHAR; }+void mpihs_get_double(MPI_Datatype *datatype) { *datatype = MPI_DOUBLE; }+void mpihs_get_float(MPI_Datatype *datatype) { *datatype = MPI_FLOAT; }+void mpihs_get_int(MPI_Datatype *datatype) { *datatype = MPI_INT; }+void mpihs_get_long(MPI_Datatype *datatype) { *datatype = MPI_LONG; }+void mpihs_get_long_double(MPI_Datatype *datatype) {+ *datatype = MPI_LONG_DOUBLE;+}+void mpihs_get_long_long_int(MPI_Datatype *datatype) {+ *datatype = MPI_LONG_LONG_INT;+}+void mpihs_get_short(MPI_Datatype *datatype) { *datatype = MPI_SHORT; }+void mpihs_get_unsigned(MPI_Datatype *datatype) { *datatype = MPI_UNSIGNED; }+void mpihs_get_unsigned_char(MPI_Datatype *datatype) {+ *datatype = MPI_UNSIGNED_CHAR;+}+void mpihs_get_unsigned_long(MPI_Datatype *datatype) {+ *datatype = MPI_UNSIGNED_LONG;+}+void mpihs_get_unsigned_short(MPI_Datatype *datatype) {+ *datatype = MPI_UNSIGNED_SHORT;+}++// Op+void mpihs_get_op_null(MPI_Op *op) { *op = MPI_OP_NULL; }++void mpihs_get_band(MPI_Op *op) { *op = MPI_BAND; }+void mpihs_get_bor(MPI_Op *op) { *op = MPI_BOR; }+void mpihs_get_bxor(MPI_Op *op) { *op = MPI_BXOR; }+void mpihs_get_land(MPI_Op *op) { *op = MPI_LAND; }+void mpihs_get_lor(MPI_Op *op) { *op = MPI_LOR; }+void mpihs_get_lxor(MPI_Op *op) { *op = MPI_LXOR; }+void mpihs_get_max(MPI_Op *op) { *op = MPI_MAX; }+void mpihs_get_maxloc(MPI_Op *op) { *op = MPI_MAXLOC; }+void mpihs_get_min(MPI_Op *op) { *op = MPI_MIN; }+void mpihs_get_minloc(MPI_Op *op) { *op = MPI_MINLOC; }+void mpihs_get_prod(MPI_Op *op) { *op = MPI_PROD; }+void mpihs_get_sum(MPI_Op *op) { *op = MPI_SUM; }++// Rank+int mpihs_get_any_source() { return MPI_ANY_SOURCE; }++// Request+void mpihs_get_request_null(MPI_Request *request) {+ *request = MPI_REQUEST_NULL;+}++// Status+MPI_Status *mpihs_get_status_ignore() { return MPI_STATUS_IGNORE; }++// Tag+int mpihs_get_any_tag() { return MPI_ANY_TAG; }++// Wrappers+int mpihs_iprobe(int source, int tag, MPI_Comm *comm, int *flag,+ MPI_Status *status) {+ return MPI_Iprobe(source, tag, *comm, flag, status);+}
+ lib/Control/Distributed/MPI.chs view
@@ -0,0 +1,1842 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++#include <mpi.h>+#include <mpihs.h>++++-- | Module: Control.Distributed.MPI+-- Description: MPI bindings for Haskell+-- Copyright: (C) 2018 Erik Schnetter+-- License: Apache-2.0+-- Maintainer: Erik Schnetter <schnetter@gmail.com>+-- Stability: experimental+-- Portability: Requires an externally installed MPI library+--+-- MPI (the [Message Passing Interface](https://www.mpi-forum.org)) is+-- widely used standard for distributed-memory programming on HPC+-- (High Performance Computing) systems. MPI allows exchanging data+-- (_messages_) between programs running in parallel. There are+-- several high-quality open source MPI 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),+-- 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 MPI API, apart from certain "reasonable"+-- mappings from C to Haskell (e.g. output arguments that are in C+-- stored to a pointer are in Haskell regular return values). A+-- high-level API simplifies exchanging arbitrary values that can be+-- serialized.+--+-- This module 'MPI' is the low-level interface.+--+-- In general, the MPI C API is translated to Haskell in the following+-- way, greatly aided by @c2hs@:+--+-- * Names of constants and functions have the @MPI_@ prefix removed.+-- Underscores are replaced by CamelCase. The 'MPI' module is+-- intended to be imported qualified, as in 'import qualified+-- Control.Distributed.MPI as MPI'.+--+-- * Opaque types such as @MPI_Request@ are wrapped via newtypes+-- holding pointers and are allocated on the heap as foreign+-- pointers.+--+-- * The MPI error return code is omitted. Currently error codes are+-- ignored, since the default MPI behaviour is to terminate the+-- application instead of actually returning error codes. In the+-- future, error codes might be reported via exceptions.+--+-- * Output arguments that are written via pointers in C are returned.+-- Some functions now return tuples. If the output argument is a+-- boolean value that indicates whether another output argument is+-- value, then this is translated into a 'Maybe'.+--+-- * MPI has a facility to pass @MPI_STATUS_IGNORE@ to indicate that+-- no message status should be returned. This is instead handled by+-- providing alternative functions ending with an underscore (e.g.+-- 'recv_') that return @()@ instead of 'Status'.+--+-- * Datatype arguments are hidden. Instead, the correct MPI datatypes+-- are inferred from the pointer type specifying the communication+-- buffers. (This translation could be relaxed, and the original MPI+-- functions could be exposed as well when needed.)++module Control.Distributed.MPI+ ( -- * Types, and associated functions constants++ -- ** Communicators+ Comm(..)+ , ComparisonResult(..)+ , commCompare+ , commRank+ , commSize+ , commNull+ , commSelf+ , commWorld++ -- ** Message sizes+ , Count(..)+ , fromCount+ , toCount+ , countUndefined++ -- ** Datatypes+ , Datatype(..)+ , Pointer(..)+ -- TODO: use a module for this namespace+ , datatypeNull+ , datatypeByte+ , datatypeChar+ , datatypeDouble+ , datatypeFloat+ , datatypeInt+ , datatypeLong+ , datatypeLongDouble+ , datatypeLongLongInt+ , datatypeShort+ , datatypeUnsigned+ , datatypeUnsignedChar+ , datatypeUnsignedLong+ , datatypeUnsignedShort+ , HasDatatype(..)+ -- , datatypeOf++ -- ** Reduction operations+ , Op(..)+ -- TODO: use a module for this namespace+ , opNull+ , opBand+ , opBor+ , opBxor+ , opLand+ , opLor+ , opLxor+ , opMax+ , opMaxloc+ , opMin+ , opMinloc+ , opProd+ , opSum+ -- , HasOp(..)++ -- ** Process ranks+ , Rank(..)+ , fromRank+ , rootRank+ , toRank+ , anySource++ -- ** Communication requests+ , Request(..)+ , requestNull++ -- ** Message status+ , Status(..)+ --, statusError+ , getSource+ , getTag+ -- , statusIgnore+ , getCount+ , getElements++ -- ** Message tags+ , Tag(..)+ , fromTag+ , toTag+ , unitTag+ , anyTag++ -- ** Thread support+ , ThreadSupport(..)+ , threadSupport++ -- * Functions++ -- ** Initialization and shutdown+ , abort+ , finalize+ , finalized+ , init+ , initThread+ , initialized++ -- ** Inquiry+ , getLibraryVersion+ , getProcessorName+ , getVersion++ -- ** Point-to-point (blocking)+ , probe+ , probe_+ , recv+ , recv_+ , send+ , sendrecv+ , sendrecv_+ , wait+ , wait_++ -- ** Point-to-point (non-blocking)+ , iprobe+ , iprobe_+ , irecv+ , isend+ , test+ , test_++ -- ** Collective (blocking)+ , allgather+ , allreduce+ , alltoall+ , barrier+ , bcast+ , exscan+ , gather+ , reduce+ , scan+ , scatter++ -- ** Collective (non-blocking)+ , iallgather+ , iallreduce+ , ialltoall+ , ibarrier+ , ibcast+ , iexscan+ , igather+ , ireduce+ , iscan+ , iscatter++ -- ** Timing+ , wtick+ , wtime+ ) where++import Prelude hiding (fromEnum, fst, init, toEnum)+import qualified Prelude++import Control.Monad (liftM)+import Data.Coerce+import Data.IORef+import Data.Ix+import qualified Data.Monoid as Monoid+import qualified Data.Semigroup as Semigroup+import Data.Version+import Foreign+import Foreign.C.String+import Foreign.C.Types+import GHC.Arr (indexError)+import System.IO.Unsafe (unsafePerformIO)++default (Int)++{#context prefix = "MPI"#}++++--------------------------------------------------------------------------------++-- See GHC's includes/rts/Flags.h+foreign import ccall "&rts_argc" rtsArgc :: Ptr CInt+foreign import ccall "&rts_argv" rtsArgv :: Ptr (Ptr CString)+argc :: CInt+argv :: Ptr CString+argc = unsafePerformIO $ peek rtsArgc+argv = unsafePerformIO $ peek rtsArgv++++--------------------------------------------------------------------------------++-- Arguments++fromEnum :: (Enum e, Integral i) => e -> i+fromEnum = fromIntegral . Prelude.fromEnum++toEnum :: (Integral i, Enum e) => i -> e+toEnum = Prelude.toEnum . fromIntegral++-- Return values++bool2maybe :: (Bool, a) -> Maybe a+bool2maybe (False, _) = Nothing+bool2maybe (True, x) = Just x++-- a Bool, probably represented as CInt+peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool+peekBool = liftM toBool . peek++-- a type that we wrapped, e.g. CInt and Rank+peekCoerce :: (Storable a, Coercible a b) => Ptr a -> IO b+peekCoerce = liftM coerce . peek++peekEnum :: (Integral i, Storable i, Enum e) => Ptr i -> IO e+peekEnum = liftM toEnum . peek++peekInt :: (Integral i, Storable i) => Ptr i -> IO Int+peekInt = liftM fromIntegral . peek++++--------------------------------------------------------------------------------++-- Types++++-- | A generic pointer-like type that supports converting to a 'Ptr'.+-- This class describes the buffers used to send and receive messages.+class Pointer p where+ withPtr :: Storable a => p a -> (Ptr a -> IO b) -> IO b++instance Pointer Ptr where+ withPtr p f = f p++instance Pointer ForeignPtr where+ withPtr = withForeignPtr++instance Pointer StablePtr where+ withPtr p f = f (castPtr (castStablePtrToPtr p))++++-- | An MPI communicator, wrapping @MPI_Comm@. A communicator defines+-- an independent communication channel between a group of processes.+-- Communicators need to be explicitly created and freed by the MPI+-- library. 'commWorld' is a communicator that is always available,+-- and which includes all processes.+{#pointer *MPI_Comm as Comm foreign newtype#}++deriving instance Eq Comm+deriving instance Ord Comm+deriving instance Show Comm++-- | The result of comparing two MPI communicator (see 'commCompare').+{#enum ComparisonResult {} deriving (Eq, Ord, Read, Show)#}++++-- | A newtype wrapper describing the size of a message. Use 'toCount'+-- and 'fromCount' to convert between 'Count' and other integral+-- types.+newtype Count = Count CInt+ deriving (Eq, Ord, Enum, Integral, Num, Real, Storable)++instance Read Count where+ readsPrec p = map (\(c, s) -> (Count c, s)) . readsPrec p++instance Show Count where+ showsPrec p (Count c) = showsPrec p c++-- | Convert an integer to a count.+toCount :: Integral i => i -> Count+toCount i = Count (fromIntegral i)++-- | Convert a count to an integer.+fromCount :: Integral i => Count -> i+fromCount (Count c) = fromIntegral c++++-- | An MPI datatype, wrapping @MPI_Datatype@. Datatypes need to be+-- explicitly created and freed by the MPI library. Predefined+-- datatypes exist for most simple C types such as 'CInt' or+-- 'CDouble'.+{#pointer *MPI_Datatype as Datatype foreign newtype#}++deriving instance Eq Datatype+deriving instance Ord Datatype+deriving instance Show Datatype++++-- | An MPI reduction operation, wrapping @MPI_Op@. Reduction+-- operations need to be explicitly created and freed by the MPI+-- library. Predefined operation exist for simple semigroups such as+-- sum, maximum, or minimum.+--+-- An MPI reduction operation corresponds to a Semigroup, not a+-- Monoid, i.e. MPI has no notion of a respective neutral element.+{#pointer *MPI_Op as Op foreign newtype#}++deriving instance Eq Op+deriving instance Ord Op+deriving instance Show Op++++-- | A newtype wrapper describing the source or destination of a+-- message, i.e. a process. Each communicator numbers its processes+-- sequentially starting from zero. Use 'toRank' and 'fromRank' to+-- convert between 'Rank' and other integral types. 'rootRank' is the+-- root (first) process of a communicator.+--+-- The association between a rank and a communicator is not explicitly+-- tracked. From MPI's point of view, ranks are simply integers. The+-- same rank might correspond to different processes in different+-- communicators.+newtype Rank = Rank CInt+ deriving (Eq, Ord, Enum, Integral, Num, Real, Storable)++instance Read Rank where+ readsPrec p = map (\(r, s) -> (Rank r, s)) . readsPrec p++instance Show Rank where+ showsPrec p (Rank r) = showsPrec p r++instance Ix Rank where+ range (Rank rmin, Rank rmax) = Rank <$> [rmin..rmax]+ {-# INLINE index #-}+ index b@(Rank rmin, _) i@(Rank r)+ | inRange b i = fromIntegral (r - rmin)+ | otherwise = indexError b i "MPI.Rank"+ inRange (Rank rmin, Rank rmax) (Rank r) = rmin <= r && r <= rmax++-- | Convert an enum to a rank.+toRank :: Enum e => e -> Rank+toRank e = Rank (fromIntegral (fromEnum e))++-- | Convert a rank to an enum.+fromRank :: Enum e => Rank -> e+fromRank (Rank r) = toEnum (fromIntegral r)++-- | The root (first) rank of a communicator.+rootRank :: Rank+rootRank = toRank 0++++-- | An MPI request, wrapping @MPI_Request@. A request describes a+-- communication that is currently in progress. Each request must be+-- explicitly freed via 'cancel', 'test', or 'wait'.+{#pointer *MPI_Request as Request foreign newtype#}++deriving instance Eq Request+deriving instance Ord Request+deriving instance Show Request++++-- | An MPI status, wrapping @MPI_Status@. The status describes+-- certain properties of a message. It contains information such as+-- the source of a communication ('getSource'), the message tag+-- ('getTag'), or the size of the message ('getCount', 'getElements').+--+-- In many cases, the status is not interesting. In this case, you can+-- use alternative functions ending with an underscore (e.g. 'recv_')+-- that do not calculate a status.+--+-- The status is particularly interesting when using 'probe' or+-- 'iprobe', as it describes a message that is ready to be received,+-- but which has not been received yet.+{#pointer *MPI_Status as Status foreign newtype#}++deriving instance Eq Status+deriving instance Ord Status+deriving instance Show Status++-- statusError :: Status -> IO Error+-- statusError (Status mst) =+-- Error $ {#get MPI_Status.MPI_ERROR#} mst++-- | Get the source rank of a message (@MPI_SOURCE@).+getSource :: Status -> IO Rank+getSource (Status fst) =+ withForeignPtr fst (\pst -> Rank <$> {#get MPI_Status->MPI_SOURCE#} pst)++-- | Get the message tag (@MPI_TAG@).+getTag :: Status -> IO Tag+getTag (Status fst) =+ withForeignPtr fst (\pst -> Tag <$> {#get MPI_Status->MPI_TAG#} pst)++++-- | A newtype wrapper describing a message tag. A tag defines a+-- sub-channel within a communicator. While communicators are+-- heavy-weight object that are expensive to set up and tear down, a+-- tag is a lightweight mechanism using an integer. Use 'toTag' and+-- 'fromTag' to convert between 'Count' and other enum types.+-- 'unitTag' defines a standard tag that can be used as default.+newtype Tag = Tag CInt+ deriving (Eq, Ord, Read, Show, Enum, Num, Storable)++-- | Convert an enum to a tag.+toTag :: Enum e => e -> Tag+toTag e = Tag (fromIntegral (fromEnum e))++-- | Convert a tag to an enum.+fromTag :: Enum e => Tag -> e+fromTag (Tag t) = toEnum (fromIntegral t)++-- | Useful default tag.+unitTag :: Tag+unitTag = toTag ()++++-- | Thread support levels for MPI (see 'initThread'):+--+-- * 'ThreadSingle' (@MPI_THREAD_SINGLE@): The application must be+-- * single-threaded+--+-- * 'ThreadFunneled' (@MPI_THREAD_FUNNELED@): The application might+-- be multi-threaded, but only a single thread will call MPI+--+-- * 'ThreadSerialized' (@MPI_THREAD_SERIALIZED@): The application+-- might be multi-threaded, but the application guarantees that only+-- one thread at a time will call MPI+--+-- * 'ThreadMultiple' (@MPI_THREAD_MULTIPLE@): The application is+-- multi-threaded, and different threads might call MPI at the same+-- time+{#enum ThreadSupport {} deriving (Eq, Ord, Read, Show)#}++-- | When MPI is initialized with this library, then it will remember+-- the provided level of thread support. (This might be less than the+-- requested level.)+threadSupport :: IO (Maybe ThreadSupport)+threadSupport = readIORef providedThreadSupport++providedThreadSupport :: IORef (Maybe ThreadSupport)+providedThreadSupport = unsafePerformIO (newIORef Nothing)++++--------------------------------------------------------------------------------++-- Constants++++-- | A null (invalid) communicator (@MPI_COMM_NULL@).+{#fun pure mpihs_get_comm_null as commNull {+} -> `Comm'#}++-- | The self communicator (@MPI_COMM_SELF@). Each process has its own+-- self communicator that includes only this process.+{#fun pure mpihs_get_comm_self as commSelf {+} -> `Comm'#}++-- | The world communicator, which includes all processes+-- (@MPI_COMM_WORLD@).+{#fun pure mpihs_get_comm_world as commWorld {+} -> `Comm'#}++++-- | Error value returned by 'getCount' if the message is too large,+-- or if the message size is not an integer multiple of the provided+-- datatype (@MPI_UNDEFINED@).+{#fun pure mpihs_get_undefined as countUndefined {} -> `Count' toCount#}++++-- | A null (invalid) datatype.+{#fun pure mpihs_get_datatype_null as datatypeNull {+} -> `Datatype'#}++-- | MPI datatype for a byte (essentially 'CUChar') (@MPI_BYTE@).+{#fun pure mpihs_get_byte as datatypeByte {+} -> `Datatype'#}++-- | MPI datatype for 'CChar' (@MPI_CHAR@).+{#fun pure mpihs_get_char as datatypeChar {+} -> `Datatype'#}++-- | MPI datatype for 'CDouble' (@MPI_DOUBLE@).+{#fun pure mpihs_get_double as datatypeDouble {+} -> `Datatype'#}++-- | MPI datatype for 'CFloat' (@MPI_FLOAT@).+{#fun pure mpihs_get_float as datatypeFloat {+} -> `Datatype'#}++-- | MPI datatype for 'CInt' (@MPI_INT@).+{#fun pure mpihs_get_int as datatypeInt {+} -> `Datatype'#}++-- | MPI datatype for 'CLong' (@MPI_LONG@).+{#fun pure mpihs_get_long as datatypeLong {+} -> `Datatype'#}++-- | MPI datatype for the C type 'long double' (@MPI_LONG_DOUBLE@).+{#fun pure mpihs_get_long_double as datatypeLongDouble {+} -> `Datatype'#}++-- | MPI datatype for 'CLLong' (@MPI_LONG_LONG_INT@). (There is no MPI+-- datatype for 'CULLong@).+{#fun pure mpihs_get_long_long_int as datatypeLongLongInt {+} -> `Datatype'#}++-- | MPI datatype for 'CShort' (@MPI_SHORT@).+{#fun pure mpihs_get_short as datatypeShort {+} -> `Datatype'#}++-- | MPI datatype for 'CUInt' (@MPI_UNSIGNED@).+{#fun pure mpihs_get_unsigned as datatypeUnsigned {+} -> `Datatype'#}++-- | MPI datatype for 'CUChar' (@MPI_UNSIGNED_CHAR@).+{#fun pure mpihs_get_unsigned_char as datatypeUnsignedChar {+} -> `Datatype'#}++-- | MPI datatype for 'CULong' (@MPI_UNSIGNED_LONG@).+{#fun pure mpihs_get_unsigned_long as datatypeUnsignedLong {+} -> `Datatype'#}++-- | MPI datatype for 'CUShort' (@MPI_UNSIGNED_SHORT@).+{#fun pure mpihs_get_unsigned_short as datatypeUnsignedShort {+} -> `Datatype'#}++-- | A type class mapping Haskell types to MPI datatypes. This is used+-- to automatically determine the MPI datatype for communication+-- buffers.+class HasDatatype a where datatype :: Datatype+instance HasDatatype CChar where datatype = datatypeChar+instance HasDatatype CDouble where datatype = datatypeDouble+instance HasDatatype CFloat where datatype = datatypeFloat+instance HasDatatype CInt where datatype = datatypeInt+instance HasDatatype CLLong where datatype = datatypeLongLongInt+instance HasDatatype CLong where datatype = datatypeLong+instance HasDatatype CShort where datatype = datatypeShort+instance HasDatatype CUChar where datatype = datatypeUnsignedChar+instance HasDatatype CUInt where datatype = datatypeUnsigned+instance HasDatatype CULong where datatype = datatypeUnsignedLong+instance HasDatatype CUShort where datatype = datatypeUnsignedShort++-- instance Coercible Int CChar => HasDatatype Int where+-- datatype = datatype @CChar+-- instance Coercible Int CShort => HasDatatype Int where+-- datatype = datatype @CShort+-- instance Coercible Int CInt => HasDatatype Int where+-- datatype = datatype @CInt+-- instance Coercible Int CLong => HasDatatype Int where+-- datatype = datatype @CLong+-- instance Coercible Int CLLong => HasDatatype Int where+-- datatype = datatype @CLLong++-- instance HasDatatype Int where+-- datatype = if | coercible @Int @CChar -> datatype @CChar+-- | coercible @Int @CShort -> datatype @CShort+-- | coercible @Int @CInt -> datatype @CInt+-- | coercible @Int @CLong -> datatype @CLong+-- | coercible @Int @CLLong -> datatype @CLLong+-- instance HasDatatype Int8 where+-- datatype = if | coercible @Int @CChar -> datatype @CChar+-- | coercible @Int @CShort -> datatype @CShort+-- | coercible @Int @CInt -> datatype @CInt+-- | coercible @Int @CLong -> datatype @CLong+-- | coercible @Int @CLLong -> datatype @CLLong+-- instance HasDatatype Int16 where+-- datatype = if | coercible @Int @CChar -> datatype @CChar+-- | coercible @Int @CShort -> datatype @CShort+-- | coercible @Int @CInt -> datatype @CInt+-- | coercible @Int @CLong -> datatype @CLong+-- | coercible @Int @CLLong -> datatype @CLLong+-- instance HasDatatype Int32 where+-- datatype = if | coercible @Int @CChar -> datatype @CChar+-- | coercible @Int @CShort -> datatype @CShort+-- | coercible @Int @CInt -> datatype @CInt+-- | coercible @Int @CLong -> datatype @CLong+-- | coercible @Int @CLLong -> datatype @CLLong+-- instance HasDatatype Int64 where+-- datatype = if | coercible @Int @CChar -> datatype @CChar+-- | coercible @Int @CShort -> datatype @CShort+-- | coercible @Int @CInt -> datatype @CInt+-- | coercible @Int @CLong -> datatype @CLong+-- | coercible @Int @CLLong -> datatype @CLLong+-- instance HasDatatype Word where+-- datatype = if | coercible @Int @CUChar -> datatype @CUChar+-- | coercible @Int @CUShort -> datatype @CUShort+-- | coercible @Int @CUInt -> datatype @CUInt+-- | coercible @Int @CULong -> datatype @CULong+-- -- | coercible @Int @CULLong -> datatype @CULLong+-- instance HasDatatype Word8 where+-- datatype = if | coercible @Int @CUChar -> datatype @CUChar+-- | coercible @Int @CUShort -> datatype @CUShort+-- | coercible @Int @CUInt -> datatype @CUInt+-- | coercible @Int @CULong -> datatype @CULong+-- -- | coercible @Int @CULLong -> datatype @CULLong+-- instance HasDatatype Word16 where+-- datatype = if | coercible @Int @CUChar -> datatype @CUChar+-- | coercible @Int @CUShort -> datatype @CUShort+-- | coercible @Int @CUInt -> datatype @CUInt+-- | coercible @Int @CULong -> datatype @CULong+-- -- | coercible @Int @CULLong -> datatype @CULLong+-- instance HasDatatype Word32 where+-- datatype = if | coercible @Int @CUChar -> datatype @CUChar+-- | coercible @Int @CUShort -> datatype @CUShort+-- | coercible @Int @CUInt -> datatype @CUInt+-- | coercible @Int @CULong -> datatype @CULong+-- -- | coercible @Int @CULLong -> datatype @CULLong+-- instance HasDatatype Word64 where+-- datatype = if | coercible @Int @CUChar -> datatype @CUChar+-- | coercible @Int @CUShort -> datatype @CUShort+-- | coercible @Int @CUInt -> datatype @CUInt+-- | coercible @Int @CULong -> datatype @CULong+-- -- | coercible @Int @CULLong -> datatype @CULLong+-- instance HasDatatype Float where+-- datatype = if | coercible @Float @CFloat -> datatype @CFloat+-- | coercible @Float @CDouble -> datatype @CDouble+-- instance HasDatatype Double where+-- datatype = if | coercible @Double @CFloat -> datatype @CFloat+-- | coercible @Double @CDouble -> datatype @CDouble++-- datatypeOf :: forall a p. HasDatatype a => p a -> Datatype+-- datatypeOf _ = datatype @a++++-- | A null (invalid) reduction operation (@MPI_OP_NULL@).+{#fun pure mpihs_get_op_null as opNull {+} -> `Op'#}++-- | The bitwise and @(.&.)@ reduction operation (@MPI_BAND@).+{#fun pure mpihs_get_band as opBand {+} -> `Op'#}++-- | The bitwise or @(.|.)@ reduction operation (@MPI_BOR@).+{#fun pure mpihs_get_bor as opBor {+} -> `Op'#}++-- | The bitwise (@xor@) reduction operation (@MPI_BXOR@).+{#fun pure mpihs_get_bxor as opBxor {+} -> `Op'#}++-- | The logical and @(&&)@ reduction operation (@MPI_LAND@).+{#fun pure mpihs_get_land as opLand {+} -> `Op'#}++-- | The logical or @(||)@ reduction operation (@MPI_LOR@).+{#fun pure mpihs_get_lor as opLor {+} -> `Op'#}++-- | The logical xor reduction operation (@MPI_LXOR@).+{#fun pure mpihs_get_lxor as opLxor {+} -> `Op'#}++-- | The 'maximum' reduction operation (@MPI_MAX@).+{#fun pure mpihs_get_max as opMax {+} -> `Op'#}++-- | The argmax reduction operation to find the maximum and its rank+-- (@MPI_MAXLOC@).+{#fun pure mpihs_get_maxloc as opMaxloc {+} -> `Op'#}++-- | The 'minimum' reduction operation (@MPI_MIN@).+{#fun pure mpihs_get_min as opMin {+} -> `Op'#}++-- | The argmin reduction operation to find the minimum and its rank+-- (@MPI_MINLOC@).+{#fun pure mpihs_get_minloc as opMinloc {+} -> `Op'#}++-- | The (@product@) reduction operation (@MPI_PROD@).+{#fun pure mpihs_get_prod as opProd {+} -> `Op'#}++-- | The (@sum@) reduction operation (@MPI_SUM@).+{#fun pure mpihs_get_sum as opSum {+} -> `Op'#}++instance HasDatatype a => HasDatatype (Monoid.Product a) where+ datatype = datatype @a+instance HasDatatype a => HasDatatype (Monoid.Sum a) where+ datatype = datatype @a+instance HasDatatype a => HasDatatype (Semigroup.Max a) where+ datatype = datatype @a+instance HasDatatype a => HasDatatype (Semigroup.Min a) where+ datatype = datatype @a++-- class (Monoid a, HasDatatype a) => HasOp a where op :: Op+-- instance (Num a, HasDatatype a) => HasOp (Monoid.Product a) where+-- op = opProd+-- instance (Num a, HasDatatype a) => HasOp (Monoid.Sum a) where+-- op = opSum+-- instance (Bounded a, Ord a, HasDatatype a) => HasOp (Semigroup.Max a) where+-- op = opMax+-- instance (Bounded a, Ord a, HasDatatype a) => HasOp (Semigroup.Min a) where+-- op = opMin++++-- | Rank placeholder to specify that a message can be received from+-- any source (@MPI_ANY_SOURCE@). When calling 'probe' or 'recv' (or+-- 'iprobe' or 'irecv') with 'anySource' as source, the actual source+-- can be determined from the returned message status via 'getSource'.+{#fun pure mpihs_get_any_source as anySource {} -> `Rank' toRank#}++++-- | A null (invalid) request (@MPI_REQUEST_NULL@).+{#fun pure mpihs_get_request_null as requestNull {+} -> `Request'#}++++{#fun pure mpihs_get_status_ignore as statusIgnore {} -> `Status'#}++withStatusIgnore :: (Ptr Status -> IO a) -> IO a+withStatusIgnore = withStatus statusIgnore++++-- | Tag placeholder to specify that a message can have any tag+-- (@MPI_ANY_TAG@). When calling 'probe' or 'recv' (or 'iprobe' or+-- 'irecv') with 'anyTag' as tag, the actual tag can be determined+-- from the returned message status via 'getTag'.+{#fun pure mpihs_get_any_tag as anyTag {} -> `Tag' toTag#}++++--------------------------------------------------------------------------------++-- Functions++++-- | Terminate MPI execution environment+-- (@[MPI_Abort](https://www.open-mpi.org/doc/current/man3/MPI_Abort.3.php)@).+{#fun Abort as ^+ { withComm* %`Comm' -- ^ Communicator describing which processes+ -- to terminate+ , fromIntegral `Int' -- ^ Error code+ } -> `()' return*-#}++{#fun Allgather as allgatherTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Gather data from all processes and broadcast the result+-- (collective,+-- @[MPI_Allgather](https://www.open-mpi.org/doc/current/man3/MPI_Allgather.3.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+allgather :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Comm -- ^ Communicator+ -> IO ()+allgather sendbuf sendcount recvbuf recvcount comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ allgatherTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ comm++{#fun Allreduce as allreduceTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Reduce data from all processes and broadcast the result+-- (collective,+-- @[MPI_Allreduce](https://www.open-mpi.org/doc/current/man3/MPI_Allreduce.3.php)@).+-- The MPI datatype is determined automatically from the buffer+-- pointer types.+allreduce :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO ()+allreduce sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ allreduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op+ comm++{#fun Alltoall as alltoallTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Send data from all processes to all processes (collective,+-- @[MPI_Alltoall](https://www.open-mpi.org/doc/current/man3/MPI_Alltoall.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+alltoall :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Comm -- ^ Communicator+ -> IO ()+alltoall sendbuf sendcount recvbuf recvcount comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ alltoallTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ comm++-- | Barrier (collective,+-- @[MPI_Barrier](https://www.open-mpi.org/doc/current/man3/MPI_Barrier.3.php)@).+{#fun Barrier as ^+ { withComm* %`Comm' -- ^ Communicator+ } -> `()' return*-#}++{#fun Bcast as bcastTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Broadcast data from one process to all processes (collective,+-- @[MPI_Bcast](https://www.open-mpi.org/doc/current/man3/MPI_Bcast.3.php)@).+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+bcast :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Buffer pointer (read on the root process, written on+ -- all other processes)+ -> Count -- ^ Number of elements+ -> Rank -- ^ Root rank (sending process)+ -> Comm -- ^ Communicator+ -> IO ()+bcast buf count root comm =+ withPtr buf $ \buf' ->+ bcastTyped (castPtr buf') count (datatype @a) root comm++-- | Compare two communicators+-- (@[MPI_Comm_compare](https://www.open-mpi.org/doc/current/man3/MPI_Comm_compare.3.php)@).+{#fun unsafe Comm_compare as ^+ { withComm* %`Comm' -- ^ Communicator+ , withComm* %`Comm' -- ^ Other communicator+ , alloca- `ComparisonResult' peekEnum*+ } -> `()' return*-#}++-- | Return this process's rank in a communicator+-- (@[MPI_Comm_rank](https://www.open-mpi.org/doc/current/man3/MPI_Comm_rank.3.php)@).+{#fun unsafe Comm_rank as ^+ { withComm* %`Comm' -- ^ Communicator+ , alloca- `Rank' peekCoerce*+ } -> `()' return*-#}++-- | Return the number of processes in a communicator+-- (@[MPI_Comm_size](https://www.open-mpi.org/doc/current/man3/MPI_Comm_size.3.php)@).+{#fun unsafe Comm_size as ^+ { withComm* %`Comm' -- ^ Communicator+ , alloca- `Rank' peekCoerce*+ } -> `()' return*-#}++{#fun Exscan as exscanTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Reduce data from all processes via an exclusive (prefix) scan+-- (collective,+-- @[MPI_Exscan](https://www.open-mpi.org/doc/current/man3/MPI_Exscan.3.php)@).+-- Each process with rank @r@ receives the result of reducing data+-- from rank @0@ to rank @r-1@ (inclusive). Rank 0 should logically+-- receive a neutral element of the reduction operation, but instead+-- receives an undefined value since MPI is not aware of neutral+-- values for reductions.+--+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+exscan :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO ()+exscan sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ exscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm++-- | Finalize (shut down) the MPI library (collective, @[MPI_Finalize](https://www.open-mpi.org/doc/current/man3/MPI_Finalize.3.php)@).+{#fun Finalize as ^ {} -> `()' return*-#}++-- | Return whether the MPI library has been finalized+-- (@[MPI_Finalized](https://www.open-mpi.org/doc/current/man3/MPI_Finalized.3.php)@).+{#fun Finalized as ^ {alloca- `Bool' peekBool*} -> `()' return*-#}++{#fun Gather as gatherTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Gather data from all processes to the root process (collective,+-- @[MPI_Gather](https://www.open-mpi.org/doc/current/man3/MPI_Gather.3.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+gather :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer (only used on the root process)+ -> Count -- ^ Number of destination elements (only used on the+ -- root process)+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO ()+gather sendbuf sendcount recvbuf recvcount root comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ gatherTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ root comm++-- | Get the size of a message, in terms of objects of type 'Datatype'+-- (@[MPI_Get_count](https://www.open-mpi.org/doc/current/man3/MPI_Get_count.3.php)@).+-- To determine the MPI datatype for a given Haskell type, use+-- 'datatype' (call e.g. as 'datatype @CInt').+{#fun unsafe Get_count as ^+ { withStatus* `Status' -- ^ Message status+ , withDatatype* %`Datatype' -- ^ MPI datatype+ , alloca- `Int' peekInt*+ } -> `()' return*-#}++-- | Get the number of elements in message, in terms of sub-object of+-- the type 'datatype'+-- (@[MPI_Get_elements](https://www.open-mpi.org/doc/current/man3/MPI_Get_elements.3.php)@).+-- This is useful when a message contains partial objects of type+-- 'datatype'. To determine the MPI datatype for a given Haskell type,+-- use 'datatype' (call e.g. as 'datatype @CInt').+{#fun unsafe Get_elements as ^+ { withStatus* `Status' -- ^ Message status+ , withDatatype* %`Datatype' -- ^ MPI datatype+ , alloca- `Int' peekInt*+ } -> `()' return*-#}++{#fun unsafe Get_library_version as getLibraryVersion_+ { id `CString'+ , alloca- `Int' peekInt*+ } -> `()' return*-#}++-- | Return the version of the MPI library+-- (@[MPI_Get_library_version](https://www.open-mpi.org/doc/current/man3/MPI_Get_library_version.3.php)@).+-- Note that the version of the MPI standard that this library+-- implements is returned by 'getVersion'.+getLibraryVersion :: IO String+getLibraryVersion =+ do buf <- mallocForeignPtrBytes {#const MPI_MAX_LIBRARY_VERSION_STRING#}+ withForeignPtr buf $ \ptr ->+ do len <- getLibraryVersion_ ptr+ str <- peekCStringLen (ptr, len)+ return str++{#fun unsafe Get_processor_name as getProcessorName_+ { id `CString'+ , alloca- `Int' peekInt*+ } -> `()' return*-#}++-- | Return the name of the current process+-- (@[MPI_Get_Processor_name](https://www.open-mpi.org/doc/current/man3/MPI_Get_processor_name.3.php)@).+-- This should uniquely identify the hardware on which this process is+-- running.+getProcessorName :: IO String+getProcessorName =+ do buf <- mallocForeignPtrBytes {#const MPI_MAX_PROCESSOR_NAME#}+ withForeignPtr buf $ \ptr ->+ do len <- getProcessorName_ ptr+ str <- peekCStringLen (ptr, len)+ return str++{#fun unsafe Get_version as getVersion_+ { alloca- `Int' peekInt*+ , alloca- `Int' peekInt*+ } -> `()' return*-#}++-- | Return the version of the MPI standard implemented by this+-- library+-- (@[MPI_Get_version](https://www.open-mpi.org/doc/current/man3/MPI_Get_version.3.php)@).+-- Note that the version of the MPI library itself is returned by+-- 'getLibraryVersion'.+getVersion :: IO Version+getVersion =+ do (major, minor) <- getVersion_+ return (makeVersion [major, minor])++{#fun Iallgather as iallgatherTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to gather data from all processes and broadcast the result,+-- and return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Iallgather](https://www.open-mpi.org/doc/current/man3/MPI_Iallgather.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+iallgather :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+iallgather sendbuf sendcount recvbuf recvcount comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ iallgatherTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ comm++{#fun Iallreduce as iallreduceTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to reduce data from all processes and broadcast the result,+-- and return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Iallreduce](https://www.open-mpi.org/doc/current/man3/MPI_Iallreduce.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatype is determined automatically from the buffer+-- pointer types.+iallreduce :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+iallreduce sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ iallreduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op+ comm++{#fun Ialltoall as ialltoallTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to send data from all processes to all processes, and+-- return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Ialltoall](https://www.open-mpi.org/doc/current/man3/MPI_Ialltoall.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+ialltoall :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+ialltoall sendbuf sendcount recvbuf recvcount comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ ialltoallTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ comm++-- | Start a barrier, and return a handle to the communication request+-- (collective, non-blocking,+-- @[MPI_Ibarrier](https://www.open-mpi.org/doc/current/man3/MPI_Ibarrier.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+{#fun Ibarrier as ^+ { withComm* %`Comm' -- ^ Communicator+ , ++ } -> `Request' return*#}++{#fun Ibcast as ibcastTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to broadcast data from one process to all processes, and+-- return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Ibcast](https://www.open-mpi.org/doc/current/man3/MPI_Ibcast.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+ibcast :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Buffer pointer (read on the root process, written on+ -- all other processes)+ -> Count -- ^ Number of elements+ -> Rank -- ^ Root rank (sending process)+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+ibcast buf count root comm =+ withPtr buf $ \buf' ->+ ibcastTyped (castPtr buf') count (datatype @a) root comm++{#fun Iexscan as iexscanTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to reduce data from all processes via an exclusive (prefix)+-- scan, and return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Iexscan](https://www.open-mpi.org/doc/current/man3/MPI_Iexscan.3.php)@).+-- Each process with rank @r@ receives the result of reducing data+-- from rank @0@ to rank @r-1@ (inclusive). Rank 0 should logically+-- receive a neutral element of the reduction operation, but instead+-- receives an undefined value since MPI is not aware of neutral+-- values for reductions.+--+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+iexscan :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+iexscan sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ iexscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm++{#fun Igather as igatherTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to gather data from all processes to the root process, and+-- return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Igather](https://www.open-mpi.org/doc/current/man3/MPI_Igather.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+igather :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer+ -> Count -- ^ Number of source elements+ -> q b -- ^ Destination buffer (relevant only+ -- on the root process)+ -> Count -- ^ Number of destination elements+ -- (relevant only on the root process)+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+igather sendbuf sendcount recvbuf recvcount root comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ igatherTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ root comm++-- | Return whether the MPI library has been initialized+-- (@[MPI_Initialized](https://www.open-mpi.org/doc/current/man3/MPI_Initialized.3.php)@).+{#fun unsafe Initialized as ^ {alloca- `Bool' peekBool*} -> `()' return*-#}++{#fun Init as init_+ { with* `CInt'+ , with* `Ptr CString'+ } -> `()' return*-#}++-- | Initialize the MPI library (collective,+-- @[MPI_Init](https://www.open-mpi.org/doc/current/man3/MPI_Init.3.php)@).+-- This corresponds to calling 'initThread' 'ThreadSingle'.+init :: IO ()+init = do init_ argc argv+ writeIORef providedThreadSupport (Just ThreadSingle)++{#fun Init_thread as initThread_+ { with* `CInt'+ , with* `Ptr CString'+ , fromEnum `ThreadSupport'+ , alloca- `ThreadSupport' peekEnum*+ } -> `()' return*-#}++-- | Initialize the MPI library (collective,+-- @[MPI_Init_thread](https://www.open-mpi.org/doc/current/man3/MPI_Init_thread.3.php)@).+-- Note that the provided level of thread support might be less than+-- (!) the required level.+initThread :: ThreadSupport -- ^ required level of thread support+ -> IO ThreadSupport -- ^ provided level of thread support+initThread ts = do ts' <- initThread_ argc argv ts+ writeIORef providedThreadSupport (Just ts')+ return ts'++iprobeBool :: Rank -> Tag -> Comm -> IO (Bool, Status)+iprobeBool rank tag comm =+ withComm comm $ \comm' ->+ do st <- Status <$> mallocForeignPtrBytes {#sizeof MPI_Status#}+ withStatus st $ \st' ->+ do alloca $ \flag ->+ do _ <- {#call mpihs_iprobe as iprobeBool_#}+ (fromRank rank) (fromTag tag) comm' flag st'+ b <- peekBool flag+ return (b, st)++-- | Probe (check) for incoming messages without waiting+-- (non-blocking,+-- @[MPI_Iprobe](https://www.open-mpi.org/doc/current/man3/MPI_Iprobe.3.php)@).+iprobe :: Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO (Maybe Status) -- ^ 'Just' 'Status' of the message if a+ -- message is available, else 'Nothing'+iprobe rank tag comm = bool2maybe <$> iprobeBool rank tag comm++-- | Probe (check) for an incoming message without waiting+-- (@[MPI_Iprobe](https://www.open-mpi.org/doc/current/man3/MPI_Iprobe.3.php)@).+-- This function does not return a status, which might be more+-- efficient if the status is not needed.+iprobe_ :: Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO Bool -- ^ Whether a message is available+iprobe_ rank tag comm =+ withComm comm $ \comm' ->+ do withStatusIgnore $ \st ->+ do alloca $ \flag ->+ do _ <- {#call mpihs_iprobe as iprobe__#}+ (fromRank rank) (fromTag tag) comm' flag st+ peekBool flag++{#fun Irecv as irecvTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to receive a message, and return a handle to the+-- communication request (non-blocking,+-- @[MPI_Irecv](https://www.open-mpi.org/doc/current/man3/MPI_Irecv.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+irecv :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Receive buffer+ -> Count -- ^ Number of elements to receive+ -> Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+irecv recvbuf recvcount recvrank recvtag comm =+ withPtr recvbuf $ \recvbuf' ->+ irecvTyped (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm++{#fun Ireduce as ireduceTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , fromRank `Rank'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to reduce data from all processes, and return a handle to+-- the communication request (collective, non-blocking,+-- @[MPI_Ireduce](https://www.open-mpi.org/doc/current/man3/MPI_Ireduce.3.php)@).+-- The result is only available on the root process. The request must+-- be freed by calling 'test', 'wait', or similar. The MPI datatypes+-- are determined automatically from the buffer pointer types.+ireduce :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+ireduce sendbuf recvbuf count op rank comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ ireduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op rank+ comm++{#fun Iscan as iscanTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to reduce data from all processes via an (inclusive) scan,+-- and return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Iscan](https://www.open-mpi.org/doc/current/man3/MPI_Iscan.3.php)@).+-- Each process with rank @r@ receives the result of reducing data+-- from rank @0@ to rank @r@ (inclusive). The request must be freed by+-- calling 'test', 'wait', or similar. The MPI datatype is determined+-- automatically from the buffer pointer type.+iscan :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+iscan sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ iscanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm++{#fun Iscatter as iscatterTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to scatter data from the root process to all processes, and+-- return a handle to the communication request (collective,+-- non-blocking,+-- @[MPI_Iscatter](https://www.open-mpi.org/doc/current/man3/MPI_Iscatter.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+iscatter :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer (only used on the root process)+ -> Count -- ^ Number of source elements (only used on the root process)+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+iscatter sendbuf sendcount recvbuf recvcount root comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ iscatterTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ root comm++{#fun Isend as isendTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , ++ } -> `Request' return*#}++-- | Begin to send a message, and return a handle to the+-- communication request (non-blocking,+-- @[MPI_Isend](https://www.open-mpi.org/doc/current/man3/MPI_Isend.3.php)@).+-- The request must be freed by calling 'test', 'wait', or similar.+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+isend :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Send buffer+ -> Count -- ^ Number of elements to send+ -> Rank -- ^ Destination rank+ -> Tag -- ^ Message tag+ -> Comm -- ^ Communicator+ -> IO Request -- ^ Communication request+isend sendbuf sendcount sendrank sendtag comm =+ withPtr sendbuf $ \sendbuf' ->+ isendTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag comm++-- | Probe (wait) for an incoming message+-- (@[MPI_Probe](https://www.open-mpi.org/doc/current/man3/MPI_Probe.3.php)@).+{#fun Probe as ^+ { fromRank `Rank' -- ^ Source rank (may be 'anySource')+ , fromTag `Tag' -- ^ Message tag (may be 'anyTag')+ , withComm* %`Comm' -- ^ Communicator+ , ++ } -> `Status' return* -- ^ Message status+#}++-- | Probe (wait) for an incoming message+-- (@[MPI_Probe](https://www.open-mpi.org/doc/current/man3/MPI_Probe.3.php)@).+-- This function does not return a status, which might be more+-- efficient if the status is not needed.+{#fun Probe as probe_+ { fromRank `Rank' -- ^ Source rank (may be 'anySource')+ , fromTag `Tag' -- ^ Message tag (may be 'anyTag')+ , withComm* %`Comm' -- ^ Communicator+ , withStatusIgnore- `Status'+ } -> `()' return*-#}++{#fun Recv as recvTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , ++ } -> `Status' return*#}++-- | Receive a message+-- (@[MPI_Recv](https://www.open-mpi.org/doc/current/man3/MPI_Recv.3.php)@).+-- The MPI datatypeis determined automatically from the buffer+-- pointer type.+recv :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Receive buffer+ -> Count -- ^ Number of elements to receive+ -> Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO Status -- ^ Message status+recv recvbuf recvcount recvrank recvtag comm =+ withPtr recvbuf $ \recvbuf' ->+ recvTyped (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm++{#fun Recv as recvTyped_+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , withStatusIgnore- `Status'+ } -> `()' return*-#}++-- | Receive a message+-- (@[MPI_Recv](https://www.open-mpi.org/doc/current/man3/MPI_Recv.3.php)@).+-- The MPI datatype is determined automatically from the buffer+-- pointer type. This function does not return a status, which might+-- be more efficient if the status is not needed.+recv_ :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Receive buffer+ -> Count -- ^ Number of elements to receive+ -> Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO ()+recv_ recvbuf recvcount recvrank recvtag comm =+ withPtr recvbuf $ \recvbuf' ->+ recvTyped_ (castPtr recvbuf') recvcount (datatype @a) recvrank recvtag comm++{#fun Reduce as reduceTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , fromRank `Rank'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Reduce data from all processes (collective,+-- @[MPI_Reduce](https://www.open-mpi.org/doc/current/man3/MPI_Reduce.3.php)@).+-- The result is only available on the root process. The MPI datatypes+-- are determined automatically from the buffer pointer types.+reduce :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO ()+reduce sendbuf recvbuf count op rank comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ reduceTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op rank+ comm++{#fun Scan as scanTyped+ { id `Ptr ()'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , withOp* %`Op'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Reduce data from all processes via an (inclusive) scan+-- (collective,+-- @[MPI_Scan](https://www.open-mpi.org/doc/current/man3/MPI_Scan.3.php)@).+-- Each process with rank @r@ receives the result of reducing data+-- from rank @0@ to rank @r@ (inclusive). The MPI datatype is+-- determined automatically from the buffer pointer type.+scan :: forall a p q.+ ( Pointer p, Pointer q, Storable a, HasDatatype a)+ => p a -- ^ Source buffer+ -> q a -- ^ Destination buffer+ -> Count -- ^ Number of elements+ -> Op -- ^ Reduction operation+ -> Comm -- ^ Communicator+ -> IO ()+scan sendbuf recvbuf count op comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ scanTyped (castPtr sendbuf') (castPtr recvbuf') count (datatype @a) op comm++{#fun Scatter as scatterTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Scatter data from the root process to all processes (collective,+-- @[MPI_Scatter](https://www.open-mpi.org/doc/current/man3/MPI_Scatter.3.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+scatter :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Source buffer (only used on the root process)+ -> Count -- ^ Number of source elements (only used on the root process)+ -> q b -- ^ Destination buffer+ -> Count -- ^ Number of destination elements+ -> Rank -- ^ Root rank+ -> Comm -- ^ Communicator+ -> IO ()+scatter sendbuf sendcount recvbuf recvcount root comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ scatterTyped (castPtr sendbuf') sendcount (datatype @a)+ (castPtr recvbuf') recvcount (datatype @b)+ root comm++{#fun Send as sendTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ } -> `()' return*-#}++-- | Send a message+-- (@[MPI_Send](https://www.open-mpi.org/doc/current/man3/MPI_Send.3.php)@).+-- The MPI datatype is determined automatically from the buffer+-- pointer type.+send :: forall a p. (Pointer p, Storable a, HasDatatype a)+ => p a -- ^ Send buffer+ -> Count -- ^ Number of elements to send+ -> Rank -- ^ Destination rank+ -> Tag -- ^ Message tag+ -> Comm -- ^ Communicator+ -> IO ()+send sendbuf sendcount sendrank sendtag comm =+ withPtr sendbuf $ \sendbuf' ->+ sendTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag comm++{#fun Sendrecv as sendrecvTyped+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , ++ } -> `Status' return*#}++-- | Send and receive a message with a single call+-- (@[MPI_Sendrecv](https://www.open-mpi.org/doc/current/man3/MPI_Sendrecv.3.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types.+sendrecv :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Send buffer+ -> Count -- ^ Number of elements to send+ -> Rank -- ^ Destination rank+ -> Tag -- ^ Sent message tag+ -> q b -- ^ Receive buffer+ -> Count -- ^ Number of elements to receive+ -> Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Received message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO Status -- ^ Status for received message+sendrecv sendbuf sendcount sendrank sendtag+ recvbuf recvcount recvrank recvtag+ comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ sendrecvTyped (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag+ (castPtr recvbuf') recvcount (datatype @b) recvrank recvtag+ comm++{#fun Sendrecv as sendrecvTyped_+ { id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , id `Ptr ()'+ , fromCount `Count'+ , withDatatype* %`Datatype'+ , fromRank `Rank'+ , fromTag `Tag'+ , withComm* %`Comm'+ , withStatusIgnore- `Status'+ } -> `()' return*-#}++-- | Send and receive a message with a single call+-- (@[MPI_Sendrecv](https://www.open-mpi.org/doc/current/man3/MPI_Sendrecv.3.php)@).+-- The MPI datatypes are determined automatically from the buffer+-- pointer types. This function does not return a status, which might+-- be more efficient if the status is not needed.+sendrecv_ :: forall a b p q.+ ( Pointer p, Pointer q+ , Storable a, HasDatatype a, Storable b, HasDatatype b)+ => p a -- ^ Send buffer+ -> Count -- ^ Number of elements to send+ -> Rank -- ^ Destination rank+ -> Tag -- ^ Sent message tag+ -> q a -- ^ Receive buffer+ -> Count -- ^ Number of elements to receive+ -> Rank -- ^ Source rank (may be 'anySource')+ -> Tag -- ^ Received message tag (may be 'anyTag')+ -> Comm -- ^ Communicator+ -> IO ()+sendrecv_ sendbuf sendcount sendrank sendtag+ recvbuf recvcount recvrank recvtag+ comm =+ withPtr sendbuf $ \sendbuf' ->+ withPtr recvbuf $ \recvbuf' ->+ sendrecvTyped_ (castPtr sendbuf') sendcount (datatype @a) sendrank sendtag+ (castPtr recvbuf') recvcount (datatype @b) recvrank recvtag+ comm++testBool :: Request -> IO (Bool, Status)+testBool req =+ withRequest req $ \req' ->+ alloca $ \flag ->+ do st <- Status <$> mallocForeignPtrBytes {#sizeof MPI_Status#}+ withStatus st $ \st' ->+ do _ <- {#call Test as testBool_#} req' flag st'+ b <- peekBool flag+ return (b, st)++-- | Check whether a communication has completed, and free the+-- communication request if so+-- (@[MPI_Test](https://www.open-mpi.org/doc/current/man3/MPI_Test.3.php)@).+test :: Request -- ^ Communication request+ -> IO (Maybe Status) -- ^ 'Just' 'Status' if the request has completed,+ -- else 'Nothing'+test req = bool2maybe <$> testBool req++-- {#fun Test as test_+-- { withRequest* `Request'+-- , alloca- `Bool' peekBool*+-- , withStatusIgnore- `Status'+-- } -> `()' return*-#}++-- | Check whether a communication has completed, and free the+-- communication request if so+-- (@[MPI_Test](https://www.open-mpi.org/doc/current/man3/MPI_Test.3.php)@).+-- This function does not return a status, which might be more+-- efficient if the status is not needed.+test_ :: Request -- ^ Communication request+ -> IO Bool -- ^ Whether the request had completed+test_ req =+ withRequest req $ \req' ->+ alloca $ \flag ->+ withStatusIgnore $ \st ->+ do _ <- {#call Test as test__#} req' flag st+ peekBool flag++-- | Wait for a communication request to complete, then free the+-- request+-- (@[MPI_Wait](https://www.open-mpi.org/doc/current/man3/MPI_Wait.3.php)@).+{#fun Wait as ^+ { withRequest* `Request' -- ^ Communication request+ , ++ } -> `Status' return* -- ^ Message status+#}++-- | Wait for a communication request to complete, then free the+-- request+-- (@[MPI_Wait](https://www.open-mpi.org/doc/current/man3/MPI_Wait.3.php)@).+-- This function does not return a status, which might be more+-- efficient if the status is not needed.+{#fun Wait as wait_+ { withRequest* `Request' -- ^ Communication request+ , withStatusIgnore- `Status'+ } -> `()' return*-#}++-- | Wall time tick (accuracy of 'wtime') (in seconds)+{#fun unsafe Wtick as ^ {} -> `Double'#}++-- | Current wall time (in seconds)+{#fun unsafe Wtime as ^ {} -> `Double'#}
+ lib/Control/Distributed/MPI/Simple.hs view
@@ -0,0 +1,69 @@+module Control.Distributed.MPI.Simple+ ( MPIException(..)+ , finalize+ , init+ , initThread+ ) where++import Prelude hiding (init)++import Control.Concurrent+import Control.Exception+import Data.Typeable+import System.IO.Unsafe++import qualified Control.Distributed.MPI as MPI++++didInit :: MVar Bool+didInit = unsafePerformIO newEmptyMVar++++newtype MPIException = MPIException String+ deriving (Eq, Ord, Read, Show, Typeable)+instance Exception MPIException++++finalize :: IO ()+finalize =+ do e <- isEmptyMVar didInit+ if e+ then throw (MPIException "Control flow error")+ else return ()+ did <- takeMVar didInit+ if did+ then MPI.finalize+ else return ()++init :: IO ()+init =+ do e <- isEmptyMVar didInit+ if not e+ then throw (MPIException "Control flow error")+ else return ()+ i <- MPI.initialized+ if not i+ then do MPI.init+ putMVar didInit True+ else putMVar didInit False++initThread :: MPI.ThreadSupport -> IO ()+initThread threadSupport =+ do e <- isEmptyMVar didInit+ if not e+ then throw (MPIException "Control flow error")+ else return ()+ i <- MPI.initialized+ if not i+ then do ts <- MPI.initThread threadSupport+ if ts < threadSupport+ then throw $ MPIException+ ("Insufficient thread support: caller required " +++ show threadSupport ++ ", MPI library provided only " +++ show ts)+ else return ()+ putMVar didInit True+ else putMVar didInit False
+ mpi-hs.cabal view
@@ -0,0 +1,115 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: a7b4d3931ec548e76111da431f03030741d23d3e21f765d151c2455add19efe5++name: mpi-hs+version: 0.1.0.1+synopsis: MPI bindings for Haskell+description: MPI (the [Message Passing Interface](https://www.mpi-forum.org)) is+ widely used standard for distributed-memory programming on HPC (High+ 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),+ 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 MPI API, apart from certain "reasonable"+ mappings from C to Haskell (e.g. output arguments that are in C+ stored to a pointer are in Haskell regular return values). A+ high-level API simplifies exchanging arbitrary values that can be+ serialized.+category: Distributed Computing+homepage: https://github.com/eschnett/mpi-hs#readme+bug-reports: https://github.com/eschnett/mpi-hs/issues+author: Erik Schnetter+maintainer: Erik Schnetter+license: Apache-2.0+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ c/include/mpihs.h+ c/src/mpihs.c+ LICENSE+ package.yaml+ README.md+ stack.yaml++source-repository head+ type: git+ location: https://github.com/eschnett/mpi-hs++library+ exposed-modules:+ Control.Distributed.MPI+ Control.Distributed.MPI.Simple+ other-modules:+ Paths_mpi_hs+ hs-source-dirs:+ lib+ ghc-options: -Wall+ include-dirs:+ c/include+ c-sources:+ c/src/mpihs.c+ extra-libraries:+ mpi+ build-depends:+ base >=4.11 && <4.12+ build-tools:+ c2hs+ default-language: Haskell2010++executable mpi-hs+ main-is: Main.hs+ other-modules:+ Paths_mpi_hs+ hs-source-dirs:+ src+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , mpi-hs+ default-language: Haskell2010++test-suite mpi-hs-test-suite+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_mpi_hs+ hs-source-dirs:+ test+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , monad-loops+ , mpi-hs+ , tasty+ , tasty-hspec+ , tasty-hunit+ , unix+ default-language: Haskell2010++benchmark mpi-hs-benchmarks+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_mpi_hs+ hs-source-dirs:+ bench+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base+ , criterion+ , mpi-hs+ default-language: Haskell2010
+ package.yaml view
@@ -0,0 +1,97 @@+name: mpi-hs+version: '0.1.0.1'+github: "eschnett/mpi-hs"+license: Apache-2.0+author: "Erik Schnetter"+maintainer: "Erik Schnetter"+category: Distributed Computing+synopsis: MPI bindings for Haskell+description: |+ MPI (the [Message Passing Interface](https://www.mpi-forum.org)) is+ widely used standard for distributed-memory programming on HPC (High+ 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),+ 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 MPI API, apart from certain "reasonable"+ mappings from C to Haskell (e.g. output arguments that are in C+ stored to a pointer are in Haskell regular return values). A+ high-level API simplifies exchanging arbitrary values that can be+ serialized.++extra-source-files:+ - LICENSE+ - README.md+ - package.yaml+ - stack.yaml+ - c/include/mpihs.h+ - c/src/mpihs.c++ghc-options:+ - -Wall++library:+ dependencies:+ - base >=4.11 && <4.12+ build-tools:+ - c2hs+ source-dirs:+ - lib+ c-sources:+ - c/src/mpihs.c+ include-dirs:+ - c/include+ extra-libraries:+ - mpi++executables:+ mpi-hs:+ source-dirs: src+ main: Main.hs+ dependencies:+ - base+ - mpi-hs+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts=-N++benchmarks:+ mpi-hs-benchmarks:+ source-dirs: bench+ main: Main.hs+ dependencies:+ - base+ - mpi-hs+ - criterion+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts=-N++tests:+ mpi-hs-test-suite:+ source-dirs: test+ main: Main.hs+ dependencies:+ - base+ - monad-loops+ - mpi-hs+ - tasty+ - tasty-hunit+ - tasty-hspec+ - unix+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts=-N
+ src/Main.hs view
@@ -0,0 +1,18 @@+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,11 @@+resolver: lts-12.13++packages:+ - .++extra-include-dirs:+ - /opt/local/include/openmpi-mp+ - /usr/lib/openmpi/include+extra-lib-dirs:+ - /opt/local/lib/openmpi-mp+ - /usr/lib/openmpi/lib
+ test/Main.hs view
@@ -0,0 +1,629 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import Data.IORef+import Foreign+import Foreign.C.Types+import System.Exit+import System.IO+-- import Test.Tasty+-- import Test.Tasty.HUnit++import qualified Control.Distributed.MPI as MPI++++--------------------------------------------------------------------------------++infix 1 @?+(@?) :: Bool -> String -> IO ()+x @? msg = if not x then die msg else return ()++infix 1 @?=+(@?=) :: Eq a => a -> a -> IO ()+x @?= y = x == y @? "test failed"++++type TestTree = IO ()++testCase :: String -> IO () -> TestTree+testCase name test =+ do rank <- MPI.commRank MPI.commWorld+ if rank == 0+ then do putStrLn $ " " ++ name ++ "..."+ hFlush stdout+ else return ()+ MPI.barrier MPI.commWorld+ test+ MPI.barrier MPI.commWorld++++testGroup :: String -> [TestTree] -> TestTree+testGroup name cases =+ do rank <- MPI.commRank MPI.commWorld+ if rank == 0+ then do putStrLn $ name ++ ":"+ hFlush stdout+ else return ()+ sequence_ cases++++defaultMain :: TestTree -> IO ()+defaultMain tree =+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ if rank == 0+ then do putStrLn $ "MPI Tests: running on " ++ show size ++ " processes"+ hFlush stdout+ else return ()+ tree++++--------------------------------------------------------------------------------++++main :: IO ()+main = bracket+ (do _ <- MPI.initThread MPI.ThreadMultiple+ return ())+ (\_ -> MPI.finalize)+ (\_ -> defaultMain tests)++tests :: TestTree+tests = testGroup "MPI"+ [ initialized+ , rankSize+ , pointToPoint+ , pointToPointNonBlocking+ , collective+ , collectiveNonBlocking+ , reductions+ , dynamic+ ]++++initialized :: TestTree+initialized = testGroup "initialized"+ [ testCase "initialized" $+ do isInit <- MPI.initialized+ isInit @?= True+ , testCase "finalized" $+ do isFini <- MPI.finalized+ isFini @?= False+ ]++++rankSize :: TestTree+rankSize = testGroup "rank and size"+ [ testCase "commSelf" $+ do rank <- MPI.commRank MPI.commSelf+ size <- MPI.commSize MPI.commSelf+ rank == 0 && size == 1 @? ""+ , testCase "commWorld" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ rank >= 0 && rank < size @? ""+ ]++++pointToPoint :: TestTree+pointToPoint = testGroup "point-to-point"+ [ testCase "send and recv" $+ do rank <- MPI.commRank MPI.commWorld++ let msg = 42+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg++ MPI.send buf 1 rank MPI.unitTag MPI.commWorld++ buf' <- mallocForeignPtr @CInt+ st <- MPI.recv buf' 1 rank MPI.unitTag MPI.commWorld+ msg' <- withForeignPtr buf' peek++ source <- MPI.getSource st+ tag <- MPI.getTag st+ count <- MPI.getCount st MPI.datatypeInt+ (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""+ , testCase "sendrecv" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld++ let msg = 42 + MPI.fromRank rank+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg++ buf' <- mallocForeignPtr @CInt++ st <- MPI.sendrecv+ buf 1 ((rank + 1) `mod` size) MPI.unitTag+ buf' 1 ((rank - 1) `mod` size) MPI.unitTag+ MPI.commWorld++ msg' <- withForeignPtr buf' peek++ source <- MPI.getSource st+ tag <- MPI.getTag st+ count <- MPI.getCount st MPI.datatypeInt+ (msg' == 42 + MPI.fromRank ((rank - 1) `mod` size) &&+ source == (rank - 1) `mod` size &&+ tag == MPI.unitTag &&+ count == 1) @? ""+ ]++++pointToPointNonBlocking :: TestTree+pointToPointNonBlocking = testGroup "point-to-point non-blocking"+ [ testCase "send and recv" $+ do rank <- MPI.commRank MPI.commWorld++ let msg = 42+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg++ req <- MPI.isend buf 1 rank MPI.unitTag MPI.commWorld++ buf' <- mallocForeignPtr @CInt+ req' <- MPI.irecv buf' 1 rank MPI.unitTag MPI.commWorld++ MPI.wait_ req+ st <- MPI.wait req'++ touchForeignPtr buf+ msg' <- withForeignPtr buf' peek++ source <- MPI.getSource st+ tag <- MPI.getTag st+ count <- MPI.getCount st MPI.datatypeInt+ (msg' == msg && source == rank && tag == MPI.unitTag && count == 1) @? ""+ ]++++collective :: TestTree+collective = testGroup "collective"+ [ testCase "allgather" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtrArray @CInt sz+ MPI.allgather buf 1 buf' 1 MPI.commWorld+ msgs' <- withForeignPtr buf' (peekArray sz)+ msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""+ , testCase "allreduce" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.allreduce buf buf' 1 MPI.opSum MPI.commWorld+ msg' <- withForeignPtr buf' peek+ msg' == sum [42 .. 42 + (sz-1)] @? ""+ , testCase "alltoall" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]+ buf <- mallocForeignPtrArray @CInt sz+ withForeignPtr buf $ \ptr -> pokeArray ptr msgs+ buf' <- mallocForeignPtrArray @CInt sz+ MPI.alltoall buf 1 buf' 1 MPI.commWorld+ msgs' <- withForeignPtr buf' (peekArray sz)+ msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""+ , testCase "barrier" $+ MPI.barrier MPI.commWorld+ , testCase "bcast" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ MPI.bcast buf 1 MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf peek+ msg' == 42 @? ""+ , testCase "exscan" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.exscan buf buf' 1 MPI.opSum MPI.commWorld+ msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)+ msg' == sum [42 .. 42 + rk-1] @? ""+ , testCase "gather" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+ MPI.gather buf 1 buf' 1 MPI.rootRank MPI.commWorld+ msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)+ (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""+ , testCase "reduce" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.reduce buf buf' 1 MPI.opSum MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+ (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+ , testCase "scan" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.scan buf buf' 1 MPI.opSum MPI.commWorld+ msg' <- withForeignPtr buf' peek+ msg' == sum [42 .. 42 + rk] @? ""+ , testCase "scatter" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msgs =+ if isroot then [42 + fromIntegral i | i <- [0 .. sz-1]] else []+ buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+ withForeignPtr buf $+ \ptr -> if isroot then pokeArray ptr msgs else return ()+ buf' <- mallocForeignPtr @CInt+ MPI.scatter buf 1 buf' 1 MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf' peek+ msg' == 42 + rk @? ""+ ]++++reductions :: TestTree+reductions = testGroup "reduction operations"+ [ testCase "max" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.reduce buf buf' 1 MPI.opMax MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+ (if isroot then msg' == maximum [42 .. 42 + sz-1] else True) @? ""+ , testCase "min" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.reduce buf buf' 1 MPI.opMin MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+ (if isroot then msg' == minimum [42 .. 42 + sz-1] else True) @? ""+ , testCase "sum" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ MPI.reduce buf buf' 1 MPI.opSum MPI.rootRank MPI.commWorld+ msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+ (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+ ]++++collectiveNonBlocking :: TestTree+collectiveNonBlocking = testGroup "collective non-blocking"+ [ testCase "iallgather" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtrArray @CInt sz+ req <- MPI.iallgather buf 1 buf' 1 MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msgs' <- withForeignPtr buf' (peekArray sz)+ msgs' == [42 .. 42 + fromIntegral (sz-1)] @? ""+ , testCase "iallreduce" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ req <- MPI.iallreduce buf buf' 1 MPI.opSum MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf' peek+ msg' == sum [42 .. 42 + (sz-1)] @? ""+ , testCase "ialltoall" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let msgs = fromIntegral <$> [42 + sz * rk + i | i <- [0 .. sz-1]]+ buf <- mallocForeignPtrArray @CInt sz+ withForeignPtr buf $ \ptr -> pokeArray ptr msgs+ buf' <- mallocForeignPtrArray @CInt sz+ req <- MPI.ialltoall buf 1 buf' 1 MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msgs' <- withForeignPtr buf' (peekArray sz)+ msgs' == (fromIntegral <$> [42 + sz * i + rk | i <- [0 .. sz-1]]) @? ""+ , testCase "ibarrier" $+ do req <- MPI.ibarrier MPI.commWorld+ MPI.wait_ req+ , testCase "ibcast" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ req <- MPI.ibcast buf 1 MPI.rootRank MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf peek+ msg' == 42 @? ""+ , testCase "iexscan" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ req <- MPI.iexscan buf buf' 1 MPI.opSum MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf' (if rank == 0 then \_ -> return 0 else peek)+ msg' == sum [42 .. 42 + rk-1] @? ""+ , testCase "igather" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+ req <- MPI.igather buf 1 buf' 1 MPI.rootRank MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msgs' <- withForeignPtr buf' $ peekArray (if isroot then sz else 0)+ (if isroot then msgs' == [42 .. 42 + fromIntegral sz-1] else True) @? ""+ , testCase "ireduce" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ req <- MPI.ireduce buf buf' 1 MPI.opSum MPI.rootRank MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf' $ if isroot then peek else \_ -> return 0+ (if isroot then msg' == sum [42 .. 42 + sz-1] else True) @? ""+ , testCase "iscan" $+ do rank <- MPI.commRank MPI.commWorld+ let rk = MPI.fromRank rank+ let msg = 42 + rk+ buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr msg+ buf' <- mallocForeignPtr @CInt+ req <- MPI.iscan buf buf' 1 MPI.opSum MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf' peek+ msg' == sum [42 .. 42 + rk] @? ""+ , testCase "iscatter" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ let rk = MPI.fromRank rank+ let sz = MPI.fromRank size+ let isroot = rank == MPI.rootRank+ let msgs = [42 + fromIntegral i | i <- [0 .. sz-1]]+ buf <- mallocForeignPtrArray @CInt (if isroot then sz else 0)+ withForeignPtr buf $ \ptr -> pokeArray ptr msgs+ buf' <- mallocForeignPtr @CInt+ req <- MPI.iscatter buf 1 buf' 1 MPI.rootRank MPI.commWorld+ MPI.wait_ req+ touchForeignPtr buf+ msg' <- withForeignPtr buf' peek+ msg' == 42 + rk @? ""+ ]++++dynamic :: TestTree+dynamic = testGroup "dynamic"+ [ testCase "sequential" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld++ breq <- newIORef Nothing+ let signalDone =+ do r <- MPI.ibarrier MPI.commWorld+ writeIORef breq (Just r)+ let checkDone =+ do mreq <- readIORef breq+ case mreq of+ Nothing -> return False+ Just req -> MPI.test_ req++ sendreqs <- newIORef []+ let sendMsg dst =+ when (dst < size) $+ do buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr 42+ r <- MPI.isend buf 1 dst MPI.unitTag MPI.commWorld+ modifyIORef' sendreqs ((buf, r) :)+ let drainSendQueue =+ do srs <- readIORef sendreqs+ srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs+ writeIORef sendreqs srs'+ let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+ let recvMsg st =+ do src <- MPI.getSource st+ buf <- mallocForeignPtr @CInt+ MPI.recv_ buf 1 src MPI.unitTag MPI.commWorld++ -- each rank sends to the next+ when (rank == 0) $+ do sendMsg (rank + 1)+ signalDone++ untilM_+ (do drainSendQueue+ mst <- checkForMsg+ case mst of+ Nothing -> return ()+ Just st -> do recvMsg st+ sendMsg (rank + 1)+ signalDone+ )+ checkDone+ , testCase "tree" $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld++ breq <- newIORef Nothing+ let signalDone =+ do r <- MPI.ibarrier MPI.commWorld+ writeIORef breq (Just r)+ let checkDone =+ do mreq <- readIORef breq+ case mreq of+ Nothing -> return False+ Just req -> MPI.test_ req++ sendreqs <- newIORef []+ let sendMsg dst =+ when (dst < size) $+ do buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr 42+ r <- MPI.isend buf 1 dst MPI.unitTag MPI.commWorld+ modifyIORef' sendreqs ((buf, r) :)+ let drainSendQueue =+ do srs <- readIORef sendreqs+ srs' <- filterM (\(_, r) -> not <$> MPI.test_ r) srs+ writeIORef sendreqs srs'+ let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+ let recvMsg st =+ do src <- MPI.getSource st+ buf <- mallocForeignPtr @CInt+ MPI.recv_ buf 1 src MPI.unitTag MPI.commWorld++ -- rank r sends to 2*r+1 and 2*r+2+ when (rank == 0) $+ do sendMsg (2 * rank + 1)+ sendMsg (2 * rank + 2)+ signalDone++ untilM_+ (do drainSendQueue+ mst <- checkForMsg+ case mst of+ Nothing -> return ()+ Just st -> do recvMsg st+ sendMsg (2 * rank + 1)+ sendMsg (2 * rank + 2)+ signalDone+ )+ checkDone+ , testCase "multi-threaded" $+ do mts <- MPI.threadSupport+ let Just ts = mts+ when (ts >= MPI.ThreadMultiple) $+ do rank <- MPI.commRank MPI.commWorld+ size <- MPI.commSize MPI.commWorld+ + breq <- newEmptyMVar+ let signalDone =+ do _ <- forkIO $+ do req <- MPI.ibarrier MPI.commWorld+ whileM_ (not <$> MPI.test_ req) yield+ putMVar breq ()+ return ()+ let checkDone = not <$> isEmptyMVar breq+ + let sendMsg dst =+ when (dst < size) $+ do _ <- forkIO $+ do buf <- mallocForeignPtr @CInt+ withForeignPtr buf $ \ptr -> poke ptr 42+ req <- MPI.isend buf 1 dst MPI.unitTag MPI.commWorld+ whileM_ (not <$> MPI.test_ req) yield+ return ()+ let checkForMsg = MPI.iprobe MPI.anySource MPI.unitTag MPI.commWorld+ let recvMsg st =+ do src <- MPI.getSource st+ buf <- mallocForeignPtr @CInt+ MPI.recv_ buf 1 src MPI.unitTag MPI.commWorld+ + -- rank r sends to 2*r+1 and 2*r+2+ when (rank == 0) $+ do sendMsg (2 * rank + 1)+ sendMsg (2 * rank + 2)+ signalDone+ + untilM_+ (do mst <- checkForMsg+ case mst of+ Nothing -> return ()+ Just st -> do recvMsg st+ sendMsg (2 * rank + 1)+ sendMsg (2 * rank + 2)+ signalDone+ yield+ )+ checkDone+ ]