packages feed

haskell-mpi (empty) → 0.5.0

raw patch · 27 files changed

+4795/−0 lines, 27 filesdep +HUnitdep +arraydep +basesetup-changed

Dependencies added: HUnit, array, base, bytestring, cereal, extensible-exceptions, haskell98, hpc, process, testrunner, unix

Files

+ LICENSE view
@@ -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.
+ README.txt view
@@ -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 <at> gmail <dot> 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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ haskell-mpi.cabal view
@@ -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:+ <http://www.mcs.anl.gov/research/projects/mpich2> and+ OpenMPI: <http://www.open-mpi.org>.+ .+ In addition to reading these documents, users may also find it+ beneficial to consult the MPI-2 standard documentation provided by the+ MPI Forum: <http://www.mpi-forum.org>, 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
+ src/C2HS.hs view
@@ -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
+ src/Control/Parallel/MPI/Base.hs view
@@ -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+@+-}
+ src/Control/Parallel/MPI/Fast.hs view
@@ -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
+ src/Control/Parallel/MPI/Internal.chs view
@@ -0,0 +1,1177 @@+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+#include <mpi.h>+#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 <http://mpi-forum.org/docs/mpi22-report/node47.htm#Node47>)++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_ #}
+ src/Control/Parallel/MPI/Simple.hs view
@@ -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+
+ src/Control/Parallel/MPI/Utils.hs view
@@ -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
+ src/cbits/constants.c view
@@ -0,0 +1,61 @@+#include <mpi.h>++/* 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)
+ src/cbits/init_wrapper.c view
@@ -0,0 +1,11 @@+#include <mpi.h>+#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); }
+ src/include/comparison_result.h view
@@ -0,0 +1,9 @@+#include <mpi.h>++/* 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+};
+ src/include/error_classes.h view
@@ -0,0 +1,60 @@+#include <mpi.h>++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+};
+ src/include/init_wrapper.h view
@@ -0,0 +1,2 @@+extern int init_wrapper (void);+extern int init_wrapper_thread (int required, int* provided);
+ src/include/thread_support.h view
@@ -0,0 +1,8 @@+#include <mpi.h>++typedef enum ThreadSupport {+  Single = MPI_THREAD_SINGLE,+  Funneled = MPI_THREAD_FUNNELED,+  Serialized = MPI_THREAD_SERIALIZED,+  Multiple = MPI_THREAD_MULTIPLE+};
+ test/CompileRunClean.hs view
@@ -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
+ test/ExceptionTests.hs view
@@ -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"
+ test/FastAndSimpleTests.hs view
@@ -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 ()
+ test/GroupTests.hs view
@@ -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
+ test/IOArrayTests.hs view
@@ -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
+ test/OtherTests.hs view
@@ -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"
+ test/PrimTypeTests.hs view
@@ -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)
+ test/SimpleTests.hs view
@@ -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
+ test/StorableArrayTests.hs view
@@ -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
+ test/TestHelpers.hs view
@@ -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
+ test/Testsuite.hs view
@@ -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<n>.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 <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