diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,63 @@ +# [mpi-hs](https://github.com/eschnett/mpi-hs) + +[MPI](https://www.mpi-forum.org) bindings for Haskell + +[![CircleCI](https://circleci.com/gh/eschnett/mpi-hs.svg?style=svg)](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 +#include + +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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,6 @@ +-- You can benchmark your code quickly and effectively with Criterion. See its +-- website for help: . +import Criterion.Main + +main :: IO () +main = defaultMain [bench "const" (whnf const ())] diff --git a/c/include/mpihs.h b/c/include/mpihs.h new file mode 100644 --- /dev/null +++ b/c/include/mpihs.h @@ -0,0 +1,77 @@ +#ifndef MPIHS_H +#define MPIHS_H + +#include + +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 diff --git a/c/src/mpihs.c b/c/src/mpihs.c new file mode 100644 --- /dev/null +++ b/c/src/mpihs.c @@ -0,0 +1,75 @@ +#include +#include + +// 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); +} diff --git a/lib/Control/Distributed/MPI.chs b/lib/Control/Distributed/MPI.chs new file mode 100644 --- /dev/null +++ b/lib/Control/Distributed/MPI.chs @@ -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 +#include + + + +-- | Module: Control.Distributed.MPI +-- Description: MPI bindings for Haskell +-- Copyright: (C) 2018 Erik Schnetter +-- License: Apache-2.0 +-- Maintainer: Erik Schnetter +-- 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'#} diff --git a/lib/Control/Distributed/MPI/Simple.hs b/lib/Control/Distributed/MPI/Simple.hs new file mode 100644 --- /dev/null +++ b/lib/Control/Distributed/MPI/Simple.hs @@ -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 diff --git a/mpi-hs.cabal b/mpi-hs.cabal new file mode 100644 --- /dev/null +++ b/mpi-hs.cabal @@ -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 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 ++ ")" diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]