diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2009-2010 Bernard James Pope (also known as Bernie Pope). + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -0,0 +1,103 @@ +Haskell-mpi, Haskell bindings to the MPI library +------------------------------------------------ + +How to build +------------ + +Use "cabal install --extra-include-dirs=/usr/include/mpi" or something similar. +Make sure that you have libmpi.a and libmpi.so available. + +Testing +------- + +Two types of tests are provided: + + 1. Unit tests. + 2. Standalone tests. + +The unit tests are designed to test the functions exported by the library on +an individual basis. The standalone tests are comprised of complete programs - +they act as simple integration tests, and may also include regression tests. + +How to enable testing +--------------------- + +Add "-ftest" to cabal install: + + cabal -ftest install + +How to run the unit tests +------------------------- + +(Assuming you have built haskell-mpi with -ftest, as described above): + +Run the program "haskell-mpi-testsuite" using "mpirun" like so: + + mpirun -np 2 haskell-mpi-testsuite 1>sender.log 2>receiver.log + +Process with rank 0 emits the output to stdout, and every other rank reports +to the stderr. + +How to run standalone tests +--------------------------- + +Standalone test programs can be found in the test/examples directory. +You can test the execution of these programs using the shelltestrunner package: + + http://hackage.haskell.org/package/shelltestrunner + +Make sure you install shelltestrunner first, for example: + + cabal install shelltestrunner + +To run the tests, issue this command: + + shelltest --execdir test/examples/ + +License and Copyright +--------------------- + +Bindings-MPI is distributed as open source software under the terms of the BSD +License (see the file LICENSE in the top directory). + +Author(s): Bernie Pope, Dmitry Astapov. Copyright 2010. + +Contact information +------------------- + +Email Bernie Pope: + + florbitous gmail com + +History +------- + +Around the year 2000 Michael Weber released hMPI, a Haskell binding to MPI: + + http://www.foldr.org/~michaelw/hmpi/ + +Development on that code appears to have stopped in about the year 2001. +Hal Daumé III picked up the code and got it working with (at the time) +a more recent version of GHC: + + http://www.umiacs.umd.edu/~hal/software.html + +In February 2010 both Michael and Hal reported that they had not worked on +the code for a long time, so it was open for new maintainers. + +In early 2010 Bernie Pope downloaded the above mentioned versions of +hMPI and tried to get them working with a modern GHC. + +A few things had changed in Haskell since hMPI was written, which suggested +that it might be worth starting the binding from scratch. In particular +the FFI had changed in a few ways, the C2HS tool had matured substantially, +and good quality serialization libraries had emerged. So while haskell-mpi +is highly inspired by hMPI (which was very good code), +it is almost entirely a rewrite. + +Haskell-mpi got its first main injection of effort during the inaugural +AusHac Australian Haskell Hackathon, hosted at UNSW from the 16th to the +18th of July 2010. The end result was a proof of concept. + +The next major injection of effort happened when Dmitry Astapov started +contributing to the project in August 2010. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/haskell-mpi.cabal b/haskell-mpi.cabal new file mode 100644 --- /dev/null +++ b/haskell-mpi.cabal @@ -0,0 +1,160 @@ +name: haskell-mpi +version: 0.5.0 +cabal-version: >= 1.6 +synopsis: Distributed parallel programming in Haskell using MPI. +description: + MPI is defined by the Message-Passing Interface Standard, + as specified by the Message Passing Interface Forum. The latest release + of the standard is known as MPI-2. These Haskell + bindings are designed to work with any standards compliant + implementation of MPI-2. Examples are MPICH2: + and + OpenMPI: . + . + In addition to reading these documents, users may also find it + beneficial to consult the MPI-2 standard documentation provided by the + MPI Forum: , and also the documentation for + the MPI implementation linked to this library (that is, the MPI + implementation that was chosen when this Haskell library was compiled). + . + "Control.Parallel.MPI.Fast" contains a high-performance interface + for working with (possibly mutable) arrays of storable Haskell data types. + . + "Control.Parallel.MPI.Simple" contains a convenient (but slower) + interface for sending arbitrary serializable Haskell data values as messages. + . + "Control.Parallel.MPI.Internal" contains a direct binding to the + C interface. + . + "Control.Parallel.MPI.Base" contains essential MPI functionality + which is independent of the message passing API. This is re-exported + by the Fast and Simple modules, and usually does not need to be + explcitly imported itself. + . + Notable differences between Haskell-MPI and the standard C interface to MPI: + . + 1. Some collective message passing operations are split into send + and receive parts to facilitate a more idiomatic Haskell style of programming. + For example, C provides the @MPI_Gather@ function which is called + by all processes participating in the communication, whereas + Haskell-MPI provides 'gatherSend' and 'gatherRecv' which are called + by the sending and receiving processes respectively. + . + 2. The order of arguments for some functions is changed to allow + for the most common patterns of partial function application. + . + 3. Errors are raised as exceptions rather than return codes (assuming + that the error handler to 'errorsThrowExceptions', otherwise errors + will terminate the computation just like C interface). + . + Below is a small but complete MPI program. Process 1 sends the message + @\"Hello World\"@ to process 0, which in turn receives the message and + prints it to standard output. All other processes, if there are any, + do nothing. + . + >module Main where + > + >import Control.Parallel.MPI.Simple (mpiWorld, commWorld, unitTag, send, recv) + > + >main :: IO () + >main = mpiWorld $ \size rank -> + > if size < 2 + > then putStrLn "At least two processes are needed" + > else case rank of + > 0 -> do (msg, _status) <- recv commWorld 1 unitTag + > putStrLn msg + > 1 -> send commWorld 0 unitTag "Hello World" + > _ -> return () + +category: FFI, Distributed Computing +license: BSD3 +license-file: LICENSE +copyright: (c) 2010 Bernard James Pope +author: Bernard James Pope (Bernie Pope) +maintainer: florbitous@gmail.com +homepage: http://github.com/bjpop/haskell-mpi +build-type: Simple +stability: experimental +tested-with: GHC==6.10.4, GHC==6.12.1 +extra-source-files: src/cbits/*.c src/include/*.h README.txt + +source-repository head + type: git + location: git://github.com/bjpop/haskell-mpi.git + +flag test + description: Build testsuite and code coverage tests + default: False + +Library + extra-libraries: mpi + build-tools: c2hs + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + c-sources: + src/cbits/init_wrapper.c, + src/cbits/constants.c + include-dirs: + src/include + hs-source-dirs: + src + build-depends: + base > 3 && <= 5, + haskell98, + bytestring, + cereal, + extensible-exceptions, + array + exposed-modules: + Control.Parallel.MPI.Base, + Control.Parallel.MPI.Internal, + Control.Parallel.MPI.Fast, + Control.Parallel.MPI.Simple + other-modules: + C2HS, + Control.Parallel.MPI.Utils + +executable haskell-mpi-testsuite + hs-source-dirs: + ./test + ./src + build-tools: c2hs + extra-libraries: mpi + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + c-sources: + src/cbits/init_wrapper.c, + src/cbits/constants.c + include-dirs: + src/include + other-modules: + Control.Parallel.MPI.Base, + Control.Parallel.MPI.Internal, + Control.Parallel.MPI.Fast, + Control.Parallel.MPI.Simple, + Control.Parallel.MPI.Utils, + C2HS, + IOArrayTests, + SimpleTests, + FastAndSimpleTests, + StorableArrayTests, + GroupTests, + PrimTypeTests, + ExceptionTests, + OtherTests, + TestHelpers + main-is: Testsuite.hs + if flag(test) + ghc-options: -fhpc + build-depends: base >=3 && <=5, HUnit, testrunner, hpc, unix + else + buildable: False + +executable haskell-mpi-comprunclean + hs-source-dirs: + ./test + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans + other-modules: + main-is: CompileRunClean.hs + if flag(test) + build-depends: base >=3 && <=5, process + else + buildable: False diff --git a/src/C2HS.hs b/src/C2HS.hs new file mode 100644 --- /dev/null +++ b/src/C2HS.hs @@ -0,0 +1,222 @@ +-- C->Haskell Compiler: Marshalling library +-- +-- Copyright (c) [1999...2005] Manuel M T Chakravarty +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- 1. Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- 3. The name of the author may not be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- This module provides the marshaling routines for Haskell files produced by +-- C->Haskell for binding to C library interfaces. It exports all of the +-- low-level FFI (language-independent plus the C-specific parts) together +-- with the C->HS-specific higher-level marshalling routines. +-- + +module C2HS ( + + -- * Re-export the language-independent component of the FFI + module Foreign, + + -- * Re-export the C language component of the FFI + module CForeign, + + -- * Composite marshalling functions + withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, + peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, + + -- * Conditional results using 'Maybe' + nothingIf, nothingIfNull, + + -- * Bit masks + combineBitMasks, containsBitMask, extractBitMasks, + + -- * Conversion between C and Haskell types + cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum +) where + + +import Foreign + hiding (Word) + -- Should also hide the Foreign.Marshal.Pool exports in + -- compilers that export them +import CForeign + +import Monad (liftM) + + +-- Composite marshalling functions +-- ------------------------------- + +-- Strings with explicit length +-- +withCStringLenIntConv :: Integral b => String -> ((Ptr CChar, b) -> IO a) -> IO a +withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) +peekCStringLenIntConv :: Integral t => (Ptr CChar, t) -> IO String +peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) + +-- Marshalling of numerals +-- + +withIntConv :: (Storable b, Integral a, Integral b) + => a -> (Ptr b -> IO c) -> IO c +withIntConv = with . cIntConv + +withFloatConv :: (Storable b, RealFloat a, RealFloat b) + => a -> (Ptr b -> IO c) -> IO c +withFloatConv = with . cFloatConv + +peekIntConv :: (Storable a, Integral a, Integral b) + => Ptr a -> IO b +peekIntConv = liftM cIntConv . peek + +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) + => Ptr a -> IO b +peekFloatConv = liftM cFloatConv . peek + +-- Passing Booleans by reference +-- + +withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b +withBool = with . fromBool + +peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool +peekBool = liftM toBool . peek + + +-- Passing enums by reference +-- + +withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c +withEnum = with . cFromEnum + +peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a +peekEnum = liftM cToEnum . peek + + +-- Storing of 'Maybe' values +-- ------------------------- + +instance Storable a => Storable (Maybe a) where + sizeOf _ = sizeOf (undefined :: Ptr ()) + alignment _ = alignment (undefined :: Ptr ()) + + peek p = do + ptr <- peek (castPtr p) + if ptr == nullPtr + then return Nothing + else liftM Just $ peek ptr + + poke p v = do + ptr <- case v of + Nothing -> return nullPtr + Just v' -> new v' + poke (castPtr p) ptr + + +-- Conditional results using 'Maybe' +-- --------------------------------- + +-- Wrap the result into a 'Maybe' type. +-- +-- * the predicate determines when the result is considered to be non-existing, +-- ie, it is represented by `Nothing' +-- +-- * the second argument allows to map a result wrapped into `Just' to some +-- other domain +-- +nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b +nothingIf p f x = if p x then Nothing else Just $ f x + +-- |Instance for special casing null pointers. +-- +nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b +nothingIfNull = nothingIf (== nullPtr) + + +-- Support for bit masks +-- --------------------- + +-- Given a list of enumeration values that represent bit masks, combine these +-- masks using bitwise disjunction. +-- +combineBitMasks :: (Enum a, Bits b) => [a] -> b +combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) + +-- Tests whether the given bit mask is contained in the given bit pattern +-- (i.e., all bits set in the mask are also set in the pattern). +-- +containsBitMask :: (Bits a, Enum b) => a -> b -> Bool +bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm + in + bm' .&. bits == bm' + +-- |Given a bit pattern, yield all bit masks that it contains. +-- +-- * This does *not* attempt to compute a minimal set of bit masks that when +-- combined yield the bit pattern, instead all contained bit masks are +-- produced. +-- +extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] +extractBitMasks bits = + [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] + + +-- Conversion routines +-- ------------------- + +-- |Integral conversion +-- +cIntConv :: (Integral a, Integral b) => a -> b +cIntConv = fromIntegral + +-- |Floating conversion +-- +cFloatConv :: (RealFloat a, RealFloat b) => a -> b +cFloatConv = realToFrac +-- As this conversion by default goes via `Rational', it can be very slow... +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + #-} + +-- |Obtain C value from Haskell 'Bool'. +-- +cFromBool :: Num a => Bool -> a +cFromBool = fromBool + +-- |Obtain Haskell 'Bool' from C value. +-- +cToBool :: Num a => a -> Bool +cToBool = toBool + +-- |Convert a C enumeration to Haskell. +-- +cToEnum :: (Integral i, Enum e) => i -> e +cToEnum = toEnum . cIntConv + +-- |Convert a Haskell enumeration to C. +-- +cFromEnum :: (Enum e, Integral i) => e -> i +cFromEnum = cIntConv . fromEnum diff --git a/src/Control/Parallel/MPI/Base.hs b/src/Control/Parallel/MPI/Base.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/MPI/Base.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.MPI.Base +-- Copyright : (c) 2010 Bernie Pope, Dmitry Astapov +-- License : BSD-style +-- Maintainer : florbitous@gmail.com +-- Stability : experimental +-- Portability : ghc +-- +-- This module provides common MPI functionality that is independent of +-- the type of message +-- being transferred between processes. Correspondences with the C API are +-- noted in the documentation where relevant. +----------------------------------------------------------------------------- + +module Control.Parallel.MPI.Base + ( + -- * Initialization, finalization, termination. + init + , finalize + , initialized + , finalized + , mpi + , mpiWorld + , initThread + , abort + + -- * Requests and statuses. + , Request + , Status (..) + , probe + , test + , cancel + , wait + + -- * Communicators and error handlers. + , Comm + , commWorld + , commSelf + , commSize + , commRank + , commTestInter + , commRemoteSize + , commCompare + , commSetErrhandler + , commGetErrhandler + , commGroup + , Errhandler + , errorsAreFatal + , errorsReturn + + -- * Tags. + , Tag + , toTag + , fromTag + , anyTag + , unitTag + , tagUpperBound + + -- Ranks. + , Rank + , rankId + , toRank + , fromRank + , anySource + , theRoot + , procNull + + -- * Synchronization. + , barrier + + -- * Groups. + , Group + , groupEmpty + , groupRank + , groupSize + , groupUnion + , groupIntersection + , groupDifference + , groupCompare + , groupExcl + , groupIncl + , groupTranslateRanks + + -- * Data types. + , Datatype + , char + , wchar + , short + , int + , long + , longLong + , unsignedChar + , unsignedShort + , unsigned + , unsignedLong + , unsignedLongLong + , float + , double + , longDouble + , byte + , packed + , typeSize + + -- * Operators. + , Operation + , maxOp + , minOp + , sumOp + , prodOp + , landOp + , bandOp + , lorOp + , borOp + , lxorOp + , bxorOp + + -- * Comparisons. + , ComparisonResult (..) + + -- * Threads. + , ThreadSupport (..) + , queryThread + , isThreadMain + + -- * Timing. + , wtime + , wtick + , wtimeIsGlobal + + -- * Environment. + , getProcessorName + , Version (..) + , getVersion + , Implementation (..) + , getImplementation + + -- * Error handling. + , MPIError(..) + , ErrorClass(..) + ) where + +import Prelude hiding (init) +import Control.Exception (finally) +import Control.Parallel.MPI.Internal + +-- | A convenience wrapper which takes an MPI computation as its argument and wraps it +-- inside calls to 'init' (before the computation) and 'finalize' (after the computation). +-- It will make sure that 'finalize' is called even if the MPI computation raises +-- an exception (assuming the error handler is set to 'errorsThrowExceptions'). +mpi :: IO () -> IO () +mpi action = init >> (action `finally` finalize) + +-- | A convenience wrapper which takes an MPI computation as its argument and wraps it +-- inside calls to 'init' (before the computation) and 'finalize' (after the computation). +-- Similar to 'mpi' but the computation is a function which is abstracted over the size of 'commWorld' +-- and the rank of the current process in 'commWorld'. +-- It will make sure that 'finalize' is called even if the MPI computation raises +-- an exception (assuming the error handler is set to 'errorsThrowExceptions'). +-- +-- @ +-- main = mpiWorld $ \\size rank -> do +-- ... +-- ... +-- @ +mpiWorld :: (Int -> Rank -> IO ()) -> IO () +mpiWorld action = do + init + size <- commSize commWorld + rank <- commRank commWorld + action size rank `finally` finalize + +-- XXX I'm temporarily leaving these comments below until we are happy with +-- the haddocks. + +{- $collectives-split +Collective operations in MPI usually take a large set of arguments +that include pointers to both the input and output buffers. This fits +nicely in the C programming style, which follows this pattern: + + 1. Pointers to send and receive buffers are declared. + + 2. if (my_rank == root) then (send buffer is allocated and filled) + + 3. Both pointers are passed to a collective function, which ignores + the unallocated send buffer for all non-root processes. + +However this style of programming is not idiomatic in Haskell. +Therefore it was decided to split most asymmetric collective calls into +two parts - sending and receiving. Thus @MPI_Gather@ is represented by +'gatherSend' and 'gatherRecv', and so on. -} + +{- $arg-order +The order of arguments to most of the Haskell communication operators +is different than that of the corresponding C functions. +This was motivated by the desire to make partial application +more natural for the common case where the communicator, +rank and tag are fixed but the message varies. +-} + +{- $rank-checking +Collective operations that are split into separate send/recv parts +(see above) take "root rank" as an argument. Right now no safeguards +are in place to ensure that rank supplied to the send function is +corresponding to the rank of that process. We believe that it does not +worsen the general go-on-and-shoot-yourself-in-the-foot attitide of +the MPI API. +-} + +{- $err-handling +Most MPI functions may fail with an error, which, by default, will cause +the program to abort. This can be changed by setting the error +handler to 'errorsThrowExceptions'. As the name suggests, this will +turn the error into an exception which can be handled using +the facilities provided by the "Control.Exception" module. +-} + +{-$example +Below is a small but complete MPI program. Process 1 sends the message +@\"Hello World\"@ to process 0. Process 0 receives the message and prints it +to standard output. It assumes that there are at least 2 MPI processes +available; a more robust program would check this condition first, before +trying to send messages. + +@ +module Main where + +import "Control.Parallel.MPI" (mpi, commRank, commWorld, unitTag) +import "Control.Parallel.MPI.Serializable" (send, recv) +import Control.Monad (when) + +main :: IO () +main = 'mpi' $ do + rank <- 'commRank' 'commWorld' + when (rank == 1) $ + 'send' 'commWorld' 0 'unitTag' \"Hello World\" + when (rank == 0) $ do + (msg, _status) <- 'recv' 'commWorld' 1 'unitTag' + putStrLn msg +@ +-} diff --git a/src/Control/Parallel/MPI/Fast.hs b/src/Control/Parallel/MPI/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/MPI/Fast.hs @@ -0,0 +1,835 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, CPP #-} + +----------------------------------------------------------------------------- +{- | +Module : Control.Parallel.MPI.Fast +Copyright : (c) 2010 Bernie Pope, Dmitry Astapov +License : BSD-style +Maintainer : florbitous@gmail.com +Stability : experimental +Portability : ghc + +This module provides the ability to transfer via MPI any Haskell value that could be +represented by some MPI type without expensive conversion or serialization. + +Most of the \"primitive\" Haskell types could be treated this way, along with Storable and IO Arrays. Full range of point-to-point and collective operation is supported, including for reduce and similar operations. + +Typeclass 'SendFrom' incapsulates the act of representing Haskell value as a flat memory region that could be used as a \"send buffer\" in MPI calls. + +Likewise, 'RecvInto' captures the rules for using Haskell value as a \"receive buffer\" in MPI calls. + +Correspondence between Haskell types and MPI types is encoded in 'Repr' typeclass. + +Below is a small but complete MPI program utilising this Module. Process 0 sends the array of @Int@s +process 1. Process 1 receives the message and prints it +to standard output. It assumes that there are at least 2 MPI processes +available. Further examples in this module would provide different implementation of +@process@ function. + +@ +\{\-\# LANGUAGE ScopedTypeVariables \#\-\} + +module Main where + +import Control.Parallel.MPI.Fast +import Data.Array.Storable + +type ArrMsg = StorableArray Int Int + +bounds :: (Int, Int) +bounds = (1,10) + +arrMsg :: IO (StorableArray Int Int) +arrMsg = newListArray bounds [1..10] + +main :: IO () +main = mpi $ do + rank <- commRank commWorld + process rank + +process :: Rank -> IO () +process rank + | rank == 0 = do sendMsg <- arrMsg + send commWorld 1 2 sendMsg + | rank == 1 = do (recvMsg::ArrMsg, status) <- intoNewArray bounds $ recv commWorld 0 2 + els <- getElems recvMsg + putStrLn $ \"Got message: \" ++ show els + | otherwise = return () +@ +-} +----------------------------------------------------------------------------- +module Control.Parallel.MPI.Fast + ( + -- * Mapping between Haskell and MPI types + Repr (..) + + -- * Treating Haskell values as send or receive buffers + , SendFrom (..) + , RecvInto (..) + + -- * On-the-fly buffer allocation helpers + , intoNewArray + , intoNewArray_ + , intoNewVal + , intoNewVal_ + , intoNewBS + , intoNewBS_ + + -- * Point-to-point operations. + -- ** Blocking. + , send + , ssend + , rsend + , recv + -- ** Non-blocking. + , isend + , issend + , irecv + , isendPtr + , issendPtr + , irecvPtr + , waitall + -- * Collective operations. + -- ** One-to-all. + , bcastSend + , bcastRecv + , scatterSend + , scatterRecv + , scattervSend + , scattervRecv + -- ** All-to-one. + , gatherSend + , gatherRecv + , gathervSend + , gathervRecv + , reduceSend + , reduceRecv + -- ** All-to-all. + , allgather + , allgatherv + , alltoall + , alltoallv + , allreduce + , reduceScatterBlock + , reduceScatter + , opCreate + , Internal.opFree + + , module Data.Word + , module Control.Parallel.MPI.Base + ) where + +#include "MachDeps.h" + +import C2HS +import Data.Array.Base (unsafeNewArray_) +import Data.Array.IO +import Data.Array.Storable +import Control.Applicative ((<$>)) +import Data.ByteString.Unsafe as BS +import qualified Data.ByteString as BS +import qualified Control.Parallel.MPI.Internal as Internal +import Control.Parallel.MPI.Base +import Data.Int() +import Data.Word + +{- + +In-place receive vs new array allocation for Storable Array +----------------------------------------------------------- +When using StorableArray API in tight numeric loops, it is best to +reuse existing arrays and avoid penalties incurred by +allocation/deallocation of memory. Which is why destinations/receive +buffers in StorableArray API are specified exclusively as +(StorableArray i e). + +If you'd rather allocate new array for a particular operation, you +could use withNewArray/withNewArray_: + +Instead of (recv comm rank tag arr) you would write +(arr <- withNewArray bounds $ recv comm rank tag), and new array would +be allocated, supplied as the target of the (recv) operation and +returned to you. + +You could easily write your own convenience wrappers similar to +withNewArray. For example, you could create wrapper that would take an +array size as a simple number instead of range. + +-} + + +{- | Helper wrapper function that would allocate array of the given size and use it as receive buffer, without the need to +preallocate it explicitly. + +Most of the functions in this API could reuse receive buffer (like 'StorableArray') over and over again. +If you do not have preallocated buffer you could use this wrapper to get yourself one. + +Consider the following code that uses preallocated buffer: + +@ +scattervRecv root comm arr +@ + +Same code with buffer allocation: + +@ +(arr,status) <- intoNewArray range $ scattervRecv root comm +@ +-} +intoNewArray :: (Ix i, MArray a e m, RecvInto (a i e)) => (i, i) -> (a i e -> m r) -> m (a i e, r) +intoNewArray range f = do + arr <- unsafeNewArray_ range -- New, uninitialized array, According to http://hackage.haskell.org/trac/ghc/ticket/3586 + -- should be faster than newArray_ + res <- f arr + return (arr, res) + +-- | Variant of 'intoNewArray' that discards the result of the wrapped function. +-- Useful for discarding @()@ from functions like 'scatterSend' that return @IO ()@ +intoNewArray_ :: (Ix i, MArray a e m, RecvInto (a i e)) => (i, i) -> (a i e -> m r) -> m (a i e) +intoNewArray_ range f = do + arr <- unsafeNewArray_ range + _ <- f arr + return arr + +-- | Sends @v@ to the process identified by @(Comm, Rank, Tag)@. Call will return as soon as MPI has copied data from its internal send buffer. +send :: (SendFrom v) => Comm -> Rank -> Tag -> v -> IO () +send = sendWith Internal.send + +-- | Sends @v@ to the process identified by @(Comm, Rank, Tag)@. Call will return as soon as receiving process started receiving data. +ssend :: (SendFrom v) => Comm -> Rank -> Tag -> v -> IO () +ssend = sendWith Internal.ssend + +-- | Sends @v@ to the process identified by @(Comm, Rank, Tag)@. Matching 'recv' should already be posted, otherwise MPI error could occur. +rsend :: (SendFrom v) => Comm -> Rank -> Tag -> v -> IO () +rsend = sendWith Internal.rsend + +type SendPrim = Ptr () -> CInt -> Datatype -> Rank -> Tag -> Comm -> IO () + +sendWith :: (SendFrom v) => SendPrim -> Comm -> Rank -> Tag -> v -> IO () +sendWith send_function comm rank tag val = do + sendFrom val $ \valPtr numBytes dtype -> do + send_function (castPtr valPtr) numBytes dtype rank tag comm + +-- | Receives data from the process identified by @(Comm, Rank, Tag)@ and store it in @v@. +recv :: (RecvInto v) => Comm -> Rank -> Tag -> v -> IO Status +recv comm rank tag arr = do + recvInto arr $ \valPtr numBytes dtype -> + Internal.recv (castPtr valPtr) numBytes dtype rank tag comm + +-- | \"Root\" process identified by @(Comm, Rank)@ sends value of @v@ to all processes in communicator @Comm@. +bcastSend :: (SendFrom v) => Comm -> Rank -> v -> IO () +bcastSend comm sendRank val = do + sendFrom val $ \valPtr numBytes dtype -> do + Internal.bcast (castPtr valPtr) numBytes dtype sendRank comm + +-- | Receive data distributed via 'bcaseSend' and store it in @v@. +bcastRecv :: (RecvInto v) => Comm -> Rank -> v -> IO () +bcastRecv comm sendRank val = do + recvInto val $ \valPtr numBytes dtype -> do + Internal.bcast (castPtr valPtr) numBytes dtype sendRank comm + +-- | Sends @v@ to the process identified by @(Comm, Rank, Tag)@ in non-blocking mode. @Request@ will be considered complete as soon as MPI copies the data from the send buffer. Use 'probe', 'test', 'cancel' or 'wait' to work with @Request@. +isend :: (SendFrom v) => Comm -> Rank -> Tag -> v -> IO Request +isend = isendWith Internal.isend + +-- | Sends @v@ to the process identified by @(Comm, Rank, Tag)@ in non-blocking mode. @Request@ will be considered complete as soon as receiving process starts to receive data. +issend :: (SendFrom v) => Comm -> Rank -> Tag -> v -> IO Request +issend = isendWith Internal.issend + +type ISendPrim = Ptr () -> CInt -> Datatype -> Rank -> Tag -> Comm -> IO (Request) + +isendWith :: (SendFrom v) => ISendPrim -> Comm -> Rank -> Tag -> v -> IO Request +isendWith send_function comm recvRank tag val = do + sendFrom val $ \valPtr numBytes dtype -> do + send_function valPtr numBytes dtype recvRank tag comm + +-- | Variant of 'isend' that stores @Request@ at the provided pointer. Useful for filling up arrays of @Request@s that would later be fed to 'waitall'. +isendPtr :: (SendFrom v) => Comm -> Rank -> Tag -> Ptr Request -> v -> IO () +isendPtr = isendWithPtr Internal.isendPtr + +-- | Variant of 'issend' that stores @Request@ at the provided pointer. Useful for filling up arrays of @Request@s that would later be fed to 'waitall'. +issendPtr :: (SendFrom v) => Comm -> Rank -> Tag -> Ptr Request -> v -> IO () +issendPtr = isendWithPtr Internal.issendPtr + +type ISendPtrPrim = Ptr () -> CInt -> Datatype -> Rank -> Tag -> Comm -> Ptr Request -> IO () +isendWithPtr :: (SendFrom v) => ISendPtrPrim -> Comm -> Rank -> Tag -> Ptr Request -> v -> IO () +isendWithPtr send_function comm recvRank tag requestPtr val = do + sendFrom val $ \valPtr numBytes dtype -> + send_function (castPtr valPtr) numBytes dtype recvRank tag comm requestPtr + +-- | Variant of 'irecv' that stores @Request@ at the provided pointer. +irecvPtr :: (Storable e, Ix i, Repr e) => Comm -> Rank -> Tag -> Ptr Request -> StorableArray i e -> IO () +irecvPtr comm sendRank tag requestPtr recvVal = do + recvInto recvVal $ \recvPtr recvElements recvType -> do + Internal.irecvPtr (castPtr recvPtr) recvElements recvType sendRank tag comm requestPtr + +{-| Receive 'StorableArray' from the process identified by @(Comm, Rank, Tag)@ in non-blocking mode. + +At the moment we are limiting this to 'StorableArray's because they +are compatible with C pointers. This means that the recieved data can +be written directly to the array, and does not have to be copied out +at the end. This is important for the non-blocking operation of @irecv@. + +It is not safe to copy the data from the C pointer until the transfer +is complete. So any array type which requires copying of data after +receipt of the message would have to wait on complete transmission. +It is not clear how to incorporate the waiting automatically into +the same interface as the one below. One option is to use a Haskell +thread to do the data copying in the \"background\" (as was done for 'Simple.irecv'). Another option +is to introduce a new kind of data handle which would encapsulate the +wait operation, and would allow the user to request the data to be +copied when the wait was complete. +-} +irecv :: (Storable e, Ix i, Repr e) => Comm -> Rank -> Tag -> StorableArray i e -> IO Request +irecv comm sendRank tag recvVal = do + recvInto recvVal $ \recvPtr recvElements recvType -> do + Internal.irecv (castPtr recvPtr) recvElements recvType sendRank tag comm + +-- | Wrapper around 'Internal.waitall' that operates on 'StorableArray's +waitall :: StorableArray Int Request -> StorableArray Int Status -> IO () +waitall requests statuses = do + cnt <- rangeSize <$> getBounds requests + withStorableArray requests $ \reqs -> + withStorableArray statuses $ \stats -> + Internal.waitall (cIntConv cnt) (castPtr reqs) (castPtr stats) + +-- | Scatter elements of @v1@ to all members of communicator @Comm@ from the \"root\" process identified by @Rank@. Receive own slice of data +-- in @v2@. Note that when @Comm@ is inter-communicator, @Rank@ could differ from the rank of the calling process. +scatterSend :: (SendFrom v1, RecvInto v2) => Comm -> Rank -> v1 -> v2 -> IO () +scatterSend comm root sendVal recvVal = do + recvInto recvVal $ \recvPtr recvElements recvType -> + sendFrom sendVal $ \sendPtr _ _ -> + Internal.scatter (castPtr sendPtr) recvElements recvType (castPtr recvPtr) recvElements recvType root comm + +-- | Receive the slice of data scattered from \"root\" process identified by @(Comm, Rank)@ and store it into @v@. +scatterRecv :: (RecvInto v) => Comm -> Rank -> v -> IO () +scatterRecv comm root recvVal = do + recvInto recvVal $ \recvPtr recvElements recvType -> + Internal.scatter nullPtr 0 byte (castPtr recvPtr) recvElements recvType root comm + +-- | Variant of 'scatterSend' that allows to send data in uneven chunks. +-- Since interface is tailored for speed, @counts@ and @displacements@ should be in 'StorableArray's. +scattervSend :: (SendFrom v1, RecvInto v2) => Comm + -> Rank + -> v1 -- ^ Value (vector) to send from + -> StorableArray Int CInt -- ^ Length of each segment (in elements) + -> StorableArray Int CInt -- ^ Offset of each segment from the beginning of @v1@ (in elements) + -> v2 + -> IO () +scattervSend comm root sendVal counts displacements recvVal = do + -- myRank <- commRank comm + -- XXX: assert myRank == sendRank ? + recvInto recvVal $ \recvPtr recvElements recvType -> + sendFrom sendVal $ \sendPtr _ sendType-> + withStorableArray counts $ \countsPtr -> + withStorableArray displacements $ \displPtr -> + Internal.scatterv (castPtr sendPtr) countsPtr displPtr sendType + (castPtr recvPtr) recvElements recvType root comm + +-- | Variant of 'scatterRecv', to be used with 'scattervSend' +scattervRecv :: (RecvInto v) => Comm -> Rank -> v -> IO () +scattervRecv comm root arr = do + -- myRank <- commRank comm + -- XXX: assert (myRank /= sendRank) + recvInto arr $ \recvPtr recvElements recvType -> + Internal.scatterv nullPtr nullPtr nullPtr byte (castPtr recvPtr) recvElements recvType root comm + +{- +XXX we should check that the recvArray is large enough to store: + + segmentSize * commSize +-} +-- | \"Root\" process identified by @(Comm, Rank)@ collects data sent via 'gatherSend' and stores them in @v2@. Collecting process supplies +-- its own share of data in @v1@. +gatherRecv :: (SendFrom v1, RecvInto v2) => Comm -> Rank -> v1 -> v2 -> IO () +gatherRecv comm root segment recvVal = do + -- myRank <- commRank comm + -- XXX: assert myRank == root + sendFrom segment $ \sendPtr sendElements sendType -> + recvInto recvVal $ \recvPtr _ _ -> + Internal.gather (castPtr sendPtr) sendElements sendType (castPtr recvPtr) sendElements sendType root comm + +-- | Send value of @v@ to the \"root\" process identified by @(Comm, Rank)@, to be collected with 'gatherRecv'. +gatherSend :: (SendFrom v) => Comm -> Rank -> v -> IO () +gatherSend comm root segment = do + -- myRank <- commRank comm + -- XXX: assert it is /= root + sendFrom segment $ \sendPtr sendElements sendType -> + -- the recvPtr is ignored in this case, so we can make it NULL, likewise recvCount can be 0 + Internal.gather (castPtr sendPtr) sendElements sendType nullPtr 0 byte root comm + +-- | Variant of 'gatherRecv' that allows to collect data segments of uneven size (see 'scattervSend' for details) +gathervRecv :: (SendFrom v1, RecvInto v2) => Comm -> Rank -> v1 -> + StorableArray Int CInt -> StorableArray Int CInt -> v2 -> IO () +gathervRecv comm root segment counts displacements recvVal = do + -- myRank <- commRank comm + -- XXX: assert myRank == root + sendFrom segment $ \sendPtr sendElements sendType -> + withStorableArray counts $ \countsPtr -> + withStorableArray displacements $ \displPtr -> + recvInto recvVal $ \recvPtr _ recvType-> + Internal.gatherv (castPtr sendPtr) sendElements sendType + (castPtr recvPtr) countsPtr displPtr recvType + root comm + +-- | Variant of 'gatherSend', to be used with 'gathervRecv'. +gathervSend :: (SendFrom v) => Comm -> Rank -> v -> IO () +gathervSend comm root segment = do + -- myRank <- commRank comm + -- XXX: assert myRank == root + sendFrom segment $ \sendPtr sendElements sendType -> + -- the recvPtr, counts and displacements are ignored in this case, so we can make it NULL + Internal.gatherv (castPtr sendPtr) sendElements sendType nullPtr nullPtr nullPtr byte root comm + +{- | A variation of 'gatherSend' and 'gatherRecv' where all members of +a group receive the result. + +Caller is expected to make sure that types of send and receive buffers +are selected in a way such that amount of bytes sent equals amount of bytes received pairwise between all processes. +-} +allgather :: (SendFrom v1, RecvInto v2) => Comm -> v1 -> v2 -> IO () +allgather comm sendVal recvVal = do + sendFrom sendVal $ \sendPtr sendElements sendType -> + recvInto recvVal $ \recvPtr _ _ -> -- Since amount sent equals amount received + Internal.allgather (castPtr sendPtr) sendElements sendType (castPtr recvPtr) sendElements sendType comm + +-- | A variation of 'allgather' that allows to use data segments of +-- different length. +allgatherv :: (SendFrom v1, RecvInto v2) => Comm + -> v1 -- ^ Send buffer + -> StorableArray Int CInt -- ^ Lengths of segments in the send buffer + -> StorableArray Int CInt -- ^ Displacements of the segments in the send buffer + -> v2 -- ^ Receive buffer + -> IO () +allgatherv comm segment counts displacements recvVal = do + sendFrom segment $ \sendPtr sendElements sendType -> + withStorableArray counts $ \countsPtr -> + withStorableArray displacements $ \displPtr -> + recvInto recvVal $ \recvPtr _ recvType -> + Internal.allgatherv (castPtr sendPtr) sendElements sendType (castPtr recvPtr) countsPtr displPtr recvType comm + +{- | Scatter/Gather data from all +members to all members of a group (also called complete exchange). + +Caller is expected to make sure that types of send and receive buffers and send/receive counts +are selected in a way such that amount of bytes sent equals amount of bytes received pairwise between all processes. +-} +alltoall :: (SendFrom v1, RecvInto v2) => Comm + -> v1 -- ^ Send buffer + -> Int -- ^ How many elements to /send/ to each process + -> Int -- ^ How many elements to /receive/ from each process + -> v2 -- ^ Receive buffer + -> IO () +alltoall comm sendVal sendCount recvCount recvVal = + sendFrom sendVal $ \sendPtr _ sendType -> + recvInto recvVal $ \recvPtr _ recvType -> -- Since amount sent must equal amount received + Internal.alltoall (castPtr sendPtr) (cIntConv sendCount) sendType (castPtr recvPtr) (cIntConv recvCount) recvType comm + +-- | A variation of 'alltoall' that allows to use data segments of +-- different length. +alltoallv :: (SendFrom v1, RecvInto v2) => Comm + -> v1 -- ^ Send buffer + -> StorableArray Int CInt -- ^ Lengths of segments in the send buffer + -> StorableArray Int CInt -- ^ Displacements of the segments in the send buffer + -> StorableArray Int CInt -- ^ Lengths of segments in the receive buffer + -> StorableArray Int CInt -- ^ Displacements of the segments in the receive buffer + -> v2 -- ^ Receive buffer + -> IO () +alltoallv comm sendVal sendCounts sendDisplacements recvCounts recvDisplacements recvVal = do + sendFrom sendVal $ \sendPtr _ sendType -> + recvInto recvVal $ \recvPtr _ recvType -> + withStorableArray sendCounts $ \sendCountsPtr -> + withStorableArray sendDisplacements $ \sendDisplPtr -> + withStorableArray recvCounts $ \recvCountsPtr -> + withStorableArray recvDisplacements $ \recvDisplPtr -> + Internal.alltoallv (castPtr sendPtr) sendCountsPtr sendDisplPtr sendType + (castPtr recvPtr) recvCountsPtr recvDisplPtr recvType comm + +{-| Reduce values from a group of processes into single value, which is delivered to single (so-called root) process. +See 'reduceRecv' for function that should be called by root process. + +If the value is scalar, then reduction is similar to 'fold1'. For example, if the opreration is 'sumOp', then +@reduceSend@ would compute sum of values supplied by all processes. +-} +reduceSend :: SendFrom v => Comm + -> Rank -- ^ Rank of the root process + -> Operation -- ^ Reduction operation + -> v -- ^ Value supplied by this process + -> IO () +reduceSend comm root op sendVal = do + sendFrom sendVal $ \sendPtr sendElements sendType -> + Internal.reduce (castPtr sendPtr) nullPtr sendElements sendType op root comm + +{-| Obtain result of reduction initiated by 'reduceSend'. Note that root process supplies value for reduction as well. +-} +reduceRecv :: (SendFrom v, RecvInto v) => Comm + -> Rank -- ^ Rank of the root process + -> Operation -- ^ Reduction operation + -> v -- ^ Value supplied by this process + -> v -- ^ Reduction result + -> IO () +reduceRecv comm root op sendVal recvVal = + sendFrom sendVal $ \sendPtr sendElements sendType -> + recvInto recvVal $ \recvPtr _ _ -> + Internal.reduce (castPtr sendPtr) (castPtr recvPtr) sendElements sendType op root comm + +-- | Variant of 'reduceSend' and 'reduceRecv', where result is delivered to all participating processes. +allreduce :: (SendFrom v, RecvInto v) => + Comm -- ^ Communicator engaged in reduction/ + -> Operation -- ^ Reduction operation + -> v -- ^ Value supplied by this process + -> v -- ^ Reduction result + -> IO () +allreduce comm op sendVal recvVal = + sendFrom sendVal $ \sendPtr sendElements sendType -> + recvInto recvVal $ \recvPtr _ _ -> + Internal.allreduce (castPtr sendPtr) (castPtr recvPtr) sendElements sendType op comm + +-- | Combination of 'reduceSend' + 'reduceRecv' and 'scatterSend' + 'scatterRecv': reduction result +-- is split and scattered among participating processes. +-- +-- See 'reduceScatter' if you want to be able to specify personal block size for each process. +-- +-- Note that this function is not supported with OpenMPI 1.5 +reduceScatterBlock :: (SendFrom v, RecvInto v) => + Comm -- ^ Communicator engaged in reduction/ + -> Operation -- ^ Reduction operation + -> Int -- ^ Size of the result block sent to each process + -> v -- ^ Value supplied by this process + -> v -- ^ Reduction result + -> IO () +reduceScatterBlock comm op blocksize sendVal recvVal = + sendFrom sendVal $ \sendPtr _ sendType -> + recvInto recvVal $ \recvPtr _ _ -> + Internal.reduceScatterBlock (castPtr sendPtr) (castPtr recvPtr) (cIntConv blocksize :: CInt) sendType op comm + +-- | Combination of 'reduceSend' / 'reduceRecv' and 'scatterSend' / 'scatterRecv': reduction result +-- is split and scattered among participating processes. +reduceScatter :: (SendFrom v, RecvInto v) => + Comm -- ^ Communicator engaged in reduction/ + -> Operation -- ^ Reduction operation + -> StorableArray Int CInt -- ^ Sizes of block distributed to each process + -> v -- ^ Value supplied by this process + -> v -- ^ Reduction result + -> IO () +reduceScatter comm op counts sendVal recvVal = + sendFrom sendVal $ \sendPtr _ sendType -> + recvInto recvVal $ \recvPtr _ _ -> + withStorableArray counts $ \countsPtr -> + Internal.reduceScatter (castPtr sendPtr) (castPtr recvPtr) countsPtr sendType op comm + +-- | How many (consecutive) elements of given datatype do we need to represent given +-- the Haskell type in MPI operations +class Repr e where + representation :: e -> (Int, Datatype) + +-- | Representation is one 'unsigned' +instance Repr Bool where + representation _ = (1,unsigned) + +-- | Note that C @int@ is alway 32-bit, while Haskell @Int@ size is platform-dependent. Therefore on 32-bit platforms 'int' +-- is used to represent 'Int', and on 64-bit platforms 'longLong' is used +instance Repr Int where +#if SIZEOF_HSINT == 4 + representation _ = (1,int) +#elif SIZEOF_HSINT == 8 + representation _ = (1,longLong) +#else +#error Haskell MPI bindings not tested on architecture where size of Haskell Int is not 4 or 8 +#endif + +-- | Representation is one 'byte' +instance Repr Int8 where + representation _ = (1,byte) +-- | Representation is one 'short' +instance Repr Int16 where + representation _ = (1,short) +-- | Representation is one 'int' +instance Repr Int32 where + representation _ = (1,int) +-- | Representation is one 'longLong' +instance Repr Int64 where + representation _ = (1,longLong) +-- | Representation is one 'int' +instance Repr CInt where + representation _ = (1,int) + +-- | Representation is either one 'int' or one 'longLong', depending on the platform. See comments for @Repr Int@. +instance Repr Word where +#if SIZEOF_HSINT == 4 + representation _ = (1,unsigned) +#else + representation _ = (1,unsignedLongLong) +#endif + +-- | Representation is one 'byte' +instance Repr Word8 where + representation _ = (1,byte) +-- | Representation is one 'unsignedShort' +instance Repr Word16 where + representation _ = (1,unsignedShort) +-- | Representation is one 'unsigned' +instance Repr Word32 where + representation _ = (1,unsigned) +-- | Representation is one 'unsignedLongLong' +instance Repr Word64 where + representation _ = (1,unsignedLongLong) + +-- | Representation is one 'wchar' +instance Repr Char where + representation _ = (1,wchar) +-- | Representation is one 'char' +instance Repr CChar where + representation _ = (1,char) + +-- | Representation is one 'double' +instance Repr Double where + representation _ = (1,double) +-- | Representation is one 'float' +instance Repr Float where + representation _ = (1,float) + +instance Repr e => Repr (StorableArray i e) where + representation _ = representation (undefined::e) + +instance Repr e => Repr (IOArray i e) where + representation _ = representation (undefined::e) + +instance Repr e => Repr (IOUArray i e) where + representation _ = representation (undefined::e) + +{- | Treat @v@ as send buffer suitable for the purposes of this API. + +Method 'sendFrom' is expected to deduce how to use @v@ as a memory-mapped buffer that consist of a number of +elements of some 'Datatype'. It would then call the supplied function, passing it the pointer to the buffer, +its size (in elements) and type of the element. + +Note that @e@ is not bound by the typeclass, so all kinds of foul play +are possible. However, since MPI declares all buffers as @void*@ anyway, +we are not making life all /that/ unsafe with this. +-} +class SendFrom v where + sendFrom :: v -- ^ Value to use as send buffer + -> (Ptr e -> CInt -> Datatype -> IO a) -- ^ Function that will accept pointer to buffer, its length and type of buffer elements + -> IO a + +{- | Treat @v@ as receive buffer for the purposes of this API. +-} +class RecvInto v where + recvInto :: v -- ^ Value to use as receive buffer + -> (Ptr e -> CInt -> Datatype -> IO a) -- ^ Function that will accept pointer to buffer, its length and type of buffer elements + -> IO a + +-- Sending from a single Storable values +instance SendFrom CInt where + sendFrom = sendFromSingleValue +instance SendFrom Int where + sendFrom = sendFromSingleValue +instance SendFrom Int8 where + sendFrom = sendFromSingleValue +instance SendFrom Int16 where + sendFrom = sendFromSingleValue +instance SendFrom Int32 where + sendFrom = sendFromSingleValue +instance SendFrom Int64 where + sendFrom = sendFromSingleValue +instance SendFrom Word where + sendFrom = sendFromSingleValue +instance SendFrom Word8 where + sendFrom = sendFromSingleValue +instance SendFrom Word16 where + sendFrom = sendFromSingleValue +instance SendFrom Word32 where + sendFrom = sendFromSingleValue +instance SendFrom Word64 where + sendFrom = sendFromSingleValue +instance SendFrom Bool where + sendFrom = sendFromSingleValue +instance SendFrom Float where + sendFrom = sendFromSingleValue +instance SendFrom Double where + sendFrom = sendFromSingleValue +instance SendFrom Char where + sendFrom = sendFromSingleValue +instance SendFrom CChar where + sendFrom = sendFromSingleValue + +sendFromSingleValue :: (Repr v, Storable v) => v -> (Ptr e -> CInt -> Datatype -> IO a) -> IO a +sendFromSingleValue v f = do + alloca $ \ptr -> do + poke ptr v + let (1, dtype) = representation v + f (castPtr ptr) (1::CInt) dtype + +-- | Sending from Storable arrays requres knowing MPI representation 'Repr' of its elements. This is very +-- fast and efficient, since array would be updated in-place. +instance (Storable e, Repr e, Ix i) => SendFrom (StorableArray i e) where + sendFrom = withStorableArrayAndSize + +-- | Receiving into Storable arrays requres knowing MPI representation 'Repr' of its elements. This is very +-- fast and efficient, since array would be updated in-place. +instance (Storable e, Repr e, Ix i) => RecvInto (StorableArray i e) where + recvInto = withStorableArrayAndSize + +withStorableArrayAndSize :: forall a i e z.(Repr e, Storable e, Ix i) => StorableArray i e -> (Ptr z -> CInt -> Datatype -> IO a) -> IO a +withStorableArrayAndSize arr f = do + rSize <- rangeSize <$> getBounds arr + let (scale, dtype) = (representation (undefined :: StorableArray i e)) + numElements = cIntConv (rSize * scale) + withStorableArray arr $ \ptr -> f (castPtr ptr) numElements dtype + +-- | This is less efficient than using 'StorableArray' +-- since extra memory copy is required to represent array as continuous memory buffer. +instance (Storable e, Repr (IOArray i e), Ix i) => SendFrom (IOArray i e) where + sendFrom = sendWithMArrayAndSize +-- | This is less efficient than using 'StorableArray' +-- since extra memory copy is required to construct the resulting array. +instance (Storable e, Repr (IOArray i e), Ix i) => RecvInto (IOArray i e) where + recvInto = recvWithMArrayAndSize + +recvWithMArrayAndSize :: forall i e r a z. (Storable e, Ix i, MArray a e IO, Repr (a i e)) => a i e -> (Ptr z -> CInt -> Datatype -> IO r) -> IO r +recvWithMArrayAndSize array f = do + bounds <- getBounds array + let (scale, dtype) = representation (undefined :: a i e) + numElements = cIntConv $ rangeSize bounds * scale + allocaArray (rangeSize bounds) $ \ptr -> do + result <- f (castPtr ptr) numElements dtype + fillArrayFromPtr (range bounds) (rangeSize bounds) ptr array + return result + +sendWithMArrayAndSize :: forall i e r a z. (Storable e, Ix i, MArray a e IO, Repr (a i e)) => a i e -> (Ptr z -> CInt -> Datatype -> IO r) -> IO r +sendWithMArrayAndSize array f = do + elements <- getElems array + bounds <- getBounds array + let (scale, dtype) = representation (undefined :: a i e) + numElements = cIntConv $ rangeSize bounds * scale + withArray elements $ \ptr -> f (castPtr ptr) numElements dtype + +-- XXX I wonder if this can be written without the intermediate list? +-- Maybe GHC can elimiate it. We should look at the generated compiled +-- code to see how well the loop is handled. +fillArrayFromPtr :: (MArray a e IO, Storable e, Ix i) => [i] -> Int -> Ptr e -> a i e -> IO () +fillArrayFromPtr indices numElements startPtr array = do + elems <- peekArray numElements startPtr + mapM_ (\(index, element) -> writeArray array index element ) (zip indices elems) + +-- | Sending from ByteString is efficient, since it already has the necessary memory layout. +instance SendFrom BS.ByteString where + sendFrom = sendWithByteStringAndSize + +sendWithByteStringAndSize :: BS.ByteString -> (Ptr z -> CInt -> Datatype -> IO a) -> IO a +sendWithByteStringAndSize bs f = do + unsafeUseAsCStringLen bs $ \(bsPtr,len) -> f (castPtr bsPtr) (cIntConv len) byte + +-- | Receiving into pointers to 'Storable' scalars with known MPI representation +instance (Storable e, Repr e) => RecvInto (Ptr e) where + recvInto = recvIntoElemPtr (representation (undefined :: e)) + where + recvIntoElemPtr (cnt,datatype) p f = f (castPtr p) (cIntConv cnt) datatype + +-- | Receiving into pointers to 'Storable' vectors with known MPI representation and length +instance (Storable e, Repr e) => RecvInto (Ptr e, Int) where + recvInto = recvIntoVectorPtr (representation (undefined :: e)) + where + recvIntoVectorPtr (scale, datatype) (p,len) f = f (castPtr p) (cIntConv (len * scale) :: CInt) datatype + +-- | Allocate new 'Storable' value and use it as receive buffer +intoNewVal :: (Storable e) => (Ptr e -> IO r) -> IO (e, r) +intoNewVal f = do + alloca $ \ptr -> do + res <- f ptr + val <- peek ptr + return (val, res) + +-- | Variant of 'intoNewVal' that discards result of the wrapped function +intoNewVal_ :: (Storable e) => (Ptr e -> IO r) -> IO e +intoNewVal_ f = do + (val, _) <- intoNewVal f + return val + +-- | Allocate new 'ByteString' of the given length and use it as receive buffer +intoNewBS :: Integral a => a -> ((Ptr CChar,Int) -> IO r) -> IO (BS.ByteString, r) +intoNewBS len f = do + let l = fromIntegral len + allocaBytes l $ \ptr -> do + res <- f (ptr, l) + bs <- BS.packCStringLen (ptr, l) + return (bs, res) + +-- | Variant of 'intoNewBS' that discards result of the wrapped function +intoNewBS_ :: Integral a => a -> ((Ptr CChar,Int) -> IO r) -> IO BS.ByteString +intoNewBS_ len f = do + (bs, _) <- intoNewBS len f + return bs + +{- | +Binds a user-dened reduction operation to an 'Operation' handle that can +subsequently be used in 'reduceSend', 'reduceRecv', 'allreduce', and 'reduceScatter'. +The user-defined operation is assumed to be associative. + +If first argument to @opCreate@ is @True@, then the operation should be both commutative and associative. If +it is not commutative, then the order of operands is fixed and is defined to be in ascending, +process rank order, beginning with process zero. The order of evaluation can be changed, +taking advantage of the associativity of the operation. If operation +is commutative then the order +of evaluation can be changed, taking advantage of commutativity and +associativity. + +User-defined operation accepts four arguments, @invec@, @inoutvec@, +@len@ and @datatype@ and applies reduction operation to the elements +of @invec@ and @inoutvec@ in pariwise manner. In pseudocode: + +@ +for i in [0..len-1] { inoutvec[i] = op invec[i] inoutvec[i] } +@ + +Full example with user-defined function that mimics standard operation +'sumOp': + +@ +import "Control.Parallel.MPI.Fast" + +foreign import ccall \"wrapper\" + wrap :: (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ()) + -> IO (FunPtr (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ())) +reduceUserOpTest myRank = do + numProcs <- commSize commWorld + userSumPtr <- wrap userSum + mySumOp <- opCreate True userSumPtr + (src :: StorableArray Int Double) <- newListArray (0,99) [0..99] + if myRank /= root + then reduceSend commWorld root sumOp src + else do + (result :: StorableArray Int Double) <- intoNewArray_ (0,99) $ reduceRecv commWorld root mySumOp src + recvMsg <- getElems result + freeHaskellFunPtr userSumPtr + where + userSum :: Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO () + userSum inPtr inoutPtr lenPtr _ = do + len <- peek lenPtr + let offs = sizeOf ( undefined :: CDouble ) + let loop 0 _ _ = return () + loop n inPtr inoutPtr = do + a <- peek inPtr + b <- peek inoutPtr + poke inoutPtr (a+b) + loop (n-1) (plusPtr inPtr offs) (plusPtr inoutPtr offs) + loop len inPtr inoutPtr +@ +-} +opCreate :: Storable t => Bool + -- ^ Whether the operation is commutative + -> (FunPtr (Ptr t -> Ptr t -> Ptr CInt -> Ptr Datatype -> IO ())) + {- ^ Pointer to function that accepts, in order: + + * @invec@, pointer to first input vector + + * @inoutvec@, pointer to second input vector, which is also the output vector + + * @len@, pointer to length of both vectors + + * @datatype@, pointer to 'Datatype' of elements in both vectors + -} + -> IO Operation -- ^ Handle to the created user-defined operation +opCreate commute f = do + Internal.opCreate (castFunPtr f) commute diff --git a/src/Control/Parallel/MPI/Internal.chs b/src/Control/Parallel/MPI/Internal.chs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/MPI/Internal.chs @@ -0,0 +1,1177 @@ +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +#include +#include "init_wrapper.h" +#include "comparison_result.h" +#include "error_classes.h" +#include "thread_support.h" +----------------------------------------------------------------------------- +{- | +Module : Control.Parallel.MPI.Internal +Copyright : (c) 2010 Bernie Pope, Dmitry Astapov +License : BSD-style +Maintainer : florbitous@gmail.com +Stability : experimental +Portability : ghc + +This module contains low-level Haskell bindings to core MPI functions. +All Haskell functions correspond to MPI functions or values with the similar +name (i.e. @commRank@ is the binding for @MPI_Comm_rank@ etc) + +Note that most of this module is re-exported by +"Control.Parallel.MPI", so if you are not interested in writing +low-level code, you should probably import "Control.Parallel.MPI" and +either "Control.Parallel.MPI.Storable" or "Control.Parallel.MPI.Serializable". +-} +----------------------------------------------------------------------------- +module Control.Parallel.MPI.Internal + ( + + -- * MPI runtime management. + -- ** Initialization, finalization, termination. + init, finalize, initialized, finalized, abort, + -- ** Multi-threaded environment support. + ThreadSupport (..), initThread, queryThread, isThreadMain, + + -- ** Runtime attributes. + getProcessorName, Version (..), getVersion, Implementation(..), getImplementation, + + -- * Requests and statuses. + Request, Status (..), probe, test, cancel, wait, waitall, + + -- * Process management. + -- ** Communicators. + Comm, commWorld, commSelf, commTestInter, + commSize, commRemoteSize, + commRank, + commCompare, commGroup, commGetAttr, + + -- ** Process groups. + Group, groupEmpty, groupRank, groupSize, groupUnion, + groupIntersection, groupDifference, groupCompare, groupExcl, + groupIncl, groupTranslateRanks, + -- ** Comparisons. + ComparisonResult (..), + + -- * Error handling. + Errhandler, errorsAreFatal, errorsReturn, errorsThrowExceptions, commSetErrhandler, commGetErrhandler, + ErrorClass (..), MPIError(..), mpiUndefined, + + -- * Ranks. + Rank, rankId, toRank, fromRank, anySource, theRoot, procNull, + + -- * Data types. + Datatype, char, wchar, short, int, long, longLong, unsignedChar, unsignedShort, unsigned, unsignedLong, unsignedLongLong, float, double, longDouble, byte, packed, typeSize, + + -- * Point-to-point operations. + -- ** Tags. + Tag, toTag, fromTag, anyTag, unitTag, tagUpperBound, + + -- ** Blocking operations. + BufferPtr, Count, -- XXX: what will break if we don't export those? + send, ssend, rsend, recv, + -- ** Non-blocking operations. + isend, issend, irecv, + isendPtr, issendPtr, irecvPtr, + + + -- * Collective operations. + -- ** One-to-all. + bcast, scatter, scatterv, + -- ** All-to-one. + gather, gatherv, reduce, + -- ** All-to-all. + allgather, allgatherv, + alltoall, alltoallv, + allreduce, + reduceScatterBlock, + reduceScatter, + barrier, + + -- ** Reduction operations. + Operation, maxOp, minOp, sumOp, prodOp, landOp, bandOp, lorOp, borOp, lxorOp, bxorOp, + opCreate, opFree, + + -- * Timing. + wtime, wtick, wtimeIsGlobal, wtimeIsGlobalKey + + ) where + +import Prelude hiding (init) +import C2HS +import Data.Typeable +import Data.Maybe (fromMaybe) +import Control.Monad (liftM, unless) +import Control.Applicative ((<$>), (<*>)) +import Control.Exception + +{# context prefix = "MPI" #} + +-- | Pointer to memory buffer that either holds data to be sent or is +-- used to receive some data. You would +-- probably have to use 'castPtr' to pass some actual pointers to +-- API functions. +type BufferPtr = Ptr () + +-- | Count of elements in the send/receive buffer +type Count = CInt + +{- | +Haskell enum that contains MPI constants +@MPI_IDENT@, @MPI_CONGRUENT@, @MPI_SIMILAR@ and @MPI_UNEQUAL@. + +Those are used to compare communicators ('commCompare') and +process groups ('groupCompare'). Refer to those +functions for description of comparison rules. +-} +{# enum ComparisonResult {underscoreToCase} deriving (Eq,Ord,Show) #} + +-- Which Haskell type will be used as Comm depends on the MPI +-- implementation that was selected during compilation. It could be +-- CInt, Ptr (), Ptr CInt or something else. +type MPIComm = {# type MPI_Comm #} + +{- | Abstract type representing MPI communicator handle. Different MPI + implementations use different C types to implement this, so + concrete Haskell type behind @Comm@ is hidden from user. + + In any MPI program you have predefined communicator 'commWorld' + which includes all running processes. You could create new + communicators with TODO +-} +newtype Comm = MkComm { fromComm :: MPIComm } +foreign import ccall "&mpi_comm_world" commWorld_ :: Ptr MPIComm +foreign import ccall "&mpi_comm_self" commSelf_ :: Ptr MPIComm + +-- | Predefined handle for communicator that includes all running +-- processes. Similar to @MPI_Comm_world@ +commWorld :: Comm +commWorld = MkComm <$> unsafePerformIO $ peek commWorld_ + +-- | Predefined handle for communicator that includes only current +-- process. Similar to @MPI_Comm_self@ +commSelf :: Comm +commSelf = MkComm <$> unsafePerformIO $ peek commSelf_ + +foreign import ccall "&mpi_max_processor_name" max_processor_name_ :: Ptr CInt +foreign import ccall "&mpi_max_error_string" max_error_string_ :: Ptr CInt + +-- | Max length of "processor name" as returned by 'getProcessorName' +maxProcessorName :: CInt +maxProcessorName = unsafePerformIO $ peek max_processor_name_ + +-- | Max length of error description as returned by 'errorString' +maxErrorString :: CInt +maxErrorString = unsafePerformIO $ peek max_error_string_ + +-- | Initialize the MPI environment. The MPI environment must be intialized by each +-- MPI process before any other MPI function is called. Note that +-- the environment may also be initialized by the functions 'initThread', 'mpi', +-- and 'mpiWorld'. It is an error to attempt to initialize the environment more +-- than once for a given MPI program execution. The only MPI functions that may +-- be called before the MPI environment is initialized are 'getVersion', +-- 'initialized' and 'finalized'. This function corresponds to @MPI_Init@. +{# fun unsafe init_wrapper as init {} -> `()' checkError*- #} + +-- | Determine if the MPI environment has been initialized. Returns @True@ if the +-- environment has been initialized and @False@ otherwise. This function +-- may be called before the MPI environment has been initialized and after it +-- has been finalized. +-- This function corresponds to @MPI_Initialized@. +{# fun unsafe Initialized as ^ {alloca- `Bool' peekBool*} -> `()' checkError*- #} + +-- | Determine if the MPI environment has been finalized. Returns @True@ if the +-- environment has been finalized and @False@ otherwise. This function +-- may be called before the MPI environment has been initialized and after it +-- has been finalized. +-- This function corresponds to @MPI_Finalized@. +{# fun unsafe Finalized as ^ {alloca- `Bool' peekBool*} -> `()' checkError*- #} + +-- | Initialize the MPI environment with a /required/ level of thread support. +-- See the documentation for 'init' for more information about MPI initialization. +-- The /provided/ level of thread support is returned in the result. +-- There is no guarantee that provided will be greater than or equal to required. +-- The level of provided thread support depends on the underlying MPI implementation, +-- and may also depend on information provided when the program is executed +-- (for example, by supplying appropriate arguments to @mpiexec@). +-- If the required level of support cannot be provided then it will try to +-- return the least supported level greater than what was required. +-- If that cannot be satisfied then it will return the highest supported level +-- provided by the MPI implementation. See the documentation for 'ThreadSupport' +-- for information about what levels are available and their relative ordering. +-- This function corresponds to @MPI_Init_thread@. +{# fun unsafe init_wrapper_thread as initThread + {cFromEnum `ThreadSupport', alloca- `ThreadSupport' peekEnum* } -> `()' checkError*- #} + +-- | Returns the current provided level of thread support. This will be the value +-- returned as \"provided level of support\" by 'initThread' as well. This function +-- corresponds to @MPI_Query_thread@. +{# fun unsafe Query_thread as ^ {alloca- `ThreadSupport' peekEnum* } -> `()' checkError*- #} + +-- | This function can be called by a thread to find out whether it is the main thread (the +-- thread that called 'init' or 'initThread'. +{# fun unsafe Is_thread_main as ^ + {alloca- `Bool' peekBool* } -> `()' checkError*- #} + +-- | Terminate the MPI execution environment. +-- Once 'finalize' is called no other MPI functions may be called except +-- 'getVersion', 'initialized' and 'finalized', however non-MPI computations +-- may continue. Each process must complete +-- any pending communication that it initiated before calling 'finalize'. +-- Note: the error code returned +-- by 'finalize' is not checked. This function corresponds to @MPI_Finalize@. +{# fun unsafe Finalize as ^ {} -> `()' discard*- #} +discard _ = return () +-- XXX can't call checkError on finalize, because +-- checkError calls Internal.errorClass and Internal.errorString. +-- These cannot be called after finalize (at least on OpenMPI). + +-- | Return the name of the current processing host. From this value it +-- must be possible to identify a specific piece of hardware on which +-- the code is running. +getProcessorName :: IO String +getProcessorName = do + allocaBytes (fromIntegral maxProcessorName) $ \ptr -> do + len <- getProcessorName' ptr + peekCStringLen (ptr, cIntConv len) + where + getProcessorName' = {# fun unsafe Get_processor_name as getProcessorName_ + {id `Ptr CChar', alloca- `CInt' peekIntConv*} -> `()' checkError*- #} + +-- | MPI implementation version +data Version = + Version { version :: Int, subversion :: Int } + deriving (Eq, Ord) + +instance Show Version where + show v = show (version v) ++ "." ++ show (subversion v) + +-- | Which MPI version the code is running on. +getVersion :: IO Version +getVersion = do + (version, subversion) <- getVersion' + return $ Version version subversion + where + getVersion' = {# fun unsafe Get_version as getVersion_ + {alloca- `Int' peekIntConv*, alloca- `Int' peekIntConv*} -> `()' checkError*- #} + +-- | Supported MPI implementations +data Implementation = MPICH2 | OpenMPI deriving (Eq,Show) + +-- | Which MPI implementation was used during linking +getImplementation :: Implementation +getImplementation = +#ifdef MPICH2 + MPICH2 +#else + OpenMPI +#endif + +-- | Return the number of processes involved in a communicator. For 'commWorld' +-- it returns the total number of processes available. If the communicator is +-- and intra-communicator it returns the number of processes in the local group. +-- This function corresponds to @MPI_Comm_size@. +{# fun unsafe Comm_size as ^ + {fromComm `Comm', alloca- `Int' peekIntConv* } -> `()' checkError*- #} + +-- | For intercommunicators, returns size of the remote process group. +-- Corresponds to @MPI_Comm_remote_size@. +{# fun unsafe Comm_remote_size as ^ + {fromComm `Comm', alloca- `Int' peekIntConv* } -> `()' checkError*- #} + +{- | Check whether the given communicator is intercommunicator - that + is, communicator connecting two different groups of processes. + +Refer to MPI Report v2.2, Section 5.2 "Communicator Argument" for +more details. +-} +{# fun unsafe Comm_test_inter as ^ + {fromComm `Comm', alloca- `Bool' peekBool* } -> `()' checkError*- #} + +-- | Look up MPI communicator argument by the given numeric key. +-- Lookup of some standard MPI arguments is provided by convenience +-- functions 'tagUpperBound' and 'wtimeIsGlobal'. +commGetAttr :: Storable e => Comm -> Int -> IO (Maybe e) +commGetAttr comm key = do + isInitialized <- initialized + if isInitialized then do + alloca $ \ptr -> do + found <- commGetAttr' comm key (castPtr ptr) + if found then do ptr2 <- peek ptr + Just <$> peek ptr2 + else return Nothing + else return Nothing + where + commGetAttr' = {# fun unsafe Comm_get_attr as commGetAttr_ + {fromComm `Comm', cIntConv `Int', id `Ptr ()', alloca- `Bool' peekBool*} -> `()' checkError*- #} + +-- | Maximum tag value supported by the current MPI implementation. Corresponds to the value of standard MPI +-- attribute @MPI_TAG_UB@. +-- +-- When called before 'init' or 'initThread' would return 0. +tagUpperBound :: Int +tagUpperBound = + let key = unsafePerformIO (peek tagUB_) + in fromMaybe 0 $ unsafePerformIO (commGetAttr commWorld key) + +foreign import ccall unsafe "&mpi_tag_ub" tagUB_ :: Ptr Int + +{- | True if clocks at all processes in +'commWorld' are synchronized, False otherwise. The expectation is that +the variation in time, as measured by calls to 'wtime', will be less then one half the +round-trip time for an MPI message of length zero. + +Communicators other than 'commWorld' could have different clocks. +You could find it out by querying attribute 'wtimeIsGlobalKey' with 'commGetAttr'. + +When wtimeIsGlobal is called before 'init' or 'initThread' it would return False. +-} +wtimeIsGlobal :: Bool +wtimeIsGlobal = + fromMaybe False $ unsafePerformIO (commGetAttr commWorld wtimeIsGlobalKey) + +foreign import ccall unsafe "&mpi_wtime_is_global" wtimeIsGlobal_ :: Ptr Int + +-- | Numeric key for standard MPI communicator attribute @MPI_WTIME_IS_GLOBAL@. +-- To be used with 'commGetAttr'. +wtimeIsGlobalKey :: Int +wtimeIsGlobalKey = unsafePerformIO (peek wtimeIsGlobal_) + +-- | Return the rank of the calling process for the given +-- communicator. If it is an intercommunicator, returns rank of the +-- process in the local group. +{# fun unsafe Comm_rank as ^ + {fromComm `Comm', alloca- `Rank' peekIntConv* } -> `()' checkError*- #} + +{- | Compares two communicators. + +* If they are handles for the same MPI communicator object, result is 'Identical'; + +* If both communicators are identical in constituents and rank + order, result is `Congruent'; + +* If they have the same members, but with different ranks, then + result is 'Similar'; + +* Otherwise, result is 'Unequal'. + +-} +{# fun unsafe Comm_compare as ^ + {fromComm `Comm', fromComm `Comm', alloca- `ComparisonResult' peekEnum*} -> `()' checkError*- #} + +-- | Test for an incomming message, without actually receiving it. +-- If a message has been sent from @Rank@ to the current process with @Tag@ on the +-- communicator @Comm@ then 'probe' will return the 'Status' of the message. Otherwise +-- it will block the current process until such a matching message is sent. +-- This allows the current process to check for an incoming message and decide +-- how to receive it, based on the information in the 'Status'. +-- This function corresponds to @MPI_Probe@. +{# fun Probe as ^ + {fromRank `Rank', fromTag `Tag', fromComm `Comm', allocaCast- `Status' peekCast*} -> `()' checkError*- #} +{- probe :: Rank -- ^ Rank of the sender. + -> Tag -- ^ Tag of the sent message. + -> Comm -- ^ Communicator. + -> IO Status -- ^ Information about the incoming message (but not the content of the message). -} + +{-| Send the values (as specified by @BufferPtr@, @Count@, @Datatype@) to + the process specified by (@Comm@, @Rank@, @Tag@). Caller will + block until data is copied from the send buffer by the MPI +-} +{# fun unsafe Send as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm' } -> `()' checkError*- #} +{-| Variant of 'send' that would terminate only when receiving side +actually starts receiving data. +-} +{# fun unsafe Ssend as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm' } -> `()' checkError*- #} +{-| Variant of 'send' that expects the relevant 'recv' to be already +started, otherwise this call could terminate with MPI error. +-} +{# fun unsafe Rsend as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm' } -> `()' checkError*- #} +-- | Receives data from the process +-- specified by (@Comm@, @Rank@, @Tag@) and stores it into buffer specified +-- by (@BufferPtr@, @Count@, @Datatype@). +{# fun unsafe Recv as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', allocaCast- `Status' peekCast* } -> `()' checkError*- #} +-- | Send the values (as specified by @BufferPtr@, @Count@, @Datatype@) to +-- the process specified by (@Comm@, @Rank@, @Tag@) in non-blocking mode. +-- +-- Use 'probe' or 'test' to check the status of the operation, +-- 'cancel' to terminate it or 'wait' to block until it completes. +-- Operation would be considered complete as soon as MPI finishes +-- copying the data from the send buffer. +{# fun unsafe Isend as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', alloca- `Request' peekRequest*} -> `()' checkError*- #} +-- | Variant of the 'isend' that would be considered complete only when +-- receiving side actually starts receiving data. +{# fun unsafe Issend as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', alloca- `Request' peekRequest*} -> `()' checkError*- #} +-- | Non-blocking variant of 'recv'. Receives data from the process +-- specified by (@Comm@, @Rank@, @Tag@) and stores it into buffer specified +-- by (@BufferPtr@, @Count@, @Datatype@). +{# fun Irecv as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', alloca- `Request' peekRequest*} -> `()' checkError*- #} + +-- | Like 'isend', but stores @Request@ at the supplied pointer. Useful +-- for making arrays of @Requests@ that could be passed to 'waitall' +{# fun unsafe Isend as isendPtr + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', castPtr `Ptr Request'} -> `()' checkError*- #} + +-- | Like 'issend', but stores @Request@ at the supplied pointer. Useful +-- for making arrays of @Requests@ that could be passed to 'waitall' +{# fun unsafe Issend as issendPtr + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', castPtr `Ptr Request'} -> `()' checkError*- #} + +-- | Like 'irecv', but stores @Request@ at the supplied pointer. Useful +-- for making arrays of @Requests@ that could be passed to 'waitall' +{# fun Irecv as irecvPtr + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm', castPtr `Ptr Request'} -> `()' checkError*- #} + +-- | Broadcast data from one member to all members of the communicator. +{# fun unsafe Bcast as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- | Blocks until all processes on the communicator call this function. +-- This function corresponds to @MPI_Barrier@. +{# fun unsafe Barrier as ^ {fromComm `Comm'} -> `()' checkError*- #} + +-- | Blocking test for the completion of a send of receive. +-- See 'test' for a non-blocking variant. +-- This function corresponds to @MPI_Wait@. +{# fun unsafe Wait as ^ + {withRequest* `Request', allocaCast- `Status' peekCast*} -> `()' checkError*- #} + +-- | Takes pointer to the array of Requests of given size, 'wait's on all of them, +-- populates array of Statuses of the same size. This function corresponds to @MPI_Waitall@ +{# fun unsafe Waitall as ^ + { id `Count', castPtr `Ptr Request', castPtr `Ptr Status'} -> `()' checkError*- #} +-- TODO: Make this Storable Array instead of Ptr ? + +-- | Non-blocking test for the completion of a send or receive. +-- Returns @Nothing@ if the request is not complete, otherwise +-- it returns @Just status@. See 'wait' for a blocking variant. +-- This function corresponds to @MPI_Test@. +test :: Request -> IO (Maybe Status) +test request = do + (flag, status) <- test' request + if flag + then return $ Just status + else return Nothing + where + test' = {# fun unsafe Test as test_ + {withRequest* `Request', alloca- `Bool' peekBool*, allocaCast- `Status' peekCast*} -> `()' checkError*- #} + +-- | Cancel a pending communication request. +-- This function corresponds to @MPI_Cancel@. +{# fun unsafe Cancel as ^ + {withRequest* `Request'} -> `()' checkError*- #} +withRequest req f = do alloca $ \ptr -> do poke ptr req + f (castPtr ptr) + +-- | Scatter data from one member to all members of +-- a group. +{# fun unsafe Scatter as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Count', fromDatatype `Datatype', + fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- | Gather data from all members of a group to one +-- member. +{# fun unsafe Gather as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Count', fromDatatype `Datatype', + fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- Note: We pass counts/displs as Ptr CInt so that caller could supply nullPtr here +-- which would be impossible if we marshal arrays ourselves here. + +-- | A variation of 'scatter' which allows to use data segments of +-- different length. +{# fun unsafe Scatterv as ^ + { id `BufferPtr', id `Ptr CInt', id `Ptr CInt', fromDatatype `Datatype', + id `BufferPtr', id `Count', fromDatatype `Datatype', + fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- | A variation of 'gather' which allows to use data segments of +-- different length. +{# fun unsafe Gatherv as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Ptr CInt', id `Ptr CInt', fromDatatype `Datatype', + fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- | A variation of 'gather' where all members of +-- a group receive the result. +{# fun unsafe Allgather as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Count', fromDatatype `Datatype', + fromComm `Comm'} -> `()' checkError*- #} + +-- | A variation of 'allgather' that allows to use data segments of +-- different length. +{# fun unsafe Allgatherv as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Ptr CInt', id `Ptr CInt', fromDatatype `Datatype', + fromComm `Comm'} -> `()' checkError*- #} + +-- | Scatter/Gather data from all +-- members to all members of a group (also called complete exchange) +{# fun unsafe Alltoall as ^ + { id `BufferPtr', id `Count', fromDatatype `Datatype', + id `BufferPtr', id `Count', fromDatatype `Datatype', + fromComm `Comm'} -> `()' checkError*- #} + +-- | A variant of 'alltoall' allows to use data segments of different length. +{# fun unsafe Alltoallv as ^ + { id `BufferPtr', id `Ptr CInt', id `Ptr CInt', fromDatatype `Datatype', + id `BufferPtr', id `Ptr CInt', id `Ptr CInt', fromDatatype `Datatype', + fromComm `Comm'} -> `()' checkError*- #} + +-- Reduce, allreduce and reduceScatter could call back to Haskell +-- via user-defined ops, so they should be imported in "safe" mode + +-- | Applies predefined or user-defined reduction operations to data, +-- and delivers result to the single process. +{# fun Reduce as ^ + { id `BufferPtr', id `BufferPtr', id `Count', fromDatatype `Datatype', + fromOperation `Operation', fromRank `Rank', fromComm `Comm'} -> `()' checkError*- #} + +-- | Applies predefined or user-defined reduction operations to data, +-- and delivers result to all members of the group. +{# fun Allreduce as ^ + { id `BufferPtr', id `BufferPtr', id `Count', fromDatatype `Datatype', + fromOperation `Operation', fromComm `Comm'} -> `()' checkError*- #} + +-- | A combined reduction and scatter operation - result is split and +-- parts are distributed among the participating processes. +-- +-- See 'reduceScatter' for variant that allows to specify personal +-- block size for each process. +-- +-- Note that this call is not supported with some MPI implementations, +-- like OpenMPI <= 1.5 and would cause a run-time 'error' in that case. +#if 0 +{# fun Reduce_scatter_block as ^ + { id `BufferPtr', id `BufferPtr', id `Count', fromDatatype `Datatype', + fromOperation `Operation', fromComm `Comm'} -> `()' checkError*- #} +#else +reduceScatterBlock :: BufferPtr -> BufferPtr -> Count -> Datatype -> Operation -> Comm -> IO () +reduceScatterBlock = error "reduceScatterBlock is not supported by OpenMPI" +#endif + +-- | A combined reduction and scatter operation - result is split and +-- parts are distributed among the participating processes. +{# fun Reduce_scatter as ^ + { id `BufferPtr', id `BufferPtr', id `Ptr CInt', fromDatatype `Datatype', + fromOperation `Operation', fromComm `Comm'} -> `()' checkError*- #} + +-- TODO: In the following haddock block, mention SCAN and EXSCAN once +-- they are implemented + +{- | Binds a user-dened reduction operation to an 'Operation' handle that can +subsequently be used in 'reduce', 'allreduce', and 'reduceScatter'. +The user-defined operation is assumed to be associative. + +If second argument to @opCreate@ is @True@, then the operation should be both commutative and associative. If +it is not commutative, then the order of operands is fixed and is defined to be in ascending, +process rank order, beginning with process zero. The order of evaluation can be changed, +taking advantage of the associativity of the operation. If operation +is commutative then the order +of evaluation can be changed, taking advantage of commutativity and +associativity. + +User-defined operation accepts four arguments, @invec@, @inoutvec@, +@len@ and @datatype@: + +[@invec@] first input vector + +[@inoutvec@] second input vector, which is also the output vector + +[@len@] length of both vectors + +[@datatype@] type of the elements in both vectors. + +Function is expected to apply reduction operation to the elements +of @invec@ and @inoutvec@ in pariwise manner: + +@ +inoutvec[i] = op invec[i] inoutvec[i] +@ + +Full example with user-defined function that mimics standard operation +'sumOp': + +@ +import "Control.Parallel.MPI.Fast" + +foreign import ccall \"wrapper\" + wrap :: (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ()) + -> IO (FunPtr (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ())) +reduceUserOpTest myRank = do + numProcs <- commSize commWorld + userSumPtr <- wrap userSum + mySumOp <- opCreate True userSumPtr + (src :: StorableArray Int Double) <- newListArray (0,99) [0..99] + if myRank /= root + then reduceSend commWorld root sumOp src + else do + (result :: StorableArray Int Double) <- intoNewArray_ (0,99) $ reduceRecv commWorld root mySumOp src + recvMsg <- getElems result + freeHaskellFunPtr userSumPtr + where + userSum :: Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO () + userSum inPtr inoutPtr lenPtr _ = do + len <- peek lenPtr + let offs = sizeOf ( undefined :: CDouble ) + let loop 0 _ _ = return () + loop n inPtr inoutPtr = do + a <- peek inPtr + b <- peek inoutPtr + poke inoutPtr (a+b) + loop (n-1) (plusPtr inPtr offs) (plusPtr inoutPtr offs) + loop len inPtr inoutPtr +@ +-} +{# fun unsafe Op_create as ^ + {castFunPtr `FunPtr (Ptr t -> Ptr t -> Ptr CInt -> Ptr Datatype -> IO ())', cFromEnum `Bool', alloca- `Operation' peekOperation*} -> `()' checkError*- #} + +{- | Free the handle for user-defined reduction operation created by 'opCreate' +-} +{# fun Op_free as ^ {withOperation* `Operation'} -> `()' checkError*- #} + +{- | Returns a +floating-point number of seconds, representing elapsed wallclock +time since some time in the past. + +The \"time in the past\" is guaranteed not to change during the life of the process. +The user is responsible for converting large numbers of seconds to other units if they are +preferred. The time is local to the node that calls @wtime@, but see 'wtimeIsGlobal'. +-} +{# fun unsafe Wtime as ^ {} -> `Double' realToFrac #} + +{- | Returns the resolution of 'wtime' in seconds. That is, it returns, +as a double precision value, the number of seconds between successive clock ticks. For +example, if the clock is implemented by the hardware as a counter that is incremented +every millisecond, the value returned by @wtick@ should be 10^(-3). +-} +{# fun unsafe Wtick as ^ {} -> `Double' realToFrac #} + +-- | Return the process group from a communicator. With +-- intercommunicator, returns the local group. +{# fun unsafe Comm_group as ^ + {fromComm `Comm', alloca- `Group' peekGroup*} -> `()' checkError*- #} + +-- | Returns the rank of the calling process in the given group. This function corresponds to @MPI_Group_rank@. +groupRank :: Group -> Rank +groupRank = unsafePerformIO <$> groupRank' + where groupRank' = {# fun unsafe Group_rank as groupRank_ + {fromGroup `Group', alloca- `Rank' peekIntConv*} -> `()' checkError*- #} + +-- | Returns the size of a group. This function corresponds to @MPI_Group_size@. +groupSize :: Group -> Int +groupSize = unsafePerformIO <$> groupSize' + where groupSize' = {# fun unsafe Group_size as groupSize_ + {fromGroup `Group', alloca- `Int' peekIntConv*} -> `()' checkError*- #} + +-- | Constructs the union of two groups: all the members of the first group, followed by all the members of the +-- second group that do not appear in the first group. This function corresponds to @MPI_Group_union@. +groupUnion :: Group -> Group -> Group +groupUnion g1 g2 = unsafePerformIO $ groupUnion' g1 g2 + where groupUnion' = {# fun unsafe Group_union as groupUnion_ + {fromGroup `Group', fromGroup `Group', alloca- `Group' peekGroup*} -> `()' checkError*- #} + +-- | Constructs a new group which is the intersection of two groups. This function corresponds to @MPI_Group_intersection@. +groupIntersection :: Group -> Group -> Group +groupIntersection g1 g2 = unsafePerformIO $ groupIntersection' g1 g2 + where groupIntersection' = {# fun unsafe Group_intersection as groupIntersection_ + {fromGroup `Group', fromGroup `Group', alloca- `Group' peekGroup*} -> `()' checkError*- #} + +-- | Constructs a new group which contains all the elements of the first group which are not in the second group. +-- This function corresponds to @MPI_Group_difference@. +groupDifference :: Group -> Group -> Group +groupDifference g1 g2 = unsafePerformIO $ groupDifference' g1 g2 + where groupDifference' = {# fun unsafe Group_difference as groupDifference_ + {fromGroup `Group', fromGroup `Group', alloca- `Group' peekGroup*} -> `()' checkError*- #} + +-- | Compares two groups. Returns 'MPI_IDENT' if the order and members of the two groups are the same, +-- 'MPI_SIMILAR' if only the members are the same, and 'MPI_UNEQUAL' otherwise. +groupCompare :: Group -> Group -> ComparisonResult +groupCompare g1 g2 = unsafePerformIO $ groupCompare' g1 g2 + where + groupCompare' = {# fun unsafe Group_compare as groupCompare_ + {fromGroup `Group', fromGroup `Group', alloca- `ComparisonResult' peekEnum*} -> `()' checkError*- #} + +-- Technically it might make better sense to make the second argument a Set rather than a list +-- but the order is significant in the groupIncl function (the other function, not this one). +-- For the sake of keeping their types in sync, a list is used instead. +{- | Create a new @Group@ from the given one. Exclude processes +with given @Rank@s from the new @Group@. Processes in new @Group@ will +have ranks @[0...]@. +-} +{# fun unsafe Group_excl as ^ + {fromGroup `Group', withRanksAsInts* `[Rank]'&, alloca- `Group' peekGroup*} -> `()' checkError*- #} +{- | Create a new @Group@ from the given one. Include only processes +with given @Rank@s in the new @Group@. Processes in new @Group@ will +have ranks @[0...]@. +-} +{# fun unsafe Group_incl as ^ + {fromGroup `Group', withRanksAsInts* `[Rank]'&, alloca- `Group' peekGroup*} -> `()' checkError*- #} + +{- | Given two @Group@s and list of @Rank@s of some processes in the +first @Group@, return @Rank@s of those processes in the second +@Group@. If there are no corresponding @Rank@ in the second @Group@, +'mpiUndefined' is returned. + +This function is important for determining the relative numbering of the same processes +in two different groups. For instance, if one knows the ranks of certain processes in the group +of 'commWorld', one might want to know their ranks in a subset of that group. +Note that 'procNull' is a valid rank for input to @groupTranslateRanks@, which +returns 'procNull' as the translated rank. +-} +groupTranslateRanks :: Group -> [Rank] -> Group -> [Rank] +groupTranslateRanks group1 ranks group2 = + unsafePerformIO $ do + let (rankIntList :: [Int]) = map fromEnum ranks + withArrayLen rankIntList $ \size ranksPtr -> + allocaArray size $ \resultPtr -> do + groupTranslateRanks' group1 (cFromEnum size) (castPtr ranksPtr) group2 resultPtr + map toRank <$> peekArray size resultPtr + where + groupTranslateRanks' = {# fun unsafe Group_translate_ranks as groupTranslateRanks_ + {fromGroup `Group', id `CInt', id `Ptr CInt', fromGroup `Group', id `Ptr CInt'} -> `()' checkError*- #} + +withRanksAsInts ranks f = withArrayLen (map fromEnum ranks) $ \size ptr -> f (cIntConv size, castPtr ptr) + +foreign import ccall "mpi_undefined" mpiUndefined_ :: Ptr Int + +-- | Predefined constant that might be returned as @Rank@ by calls +-- like 'groupTranslateRanks'. Corresponds to @MPI_UNDEFINED@. Please +-- refer to \"MPI Report Constant And Predefined Handle Index\" for a +-- list of situations where @mpiUndefined@ could appear. +mpiUndefined :: Int +mpiUndefined = unsafePerformIO $ peek mpiUndefined_ + +-- | Return the number of bytes used to store an MPI @Datatype@. +typeSize :: Datatype -> Int +typeSize = unsafePerformIO . typeSize' + where + typeSize' = + {# fun unsafe Type_size as typeSize_ + {fromDatatype `Datatype', alloca- `Int' peekIntConv*} -> `()' checkError*- #} + +{# fun unsafe Error_class as ^ + { id `CInt', alloca- `CInt' peek*} -> `CInt' id #} + +-- | Set the error handler for a communicator. +-- This function corresponds to @MPI_Comm_set_errhandler@. +{# fun unsafe Comm_set_errhandler as ^ + {fromComm `Comm', fromErrhandler `Errhandler'} -> `()' checkError*- #} + +-- | Get the error handler for a communicator. +-- This function corresponds to @MPI_Comm_get_errhandler@. +{# fun unsafe Comm_get_errhandler as ^ + {fromComm `Comm', alloca- `Errhandler' peekErrhandler*} -> `()' checkError*- #} + +-- | Tries to terminate all MPI processes in its communicator argument. +-- The second argument is an error code which /may/ be used as the return status +-- of the MPI process, but this is not guaranteed. On systems where 'Int' has a larger +-- range than 'CInt', the error code will be clipped to fit into the range of 'CInt'. +-- This function corresponds to @MPI_Abort@. +abort :: Comm -> Int -> IO () +abort comm code = + abort' comm (toErrorCode code) + where + toErrorCode :: Int -> CInt + toErrorCode i + -- Assumes Int always has range at least as big as CInt. + | i < (fromIntegral (minBound :: CInt)) = minBound + | i > (fromIntegral (maxBound :: CInt)) = maxBound + | otherwise = cIntConv i + + abort' = {# fun unsafe Abort as abort_ {fromComm `Comm', id `CInt'} -> `()' checkError*- #} + + +type MPIDatatype = {# type MPI_Datatype #} + +-- | Haskell datatype used to represent @MPI_Datatype@. +-- Please refer to Chapter 4 of MPI Report v. 2.2 for a description +-- of various datatypes. +newtype Datatype = MkDatatype { fromDatatype :: MPIDatatype } + +foreign import ccall unsafe "&mpi_char" char_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_wchar" wchar_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_short" short_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_int" int_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_long" long_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_long_long" longLong_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_unsigned_char" unsignedChar_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_unsigned_short" unsignedShort_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_unsigned" unsigned_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_unsigned_long" unsignedLong_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_unsigned_long_long" unsignedLongLong_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_float" float_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_double" double_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_long_double" longDouble_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_byte" byte_ :: Ptr MPIDatatype +foreign import ccall unsafe "&mpi_packed" packed_ :: Ptr MPIDatatype + +char, wchar, short, int, long, longLong, unsignedChar, unsignedShort :: Datatype +unsigned, unsignedLong, unsignedLongLong, float, double, longDouble :: Datatype +byte, packed :: Datatype + +char = MkDatatype <$> unsafePerformIO $ peek char_ +wchar = MkDatatype <$> unsafePerformIO $ peek wchar_ +short = MkDatatype <$> unsafePerformIO $ peek short_ +int = MkDatatype <$> unsafePerformIO $ peek int_ +long = MkDatatype <$> unsafePerformIO $ peek long_ +longLong = MkDatatype <$> unsafePerformIO $ peek longLong_ +unsignedChar = MkDatatype <$> unsafePerformIO $ peek unsignedChar_ +unsignedShort = MkDatatype <$> unsafePerformIO $ peek unsignedShort_ +unsigned = MkDatatype <$> unsafePerformIO $ peek unsigned_ +unsignedLong = MkDatatype <$> unsafePerformIO $ peek unsignedLong_ +unsignedLongLong = MkDatatype <$> unsafePerformIO $ peek unsignedLongLong_ +float = MkDatatype <$> unsafePerformIO $ peek float_ +double = MkDatatype <$> unsafePerformIO $ peek double_ +longDouble = MkDatatype <$> unsafePerformIO $ peek longDouble_ +byte = MkDatatype <$> unsafePerformIO $ peek byte_ +packed = MkDatatype <$> unsafePerformIO $ peek packed_ + +type MPIErrhandler = {# type MPI_Errhandler #} + +-- | Haskell datatype that represents values usable as @MPI_Errhandler@ +newtype Errhandler = MkErrhandler { fromErrhandler :: MPIErrhandler } deriving Storable +peekErrhandler ptr = MkErrhandler <$> peek ptr + +foreign import ccall "&mpi_errors_are_fatal" errorsAreFatal_ :: Ptr MPIErrhandler +foreign import ccall "&mpi_errors_return" errorsReturn_ :: Ptr MPIErrhandler + +-- | Predefined @Errhandler@ that will terminate the process on any +-- MPI error +errorsAreFatal :: Errhandler +errorsAreFatal = MkErrhandler <$> unsafePerformIO $ peek errorsAreFatal_ + +-- | Predefined @Errhandler@ that will convert errors into Haskell +-- exceptions. Mimics the semantics of @MPI_Errors_return@ +errorsReturn :: Errhandler +errorsReturn = MkErrhandler <$> unsafePerformIO $ peek errorsReturn_ + +-- | Same as 'errorsReturn', but with a more meaningful name. +errorsThrowExceptions :: Errhandler +errorsThrowExceptions = errorsReturn + +{# enum ErrorClass {underscoreToCase} deriving (Eq,Ord,Show,Typeable) #} + +-- XXX Should this be a ForeinPtr? +-- there is a MPI_Group_free function, which we should probably +-- call when the group is no longer referenced. + +-- | Actual Haskell type used depends on the MPI implementation. +type MPIGroup = {# type MPI_Group #} + +-- | Haskell datatype representing MPI process groups. +newtype Group = MkGroup { fromGroup :: MPIGroup } deriving Storable +peekGroup ptr = MkGroup <$> peek ptr + +foreign import ccall "&mpi_group_empty" groupEmpty_ :: Ptr MPIGroup +-- | A predefined group without any members. Corresponds to @MPI_GROUP_EMPTY@. +groupEmpty :: Group +groupEmpty = MkGroup <$> unsafePerformIO $ peek groupEmpty_ + + +-- | Actual Haskell type used depends on the MPI implementation. +type MPIOperation = {# type MPI_Op #} + +{- | Abstract type representing handle for MPI reduction operation +(that can be used with 'reduce', 'allreduce', and 'reduceScatter'). +-} +newtype Operation = MkOperation { fromOperation :: MPIOperation } deriving Storable +peekOperation ptr = MkOperation <$> peek ptr +withOperation op f = alloca $ \ptr -> do poke ptr (fromOperation op) + f (castPtr ptr) + +foreign import ccall unsafe "&mpi_max" maxOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_min" minOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_sum" sumOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_prod" prodOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_land" landOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_band" bandOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_lor" lorOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_bor" borOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_lxor" lxorOp_ :: Ptr MPIOperation +foreign import ccall unsafe "&mpi_bxor" bxorOp_ :: Ptr MPIOperation +-- foreign import ccall "mpi_maxloc" maxlocOp :: MPIOperation +-- foreign import ccall "mpi_minloc" minlocOp :: MPIOperation +-- foreign import ccall "mpi_replace" replaceOp :: MPIOperation +-- TODO: support for those requires better support for pair datatypes + +-- | Predefined reduction operation: maximum +maxOp :: Operation +maxOp = MkOperation <$> unsafePerformIO $ peek maxOp_ + +-- | Predefined reduction operation: minimum +minOp :: Operation +minOp = MkOperation <$> unsafePerformIO $ peek minOp_ + +-- | Predefined reduction operation: (+) +sumOp :: Operation +sumOp = MkOperation <$> unsafePerformIO $ peek sumOp_ + +-- | Predefined reduction operation: (*) +prodOp :: Operation +prodOp = MkOperation <$> unsafePerformIO $ peek prodOp_ + +-- | Predefined reduction operation: logical \"and\" +landOp :: Operation +landOp = MkOperation <$> unsafePerformIO $ peek landOp_ + +-- | Predefined reduction operation: bit-wise \"and\" +bandOp :: Operation +bandOp = MkOperation <$> unsafePerformIO $ peek bandOp_ + +-- | Predefined reduction operation: logical \"or\" +lorOp :: Operation +lorOp = MkOperation <$> unsafePerformIO $ peek lorOp_ + +-- | Predefined reduction operation: bit-wise \"or\" +borOp :: Operation +borOp = MkOperation <$> unsafePerformIO $ peek borOp_ + +-- | Predefined reduction operation: logical \"xor\" +lxorOp :: Operation +lxorOp = MkOperation <$> unsafePerformIO $ peek lxorOp_ + +-- | Predefined reduction operation: bit-wise \"xor\" +bxorOp :: Operation +bxorOp = MkOperation <$> unsafePerformIO $ peek bxorOp_ + + +{- | Haskell datatype that represents values which + could be used as MPI rank designations. Low-level MPI calls require + that you use 32-bit non-negative integer values as ranks, so any + non-numeric Haskell Ranks should provide a sensible instances of + 'Enum'. + +Attempt to supply a value that does not fit into 32 bits will cause a +run-time 'error'. +-} +newtype Rank = MkRank { rankId :: Int -- ^ Extract numeric value of the 'Rank' + } + deriving (Eq, Ord, Enum, Integral, Real) + +instance Num Rank where + (MkRank x) + (MkRank y) = MkRank (x+y) + (MkRank x) * (MkRank y) = MkRank (x*y) + abs (MkRank x) = MkRank (abs x) + signum (MkRank x) = MkRank (signum x) + fromInteger x + | x > ( fromIntegral (maxBound :: CInt)) = error "Rank value does not fit into 32 bits" + | x < 0 = error "Negative Rank value" + | otherwise = MkRank (fromIntegral x) + +foreign import ccall "mpi_any_source" anySource_ :: Ptr Int +foreign import ccall "mpi_root" theRoot_ :: Ptr Int +foreign import ccall "mpi_proc_null" procNull_ :: Ptr Int + +-- | Predefined rank number that allows reception of point-to-point messages +-- regardless of their source. Corresponds to @MPI_ANY_SOURCE@ +anySource :: Rank +anySource = toRank $ unsafePerformIO $ peek anySource_ + +-- | Predefined rank number that specifies root process during +-- operations involving intercommunicators. Corresponds to @MPI_ROOT@ +theRoot :: Rank +theRoot = toRank $ unsafePerformIO $ peek theRoot_ + +-- | Predefined rank number that specifies non-root processes during +-- operations involving intercommunicators. Corresponds to @MPI_PROC_NULL@ +procNull :: Rank +procNull = toRank $ unsafePerformIO $ peek procNull_ + +instance Show Rank where + show = show . rankId + +-- | Map arbitrary 'Enum' value to 'Rank' +toRank :: Enum a => a -> Rank +toRank x = MkRank { rankId = fromEnum x } + +-- | Map 'Rank' to arbitrary 'Enum' +fromRank :: Enum a => Rank -> a +fromRank = toEnum . rankId + +type MPIRequest = {# type MPI_Request #} +{-| Haskell representation of the @MPI_Request@ type. Returned by +non-blocking communication operations, could be further processed with +'probe', 'test', 'cancel' or 'wait'. -} +newtype Request = MkRequest MPIRequest deriving Storable +peekRequest ptr = MkRequest <$> peek ptr + +{- +This module provides Haskell representation of the @MPI_Status@ type +(request status). + +Field `status_error' should be used with care: +\"The error field in status is not needed for calls that return only +one status, such as @MPI_WAIT@, since that would only duplicate the +information returned by the function itself. The current design avoids +the additional overhead of setting it, in such cases. The field is +needed for calls that return multiple statuses, since each request may +have had a different failure.\" +(this is a quote from ) + +This means that, for example, during the call to @MPI_Wait@ +implementation is free to leave this field filled with whatever +garbage got there during memory allocation. Haskell FFI is not +blanking out freshly allocated memory, so beware! +-} + +-- | Haskell structure that holds fields of @MPI_Status@. +-- +-- Please note that MPI report lists only three fields as mandatory: +-- @status_source@, @status_tag@ and @status_error@. However, all +-- MPI implementations that were used to test those bindings supported +-- extended set of fields represented here. +data Status = + Status + { status_source :: Rank -- ^ rank of the source process + , status_tag :: Tag -- ^ tag assigned at source + , status_error :: CInt -- ^ error code, if any + , status_count :: CInt -- ^ number of received elements, if applicable + , status_cancelled :: Bool -- ^ whether the request was cancelled + } + deriving (Eq, Ord, Show) + +instance Storable Status where + sizeOf _ = {#sizeof MPI_Status #} + alignment _ = 4 + peek p = Status + <$> liftM (MkRank . cIntConv) ({#get MPI_Status->MPI_SOURCE #} p) + <*> liftM (MkTag . cIntConv) ({#get MPI_Status->MPI_TAG #} p) + <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p) +#ifdef MPICH2 + -- MPICH2 and OpenMPI use different names for the status struct + -- fields- + <*> liftM cIntConv ({#get MPI_Status->count #} p) + <*> liftM cToEnum ({#get MPI_Status->cancelled #} p) +#else + <*> liftM cIntConv ({#get MPI_Status->_count #} p) + <*> liftM cToEnum ({#get MPI_Status->_cancelled #} p) +#endif + poke p x = do + {#set MPI_Status.MPI_SOURCE #} p (fromRank $ status_source x) + {#set MPI_Status.MPI_TAG #} p (fromTag $ status_tag x) + {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x) +#ifdef MPICH2 + -- MPICH2 and OpenMPI use different names for the status struct + -- fields AND different order of fields + {#set MPI_Status.count #} p (cIntConv $ status_count x) + {#set MPI_Status.cancelled #} p (cFromEnum $ status_cancelled x) +#else + {#set MPI_Status._count #} p (cIntConv $ status_count x) + {#set MPI_Status._cancelled #} p (cFromEnum $ status_cancelled x) +#endif + +-- NOTE: Int here is picked arbitrary +allocaCast f = + alloca $ \(ptr :: Ptr Int) -> f (castPtr ptr :: Ptr ()) +peekCast = peek . castPtr + + +{-| Haskell datatype that represents values which could be used as +tags for point-to-point transfers. +-} +newtype Tag = MkTag { tagVal :: Int -- ^ Extract numeric value of the Tag + } + deriving (Eq, Ord, Enum, Integral, Real) + +instance Num Tag where + (MkTag x) + (MkTag y) = MkTag (x+y) + (MkTag x) * (MkTag y) = MkTag (x*y) + abs (MkTag x) = MkTag (abs x) + signum (MkTag x) = MkTag (signum x) + fromInteger x + | fromIntegral x > tagUpperBound = error "Tag value is over the MPI_TAG_UB" + | x < 0 = error "Negative Tag value" + | otherwise = MkTag (fromIntegral x) + +instance Show Tag where + show = show . tagVal + +-- | Map arbitrary 'Enum' value to 'Tag' +toTag :: Enum a => a -> Tag +toTag x = MkTag { tagVal = fromEnum x } + +-- | Map 'Tag' to arbitrary 'Enum' +fromTag :: Enum a => Tag -> a +fromTag = toEnum . tagVal + +foreign import ccall unsafe "&mpi_any_tag" anyTag_ :: Ptr Int + +-- | Predefined tag value that allows reception of the messages with +-- arbitrary tag values. Corresponds to @MPI_ANY_TAG@. +anyTag :: Tag +anyTag = toTag $ unsafePerformIO $ peek anyTag_ + +-- | A tag with unit value. Intended to be used as a convenient default. +unitTag :: Tag +unitTag = toTag () + +{- | Constants used to describe the required level of multithreading + support in call to 'initThread'. They also describe provided level + of multithreading support as returned by 'queryThread' and + 'initThread'. + +[@Single@] Only one thread will execute. + +[@Funneled@] The process may be multi-threaded, but the application must +ensure that only the main thread makes MPI calls (see 'isThreadMain'). + +[@Serialized@] The process may be multi-threaded, and multiple threads may +make MPI calls, but only one at a time: MPI calls are not made concurrently from +two distinct threads + +[@Multiple@] Multiple threads may call MPI, with no restrictions. + +XXX Make sure we have the correct ordering as defined by MPI. Also we should +describe the ordering here (other parts of the docs need it to be explained - see initThread). + +-} +{# enum ThreadSupport {underscoreToCase} deriving (Eq,Ord,Show) #} + +-- | Value thrown as exception when MPI runtime is instructed to pass +-- errors to user code (via 'commSetErrhandler' and 'errorsReturn'). +-- Since raw MPI errors codes are not standartized and not portable, +-- they are not exposed. +data MPIError + = MPIError + { mpiErrorClass :: ErrorClass -- ^ Broad class of errors this one belongs to + , mpiErrorString :: String -- ^ Human-readable error description + } + deriving (Eq, Show, Typeable) + +instance Exception MPIError + +checkError :: CInt -> IO () +checkError code = do + -- We ignore the error code from the call to Internal.errorClass + -- because we call errorClass from checkError. We'd end up + -- with an infinite loop if we called checkError here. + (_, errClassRaw) <- errorClass code + let errClass = cToEnum errClassRaw + unless (errClass == Success) $ do + errStr <- errorString code + throwIO $ MPIError errClass errStr + +-- | Convert MPI error code human-readable error description. Corresponds to @MPI_Error_string@. +errorString :: CInt -> IO String +errorString code = + allocaBytes (fromIntegral maxErrorString) $ \ptr -> + alloca $ \lenPtr -> do + -- We ignore the error code from the call to Internal.errorString + -- because we call errorString from checkError. We'd end up + -- with an infinite loop if we called checkError here. + _ <- errorString' code ptr lenPtr + len <- peek lenPtr + peekCStringLen (ptr, cIntConv len) + where + errorString' = {# call unsafe Error_string as errorString_ #} diff --git a/src/Control/Parallel/MPI/Simple.hs b/src/Control/Parallel/MPI/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/MPI/Simple.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Parallel.MPI.Simple +-- Copyright : (c) 2010 Bernie Pope, Dmitry Astapov +-- License : BSD-style +-- Maintainer : florbitous@gmail.com +-- Stability : experimental +-- Portability : ghc +-- +-- This module provides MPI functionality for arbitrary Haskell values that are +-- instances of Storable typeclass. +-- +-- Since low-level MPI calls have to know the size of transmitted message, all +-- functions in this module internally make one extra call to transfer the size +-- of encoded message to receiving side prior to transmitting the message itself. +-- Obviously, this incurs some overhead. +-- +-- Full range of point-to-point and collective operation is supported, except for reduce and similar operations. +-- Low-level MPI reduction operations could not be used on values whose structure is hidden from MPI (which is +-- exactly the case here), and implementation of reduction in Haskell heavily depends on the nature of data being +-- processed, so there is no need to try and implement some general case in this module. +-- +-- Below is a small but complete MPI program utilising this module. +-- Process 1 sends the message +-- @\"Hello World\"@ to process 0, which in turn receives the message and +-- prints it to standard output. All other processes, if there are any, +-- do nothing. +-- Further examples in this module provide different implementations of the +-- @process@ function. +-- +-- >import Control.Parallel.MPI.Simple (Rank, mpiWorld, commWorld, unitTag, send, recv) +-- > +-- >main :: IO () +-- >main = mpiWorld $ \size rank -> +-- > if size < 2 +-- > then putStrLn "At least two processes are needed" +-- > else process rank +-- > +-- >process :: Rank -> IO () +-- >process rank +-- > | rank == 1 = send commWorld 0 unitTag "Hello World" +-- > | rank == 0 = do +-- > (msg, _status) <- recv commWorld 1 unitTag +-- > putStrLn msg +-- > | otherwise = return () -- do nothing +----------------------------------------------------------------------------- + +module Control.Parallel.MPI.Simple + ( + -- * Point-to-point operations. + -- ** Blocking. + send + , ssend + , rsend + , recv + -- ** Non-blocking. + , isend + , issend + , waitall + -- *** Futures. + , Future() + , waitFuture + , getFutureStatus + , pollFuture + , cancelFuture + , recvFuture + + -- ** Low-level (operating on ByteStrings). + , sendBS + , recvBS + , isendBS + -- | Here is how you can use those functions + -- + -- @ + -- process rank + -- | rank == 0 = do sendBS 'commWorld' 1 123 (BS.Pack \"Hello world!\") + -- request <- isendBS 'commWorld' 2 123 (BS.Pack \"And you too!\") + -- 'wait' request + -- | rank \`elem\` [1,2] = do (msg, status) <- recvBS 'commWorld' 0 123 + -- print msg + -- | otherwise = return () + -- @ + + -- * Collective operations. + {- | Broadcast and other collective operations are tricky because the receiver doesn't know how much memory to allocate. + The C interface assumes the sender and receiver agree on the size in advance, but + this is not useful for the Haskell interface (where we want to send arbitrary sized + values) because the sender is the only process which has the actual data available. + + The work around is for the sender to send two messages. The first says how much data + is coming. The second message sends the actual data. We rely on the two messages being + sent and received in this order. Conversely the receiver gets two messages. The first is + the size of memory to allocate and the second in the actual message. + + The obvious downside of this approach is that it requires two MPI calls for one + payload. + -} + -- ** One-to-all. + , bcastSend + , bcastRecv + , scatterSend + , scatterRecv + -- ** All-to-one. + , gatherSend + , gatherRecv + , allgather + -- ** All-to-all. + , alltoall + + , module Control.Parallel.MPI.Base + ) where + +import C2HS +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, tryTakeMVar, readMVar, newEmptyMVar, putMVar) +import Control.Concurrent (ThreadId, killThread) +import Control.Monad (when) +import Data.ByteString.Unsafe as BS +import qualified Data.ByteString as BS +import Data.Serialize (encode, decode, Serialize) +import qualified Control.Parallel.MPI.Fast as Fast +import qualified Control.Parallel.MPI.Internal as Internal +import Control.Parallel.MPI.Base +import qualified Data.Array.Storable as SA +import Data.List (unfoldr) + +-- | Serializes the supplied value to ByteString and sends to specified process as the array of 'byte's using 'Internal.send'. +-- +-- This call could complete before the matching receive is posted by some other process. +send :: Serialize msg => Comm -> Rank -> Tag -> msg -> IO () +send c r t m = sendBSwith Internal.send c r t $ encode m + +-- | Serializes the supplied value and sends to specified process as the array of 'byte's using 'Internal.ssend'. +-- +-- This is so-called \"synchronous blocking send\" mode - this call would not complete until +-- matching receive is posted and started to receive data. +ssend :: Serialize msg => Comm -> Rank -> Tag -> msg -> IO () +ssend c r t m = sendBSwith Internal.ssend c r t $ encode m + +-- | Serializes the supplied value and sends to specified process as the array of 'byte's using 'Internal.rsend'. +-- +-- This call expects the matching receive already to be posted, otherwise error will occur. +-- +-- Due to the difference between OpenMPI and MPICH2 (tested on v.1.2.1.1) size of messages posted with @rsend@ +-- could not be 'probe'd, which breaks +-- all variants of point-to-point receving code in this module. Therefore, when liked with MPICH2, this function +-- will use 'Internal.send' internally. +rsend :: Serialize msg => Comm -> Rank -> Tag -> msg -> IO () +rsend c r t m = sendBSwith impl c r t $ encode m + where impl = if Internal.getImplementation == Internal.MPICH2 then Internal.send else Internal.rsend + +-- | Sends ByteString to specified process as the array of 'byte's using 'Internal.send'. +sendBS :: Comm -> Rank -> Tag -> BS.ByteString -> IO () +sendBS = sendBSwith Internal.send + +sendBSwith :: + (Ptr () -> CInt -> Datatype -> Rank -> Tag -> Comm -> IO ()) -> + Comm -> Rank -> Tag -> BS.ByteString -> IO () +sendBSwith send_function comm rank tag bs = do + let cCount = cIntConv $ BS.length bs + unsafeUseAsCString bs $ \cString -> + send_function (castPtr cString) cCount byte rank tag comm + +-- | Receives arbitrary serializable message from specified process. Operation status +-- is returned as second component of the tuple, and usually could be discarded. +-- +-- This function uses @MPI_Recv@ internally and relies on 'probe' to get the size of incoming message +-- and allocate sufficient memory in receiving buffer, which incurs slight additional overhead. +recv :: Serialize msg => Comm -> Rank -> Tag -> IO (msg, Status) +recv comm rank tag = do + (bs, status) <- recvBS comm rank tag + case decode bs of + Left e -> fail e + Right val -> return (val, status) + +-- | Receives ByteString from specified process. Internally uses 'Internal.recv' and relies on 'probe' to +-- get the size of incoming message, which incurs slight additional overhead. +recvBS :: Comm -> Rank -> Tag -> IO (BS.ByteString, Status) +recvBS comm rank tag = do + probeStatus <- probe rank tag comm + let count = fromIntegral $ status_count probeStatus + cCount = cIntConv count + allocaBytes count + (\bufferPtr -> do + recvStatus <- Internal.recv bufferPtr cCount byte rank tag comm + message <- BS.packCStringLen (castPtr bufferPtr, count) + return (message, recvStatus)) + +-- | Serializes message to ByteString and sends it to specified process in non-blocking mode as the array of 'byte's using 'Internal.isend'. +-- +-- User have to utilise `wait' on the +-- returned `Request' object to find out when operation is completed. +-- In this case it actually means \"data has been copied to the internal MPI buffer\" - no +-- check for matching `recv' being posted is done. +-- +-- Example: +-- +-- @ +-- do req <- isend 'commWorld' 0 'unitTag' \"Hello world!\" +-- 'wait' req +-- @ +isend :: Serialize msg => Comm -> Rank -> Tag -> msg -> IO Request +isend c r t m = isendBSwith Internal.isend c r t $ encode m + +-- | Serializes message to ByteString and sends it to the specified process in non-blocking mode as the array of 'byte's using 'Internal.issend'. +-- +-- Calling `wait' on returned `Request' object would complete once the receiving +-- process has actually started receiving data. +issend :: Serialize msg => Comm -> Rank -> Tag -> msg -> IO Request +issend c r t m = isendBSwith Internal.issend c r t $ encode m + +-- | Serializes message to ByteString and sends it to the specified process in non-blocking mode as the array of 'byte's using 'Internal.isend'. +isendBS :: Comm -> Rank -> Tag -> BS.ByteString -> IO Request +isendBS = isendBSwith Internal.isend + +isendBSwith :: + (Ptr () -> CInt -> Datatype -> Rank -> Tag -> Comm -> IO Request) -> + Comm -> Rank -> Tag -> BS.ByteString -> IO Request +isendBSwith send_function comm rank tag bs = do + let cCount = cIntConv $ BS.length bs + unsafeUseAsCString bs $ \cString -> do + send_function (castPtr cString) cCount byte rank tag comm + +-- | Blocking test for completion of all specified `Request' objects +-- +-- Example. Posting 100 sends and waiting until all of them complete: +-- +-- >do requests <- forM ([0..99]) $ \s -> +-- > isend commWorld someRank unitTag (take s longMessage) +-- > waitall requests +waitall :: [Request] -> IO [Status] +waitall reqs = do + withArrayLen reqs $ \len reqPtr -> + allocaArray len $ \statPtr -> do + Internal.waitall (cIntConv len) reqPtr (castPtr statPtr) + peekArray len statPtr + +-- | A value to be computed by some thread in the future. +data Future a = + Future + { futureThread :: ThreadId + , futureStatus :: MVar Status + , futureVal :: MVar a + } + +-- | Obtain the computed value from a 'Future'. If the computation +-- has not completed, the caller will block, until the value is ready. +-- See 'pollFuture' for a non-blocking variant. +waitFuture :: Future a -> IO a +waitFuture = readMVar . futureVal + +-- | Obtain the 'Status' from a 'Future'. If the computation +-- has not completed, the caller will block, until the value is ready. +getFutureStatus :: Future a -> IO Status +getFutureStatus = readMVar . futureStatus +-- XXX do we need a pollStatus? + +-- | Poll for the computed value from a 'Future'. If the computation +-- has not completed, the function will return @None@, otherwise it +-- will return @Just value@. +pollFuture :: Future a -> IO (Maybe a) +pollFuture = tryTakeMVar . futureVal + +-- | Terminate the computation associated with a 'Future'. +cancelFuture :: Future a -> IO () +cancelFuture = killThread . futureThread +-- XXX May want to stop people from waiting on Futures which are killed... + +-- | Non-blocking receive of the message. Returns value of type `Future', +-- which could be used to check status of the operation using `getFutureStatus' +-- and extract actual value using either `waitFuture' or `pollFuture'. +-- Internally this uses the blocking 'recv' in a separate execution thread. +-- +-- Example: +-- +-- >do f <- recvFuture commWorld someRank unitTag +-- > value <- waitFuture f +recvFuture :: Serialize msg => Comm -> Rank -> Tag -> IO (Future msg) +recvFuture comm rank tag = do + valRef <- newEmptyMVar + statusRef <- newEmptyMVar + -- is forkIO acceptable here? Depends on thread local stateness of MPI. + -- threadId <- forkOS $ do + threadId <- forkIO $ do + -- do a synchronous recv in another thread + (msg, status) <- recv comm rank tag + putMVar valRef msg + putMVar statusRef status + return $ Future { futureThread = threadId, futureStatus = statusRef, futureVal = valRef } + +-- | Broadcasts message to all members of specified inter- or intra-communicator. +-- `Rank' of the sending process should be provided, as mandated by MPI. Internally uses two 'Fast.bcastSend' calls to +-- distribute length of the message before the message itself. +-- +-- This function handles both inter- and intracommunicators, provided that the caller makes proper use of `theRoot' and `procNull'. +-- +-- See `bcastRecv' for complete example. +bcastSend :: Serialize msg => Comm -> Rank -> msg -> IO () +bcastSend comm rootRank msg = do + -- Intercommunicators are handled differently. + -- Basically, if communicator is intercommunicator, it means that + -- there are two groups of processes - sending group and + -- receiving group. From the sending group only one process + -- actually sends the data - the one that specifies + -- "theRoot" as the value of rootRank. All other processes from the + -- sending group should specify "procNull" as the + -- rootRank and (if I understand MPI specs properly) + -- would disregard "sending buffer" argument and would + -- not actually send anything. That's why for procNull ranks we + -- use empty ByteString as payload. + isInter <- commTestInter comm + if isInter then if rootRank == theRoot then doSend (encode msg) + else if rootRank == procNull then doSend BS.empty -- do nothing + else fail "bcastSend with intercommunicator accepts either theRoot or procNull as Rank" + else -- intra-communicator, i.e. a single homogenous group of processes. + doSend (encode msg) + where + doSend bs = do + -- broadcast the size of the message first + Fast.bcastSend comm rootRank (cIntConv (BS.length bs) :: CInt) + -- then broadcast the actual message + Fast.bcastSend comm rootRank bs + +{- | Receive the message being broadcasted in the communicator from the process with specified `Rank'. +Internally uses two 'Fast.bcastRecv' calls to receive the length of the message and after that the message itself. + +Example: + +>process rank +> | rank == 0 = bcastSend commWorld 0 "Hello world!" +> | otherwise = bcastRecv commWorld 0 >>= print +-} +bcastRecv :: Serialize msg => Comm -> Rank -> IO msg +bcastRecv comm rootRank = do + -- receive the broadcast of the size + (count::CInt) <- Fast.intoNewVal_ $ Fast.bcastRecv comm rootRank + -- receive the broadcast of the message + bs <- Fast.intoNewBS_ count $ Fast.bcastRecv comm rootRank + case decode bs of + Left e -> fail e + Right val -> return val + +{- | Send a message to the specified process, to be collected using `gatherRecv'. +Internally uses 'Fast.gatherSend' to send the message length and 'Fast.gathervSend' to send the message itself. +-} +gatherSend :: Serialize msg => Comm -> Rank -> msg -> IO () +gatherSend comm root msg = do + let enc_msg = encode msg + -- Send length + Fast.gatherSend comm root (cIntConv (BS.length enc_msg) :: CInt) + -- Send payload + Fast.gathervSend comm root enc_msg + +{- | Collects the messages sent with `gatherSend' and returns them as list. +Note that per MPI semantics collecting process is expected to supply the message as well. +Internally uses 'Fast.gatherRecv' to obtain the message lengths and 'Fast.gathervRecv' to collect the messages. + +This function handles both inter- and intracommunicators, provided that the caller makes proper use of `theRoot' and `procNull'. + +Example. Gathering rank numbers from all processes to the process with rank 0: + +>process rank +> | rank == 0 = do ranks <- gatherRecv commWorld 0 rank +> putStrLn $ "Got messages from ranks:" ++ show ranks +> | otherwise = gatherSend commWorld 0 rank +-} +gatherRecv :: Serialize msg => Comm -> Rank -> msg -> IO [msg] +gatherRecv comm root msg = do + isInter <- commTestInter comm + if isInter then if root == procNull then return [] + else if root == theRoot then doRecv isInter + else fail "Process in receiving group of intercommunicator uses unsupported value of root in gatherRecv" + else doRecv isInter + where + doRecv isInter = do + let enc_msg = encode msg + numProcs <- if isInter then commRemoteSize comm else commSize comm + (lengthsArr :: SA.StorableArray Int CInt) <- Fast.intoNewArray_ (0,numProcs-1) $ Fast.gatherRecv comm root (cIntConv (BS.length enc_msg) :: CInt) + -- calculate displacements from sizes + lengths <- SA.getElems lengthsArr + (displArr :: SA.StorableArray Int CInt) <- SA.newListArray (0,numProcs-1) $ Prelude.init $ scanl1 (+) (0:lengths) + bs <- Fast.intoNewBS_ (sum lengths) $ Fast.gathervRecv comm root enc_msg lengthsArr displArr + return $ decodeList lengths bs + +decodeList :: (Serialize msg) => [CInt] -> BS.ByteString -> [msg] +decodeList lengths bs = unfoldr decodeNext (lengths,bs) + where + decodeNext ([],_) = Nothing + decodeNext ((l:ls),bs) = + case decode bs of + Left e -> fail e + Right val -> Just (val, (ls, BS.drop (cIntConv l) bs)) + +{- | Receives single message from the process that distributes them with `scatterSend'. +Internally uses 'Fast.scatterRecv' to get the length of the message followed by 'Fast.scattervRecv' to get the message itself. + +Example. Scattering @\"Hello world\"@ to all processes from process with rank 0: + +>process rank +> | rank == 0 = do n <- commSize commWorld +> myMsg <- scatterSend commWorld 0 $ replicate n "Hello World!" +> | otherwise = do msg <- scatterRecv commWorld 0 +> print msg +-} +scatterRecv :: Serialize msg => Comm -> Rank -> IO msg +scatterRecv comm root = do + -- Recv length + (len::CInt) <- Fast.intoNewVal_ $ Fast.scatterRecv comm root + -- Recv payload + bs <- Fast.intoNewBS_ len $ Fast.scattervRecv comm root + case decode bs of + Left e -> fail e + Right val -> return val + +-- | Distributes a list of messages between processes in the given communicator +-- so that each process gets exactly one message. It is caller's responsibility +-- to ensure that list has proper amount of messages (error would be raised otherwise). +-- +-- Internally uses 'Fast.scatterSend' to distribute the lengths of the messages followed by 'Fast.scattervSend' to distribute the serialized messages. +-- +-- This function handles both inter- and intracommunicators. +scatterSend :: Serialize msg => Comm -> Rank -> [msg] -> IO msg +scatterSend comm root msgs = do + isInter <- commTestInter comm + numProcs <- if isInter then commRemoteSize comm else commSize comm + when (length msgs /= numProcs) $ fail "Unable to deliver one message to each receiving process in scatterSend" + if isInter then if root == procNull then return $ head msgs + -- XXX: + -- fix this. We really + -- should just return () + -- here. + else if root == theRoot then doSend + else fail "Process in sending group of intercommunicator uses unsupported value of root in scatterSend" + else doSend -- intracommunicator + where + doSend = do + let enc_msgs = map encode msgs + lengths = map (cIntConv . BS.length) enc_msgs + payload = BS.concat enc_msgs + numProcs = length msgs + -- scatter numProcs ints - sizes of payloads to be sent to other processes + (lengthsArr :: SA.StorableArray Int CInt) <- SA.newListArray (0,numProcs-1) lengths + (myLen :: CInt) <- Fast.intoNewVal_ $ Fast.scatterSend comm root lengthsArr + -- calculate displacements from sizes + (displArr :: SA.StorableArray Int CInt) <- SA.newListArray (0,numProcs-1) $ Prelude.init $ scanl1 (+) (0:lengths) + -- scatter payloads + bs <- Fast.intoNewBS_ myLen $ Fast.scattervSend comm root payload lengthsArr displArr + case decode bs of + Left e -> fail e + Right val -> return val + +{- | All processes in the given communicator supply a message. This list of messages is then received +by every process in the communicator. Value returned from this function would be identical across +all processes. + +Internally uses 'Fast.allgather' to send length of the message and collect lengths of messages coming from other processes, and then uses +'Fast.allgatherv' to send own message and collect messages from other processes. + +This function handles both inter- and intracommunicators. + +Example. Each process shares it's rank number, so that all processes have to full list of all participating ranks: + +> process rank = do ranks <- allgather commWorld rank +> putStrLn $ "Participating ranks:" ++ show ranks +-} +allgather :: (Serialize msg) => Comm -> msg -> IO [msg] +allgather comm msg = do + let enc_msg = encode msg + isInter <- commTestInter comm + numProcs <- if isInter then commRemoteSize comm else commSize comm + -- Send length of my message and receive lengths from other ranks + (lengthsArr :: SA.StorableArray Int CInt) <- Fast.intoNewArray_ (0, numProcs-1) $ Fast.allgather comm (cIntConv (BS.length enc_msg) :: CInt) + -- calculate displacements from sizes + lengths <- SA.getElems lengthsArr + (displArr :: SA.StorableArray Int CInt) <- SA.newListArray (0,numProcs-1) $ Prelude.init $ scanl1 (+) (0:lengths) + -- Send my payload and receive payloads from other ranks + bs <- Fast.intoNewBS_ (sum lengths) $ Fast.allgatherv comm enc_msg lengthsArr displArr + return $ decodeList lengths bs + +{- | Each processes in the given communicator sends one message to every other process +and receives a list of messages, one from every process in the communicator. + +Internally uses 'Fast.alltoall' to communicate lengths of the messages followed by 'Fast.alltoallv' to communicate the serialized messages. + +This function handles both inter- and intracommunicators. + +Example. Each process sends his own rank (as a list @[rank]@) to process with rank 0, @[rank, rank]@ to process with rank 1, and so on. +Therefore, process with rank 0 gets @[[0],[1],[2]]@, process with rank 1 gets @[[0,0],[1,1],[2,2]]@ and so on: + +> process rank = do +> numProcs <- commSize commWorld +> let msg = take numProcs $ map (`take` (repeat rank)) [1..] +> result <- alltoall commWorld msg +> putStrLn $ "Rank " ++ show rank ++ " got message " ++ show result +-} +alltoall :: (Serialize msg) => Comm -> [msg] -> IO [msg] +alltoall comm msgs = do + let enc_msgs = map encode msgs + sendLengths = map (cIntConv . BS.length) enc_msgs + sendPayload = BS.concat enc_msgs + isInter <- commTestInter comm + numProcs <- if isInter then commRemoteSize comm else commSize comm + when (length msgs /= numProcs) $ fail "Unable to deliver one message to each receiving process in alltoall" + -- First, all-to-all payload sizes + (sendLengthsArr :: SA.StorableArray Int CInt) <- SA.newListArray (1,numProcs) sendLengths + (recvLengthsArr :: SA.StorableArray Int CInt) <- Fast.intoNewArray_ (1,numProcs) $ Fast.alltoall comm sendLengthsArr 1 1 + recvLengths <- SA.getElems recvLengthsArr + -- calculate displacements from sizes + (sendDisplArr :: SA.StorableArray Int CInt) <- SA.newListArray (1,numProcs) $ Prelude.init $ scanl1 (+) (0:sendLengths) + (recvDisplArr :: SA.StorableArray Int CInt) <- SA.newListArray (1,numProcs) $ Prelude.init $ scanl1 (+) (0:recvLengths) + -- Receive payloads + bs <- Fast.intoNewBS_ (sum recvLengths) $ Fast.alltoallv comm sendPayload sendLengthsArr sendDisplArr recvLengthsArr recvDisplArr + return $ decodeList recvLengths bs + diff --git a/src/Control/Parallel/MPI/Utils.hs b/src/Control/Parallel/MPI/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/MPI/Utils.hs @@ -0,0 +1,29 @@ +module Control.Parallel.MPI.Utils (asBool, asInt, asEnum, debugOut) where + +import C2HS + +asBool :: (Ptr CInt -> IO ()) -> IO Bool +asBool f = + alloca $ \ptr -> do + f ptr + res <- peek ptr + return $ res /= 0 + +asInt :: (Ptr CInt -> IO ()) -> IO Int +asInt f = + alloca $ \ptr -> do + f ptr + res <- peek ptr + return $ cIntConv res + +asEnum :: Enum a => (Ptr CInt -> IO ()) -> IO a +asEnum f = + alloca $ \ptr -> do + f ptr + res <- peek ptr + return $ cToEnum res + +debugOut :: Show a => a -> Bool +debugOut x = unsafePerformIO $ do + print x + return False diff --git a/src/cbits/constants.c b/src/cbits/constants.c new file mode 100644 --- /dev/null +++ b/src/cbits/constants.c @@ -0,0 +1,61 @@ +#include + +/* Taken from HMPI */ +// #define MPI_CONST(ty, name, defn) inline ty name () { return ((ty)defn); } +#define MPI_CONST(ty, name, defn) ty name = defn; + +/* Datatypes */ +MPI_CONST (MPI_Datatype, mpi_char, MPI_CHAR) +MPI_CONST (MPI_Datatype, mpi_wchar, MPI_WCHAR) +MPI_CONST (MPI_Datatype, mpi_short, MPI_SHORT) +MPI_CONST (MPI_Datatype, mpi_int, MPI_INT) +MPI_CONST (MPI_Datatype, mpi_long, MPI_LONG) +MPI_CONST (MPI_Datatype, mpi_long_long, MPI_LONG_LONG) +MPI_CONST (MPI_Datatype, mpi_unsigned_char, MPI_UNSIGNED_CHAR) +MPI_CONST (MPI_Datatype, mpi_unsigned_short, MPI_UNSIGNED_SHORT) +MPI_CONST (MPI_Datatype, mpi_unsigned, MPI_UNSIGNED) +MPI_CONST (MPI_Datatype, mpi_unsigned_long, MPI_UNSIGNED_LONG) +MPI_CONST (MPI_Datatype, mpi_unsigned_long_long, MPI_UNSIGNED_LONG_LONG) +MPI_CONST (MPI_Datatype, mpi_float, MPI_FLOAT) +MPI_CONST (MPI_Datatype, mpi_double, MPI_DOUBLE) +MPI_CONST (MPI_Datatype, mpi_long_double, MPI_LONG_DOUBLE) +MPI_CONST (MPI_Datatype, mpi_byte, MPI_BYTE) +MPI_CONST (MPI_Datatype, mpi_packed, MPI_PACKED) + +/* Misc */ +MPI_CONST (int, mpi_any_source, MPI_ANY_SOURCE) +MPI_CONST (int, mpi_proc_null, MPI_PROC_NULL) +MPI_CONST (int, mpi_root, MPI_ROOT) +MPI_CONST (int, mpi_any_tag, MPI_ANY_TAG) +MPI_CONST (int, mpi_tag_ub, MPI_TAG_UB) +MPI_CONST (int, mpi_wtime_is_global, MPI_WTIME_IS_GLOBAL) +MPI_CONST (int, mpi_max_processor_name, MPI_MAX_PROCESSOR_NAME) +MPI_CONST (int, mpi_max_error_string, MPI_MAX_ERROR_STRING) +MPI_CONST (int, mpi_max_object_name, MPI_MAX_OBJECT_NAME) +MPI_CONST (int, mpi_undefined, MPI_UNDEFINED) +MPI_CONST (int, mpi_cart, MPI_CART) +MPI_CONST (int, mpi_graph, MPI_GRAPH) + +/* MPI predefined handles */ +MPI_CONST (MPI_Comm, mpi_comm_world, MPI_COMM_WORLD) +MPI_CONST (MPI_Comm, mpi_comm_self, MPI_COMM_SELF) +MPI_CONST (MPI_Group, mpi_group_empty, MPI_GROUP_EMPTY) + +/* Operations */ +MPI_CONST (MPI_Op, mpi_max , MPI_MAX ) +MPI_CONST (MPI_Op, mpi_min , MPI_MIN ) +MPI_CONST (MPI_Op, mpi_sum , MPI_SUM ) +MPI_CONST (MPI_Op, mpi_prod , MPI_PROD ) +MPI_CONST (MPI_Op, mpi_land , MPI_LAND ) +MPI_CONST (MPI_Op, mpi_band , MPI_BAND ) +MPI_CONST (MPI_Op, mpi_lor , MPI_LOR ) +MPI_CONST (MPI_Op, mpi_bor , MPI_BOR ) +MPI_CONST (MPI_Op, mpi_lxor , MPI_LXOR ) +MPI_CONST (MPI_Op, mpi_bxor , MPI_BXOR ) +MPI_CONST (MPI_Op, mpi_maxloc , MPI_MAXLOC ) +MPI_CONST (MPI_Op, mpi_minloc , MPI_MINLOC ) +MPI_CONST (MPI_Op, mpi_replace, MPI_REPLACE) + +/* Error handlers */ +MPI_CONST (MPI_Errhandler, mpi_errors_are_fatal, MPI_ERRORS_ARE_FATAL) +MPI_CONST (MPI_Errhandler, mpi_errors_return, MPI_ERRORS_RETURN) diff --git a/src/cbits/init_wrapper.c b/src/cbits/init_wrapper.c new file mode 100644 --- /dev/null +++ b/src/cbits/init_wrapper.c @@ -0,0 +1,11 @@ +#include +#include "init_wrapper.h" + +/* the following is taken from includes/Stg.h of the GHC distribution */ + +extern char **prog_argv; +extern int prog_argc; + +int init_wrapper (void) { return MPI_Init (&prog_argc, &prog_argv); } + +int init_wrapper_thread (int required, int* provided) { return MPI_Init_thread (&prog_argc, &prog_argv, required, provided); } diff --git a/src/include/comparison_result.h b/src/include/comparison_result.h new file mode 100644 --- /dev/null +++ b/src/include/comparison_result.h @@ -0,0 +1,9 @@ +#include + +/* The order of these is significant, at least for OpenMPI */ +typedef enum ComparisonResult { + Identical = MPI_IDENT, + Congruent = MPI_CONGRUENT, + Similar = MPI_SIMILAR, + Unequal = MPI_UNEQUAL +}; diff --git a/src/include/error_classes.h b/src/include/error_classes.h new file mode 100644 --- /dev/null +++ b/src/include/error_classes.h @@ -0,0 +1,60 @@ +#include + +typedef enum ErrorClass +{ + Success = MPI_SUCCESS, + Buffer = MPI_ERR_BUFFER, + Count = MPI_ERR_COUNT, + Type = MPI_ERR_TYPE, + Tag = MPI_ERR_TAG, + Comm = MPI_ERR_COMM, + Rank = MPI_ERR_RANK, + Request = MPI_ERR_REQUEST, + Root = MPI_ERR_ROOT, + Group = MPI_ERR_GROUP, + Op = MPI_ERR_OP, + Topology = MPI_ERR_TOPOLOGY, + Dims = MPI_ERR_DIMS, + Arg = MPI_ERR_ARG, + Unknown = MPI_ERR_UNKNOWN, + Truncate = MPI_ERR_TRUNCATE, + Other = MPI_ERR_OTHER, + Intern = MPI_ERR_INTERN, + InStatus = MPI_ERR_IN_STATUS, + Pending = MPI_ERR_PENDING, + Access = MPI_ERR_ACCESS, + AMode = MPI_ERR_AMODE, + Assert = MPI_ERR_ASSERT, + BadFile = MPI_ERR_BAD_FILE, + Base = MPI_ERR_BASE, + Conversrion = MPI_ERR_CONVERSION, + Disp = MPI_ERR_DISP, + DupDataRep = MPI_ERR_DUP_DATAREP, + FileExists = MPI_ERR_FILE_EXISTS, + FileInUse = MPI_ERR_FILE_IN_USE, + File = MPI_ERR_FILE, + InfoKey = MPI_ERR_INFO_KEY, + InfoNoKey = MPI_ERR_INFO_NOKEY, + InfoValue = MPI_ERR_INFO_VALUE, + Info = MPI_ERR_INFO, + IO = MPI_ERR_IO, + KeyVal = MPI_ERR_KEYVAL, + LockType = MPI_ERR_LOCKTYPE, + Name = MPI_ERR_NAME, + NoMem = MPI_ERR_NO_MEM, + NotSame = MPI_ERR_NOT_SAME, + NoSpace = MPI_ERR_NO_SPACE, + NoSuchFile = MPI_ERR_NO_SUCH_FILE, + Port = MPI_ERR_PORT, + Quota = MPI_ERR_QUOTA, + ReadOnly = MPI_ERR_READ_ONLY, + RMAConflict = MPI_ERR_RMA_CONFLICT, + RMASync = MPI_ERR_RMA_SYNC, + Service = MPI_ERR_SERVICE, + Size = MPI_ERR_SIZE, + Spawn = MPI_ERR_SPAWN, + UnsupportedDataRep = MPI_ERR_UNSUPPORTED_DATAREP, + UnsupportedOperation = MPI_ERR_UNSUPPORTED_OPERATION, + Win = MPI_ERR_WIN, + LastCode = MPI_ERR_LASTCODE +}; diff --git a/src/include/init_wrapper.h b/src/include/init_wrapper.h new file mode 100644 --- /dev/null +++ b/src/include/init_wrapper.h @@ -0,0 +1,2 @@ +extern int init_wrapper (void); +extern int init_wrapper_thread (int required, int* provided); diff --git a/src/include/thread_support.h b/src/include/thread_support.h new file mode 100644 --- /dev/null +++ b/src/include/thread_support.h @@ -0,0 +1,8 @@ +#include + +typedef enum ThreadSupport { + Single = MPI_THREAD_SINGLE, + Funneled = MPI_THREAD_FUNNELED, + Serialized = MPI_THREAD_SERIALIZED, + Multiple = MPI_THREAD_MULTIPLE +}; diff --git a/test/CompileRunClean.hs b/test/CompileRunClean.hs new file mode 100644 --- /dev/null +++ b/test/CompileRunClean.hs @@ -0,0 +1,54 @@ +{- Compile, Run and Clean. + + A helper program for running standalone tests for haskell-mpi. + Intended to be used in conjunction with shelltestrunner. + + Use like so: + + haskell-mpi-comprunclean -np 2 Pi.hs + + The last argument is the name of a haskell file to compile + (should be the Main module). All other arguments are given + to mpirun. + + The program is compiled. The resulting executable is run + underneath mpirun. + + The executable is deleted and so are temporary files. + + XXX should allow program to be run to accept its own command + line arguments. +-} + +module Main where + +import System (getArgs) +import System.Cmd (system) +import System.Exit (ExitCode (..), exitWith) +import Control.Monad (when) +import Data.List (isSuffixOf) + +main :: IO () +main = do + args <- getArgs + when (length args > 0) $ do + let mpirunFlags = init args + (sourceFile, exeFile) = getFileNames $ last args + run $ "ghc -v0 --make -O2 " ++ sourceFile + run $ "mpirun " ++ unwords (mpirunFlags ++ [exeFile]) + run $ "rm -f *.o *.hi " ++ exeFile + +run :: String -> IO () +run cmd = do + -- putStrLn cmd + status <- system cmd + if status /= ExitSuccess + then do + putStrLn $ "Command failed with status: " ++ show status + exitWith status + else return () + +getFileNames :: String -> (String, String) +getFileNames str + | isSuffixOf ".hs" str = (str, take (length str - 3) str) + | otherwise = error $ "Not a Haskell filename: " ++ str diff --git a/test/ExceptionTests.hs b/test/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/test/ExceptionTests.hs @@ -0,0 +1,33 @@ +module ExceptionTests (exceptionTests) where + +import TestHelpers +import Control.Exception as Ex (try) +import Control.Parallel.MPI.Simple + +exceptionTests :: Rank -> [(String,TestRunnerTest)] +exceptionTests rank = + [ mpiTestCase rank "bad rank exception" badRankSend + ] + +-- choose some ridiculously large number for a bad rank +badRank :: Rank +badRank = 10^(9::Int) + +-- save and restore the current error handler, but set it +-- to errorsReturn for the nested action. +withErrorsReturn :: IO () -> IO () +withErrorsReturn action = do + oldHandler <- commGetErrhandler commWorld + commSetErrhandler commWorld errorsReturn + action + commSetErrhandler commWorld oldHandler + +-- All procs try to send a message to a bad rank +badRankSend :: Rank -> IO () +badRankSend _rank = withErrorsReturn $ do + result <- try $ send commWorld badRank unitTag "hello" + errorClass <- + case result of + Left e -> return $ mpiErrorClass e + Right _ -> return $ Success + errorClass == Rank @? "error class for bad rank send was: " ++ show errorClass ++ ", but expected: Rank" diff --git a/test/FastAndSimpleTests.hs b/test/FastAndSimpleTests.hs new file mode 100644 --- /dev/null +++ b/test/FastAndSimpleTests.hs @@ -0,0 +1,22 @@ +module FastAndSimpleTests (fastAndSimpleTests) where + +import TestHelpers +import Control.Parallel.MPI.Fast as Fast +import Control.Parallel.MPI.Simple as Simple + +import Data.Serialize () + +fastAndSimpleTests :: Rank -> [(String,TestRunnerTest)] +fastAndSimpleTests rank = + [ mpiTestCase rank "mixing Fast and Simple point-to-point operations" sendRecvTest + ] + +sendRecvTest :: Rank -> IO () +sendRecvTest rank + | rank == sender = do Simple.send commWorld receiver 123 "Sending via Simple" + Fast.send commWorld receiver 456 (999.666::Double) -- sending via Fast + | rank == receiver = do (str, _) <- Simple.recv commWorld sender 123 + num <- intoNewVal_ $ Fast.recv commWorld sender 456 + str == "Sending via Simple" @? "Sending via simple failed, got " ++ str + num == (999.666 :: Double) @? "Sending via Fast failed, got " ++ show num + | otherwise = return () diff --git a/test/GroupTests.hs b/test/GroupTests.hs new file mode 100644 --- /dev/null +++ b/test/GroupTests.hs @@ -0,0 +1,75 @@ +module GroupTests (groupTests) where + +import TestHelpers +import Control.Parallel.MPI.Base + +groupTests :: Rank -> [(String,TestRunnerTest)] +groupTests rank = + [ groupTestCase rank "groupRank" groupRankTest + , groupTestCase rank "groupSize" groupSizeTest + , groupTestCase rank "groupUnionSelf" groupUnionSelfTest + , groupTestCase rank "groupIntersectionSelf" groupIntersectionSelfTest + , groupTestCase rank "groupDifferenceSelf" groupDifferenceSelfTest + , groupTestCase rank "groupCompareSelf" groupCompareSelfTest + , groupTestCase rank "groupCompareEmpty" groupCompareSelfEmptyTest + , mpiTestCase rank "groupEmptySize" groupEmptySizeTest + ] + +groupTestCase :: Rank -> String -> (Rank -> Group -> IO ()) -> (String,TestRunnerTest) +groupTestCase rank str test = + mpiTestCase rank str $ \rank -> do + group <- commGroup commWorld + test rank group + +-- Test if the rank from commWorld is the same as the rank from a group created +-- from commWorld. +groupRankTest :: Rank -> Group -> IO () +groupRankTest rank group = do + let gRank = groupRank group + gRank == rank @? "Rank == " ++ show rank ++ ", but group rank == " ++ show gRank + +-- Test if the size of commWorld is the same as the size of a group created +-- from commWorld. +groupSizeTest :: Rank -> Group -> IO () +groupSizeTest _rank group = do + cSize <- commSize commWorld + let gSize = groupSize group + gSize > 0 @? "Group size " ++ show gSize ++ " not greater than zero" + gSize == cSize @? "CommWorld size == " ++ show cSize ++ ", but group size == " ++ show gSize + +-- Test if the union of a group with itself is the identity on groups +-- XXX is it enough to just check sizes? + +groupUnionSelfTest :: Rank -> Group -> IO () +groupUnionSelfTest _rank group = + groupOpSelfTest group groupUnion "union" (==) + +groupIntersectionSelfTest :: Rank -> Group -> IO () +groupIntersectionSelfTest _rank group = + groupOpSelfTest group groupIntersection "intersection" (==) + +groupDifferenceSelfTest :: Rank -> Group -> IO () +groupDifferenceSelfTest _rank group = + groupOpSelfTest group groupDifference "difference" (\ _gSize uSize -> uSize == 0) + +groupOpSelfTest :: Group -> (Group -> Group -> Group) -> String -> (Int -> Int -> Bool) -> IO () +groupOpSelfTest group groupOp opString compare = do + let gSize = groupSize group + uGroup = groupOp group group + uSize = groupSize uGroup + gSize `compare` uSize @? "Group size " ++ show gSize ++ ", " ++ opString ++ "(Group,Group) size == " ++ show uSize + +groupCompareSelfTest :: Rank -> Group -> IO () +groupCompareSelfTest _rank group = do + let res = groupCompare group group + res == Identical @? "Group compare with self gives non ident result: " ++ show res + +groupCompareSelfEmptyTest :: Rank -> Group -> IO () +groupCompareSelfEmptyTest _rank group = do + let res = groupCompare group groupEmpty + res == Unequal @? "Group compare with empty group gives non unequal result: " ++ show res + +groupEmptySizeTest :: Rank -> IO () +groupEmptySizeTest _rank = do + let size = groupSize groupEmpty + size == 0 @? "Empty group has non-zero size: " ++ show size diff --git a/test/IOArrayTests.hs b/test/IOArrayTests.hs new file mode 100644 --- /dev/null +++ b/test/IOArrayTests.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module IOArrayTests (ioArrayTests) where + +import TestHelpers +import Data.Array.Storable (StorableArray) +import Control.Parallel.MPI.Fast +import Data.Array.IO (IOArray, newListArray, getElems) + +import Control.Concurrent (threadDelay) +import Control.Monad (when) + +import Foreign.C.Types +import Data.List + +root :: Rank +root = 0 + +ioArrayTests :: Rank -> [(String,TestRunnerTest)] +ioArrayTests rank = + [ mpiTestCase rank "send+recv IO array" $ syncSendRecvTest send + , mpiTestCase rank "ssend+recv IO array" $ syncSendRecvTest ssend + , mpiTestCase rank "rsend+recv IO array" $ rsendRecvTest +-- irecv only works for StorableArray at the moment. See comments in source. +-- , mpiTestCase rank "isend+irecv IO array" $ asyncSendRecvTest isend +-- , mpiTestCase rank "issend+irecv IO array" $ asyncSendRecvTest issend + , mpiTestCase rank "broadcast IO array" broadcastTest + , mpiTestCase rank "scatter IO array" scatterTest + , mpiTestCase rank "scatterv IO array" scattervTest + , mpiTestCase rank "gather IO array" gatherTest + , mpiTestCase rank "gatherv IO array" gathervTest + , mpiTestCase rank "allgather IO array" allgatherTest + , mpiTestCase rank "allgatherv IO array" allgathervTest + , mpiTestCase rank "alltoall IO array" alltoallTest + , mpiTestCase rank "alltoallv IO array" alltoallvTest + , mpiTestCase rank "reduce IO array" reduceTest + , mpiTestCase rank "allreduce IO array" allreduceTest + , mpiTestCase rank "reduceScatter IO array" reduceScatterTest + ] +syncSendRecvTest :: (Comm -> Rank -> Tag -> ArrMsg -> IO ()) -> Rank -> IO () +-- asyncSendRecvTest :: (Comm -> Rank -> Tag -> IOArray Int Int -> IO Request) -> Rank -> IO () +rsendRecvTest, broadcastTest, scatterTest, scattervTest, gatherTest, gathervTest :: Rank -> IO () +allgatherTest, allgathervTest, alltoallTest, alltoallvTest, reduceTest, allreduceTest, reduceScatterTest :: Rank -> IO () + +type ElementType = Double +type ArrMsg = IOArray Int ElementType + +low,hi :: Int +range :: (Int, Int) +range@(low,hi) = (1,10) + +arrMsgContent :: [ElementType] +arrMsgContent = map fromIntegral [low..hi] + +arrMsg :: IO ArrMsg +arrMsg = newListArray range arrMsgContent + + +syncSendRecvTest sendf rank + | rank == sender = do msg <- arrMsg + sendf commWorld receiver 789 msg + | rank == receiver = do (newMsg::ArrMsg, status) <- intoNewArray range $ recv commWorld sender 789 + checkStatus status sender 789 + elems <- getElems newMsg + elems == arrMsgContent @? "Got wrong array: " ++ show elems + | otherwise = return () + +rsendRecvTest rank = do + when (rank == receiver) $ do (newMsg::ArrMsg, status) <- intoNewArray range $ recv commWorld sender 789 + checkStatus status sender 789 + elems <- getElems newMsg + elems == arrMsgContent @? "Got wrong array: " ++ show elems + when (rank == sender) $ do msg <- arrMsg + threadDelay (2* 10^(6 :: Integer)) + rsend commWorld receiver 789 msg + return () + +{- +asyncSendRecvTest isendf rank + | rank == sender = do msg <- arrMsg + req <- isendf commWorld receiver 123456 msg + stat <- wait req + checkStatus stat sender 123456 + -- XXX this type annotation is ugly. Is there a way to make it nicer? + | rank == receiver = do (newMsg, req) <- intoNewArray range $ (irecv commWorld sender 123456 :: IOArray Int Int -> IO Request) + stat <- wait req + checkStatus stat sender 123456 + elems <- getElems newMsg + elems == [low..hi::Int] @? "Got wrong array: " ++ show elems + | otherwise = return () +-} + +broadcastTest myRank = do + msg <- arrMsg + expected <- arrMsg + if myRank == root + then bcastSend commWorld sender (msg :: ArrMsg) + else bcastRecv commWorld sender (msg :: ArrMsg) + elems <- getElems msg + expectedElems <- getElems expected + elems == expectedElems @? "IOArray bcast yielded garbled result: " ++ show elems + + +scatterTest myRank = do + numProcs <- commSize commWorld + let segRange = (1, segmentSize) + + (segment::ArrMsg) <- if myRank == root then do + let bigRange@(low, hi) = (1, segmentSize * numProcs) + (msg :: ArrMsg) <- newListArray bigRange $ map fromIntegral [low..hi] + intoNewArray_ segRange $ scatterSend commWorld root msg + else intoNewArray_ segRange $ scatterRecv commWorld root + + let myRankNo = fromRank myRank + expected = take 10 [myRankNo*10+1..] + + recvMsg <- getElems segment + recvMsg == expected @? "Rank " ++ show myRank ++ " got segment " ++ show recvMsg ++ " instead of " ++ show expected + where + segmentSize = 10 + +-- scatter list [1..] in a way such that: +-- rank 0 will receive [1] +-- rank 1 will receive [2,3] +-- rank 2 will receive [3,4,5] +-- rank 3 will receive [6,7,8,9] +-- etc +scattervTest myRank = do + numProcs <- commSize commWorld + + let bigRange@(low, hi) = (1, sum [1..numProcs]) + recvRange = (0, myRankNo) + myRankNo = fromRank myRank + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + + (segment::ArrMsg) <- if myRank == root then do + (msg :: ArrMsg) <- newListArray bigRange $ map fromIntegral [low..hi] + + let msgRange = (1, numProcs) + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + intoNewArray_ recvRange $ scattervSend commWorld root msg packCounts packDispls + else intoNewArray_ recvRange $ scattervRecv commWorld root + + recvMsg <- getElems segment + + let myCount = fromIntegral $ counts!!myRankNo + myDispl = fromIntegral $ displs!!myRankNo + expected = map fromIntegral $ take myCount $ drop myDispl [low..hi] + recvMsg == expected @? "Rank = " ++ show myRank ++ " got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +gatherTest myRank = do + numProcs <- commSize commWorld + + let segRange@(low,hi) = (1, segmentSize) + (msg :: ArrMsg) <- newListArray segRange $ map fromIntegral [low..hi] + + if myRank /= root + then gatherSend commWorld root msg + else do + let bigRange = (1, segmentSize * numProcs) + expected = map fromIntegral $ concat $ replicate numProcs [1..segmentSize] + (result::ArrMsg) <- intoNewArray_ bigRange $ gatherRecv commWorld root msg + recvMsg <- getElems result + recvMsg == expected @? "Rank " ++ show myRank ++ " got " ++ show recvMsg ++ " instead of " ++ show expected + where segmentSize = 10 + +gathervTest myRank = do + numProcs <- commSize commWorld + let bigRange = (1, sum [1..numProcs]) + + let myRankNo = fromRank myRank + sendRange = (0, myRankNo) + (msg :: ArrMsg) <- newListArray sendRange $ map fromIntegral [0..myRankNo] + if myRank /= root + then gathervSend commWorld root msg + else do + let msgRange = (1, numProcs) + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + expected = map fromIntegral $ concat $ reverse $ take numProcs $ iterate Prelude.init [0..numProcs-1] + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + (segment::ArrMsg) <- intoNewArray_ bigRange $ gathervRecv commWorld root msg packCounts packDispls + recvMsg <- getElems segment + + recvMsg == expected @? "Rank = " ++ show myRank ++ " got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +allgatherTest _ = do + numProcs <- commSize commWorld + + let segRange@(low,hi) = (1, segmentSize) + (msg :: ArrMsg) <- newListArray segRange $ map fromIntegral [low..hi] + + let bigRange = (1, segmentSize * numProcs) + expected = map fromIntegral $ concat $ replicate numProcs [1..segmentSize] + (result::ArrMsg) <- intoNewArray_ bigRange $ allgather commWorld msg + recvMsg <- getElems result + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + where segmentSize = 10 + +allgathervTest myRank = do + numProcs <- commSize commWorld + let bigRange = (1, sum [1..numProcs]) + + let myRankNo = fromRank myRank + sendRange = (0, myRankNo) + (msg :: ArrMsg) <- newListArray sendRange $ map fromIntegral [0..myRankNo] + + let msgRange = (1, numProcs) + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + expected = map fromIntegral $ concat $ reverse $ take numProcs $ iterate Prelude.init [0..numProcs-1] + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + (result::ArrMsg) <- intoNewArray_ bigRange $ allgatherv commWorld msg packCounts packDispls + recvMsg <- getElems result + + recvMsg == expected @? "Got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +alltoallTest myRank = do + numProcs <- commSize commWorld + + let myRankNo = fromRank myRank + sendRange = (0, numProcs-1) + (msg :: ArrMsg) <- newListArray sendRange $ take numProcs $ repeat myRankNo + + let recvRange = sendRange + expected = map fromIntegral $ [0..numProcs-1] + + (result::ArrMsg) <- intoNewArray_ recvRange $ alltoall commWorld msg 1 1 + recvMsg <- getElems result + + recvMsg == expected @? "Got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +-- Each rank sends its own number (Int) with sendCounts [1,2,3..] +-- Each rank receives Ints with recvCounts [rank+1,rank+1,rank+1,...] +-- Rank 0 should receive 0,1,2 +-- Rank 1 should receive 0,0,1,1,2,2 +-- Rank 2 should receive 0,0,0,1,1,1,2,2,2 +-- etc +alltoallvTest myRank = do + numProcs <- commSize commWorld + let myRankNo :: CInt = fromRank myRank + sendCounts = take numProcs [1..] + msgLen = fromIntegral $ sum sendCounts + sendDispls = Prelude.init $ scanl1 (+) $ 0:sendCounts + recvCounts = take numProcs (repeat (myRankNo+1)) + recvDispls = Prelude.init $ scanl1 (+) $ 0:recvCounts + expected = map fromIntegral $ concatMap (genericReplicate (myRankNo+1)) (take numProcs [(0::CInt)..]) + + (packSendCounts :: StorableArray Int CInt) <- newListArray (1, length sendCounts) sendCounts + (packSendDispls :: StorableArray Int CInt) <- newListArray (1, length sendDispls) sendDispls + (packRecvCounts :: StorableArray Int CInt) <- newListArray (1, length recvCounts) recvCounts + (packRecvDispls :: StorableArray Int CInt) <- newListArray (1, length recvDispls) recvDispls + (msg :: ArrMsg) <- newListArray (1, msgLen) $ map fromIntegral $ take msgLen $ repeat myRankNo + + (result::ArrMsg) <- intoNewArray_ (1, length expected) $ alltoallv commWorld msg packSendCounts packSendDispls + packRecvCounts packRecvDispls + recvMsg <- getElems result + + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +-- Reducing arrays [0,1,2....] with SUM should yield [0,numProcs,2*numProcs, ...] +reduceTest myRank = do + numProcs <- commSize commWorld + (src :: ArrMsg) <- newListArray (0,99) [0..99] + if myRank /= root + then reduceSend commWorld root sumOp src + else do + (result :: ArrMsg) <- intoNewArray_ (0,99) $ reduceRecv commWorld root sumOp src + recvMsg <- getElems result + let expected = map ((fromIntegral numProcs)*) [0..99::ElementType] + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +allreduceTest _ = do + numProcs <- commSize commWorld + (src :: ArrMsg) <- newListArray (0,99) [0..99] + (result :: ArrMsg) <- intoNewArray_ (0,99) $ allreduce commWorld sumOp src + recvMsg <- getElems result + let expected = map (fromIntegral.(numProcs*)) [0..99] + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +-- We reduce [0..] with SUM. +-- Each process gets (rank+1) elements of the result +reduceScatterTest myRank = do + numProcs <- commSize commWorld + let dataSize = sum [1..numProcs] + msg = take dataSize [0..] + myRankNo = fromRank myRank + (src :: ArrMsg) <- newListArray (1,dataSize) msg + (counts :: StorableArray Int CInt) <- newListArray (1, numProcs) [1..fromIntegral numProcs] + (result :: ArrMsg) <- intoNewArray_ (1,myRankNo + 1) $ reduceScatter commWorld sumOp counts src + recvMsg <- getElems result + let expected = map ((fromIntegral numProcs)*) $ take (myRankNo+1) $ drop (sum [0..myRankNo]) msg + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected diff --git a/test/OtherTests.hs b/test/OtherTests.hs new file mode 100644 --- /dev/null +++ b/test/OtherTests.hs @@ -0,0 +1,70 @@ +module OtherTests (otherTests) where + +import TestHelpers + +import Foreign.Storable (peek, poke) +import Foreign.Marshal (alloca) +import Foreign.C.Types (CInt) +import Control.Parallel.MPI.Base + +otherTests :: ThreadSupport -> Rank -> [(String,TestRunnerTest)] +otherTests threadSupport _ = + [ testCase "Peeking/poking Status" statusPeekPoke + , testCase "Querying MPI implementation" getImplementationTest + , testCase "wtime/wtick" wtimeWtickTest + , testCase "commRank, commSize, getProcessor name, version" rankSizeNameVersionTest + , testCase "initialized" initializedTest + , testCase "finalized" finalizedTest + , testCase "tag value upper bound" tagUpperBoundTest + , testCase "queryThread" $ queryThreadTest threadSupport + ] + +queryThreadTest :: ThreadSupport -> IO () +queryThreadTest threadSupport = do + newThreadSupport <- queryThread + threadSupport == newThreadSupport @? + ("Result from queryThread: " ++ show newThreadSupport ++ + ", differs from result from initThread: " ++ show threadSupport) + +statusPeekPoke :: IO () +statusPeekPoke = do + alloca $ \statusPtr -> do + let s0 = Status (fromIntegral (maxBound::CInt)) 2 3 maxBound True + poke statusPtr s0 + s1 <- peek statusPtr + s0 == s1 @? ("Poked " ++ show s0 ++ ", but peeked " ++ show s1) + +getImplementationTest :: IO () +getImplementationTest = do + putStrLn $ "Using " ++ show (getImplementation) + +wtimeWtickTest :: IO () +wtimeWtickTest = do + t <- wtime + tick <- wtick + tick < t @? "Timer resolution is greater than current time" + putStrLn $ "Current time is " ++ show t ++ ", timer resolution is " ++ show tick + putStrLn $ "Wtime is global: " ++ show wtimeIsGlobal + +rankSizeNameVersionTest :: IO () +rankSizeNameVersionTest = do + r <- commRank commWorld + s <- commSize commWorld + p <- getProcessorName + v <- getVersion + putStrLn $ "I am process " ++ show r ++ " out of " ++ show s ++ ", running on " ++ p ++ ", MPI version " ++ show v + +initializedTest :: IO () +initializedTest = do + isInit <- initialized + isInit == True @? "initialized return False, but was expected to return True" + +finalizedTest :: IO () +finalizedTest = do + isFinal <- finalized + isFinal == False @? "finalized return True, but was expected to return False" + +tagUpperBoundTest :: IO () +tagUpperBoundTest = do + putStrLn $ "Maximum tag value is " ++ show tagUpperBound + tagUpperBound /= (-1) @? "tagUpperBound has no value" diff --git a/test/PrimTypeTests.hs b/test/PrimTypeTests.hs new file mode 100644 --- /dev/null +++ b/test/PrimTypeTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} + +module PrimTypeTests (primTypeTests) where + +import TestHelpers +import Control.Parallel.MPI.Fast +import C2HS +import Data.Typeable + +primTypeTests :: Rank -> [(String,TestRunnerTest)] +primTypeTests rank = + [ mpiTestCase rank "intMaxBound" (sendRecvSingleValTest (maxBound :: Int)) + , mpiTestCase rank "intMinBound" (sendRecvSingleValTest (minBound :: Int)) + , mpiTestCase rank "boolMaxBound" (sendRecvSingleValTest (maxBound :: Bool)) + , mpiTestCase rank "boolMinBound" (sendRecvSingleValTest (minBound :: Bool)) + , mpiTestCase rank "charMaxBound" (sendRecvSingleValTest (maxBound :: Char)) + , mpiTestCase rank "charMinBound" (sendRecvSingleValTest (minBound :: Char)) + , mpiTestCase rank "int8MaxBound" (sendRecvSingleValTest (maxBound :: Int8)) + , mpiTestCase rank "int8MinBound" (sendRecvSingleValTest (minBound :: Int8)) + , mpiTestCase rank "int16MaxBound" (sendRecvSingleValTest (maxBound :: Int16)) + , mpiTestCase rank "int16MinBound" (sendRecvSingleValTest (minBound :: Int16)) + , mpiTestCase rank "int32MaxBound" (sendRecvSingleValTest (maxBound :: Int32)) + , mpiTestCase rank "int32MinBound" (sendRecvSingleValTest (minBound :: Int32)) + , mpiTestCase rank "int64MaxBound" (sendRecvSingleValTest (maxBound :: Int64)) + , mpiTestCase rank "int64MinBound" (sendRecvSingleValTest (minBound :: Int64)) + , mpiTestCase rank "wordMaxBound" (sendRecvSingleValTest (maxBound :: Word)) + , mpiTestCase rank "wordMinBound" (sendRecvSingleValTest (minBound :: Word)) + , mpiTestCase rank "word8MaxBound" (sendRecvSingleValTest (maxBound :: Word8)) + , mpiTestCase rank "word8MinBound" (sendRecvSingleValTest (minBound :: Word8)) + , mpiTestCase rank "word16MaxBound" (sendRecvSingleValTest (maxBound :: Word16)) + , mpiTestCase rank "word16MinBound" (sendRecvSingleValTest (minBound :: Word16)) + , mpiTestCase rank "word32MaxBound" (sendRecvSingleValTest (maxBound :: Word32)) + , mpiTestCase rank "word32MinBound" (sendRecvSingleValTest (minBound :: Word32)) + , mpiTestCase rank "word64MaxBound" (sendRecvSingleValTest (maxBound :: Word64)) + , mpiTestCase rank "word64MinBound" (sendRecvSingleValTest (minBound :: Word64)) + , mpiTestCase rank "intSize" (sizeSingleValTest (undefined :: Int)) + , mpiTestCase rank "int8Size" (sizeSingleValTest (undefined :: Int8)) + , mpiTestCase rank "int16Size" (sizeSingleValTest (undefined :: Int16)) + , mpiTestCase rank "int32Size" (sizeSingleValTest (undefined :: Int32)) + , mpiTestCase rank "int64Size" (sizeSingleValTest (undefined :: Int64)) + , mpiTestCase rank "wordSize" (sizeSingleValTest (undefined :: Word)) + , mpiTestCase rank "word8Size" (sizeSingleValTest (undefined :: Word8)) + , mpiTestCase rank "word16Size" (sizeSingleValTest (undefined :: Word16)) + , mpiTestCase rank "word32Size" (sizeSingleValTest (undefined :: Word32)) + , mpiTestCase rank "word64Size" (sizeSingleValTest (undefined :: Word64)) + , mpiTestCase rank "charSize" (sizeSingleValTest (undefined :: Char)) + , mpiTestCase rank "boolSize" (sizeSingleValTest (undefined :: Bool)) + , mpiTestCase rank "floatSize" (sizeSingleValTest (undefined :: Float)) + , mpiTestCase rank "doubleSize" (sizeSingleValTest (undefined :: Double)) + , mpiTestCase rank "CIntSize" (sizeSingleValTest (undefined :: CInt)) + , mpiTestCase rank "CCharSize" (sizeSingleValTest (undefined :: CChar)) + ] + +sendRecvSingleValTest :: forall a . (Typeable a, RecvInto (Ptr a), Repr a, SendFrom a, Storable a, Eq a, Show a) => a -> Rank -> IO () +sendRecvSingleValTest val rank + | rank == 0 = send commWorld 1 unitTag (val :: a) + | rank == 1 = do + (result :: a, _status) <- intoNewVal $ recv commWorld 0 unitTag + result == val @? "result: " ++ show result ++ " not equal to sent val: " ++ show (val :: a) ++ " for type " ++ show (typeOf val) + | otherwise = return () + +sizeSingleValTest :: (Typeable a, Storable a, Show a, Eq a, Repr a) => a -> Rank -> IO () +sizeSingleValTest val _rank = do + let (scale,mpiType) = representation val + mpiTypeSize = (typeSize mpiType) * scale + storableSize = sizeOf val + mpiTypeSize == storableSize @? "MPI repr type size: " ++ show mpiTypeSize ++ " not equal to storable size: " ++ show storableSize ++ " for type " ++ show (typeOf val) diff --git a/test/SimpleTests.hs b/test/SimpleTests.hs new file mode 100644 --- /dev/null +++ b/test/SimpleTests.hs @@ -0,0 +1,191 @@ +module SimpleTests (simpleTests) where + +import TestHelpers +import Control.Parallel.MPI.Simple + +import Control.Concurrent (threadDelay) +import Data.Serialize () + +root :: Rank +root = 0 + +simpleTests :: Rank -> [(String,TestRunnerTest)] +simpleTests rank = + [ mpiTestCase rank "send+recv simple message" $ syncSendRecv send + , mpiTestCase rank "send+recv simple message (with sending process blocking)" syncSendRecvBlock + , mpiTestCase rank "ssend+recv simple message" $ syncSendRecv ssend + , mpiTestCase rank "rsend+recv simple message" $ syncRSendRecv + , mpiTestCase rank "send+recvFuture simple message" syncSendRecvFuture + , mpiTestCase rank "isend+recv simple message" $ asyncSendRecv isend + , mpiTestCase rank "issend+recv simple message" $ asyncSendRecv issend + , mpiTestCase rank "isend+recv two messages" asyncSendRecv2 + , mpiTestCase rank "isend+recvFuture two messages, out of order" asyncSendRecv2ooo + , mpiTestCase rank "isend+recvFuture two messages (criss-cross)" crissCrossSendRecv + , mpiTestCase rank "isend+issend+waitall two messages" waitallTest + , mpiTestCase rank "broadcast message" broadcastTest + , mpiTestCase rank "scatter message" scatterTest + , mpiTestCase rank "gather message" gatherTest + , mpiTestCase rank "allgather message" allgatherTest + , mpiTestCase rank "alltoall message" alltoallTest + ] +syncSendRecv :: (Comm -> Rank -> Tag -> SmallMsg -> IO ()) -> Rank -> IO () +asyncSendRecv :: (Comm -> Rank -> Tag -> BigMsg -> IO Request) -> Rank -> IO () +syncRSendRecv, syncSendRecvBlock, syncSendRecvFuture, asyncSendRecv2, asyncSendRecv2ooo :: Rank -> IO () +crissCrossSendRecv, broadcastTest, scatterTest, gatherTest, allgatherTest, alltoallTest :: Rank -> IO () +waitallTest :: Rank -> IO () + +-- Serializable tests +type SmallMsg = (Bool, Int, String, [()]) +smallMsg :: SmallMsg +smallMsg = (True, 12, "fred", [(), (), ()]) +syncSendRecv sendf rank + | rank == sender = sendf commWorld receiver 123 smallMsg + | rank == receiver = do (result, status) <- recv commWorld sender 123 + checkStatus status sender 123 + result == smallMsg @? "Got garbled result " ++ show result + | otherwise = return () -- idling + +syncRSendRecv rank + | rank == sender = do threadDelay (2* 10^(6 :: Integer)) + rsend commWorld receiver 123 smallMsg + | rank == receiver = do (result, status) <- recv commWorld sender 123 + checkStatus status sender 123 + result == smallMsg @? "Got garbled result " ++ show result + | otherwise = return () -- idling + +type BigMsg = [Int] +bigMsg :: BigMsg +bigMsg = [0..50000] +syncSendRecvBlock rank + | rank == sender = send commWorld receiver 456 bigMsg + | rank == receiver = do (result, status) <- recv commWorld sender 456 + checkStatus status sender 456 + threadDelay (2* 10^(6 :: Integer)) + (result::BigMsg) == bigMsg @? "Got garbled result: " ++ show (length result) + | otherwise = return () -- idling + +syncSendRecvFuture rank + | rank == sender = do send commWorld receiver 789 bigMsg + | rank == receiver = do future <- recvFuture commWorld sender 789 + result <- waitFuture future + status <- getFutureStatus future + checkStatus status sender 789 + (result::BigMsg) == bigMsg @? "Got garbled result: " ++ show (length result) + | otherwise = return () -- idling + +asyncSendRecv isendf rank + | rank == sender = do req <- isendf commWorld receiver 123456 bigMsg + status <- wait req + checkStatusIfNotMPICH2 status sender 123456 + | rank == receiver = do (result, status) <- recv commWorld sender 123456 + checkStatus status sender 123456 + (result::BigMsg) == bigMsg @? "Got garbled result: " ++ show (length result) + | otherwise = return () -- idling + +asyncSendRecv2 rank + | rank == sender = do req1 <- isend commWorld receiver 123 smallMsg + req2 <- isend commWorld receiver 456 bigMsg + stat1 <- wait req1 + checkStatusIfNotMPICH2 stat1 sender 123 + stat2 <- wait req2 + checkStatusIfNotMPICH2 stat2 sender 456 + | rank == receiver = do (result1, stat1) <- recv commWorld sender 123 + checkStatus stat1 sender 123 + (result2, stat2) <- recv commWorld sender 456 + checkStatus stat2 sender 456 + (result2::BigMsg) == bigMsg && result1 == smallMsg @? "Got garbled result" + | otherwise = return () -- idling + +asyncSendRecv2ooo rank + | rank == sender = do req1 <- isend commWorld receiver 123 smallMsg + req2 <- isend commWorld receiver 456 bigMsg + stat1 <- wait req1 + checkStatusIfNotMPICH2 stat1 sender 123 + stat2 <- wait req2 + checkStatusIfNotMPICH2 stat2 sender 456 + | rank == receiver = do future2 <- recvFuture commWorld sender 456 + future1 <- recvFuture commWorld sender 123 + result2 <- waitFuture future2 + result1 <- waitFuture future1 + stat1 <- getFutureStatus future1 + stat2 <- getFutureStatus future2 + checkStatus stat1 sender 123 + checkStatus stat2 sender 456 + (length (result2::BigMsg) == length bigMsg) && (result1 == smallMsg) @? "Got garbled result" + | otherwise = return () -- idling + +crissCrossSendRecv rank + | rank == sender = do req <- isend commWorld receiver 123 smallMsg + future <- recvFuture commWorld receiver 456 + result <- waitFuture future + (length (result::BigMsg) == length bigMsg) @? "Got garbled BigMsg" + status <- getFutureStatus future + checkStatus status receiver 456 + status2 <- wait req + checkStatusIfNotMPICH2 status2 sender 123 + | rank == receiver = do req <- isend commWorld sender 456 bigMsg + future <- recvFuture commWorld sender 123 + result <- waitFuture future + (result == smallMsg) @? "Got garbled SmallMsg" + status <- getFutureStatus future + checkStatus status sender 123 + status2 <- wait req + checkStatusIfNotMPICH2 status2 receiver 456 + | otherwise = return () -- idling + +waitallTest rank + | rank == sender = do req1 <- isend commWorld receiver 123 smallMsg + req2 <- isend commWorld receiver 789 smallMsg + [stat1, stat2] <- waitall [req1, req2] + checkStatusIfNotMPICH2 stat1 sender 123 + checkStatusIfNotMPICH2 stat2 sender 789 + | rank == receiver = do (msg1,_) <- recv commWorld sender 123 + (msg2,_) <- recv commWorld sender 789 + msg1 == smallMsg @? "Got garbled msg1" + msg2 == smallMsg @? "Got garbled msg2" + | otherwise = return () -- idling + + +broadcastTest rank + | rank == root = bcastSend commWorld sender bigMsg + | otherwise = do result <- bcastRecv commWorld sender + (result::BigMsg) == bigMsg @? "Got garbled BigMsg" + +gatherTest rank + | rank == root = do result <- gatherRecv commWorld root [fromRank rank :: Int] + numProcs <- commSize commWorld + let expected = concat $ reverse $ take numProcs $ iterate Prelude.init [0..numProcs-1] + got = concat (result::[[Int]]) + got == expected @? "Got " ++ show got ++ " instead of " ++ show expected + | otherwise = gatherSend commWorld root [0..fromRank rank :: Int] + +scatterTest rank + | rank == root = do numProcs <- commSize commWorld + result <- scatterSend commWorld root $ map (^(2::Int)) [1..numProcs] + result == 1 @? "Root got " ++ show result ++ " instead of 1" + | otherwise = do result <- scatterRecv commWorld root + let expected = (fromRank rank + 1::Int)^(2::Int) + result == expected @? "Got " ++ show result ++ " instead of " ++ show expected + +allgatherTest rank = do + let msg = [fromRank rank] + numProcs <- commSize commWorld + result <- allgather commWorld msg + let expected = map (:[]) [0..numProcs-1] + result == expected @? "Got " ++ show result ++ " instead of " ++ show expected + +-- Each rank sends its own number (Int) with sendCounts [1,2,3..] +-- Each rank receives Ints with recvCounts [rank+1,rank+1,rank+1,...] +-- Rank 0 should receive 0,1,2 +-- Rank 1 should receive 0,0,1,1,2,2 +-- Rank 2 should receive 0,0,0,1,1,1,2,2,2 +-- etc +alltoallTest myRank = do + numProcs <- commSize commWorld + let myRankNo = fromRank myRank + msg = take numProcs $ map (`take` (repeat myRankNo)) [1..] + expected = map (replicate (myRankNo+1)) (take numProcs [0..]) + + result <- alltoall commWorld msg + + result == expected @? "Got " ++ show result ++ " instead of " ++ show expected diff --git a/test/StorableArrayTests.hs b/test/StorableArrayTests.hs new file mode 100644 --- /dev/null +++ b/test/StorableArrayTests.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} +module StorableArrayTests (storableArrayTests) where + +import TestHelpers +import Control.Parallel.MPI.Fast +import Data.Array.Storable (StorableArray, newListArray, getElems, withStorableArray, newArray_) + +import Control.Concurrent (threadDelay) +import Control.Monad (when) + +import Foreign +import Foreign.C.Types + +root :: Rank +root = 0 + +storableArrayTests :: Rank -> [(String,TestRunnerTest)] +storableArrayTests rank = + [ mpiTestCase rank "send+recv storable array" $ syncSendRecvTest send + , mpiTestCase rank "ssend+recv storable array" $ syncSendRecvTest ssend + , mpiTestCase rank "rsend+recv storable array" $ rsendRecvTest + , mpiTestCase rank "isend+irecv storable array" $ asyncSendRecvTest isend + , mpiTestCase rank "issend+irecv storable array" $ asyncSendRecvTest issend + , mpiTestCase rank "isend+issend+waitall storable array" $ asyncSendRecvWaitallTest + , mpiTestCase rank "broadcast storable array" broadcastTest + , mpiTestCase rank "scatter storable array" scatterTest + , mpiTestCase rank "scatterv storable array" scattervTest + , mpiTestCase rank "gather storable array" gatherTest + , mpiTestCase rank "gatherv storable array" gathervTest + , mpiTestCase rank "allgather storable array" allgatherTest + , mpiTestCase rank "allgatherv storable array" allgathervTest + , mpiTestCase rank "alltoall storable array" alltoallTest + , mpiTestCase rank "alltoallv storable array" alltoallvTest + , mpiTestCase rank "reduce storable array" reduceTest + , mpiTestCase rank "allreduce storable array" allreduceTest + , mpiTestCase rank "reduceScatter storable array" reduceScatterTest + , mpiTestCase rank "reduce storable array with user-defined operation" reduceUserOpTest + ] +syncSendRecvTest :: (Comm -> Rank -> Tag -> ArrMsg -> IO ()) -> Rank -> IO () +asyncSendRecvTest :: (Comm -> Rank -> Tag -> ArrMsg -> IO Request) -> Rank -> IO () +rsendRecvTest, broadcastTest, scatterTest, scattervTest, gatherTest, gathervTest :: Rank -> IO () +allgatherTest, allgathervTest, alltoallTest, alltoallvTest, reduceTest, allreduceTest, reduceScatterTest :: Rank -> IO () +asyncSendRecvWaitallTest :: Rank -> IO () +reduceUserOpTest :: Rank -> IO () + +-- StorableArray tests +type ArrMsg = StorableArray Int Int + +low,hi :: Int +range :: (Int, Int) +range@(low,hi) = (1,10) + +arrMsg :: IO ArrMsg +arrMsg = newListArray range [low..hi] + +-- Convenience shortcuts +-- sendToReceiver :: forall i e.(Ix i, Storable e, AsMpiDatatype (StorableArray i e)) => Tag -> StorableArray i e -> IO () +-- recvFromSender :: forall i e.(Ix i, Storable e, AsMpiDatatype) => Tag -> StorableArray i e -> IO Status + +syncSendRecvTest sendf rank + | rank == sender = do msg <- arrMsg + sendf commWorld receiver 789 msg + | rank == receiver = do (newMsg::ArrMsg, status) <- intoNewArray range $ recv commWorld sender 789 + checkStatus status sender 789 + elems <- getElems newMsg + elems == [low..hi::Int] @? "Got wrong array: " ++ show elems + | otherwise = return () + +rsendRecvTest rank = do + when (rank == receiver) $ do (newMsg::ArrMsg, status) <- intoNewArray range $ recv commWorld sender 789 + checkStatus status sender 789 + elems <- getElems newMsg + elems == [low..hi::Int] @? "Got wrong array: " ++ show elems + when (rank == sender) $ do msg <- arrMsg + threadDelay (2* 10^(6 :: Integer)) + rsend commWorld receiver 789 msg + return () + +asyncSendRecvTest isendf rank + | rank == sender = do msg <- arrMsg + req <- isendf commWorld receiver 123456 msg + stat <- wait req + checkStatusIfNotMPICH2 stat sender 123456 + -- XXX this type annotation is ugly. Is there a way to make it nicer? + | rank == receiver = do (newMsg, req) <- intoNewArray range $ irecv commWorld sender 123456 + stat <- wait req + checkStatus stat sender 123456 + elems <- getElems newMsg + elems == [low..hi::Int] @? "Got wrong array: " ++ show elems + | otherwise = return () + +asyncSendRecvWaitallTest rank + | rank == sender = do request :: StorableArray Int Request <- newArray_ (1,2) + reqstat :: StorableArray Int Status <- newArray_ (1,2) + msg <- arrMsg + withStorableArray request $ \reqPtr -> do + isendPtr commWorld receiver 456 reqPtr msg + issendPtr commWorld receiver 789 (advancePtr reqPtr 1) msg + waitall request reqstat + statuses <- getElems reqstat + checkStatusIfNotMPICH2 (statuses!!0) sender 456 + checkStatusIfNotMPICH2 (statuses!!1) sender 789 + -- XXX this type annotation is ugly. Is there a way to make it nicer? + | rank == receiver = do request :: StorableArray Int Request <- newArray_ (1,2) + reqstat :: StorableArray Int Status <- newArray_ (1,2) + (newMsg1, newMsg2) <- withStorableArray request $ \reqPtr -> do + msg1 <- intoNewArray_ range $ irecvPtr commWorld sender 456 reqPtr + msg2 <- intoNewArray_ range $ irecvPtr commWorld sender 789 (advancePtr reqPtr 1) + return (msg1, msg2) + waitall request reqstat + statuses <- getElems reqstat + checkStatus (statuses!!0) sender 456 + checkStatus (statuses!!1) sender 789 + elems1 <- getElems newMsg1 + elems2 <- getElems newMsg2 + elems1 == [low..hi::Int] @? "Got wrong array 1: " ++ show elems1 + elems2 == [low..hi::Int] @? "Got wrong array 2: " ++ show elems2 + | otherwise = return () + + +broadcastTest myRank = do + msg <- arrMsg + expected <- arrMsg + if myRank == root + then bcastSend commWorld sender (msg :: ArrMsg) + else bcastRecv commWorld sender (msg :: ArrMsg) + elems <- getElems msg + expectedElems <- getElems expected + elems == expectedElems @? "StorableArray bcast yielded garbled result: " ++ show elems + + +scatterTest myRank = do + numProcs <- commSize commWorld + let segRange = (1, segmentSize) + + ( segment :: ArrMsg) <- if myRank == root then do + let bigRange@(low, hi) = (1, segmentSize * numProcs) + (msg :: ArrMsg) <- newListArray bigRange [low..hi] + intoNewArray_ segRange $ scatterSend commWorld root msg + else intoNewArray_ segRange $ scatterRecv commWorld root + + let myRankNo = fromRank myRank + expected = take 10 [myRankNo*10+1..] + + recvMsg <- getElems segment + recvMsg == expected @? "Rank " ++ show myRank ++ " got segment " ++ show recvMsg ++ " instead of " ++ show expected + where + segmentSize = 10 + +-- scatter list [1..] in a way such that: +-- rank 0 will receive [1] +-- rank 1 will receive [2,3] +-- rank 2 will receive [3,4,5] +-- rank 3 will receive [6,7,8,9] +-- etc +scattervTest myRank = do + numProcs <- commSize commWorld + + let bigRange@(low, hi) = (1, sum [1..numProcs]) + recvRange = (0, myRankNo) + myRankNo = fromRank myRank + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + + (segment::ArrMsg) <- if myRank == root then do + (msg :: ArrMsg) <- newListArray bigRange [low..hi] + + let msgRange = (1, numProcs) + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + intoNewArray_ recvRange $ scattervSend commWorld root msg packCounts packDispls + else intoNewArray_ recvRange $ scattervRecv commWorld root + + recvMsg <- getElems segment + + let myCount = fromIntegral $ counts!!myRankNo + myDispl = fromIntegral $ displs!!myRankNo + expected = take myCount $ drop myDispl [low..hi] + recvMsg == expected @? "Rank = " ++ show myRank ++ " got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +gatherTest myRank = do + numProcs <- commSize commWorld + + let segRange@(low,hi) = (1, segmentSize) + (msg :: ArrMsg) <- newListArray segRange [low..hi] + + if myRank /= root + then gatherSend commWorld root msg + else do + let bigRange = (1, segmentSize * numProcs) + expected = concat $ replicate numProcs [1..segmentSize] + (result :: ArrMsg) <- intoNewArray_ bigRange $ gatherRecv commWorld root msg + recvMsg <- getElems result + recvMsg == expected @? "Rank " ++ show myRank ++ " got " ++ show recvMsg ++ " instead of " ++ show expected + where segmentSize = 10 + +gathervTest myRank = do + numProcs <- commSize commWorld + let bigRange = (1, sum [1..numProcs]) + + let myRankNo = fromRank myRank + sendRange = (0, myRankNo) + (msg :: ArrMsg) <- newListArray sendRange [0..myRankNo] + if myRank /= root + then gathervSend commWorld root msg + else do + let msgRange = (1, numProcs) + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + expected = concat $ reverse $ take numProcs $ iterate Prelude.init [0..numProcs-1] + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + (segment::ArrMsg) <- intoNewArray_ bigRange $ gathervRecv commWorld root msg packCounts packDispls + recvMsg <- getElems segment + + recvMsg == expected @? "Rank = " ++ show myRank ++ " got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +allgatherTest _ = do + numProcs <- commSize commWorld + + let segRange@(low,hi) = (1, segmentSize) + (msg :: ArrMsg) <- newListArray segRange [low..hi] + + let bigRange = (1, segmentSize * numProcs) + expected = concat $ replicate numProcs [1..segmentSize] + (result::ArrMsg) <- intoNewArray_ bigRange $ allgather commWorld msg + recvMsg <- getElems result + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + where segmentSize = 10 + +allgathervTest myRank = do + numProcs <- commSize commWorld + let bigRange = (1, sum [1..numProcs]) + + let myRankNo = fromRank myRank + sendRange = (0, myRankNo) + (msg :: ArrMsg) <- newListArray sendRange [0..myRankNo] + + let msgRange = (1, numProcs) + counts = [1..fromIntegral numProcs] + displs = (0:(Prelude.init $ scanl1 (+) $ [1..fromIntegral numProcs])) + expected = concat $ reverse $ take numProcs $ iterate Prelude.init [0..numProcs-1] + (packCounts :: StorableArray Int CInt) <- newListArray msgRange counts + (packDispls :: StorableArray Int CInt) <- newListArray msgRange displs + + (result::ArrMsg) <- intoNewArray_ bigRange $ allgatherv commWorld msg packCounts packDispls + recvMsg <- getElems result + + recvMsg == expected @? "Got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +alltoallTest myRank = do + numProcs <- commSize commWorld + + let myRankNo = fromRank myRank + sendRange = (0, numProcs-1) + (msg :: ArrMsg) <- newListArray sendRange $ take numProcs $ repeat (maxBound - myRankNo) + + let recvRange = sendRange + expected = map (maxBound-) [0..numProcs-1] + + (result::ArrMsg) <- intoNewArray_ recvRange $ alltoall commWorld msg 1 1 + recvMsg <- getElems result + + recvMsg == expected @? "Got segment = " ++ show recvMsg ++ " instead of " ++ show expected + +-- Each rank sends its own number (Int) with sendCounts [1,2,3..] +-- Each rank receives Ints with recvCounts [rank+1,rank+1,rank+1,...] +-- Rank 0 should receive 0,1,2 +-- Rank 1 should receive 0,0,1,1,2,2 +-- Rank 2 should receive 0,0,0,1,1,1,2,2,2 +-- etc +alltoallvTest myRank = do + numProcs <- commSize commWorld + let myRankNo = fromRank myRank + sendCounts = take numProcs [1..] + msgLen = fromIntegral $ sum sendCounts + sendDispls = Prelude.init $ scanl1 (+) $ 0:sendCounts + recvCounts = take numProcs (repeat (fromIntegral myRankNo+1)) + recvDispls = Prelude.init $ scanl1 (+) $ 0:recvCounts + expected = concatMap (replicate (myRankNo+1)) (take numProcs [0..]) + + (packSendCounts :: StorableArray Int CInt) <- newListArray (1, length sendCounts) sendCounts + (packSendDispls :: StorableArray Int CInt) <- newListArray (1, length sendDispls) sendDispls + (packRecvCounts :: StorableArray Int CInt) <- newListArray (1, length recvCounts) recvCounts + (packRecvDispls :: StorableArray Int CInt) <- newListArray (1, length recvDispls) recvDispls + (msg :: ArrMsg) <- newListArray (1, msgLen) $ take msgLen $ repeat myRankNo + + (result::ArrMsg) <- intoNewArray_ (1, length expected) $ alltoallv commWorld msg packSendCounts packSendDispls + packRecvCounts packRecvDispls + recvMsg <- getElems result + + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +-- Reducing arrays [0,1,2....] with SUM should yield [0,numProcs,2*numProcs, ...] +reduceTest myRank = do + numProcs <- commSize commWorld + (src :: ArrMsg) <- newListArray (0,99) [0..99] + if myRank /= root + then reduceSend commWorld root sumOp src + else do + (result :: ArrMsg) <- intoNewArray_ (0,99) $ reduceRecv commWorld root sumOp src + recvMsg <- getElems result + let expected = map (numProcs*) [0..99] + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +allreduceTest _ = do + numProcs <- commSize commWorld + (src :: ArrMsg) <- newListArray (0,99) [0..99] + (result :: ArrMsg) <- intoNewArray_ (0,99) $ allreduce commWorld sumOp src + recvMsg <- getElems result + let expected = map (numProcs*) [0..99] + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +-- We reduce [0..] with SUM. +-- Each process gets (rank+1) elements of the result +reduceScatterTest myRank = do + numProcs <- commSize commWorld + let dataSize = sum [1..numProcs] + msg = take dataSize [0..] + myRankNo = fromRank myRank + (src :: ArrMsg) <- newListArray (1,dataSize) msg + (counts :: StorableArray Int CInt) <- newListArray (1, numProcs) [1..fromIntegral numProcs] + (result :: ArrMsg) <- intoNewArray_ (1,myRankNo + 1) $ reduceScatter commWorld sumOp counts src + recvMsg <- getElems result + let expected = map (numProcs*) $ take (myRankNo+1) $ drop (sum [0..myRankNo]) msg + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + +-- Reducing arrays [0,1,2....] with SUM should yield [0,numProcs,2*numProcs, ...] +foreign import ccall "wrapper" + wrap :: (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ()) + -> IO (FunPtr (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ())) +reduceUserOpTest myRank = do + numProcs <- commSize commWorld + userSumPtr <- wrap userSum + mySumOp <- opCreate True userSumPtr + (src :: ArrMsg) <- newListArray (0,99) [0..99] + if myRank /= root + then reduceSend commWorld root sumOp src + else do + (result :: ArrMsg) <- intoNewArray_ (0,99) $ reduceRecv commWorld root mySumOp src + recvMsg <- getElems result + let expected = map (numProcs*) [0..99] + recvMsg == expected @? "Got " ++ show recvMsg ++ " instead of " ++ show expected + freeHaskellFunPtr userSumPtr + where + userSum :: Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO () + userSum inPtr inoutPtr lenPtr _ = do + len <- peek lenPtr + let offs = sizeOf ( undefined :: CDouble ) + let loop 0 _ _ = return () + loop n inPtr inoutPtr = do + a <- peek inPtr + b <- peek inoutPtr + poke inoutPtr (a+b) + loop (n-1) (plusPtr inPtr offs) (plusPtr inoutPtr offs) + loop len inPtr inoutPtr diff --git a/test/TestHelpers.hs b/test/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/TestHelpers.hs @@ -0,0 +1,52 @@ +module TestHelpers ( + module Test.Runner, + module Test.HUnit, + module Test.HUnit.Lang, + mpiTestCase, + testCase, + checkStatus, + checkStatusIfNotMPICH2, + Actor(..), + sender, + receiver, + ) where + +import Test.Runner +import Test.HUnit ((@?), Test(..)) +import Test.HUnit.Lang (Assertion) + +import Control.Parallel.MPI.Base as Base + +-- Test case creation helpers +mpiTestCase :: Rank -> String -> (Rank -> IO ()) -> (String,TestRunnerTest) +mpiTestCase rank title worker = + -- Processes are synchronized before each test with "barrier" + testCase (unwords ["[ rank",show rank,"]",title]) $ (barrier commWorld >> worker rank) + +testCase :: String -> Assertion -> (String, TestRunnerTest) +testCase title body = (title, TestRunnerTest $ TestCase body) + +-- Dissect status returned by some multi-target functions +checkStatus :: Status -> Rank -> Tag -> IO () +checkStatus _status src tag = do + status_source _status == src @? "Wrong source in status: expected " ++ show src ++ ", but got " ++ show (status_source _status) + status_tag _status == tag @? "Wrong tag in status: expected " ++ show tag ++ ", but got " ++ show (status_tag _status) + not (status_cancelled _status) @? "Status says \"cancelled\"" + -- Error status is not checked since MPI implementation does not have to set it to 0 if there were no error + -- status_error _status == 0 @? "Non-zero error code: " ++ show (status_error _status) + +-- | MPICH2 does not fill Status for non-blocking point-to-point sends, which would mark many tests as errors. +-- Hence, this kludge. +checkStatusIfNotMPICH2 :: Status -> Rank -> Tag -> IO () +checkStatusIfNotMPICH2 status src tag = + if getImplementation == MPICH2 + then return () + else checkStatus status src tag + +-- Commonly used constants +data Actor = Sender | Receiver + deriving (Enum, Eq) + +sender, receiver :: Rank +sender = toRank Sender +receiver = toRank Receiver diff --git a/test/Testsuite.hs b/test/Testsuite.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite.hs @@ -0,0 +1,108 @@ +module Main where + +import Control.Parallel.MPI.Base + +import TestHelpers +import OtherTests +import SimpleTests +import StorableArrayTests +import IOArrayTests +import FastAndSimpleTests +import GroupTests +import PrimTypeTests +import ExceptionTests + +import Control.Monad (when) +import System.Posix.IO (dupTo, stdError, stdOutput) + +import Trace.Hpc.Tix +import Trace.Hpc.Reflect +{- +Test.Runner vs TestFramework +---------------------------- +In order to be able to debug MPI bindings testsuite on a single-node +MPI installation one has to be able to separate output from processes +of different rank. + +OpenMPI allows to do so via the --output-filename switch of mpirun, +but MPICH2 does not have similar feature. And since most of the output +in the testsuite is done from inside test harness library, there is +very little control over output. + +Obvious solution would be to redirect stdout of the process to some +other file handle via dup2(2). However, there are several downsides: +1. Binding for dup2 (hDuplicateTo) is a GHC-only solutions +2. TestFramework does not play well with this solution, shutting + output completely when stdout is redirected (probably "ncurses" is + disappointed to find that output is not a terminal anymore) + +Nevertheless, I decided to stick to hDuplicateTo and ditch +TestFramework in favor of TestRunner, since it allows for consistent +experience across MPI implementations. + +-} +{- +Code coverage analysis +---------------------- +It's very nice to have code coverage report for testsuite to make sure +that no major piece of code is left untested. However, current +profiling mechanism does not play well with MPI: when mpirun starts +two processes (on the single node), they both try to run to the same +.tix file at once. Mayhem ensues. + +In order to fix this, Testsuite.hs has been made to depend on hpc +package, and after all tests has been run, HPC API is instructed to +write tix data to files rank.tix. + +Command line tool "hpc" could then be used to combine those into +single .tix file, which could be used to produce code coverage report. +Simple script "bin/coverage.sh" does all this automatically. Note: +script should be run from the toplevel project dir (where +haskell-mpi.cabal is residing). + +-} +{- +How to set up OpenMPI on 2 (3,4,..) nodes? +------------------------------------------ +Quick intro for the impatient: +1)Set up OpenMPI on each node +2)Either use a global filesystem, or make sure that binary is on each +node in the $PATH +3)If you have several network interfaces on a particular node, but +want to use only some of them, edit +/etc/openmpi/openmpi-mca-params.conf and add there: +btl_tcp_if_include=wlan0 +oob_tcp_if_include=wlan0 +oob_tcp_include=wlan0 +4)Create hostfile +5)Use mpirun -np X --hostfile +-} +main :: IO () +main = do + provided <- initThread Multiple + size <- commSize commWorld + rank <- commRank commWorld + if (size < 2) + then putStrLn $ unlines [ "Need at least two processes to run the tests." + , "Typical command line could look like this:" + , "'mpirun -np 2 bindings-mpi-testsuite 1>sender.log 2>receiver.log'" ] + else do when (rank /= 0) $ do _ <- dupTo stdError stdOutput -- redirect stdout to stderr for non-root processes + return () + putStrLn $ "MPI implementation provides thread support level: " ++ show provided + testRunnerMain $ tests provided rank + barrier commWorld -- synchronize processes after all tests + -- Dump profiling data + tix <- examineTix + writeTix ("rank" ++ (show rank) ++ ".tix") tix + finalize + +tests :: ThreadSupport -> Rank -> [(String, TestRunnerTest)] +tests threadSupport rank = + otherTests threadSupport rank + ++ primTypeTests rank + ++ simpleTests rank + ++ storableArrayTests rank + ++ ioArrayTests rank + ++ fastAndSimpleTests rank + ++ groupTests rank + ++ exceptionTests rank