haskell-mpi 1.2.1 → 1.4.0
raw patch · 16 files changed
+457/−416 lines, 16 filesnew-uploader
Files
- README.txt +12/−2
- haskell-mpi.cabal +12/−10
- src/C2HS.hs +0/−222
- src/Control/Parallel/MPI/Base.hs +6/−0
- src/Control/Parallel/MPI/Fast.hs +46/−45
- src/Control/Parallel/MPI/Internal.chs +194/−107
- src/Control/Parallel/MPI/Simple.hs +22/−20
- src/Control/Parallel/MPI/Utils.hs +6/−4
- src/cbits/constants.c +1/−0
- test/CompileRunClean.hs +1/−1
- test/OtherTests.hs +14/−0
- test/PrimTypeTests.hs +6/−5
- test/examples/clientserver/Client.c +28/−0
- test/examples/clientserver/Client.hs +27/−0
- test/examples/clientserver/Server.c +45/−0
- test/examples/clientserver/Server.hs +37/−0
README.txt view
@@ -4,8 +4,8 @@ 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.+Use "cabal install --extra-include-dirs=/path/to/mpi/headers --extra-lib-dirs=/path/to/mpi/libs"+or something similar. Make sure that you have libmpi.a and libmpi.so available. When building against MPICH 1.4, pass extra flag "-fmpich14" @@ -40,6 +40,9 @@ Process with rank 0 emits the output to stdout, and every other rank reports to the stderr. +If you are using the PBS batch system to launch jobs, there is a sample+job script in test/pbs/ for submitting the test case to the jobs queue.+ How to run standalone tests --------------------------- @@ -103,3 +106,10 @@ The next major injection of effort happened when Dmitry Astapov started contributing to the project in August 2010.++Contributions have also been made by:++ - Abhishek Kulkarni: support for MPI-2 intercommunicator client/server+ functions + - Andres Löh: bug fixes+ - Ian Ross: updated the code to work with newer C2HS.
haskell-mpi.cabal view
@@ -1,5 +1,5 @@ name: haskell-mpi-version: 1.2.1+version: 1.4.0 cabal-version: >= 1.6 synopsis: Distributed parallel programming in Haskell using MPI. description:@@ -69,14 +69,16 @@ category: FFI, Distributed Computing license: BSD3 license-file: LICENSE-copyright: (c) 2010 Bernard James Pope, Dmitry Astapov+copyright: (c) 2010-2015 Bernard James Pope, Dmitry Astapov, Abhishek Kulkarni, Andres Löh, Ian Ross 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+tested-with: GHC==6.10.4, GHC==6.12.1, GHC==7.4.1 extra-source-files: src/cbits/*.c src/include/*.h README.txt+ test/examples/clientserver/*.c+ test/examples/clientserver/*.hs test/examples/HaskellAndC/Makefile test/examples/HaskellAndC/*.c test/examples/HaskellAndC/*.hs@@ -100,11 +102,12 @@ default: False Library- extra-libraries: mpi if flag(mpich14)- extra-libraries: mpl+ extra-libraries: mpich, opa, mpl+ else+ extra-libraries: mpi, open-rte, open-pal build-tools: c2hs- ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans+ ghc-options: -O2 -Wall -fno-warn-name-shadowing -fno-warn-orphans c-sources: src/cbits/init_wrapper.c, src/cbits/constants.c@@ -124,7 +127,6 @@ Control.Parallel.MPI.Fast, Control.Parallel.MPI.Simple other-modules:- C2HS, Control.Parallel.MPI.Utils executable haskell-mpi-testsuite@@ -132,9 +134,10 @@ ./test ./src build-tools: c2hs- extra-libraries: mpi if flag(mpich14)- extra-libraries: mpl+ extra-libraries: mpich, opa, mpl+ else+ extra-libraries: mpi, open-rte, open-pal ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans c-sources: src/cbits/init_wrapper.c,@@ -147,7 +150,6 @@ Control.Parallel.MPI.Fast, Control.Parallel.MPI.Simple, Control.Parallel.MPI.Utils,- C2HS, IOArrayTests, SimpleTests, FastAndSimpleTests,
− src/C2HS.hs
@@ -1,222 +0,0 @@--- 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 Foreign.C,-- -- * 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 Foreign.C--import Control.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 :: Eq a => 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
@@ -46,6 +46,7 @@ , commTestInter , commRemoteSize , commCompare+ , commFree , commSetErrhandler , commGetErrhandler , commGroup@@ -149,6 +150,11 @@ , commSpawnSimple , argvNull , errcodesIgnore+ , openPort+ , closePort+ , commAccept+ , commConnect+ , commDisconnect -- * Error handling. , MPIError(..)
src/Control/Parallel/MPI/Fast.hs view
@@ -59,10 +59,10 @@ -} ----------------------------------------------------------------------------- module Control.Parallel.MPI.Fast- ( + ( -- * Mapping between Haskell and MPI types Repr (..)- + -- * Treating Haskell values as send or receive buffers , SendFrom (..) , RecvInto (..)@@ -74,7 +74,7 @@ , intoNewVal_ , intoNewBS , intoNewBS_- + -- * Point-to-point operations. -- ** Blocking. , send@@ -114,14 +114,13 @@ , 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@@ -132,6 +131,8 @@ import Control.Parallel.MPI.Base import Data.Int() import Data.Word+import Foreign+import Foreign.C.Types {- @@ -146,7 +147,7 @@ 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 +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.@@ -291,7 +292,7 @@ cnt <- rangeSize <$> getBounds requests withStorableArray requests $ \reqs -> withStorableArray statuses $ \stats ->- Internal.waitall (cIntConv cnt) (castPtr reqs) (castPtr stats)+ Internal.waitall (fromIntegral 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.@@ -307,10 +308,10 @@ 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. +-- | 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 +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)@@ -368,8 +369,8 @@ withStorableArray counts $ \countsPtr -> withStorableArray displacements $ \displPtr -> recvInto recvVal $ \recvPtr _ recvType->- Internal.gatherv (castPtr sendPtr) sendElements sendType - (castPtr recvPtr) countsPtr displPtr recvType + Internal.gatherv (castPtr sendPtr) sendElements sendType+ (castPtr recvPtr) countsPtr displPtr recvType root comm -- | Variant of 'gatherSend', to be used with 'gathervRecv'.@@ -403,18 +404,18 @@ -> IO () allgatherv comm segment counts displacements recvVal = do sendFrom segment $ \sendPtr sendElements sendType ->- withStorableArray counts $ \countsPtr -> - withStorableArray displacements $ \displPtr -> + 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 +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@@ -423,11 +424,11 @@ 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+ Internal.alltoall (castPtr sendPtr) (fromIntegral sendCount) sendType (castPtr recvPtr) (fromIntegral recvCount) recvType comm -- | A variation of 'alltoall' that allows to use data segments of -- different length.-alltoallv :: (SendFrom v1, RecvInto v2) => Comm +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@@ -444,14 +445,14 @@ 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 +reduceSend :: SendFrom v => Comm -> Rank -- ^ Rank of the root process -> Operation -- ^ Reduction operation -> v -- ^ Value supplied by this process@@ -462,7 +463,7 @@ {-| Obtain result of reduction initiated by 'reduceSend'. Note that root process supplies value for reduction as well. -}-reduceRecv :: (SendFrom v, RecvInto v) => Comm +reduceRecv :: (SendFrom v, RecvInto v) => Comm -> Rank -- ^ Rank of the root process -> Operation -- ^ Reduction operation -> v -- ^ Value supplied by this process@@ -474,13 +475,13 @@ 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) => +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 = +allreduce comm op sendVal recvVal = sendFrom sendVal $ \sendPtr sendElements sendType -> recvInto recvVal $ \recvPtr _ _ -> Internal.allreduce (castPtr sendPtr) (castPtr recvPtr) sendElements sendType op comm@@ -489,9 +490,9 @@ -- 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) => +reduceScatterBlock :: (SendFrom v, RecvInto v) => Comm -- ^ Communicator engaged in reduction/ -> Operation -- ^ Reduction operation -> Int -- ^ Size of the result block sent to each process@@ -501,11 +502,11 @@ 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+ Internal.reduceScatterBlock (castPtr sendPtr) (castPtr recvPtr) (fromIntegral 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) => +reduceScatter :: (SendFrom v, RecvInto v) => Comm -- ^ Communicator engaged in reduction/ -> Operation -- ^ Reduction operation -> StorableArray Int CInt -- ^ Sizes of block distributed to each process@@ -527,10 +528,10 @@ 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' +-- | 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 +#if SIZEOF_HSINT == 4 representation _ = (1,int) #elif SIZEOF_HSINT == 8 representation _ = (1,longLong)@@ -556,7 +557,7 @@ -- | 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 +#if SIZEOF_HSINT == 4 representation _ = (1,unsigned) #else representation _ = (1,unsignedLongLong)@@ -605,7 +606,7 @@ 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, +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@@ -616,7 +617,7 @@ {- | Treat @v@ as receive buffer for the purposes of this API. -} class RecvInto v where- recvInto :: v -- ^ Value to use as receive buffer + 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 @@ -653,7 +654,7 @@ 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@@ -675,11 +676,11 @@ withStorableArrayAndSize arr f = do rSize <- rangeSize <$> getBounds arr let (scale, dtype) = (representation (undefined :: StorableArray i e))- numElements = cIntConv (rSize * scale)+ numElements = fromIntegral (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. +-- 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'@@ -691,7 +692,7 @@ recvWithMArrayAndSize array f = do bounds <- getBounds array let (scale, dtype) = representation (undefined :: a i e)- numElements = cIntConv $ rangeSize bounds * scale+ numElements = fromIntegral $ rangeSize bounds * scale allocaArray (rangeSize bounds) $ \ptr -> do result <- f (castPtr ptr) numElements dtype fillArrayFromPtr (range bounds) (rangeSize bounds) ptr array@@ -702,7 +703,7 @@ elements <- getElems array bounds <- getBounds array let (scale, dtype) = representation (undefined :: a i e)- numElements = cIntConv $ rangeSize bounds * scale+ numElements = fromIntegral $ rangeSize bounds * scale withArray elements $ \ptr -> f (castPtr ptr) numElements dtype -- XXX I wonder if this can be written without the intermediate list?@@ -719,19 +720,19 @@ 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+ unsafeUseAsCStringLen bs $ \(bsPtr,len) -> f (castPtr bsPtr) (fromIntegral 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+ recvIntoElemPtr (cnt,datatype) p f = f (castPtr p) (fromIntegral 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+ recvIntoVectorPtr (scale, datatype) (p,len) f = f (castPtr p) (fromIntegral (len * scale) :: CInt) datatype -- | Allocate new 'Storable' value and use it as receive buffer intoNewVal :: (Storable e) => (Ptr e -> IO r) -> IO (e, r)@@ -765,7 +766,7 @@ {- | 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. +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,@@ -789,8 +790,8 @@ @ import "Control.Parallel.MPI.Fast" -foreign import ccall \"wrapper\" - wrap :: (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ()) +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@@ -819,9 +820,9 @@ -} opCreate :: Storable t => Bool -- ^ Whether the operation is commutative- -> (FunPtr (Ptr t -> Ptr t -> Ptr CInt -> Ptr Datatype -> IO ())) + -> (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
src/Control/Parallel/MPI/Internal.chs view
@@ -41,14 +41,14 @@ Info, infoNull, infoCreate, infoSet, infoDelete, infoGet, -- * Requests and statuses.- Request, Status (..), getCount, test, testPtr, cancel, cancelPtr, wait, waitPtr, waitall, requestNull, + Request, Status (..), getCount, test, testPtr, cancel, cancelPtr, wait, waitPtr, waitall, requestNull, -- * Process management. -- ** Communicators. Comm, commWorld, commSelf, commNull, commTestInter,- commSize, commRemoteSize, - commRank, - commCompare, commGroup, commGetAttr,+ commSize, commRemoteSize,+ commRank,+ commCompare, commFree, commGroup, commGetAttr, -- ** Process groups. Group, groupEmpty, groupRank, groupSize, groupUnion,@@ -59,6 +59,7 @@ -- ** Dynamic process management commGetParent, commSpawn, commSpawnSimple, argvNull, errcodesIgnore,+ openPort, closePort, commAccept, commConnect, commDisconnect, -- * Error handling. Errhandler, errorsAreFatal, errorsReturn, errorsThrowExceptions, commSetErrhandler, commGetErrhandler,@@ -90,7 +91,7 @@ -- ** All-to-all. allgather, allgatherv, alltoall, alltoallv,- allreduce, + allreduce, reduceScatterBlock, reduceScatter, barrier,@@ -105,15 +106,34 @@ ) 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+import Foreign hiding (unsafePerformIO)+import Foreign.C.Types+import Foreign.C.String+import System.IO.Unsafe {# context prefix = "MPI" #} +cFromEnum :: (Enum e, Integral i) => e -> i+cFromEnum = fromIntegral . fromEnum++cToEnum :: (Integral i, Enum e) => i -> e+cToEnum = toEnum . fromIntegral++peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool+peekBool = liftM toBool . peek++peekIntConv :: (Storable a, Integral a, Integral b)+ => Ptr a -> IO b+peekIntConv = liftM fromIntegral . peek++peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a+peekEnum = liftM cToEnum . peek+ -- | 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@@ -148,6 +168,8 @@ -} newtype Comm = MkComm { fromComm :: MPIComm } deriving Eq peekComm ptr = MkComm <$> peek ptr+withComm comm f = alloca $ \ptr -> do poke ptr (fromComm comm)+ f (castPtr ptr) foreign import ccall "&mpi_comm_world" commWorld_ :: Ptr MPIComm foreign import ccall "&mpi_comm_self" commSelf_ :: Ptr MPIComm@@ -163,12 +185,17 @@ commSelf = MkComm <$> unsafePerformIO $ peek commSelf_ foreign import ccall "&mpi_max_processor_name" max_processor_name_ :: Ptr CInt+foreign import ccall "&mpi_max_port_name" max_port_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 "port name" as returned by 'openPort'+maxPortName :: CInt+maxPortName = unsafePerformIO $ peek max_port_name_+ -- | Max length of error description as returned by 'errorString' maxErrorString :: CInt maxErrorString = unsafePerformIO $ peek max_error_string_@@ -187,14 +214,14 @@ -- 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*- #}+{# fun unsafe Initialized as ^ {alloca- `Bool' peekBool*} -> `()' discard*- #} -- | 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*- #}+{# fun unsafe Finalized as ^ {alloca- `Bool' peekBool*} -> `()' discard*- #} -- | Initialize the MPI environment with a /required/ level of thread support. -- See the documentation for 'init' for more information about MPI initialization.@@ -241,12 +268,12 @@ 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*- #}+ len <- getProcessorName_ ptr+ peekCStringLen (ptr, fromIntegral len) +{# fun unsafe Get_processor_name as getProcessorName_+ {id `Ptr CChar', alloca- `CInt' peekIntConv*} -> `()' checkError*- #}+ -- | MPI implementation version data Version = Version { version :: Int, subversion :: Int }@@ -258,12 +285,13 @@ -- | Which MPI version the code is running on. getVersion :: IO Version getVersion = do- (version, subversion) <- getVersion'+ (version, subversion) <- getVersion_ return $ Version version subversion- where- getVersion' = {# fun unsafe Get_version as getVersion_- {alloca- `Int' peekIntConv*, alloca- `Int' peekIntConv*} -> `()' checkError*- #} +{# fun unsafe Get_version as getVersion_+ {alloca- `Int' peekIntConv*, alloca- `Int' peekIntConv*} ->+ `()' checkError*- #}+ -- | Supported MPI implementations data Implementation = MPICH2 | OpenMPI deriving (Eq,Show) @@ -305,30 +333,31 @@ isInitialized <- initialized if isInitialized then do alloca $ \ptr -> do- found <- commGetAttr' comm key (castPtr ptr)+ 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*- #} +{# fun unsafe Comm_get_attr as commGetAttr_+ {fromComm `Comm', fromIntegral `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_)+ let key = unsafePerformIO (peekIntConv tagUB_) in fromMaybe 0 $ unsafePerformIO (commGetAttr commWorld key) -foreign import ccall unsafe "&mpi_tag_ub" tagUB_ :: Ptr Int+foreign import ccall unsafe "&mpi_tag_ub" tagUB_ :: Ptr CInt {- | 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. +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'.@@ -339,14 +368,14 @@ wtimeIsGlobal = fromMaybe False $ unsafePerformIO (commGetAttr commWorld wtimeIsGlobalKey) -foreign import ccall unsafe "&mpi_wtime_is_global" wtimeIsGlobal_ :: Ptr Int+foreign import ccall unsafe "&mpi_wtime_is_global" wtimeIsGlobal_ :: Ptr CInt -- | Numeric key for standard MPI communicator attribute @MPI_WTIME_IS_GLOBAL@. -- To be used with 'commGetAttr'. wtimeIsGlobalKey :: Int-wtimeIsGlobalKey = unsafePerformIO (peek wtimeIsGlobal_)+wtimeIsGlobalKey = unsafePerformIO (peekIntConv wtimeIsGlobal_) -{- | +{- | Many ``dynamic'' MPI applications are expected to exist in a static runtime environment, in which resources have been allocated before the application is run. When a user (or possibly a batch system) runs one of these quasi-static applications, she will usually specify a number of processes to start and a total number of processes that are expected. An application simply needs to know how many slots there are, i.e., how many processes it should spawn. This attribute indicates the total number of processes that are expected.@@ -357,12 +386,12 @@ universeSize c = commGetAttr c universeSizeKey -foreign import ccall unsafe "&mpi_universe_size" universeSize_ :: Ptr Int+foreign import ccall unsafe "&mpi_universe_size" universeSize_ :: Ptr CInt -- | Numeric key for recommended MPI communicator attribute @MPI_UNIVERSE_SIZE@. -- To be used with 'commGetAttr'. universeSizeKey :: Int-universeSizeKey = unsafePerformIO (peek universeSize_)+universeSizeKey = unsafePerformIO (peekIntConv universeSize_) -- | Return the rank of the calling process for the given -- communicator. If it is an intercommunicator, returns rank of the@@ -410,13 +439,14 @@ getCount comm rank tag datatype = alloca $ \statusPtr -> do probe rank tag comm statusPtr- cnt <- getCount' statusPtr datatype+ cnt <- getCount_ statusPtr datatype return $ fromIntegral cnt- where- getCount' = {# fun unsafe Get_count as getCount_- {castPtr `Ptr Status', fromDatatype `Datatype', alloca- `CInt' peekIntConv*} -> `()' checkError*- #} +{# fun unsafe Get_count as getCount_+ {castPtr `Ptr Status', fromDatatype `Datatype',+ alloca- `CInt' peekIntConv*} -> `()' checkError*- #} + {-| 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@@ -424,7 +454,7 @@ {# 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. +actually starts receiving data. -} {# fun unsafe Ssend as ^ { id `BufferPtr', id `Count', fromDatatype `Datatype', fromRank `Rank', fromTag `Tag', fromComm `Comm' } -> `()' checkError*- #}@@ -440,15 +470,15 @@ { 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. +-- 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. +-- 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@@ -511,20 +541,22 @@ test :: Request -> IO (Maybe Status) test request = withRequest request testPtr --- | Analogous to 'test' but uses pointer to @Request@. If request is completed, pointer would be +-- | Analogous to 'test' but uses pointer to @Request@. If request is completed, pointer would be -- set to point to @requestNull@. testPtr :: Ptr Request -> IO (Maybe Status) testPtr reqPtr = do- (flag, status) <- testPtr' reqPtr+ (flag, status) <- testPtr_ reqPtr request' <- peek reqPtr if flag then do if request' == requestNull then return $ Just status else error "testPtr: request modified, but not set to MPI_REQUEST_NULL!" else return Nothing- where testPtr' = {# fun unsafe Test as testPtr_- {castPtr `Ptr Request', alloca- `Bool' peekBool*, allocaCast- `Status' peekCast*} -> `()' checkError*- #} +{# fun unsafe Test as testPtr_+ {castPtr `Ptr Request', alloca- `Bool' peekBool*,+ allocaCast- `Status' peekCast*} -> `()' checkError*- #}+ -- | Cancel a pending communication request. -- This function corresponds to @MPI_Cancel@. Sets pointer to point to @requestNull@. {# fun unsafe Cancel as cancelPtr@@ -635,11 +667,11 @@ fromOperation `Operation', fromComm `Comm'} -> `()' checkError*- #} -- TODO: In the following haddock block, mention SCAN and EXSCAN once--- they are implemented +-- 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. +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,@@ -673,8 +705,8 @@ @ import "Control.Parallel.MPI.Fast" -foreign import ccall \"wrapper\" - wrap :: (Ptr CDouble -> Ptr CDouble -> Ptr CInt -> Ptr Datatype -> IO ()) +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@@ -708,7 +740,7 @@ -} {# fun Op_free as ^ {withOperation* `Operation'} -> `()' checkError*- #} -{- | Returns a +{- | Returns a floating-point number of seconds, representing elapsed wallclock time since some time in the past. @@ -732,44 +764,53 @@ -- | 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*- #}+groupRank = unsafePerformIO <$> 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*- #}+groupSize = unsafePerformIO <$> groupSize_ --- | Constructs the union of two groups: all the members of the first group, followed by all the members of the +{# 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*- #}+groupUnion g1 g2 = unsafePerformIO $ groupUnion_ g1 g2 +{# 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*- #}+groupIntersection g1 g2 = unsafePerformIO $ groupIntersection_ g1 g2 --- | Constructs a new group which contains all the elements of the first group which are not in the second group. +{# 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*- #}+groupDifference g1 g2 = unsafePerformIO $ groupDifference_ g1 g2 +{# 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*- #}+groupCompare g1 g2 = unsafePerformIO $ groupCompare_ g1 g2 +{# 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.@@ -803,28 +844,29 @@ let (rankIntList :: [Int]) = map fromEnum ranks withArrayLen rankIntList $ \size ranksPtr -> allocaArray size $ \resultPtr -> do- groupTranslateRanks' group1 (cFromEnum size) (castPtr ranksPtr) group2 resultPtr+ 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)+{# 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 (fromIntegral size, castPtr ptr)+ {- | If a process was started with 'commSpawn', @commGetParent@ returns the parent intercommunicator of the current process. This parent intercommunicator is created implicitly inside of 'init' and is the same intercommunicator returned by 'commSpawn' in the parents. If the process was not spawned, @commGetParent@ returns 'commNull'. After the parent communicator is freed or disconnected,-@commGetParent@ returns 'commNull'. -} +@commGetParent@ returns 'commNull'. -} {# fun unsafe Comm_get_parent as ^ {alloca- `Comm' peekComm*} -> `()' checkError*- #} withT = with {# fun unsafe Comm_spawn as ^- { `String' + { `String' , withT* `Ptr CChar' , id `Count' , fromInfo `Info'@@ -838,27 +880,69 @@ argvNull = unsafePerformIO $ peek mpiArgvNull_ errcodesIgnore = unsafePerformIO $ peek mpiErrcodesIgnore_ -{-| Simplified version of `commSpawn' that does not support argument passing and spawn error code checking -}+{-| Simplified version of `commSpawn' that does not support argument passing and spawn error code checking. -} commSpawnSimple rank program maxprocs = commSpawn program argvNull maxprocs infoNull rank commSelf errcodesIgnore -foreign import ccall "&mpi_undefined" mpiUndefined_ :: Ptr Int+foreign import ccall "&mpi_undefined" mpiUndefined_ :: Ptr CInt +{-| Opens up a port (network address) on the server where clients+ can establish connections using @commConnect@.++Refer to MPI Report v2.2, Section 10.4 "Establishing communication"+for more details on client/server programming with MPI. -}+openPort :: Info -> IO String+openPort info = do+ allocaBytes (fromIntegral maxPortName) $ \ptr -> do+ openPort_ info ptr+ peekCStringLen (ptr, fromIntegral maxPortName)++{# fun unsafe Open_port as openPort_+ {fromInfo `Info', id `Ptr CChar'} -> `()' checkError*- #}++-- | Closes the specified port on the server.+{# fun unsafe Close_port as ^+ {`String'} -> `()' checkError*- #}++{-| @commAccept@ allows a connection from a client. The intercommunicator+ object returned can be used to communicate with the client. -}+{# fun unsafe Comm_accept as ^+ { `String'+ , fromInfo `Info'+ , fromRank `Rank'+ , fromComm `Comm'+ , alloca- `Comm' peekComm*} -> `()' checkError*- #}++{-| @commConnect@ creates a connection to the server. The intercommunicator+ object returned can be used to communicate with the server. -}+{# fun unsafe Comm_connect as ^+ { `String'+ , fromInfo `Info'+ , fromRank `Rank'+ , fromComm `Comm'+ , alloca- `Comm' peekComm*} -> `()' checkError*- #}++-- | Free a communicator object.+{# fun Comm_free as ^ {withComm* `Comm'} -> `()' checkError*- #}++-- | Stop pending communication and deallocate a communicator object.+{# fun Comm_disconnect as ^ {withComm* `Comm'} -> `()' checkError*- #}+ -- | 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_+mpiUndefined = unsafePerformIO $ peekIntConv 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*- #}+typeSize = unsafePerformIO . 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 #} @@ -879,21 +963,22 @@ -- This function corresponds to @MPI_Abort@. abort :: Comm -> Int -> IO () abort comm code =- abort' comm (toErrorCode 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+ | otherwise = fromIntegral i - abort' = {# fun unsafe Abort as abort_ {fromComm `Comm', id `CInt'} -> `()' checkError*- #}+{# fun unsafe Abort as abort_+ {fromComm `Comm', id `CInt'} -> `()' checkError*- #} type MPIDatatype = {# type MPI_Datatype #} --- | Haskell datatype used to represent @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 }@@ -1073,20 +1158,22 @@ {-| Gets the specified key -} infoGet :: Info -> String -> IO (Maybe String) infoGet info key = do- (len, found) <- infoGetValuelen' info key + (len, found) <- infoGetValuelen_ info key -- len+1 is required to allow for the terminating \NULL if found/=0 then allocaBytes (fromIntegral len + 1) (\bufferPtr -> do- found <- infoGet' info key (len+1) bufferPtr+ found <- infoGet_ info key (len+1) bufferPtr if found/=0 then Just <$> peekCStringLen (bufferPtr, fromIntegral len) else return Nothing) else return Nothing -infoGetValuelen' = {# fun unsafe Info_get_valuelen as infoGetValuelen_- {fromInfo `Info', `String', alloca- `CInt' peek*, alloca- `CInt' peek* } -> `()' checkError*- #}+{# fun unsafe Info_get_valuelen as infoGetValuelen_+ {fromInfo `Info', `String', alloca- `CInt' peek*,+ alloca- `CInt' peek* } -> `()' checkError*- #} -infoGet' = {# fun unsafe Info_get as infoGet_- {fromInfo `Info', `String', id `CInt', castPtr `Ptr CChar', alloca- `CInt' peek*} -> `()' checkError*- #}+{# fun unsafe Info_get as infoGet_+ {fromInfo `Info', `String', id `CInt',+ castPtr `Ptr CChar', alloca- `CInt' peek*} -> `()' checkError*- #} {- | Haskell datatype that represents values which@@ -1098,7 +1185,7 @@ 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'+newtype Rank = MkRank { rankId :: CInt -- ^ Extract numeric value of the 'Rank' } deriving (Eq, Ord, Enum, Integral, Real) @@ -1112,9 +1199,9 @@ | 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+foreign import ccall "&mpi_any_source" anySource_ :: Ptr CInt+foreign import ccall "&mpi_root" theRoot_ :: Ptr CInt+foreign import ccall "&mpi_proc_null" procNull_ :: Ptr CInt foreign import ccall "&mpi_request_null" requestNull_ :: Ptr MPIRequest foreign import ccall "&mpi_comm_null" commNull_ :: Ptr MPIComm @@ -1148,11 +1235,11 @@ -- | Map arbitrary 'Enum' value to 'Rank' toRank :: Enum a => a -> Rank-toRank x = MkRank { rankId = fromEnum x }+toRank x = MkRank { rankId = fromIntegral (fromEnum x) } -- | Map 'Rank' to arbitrary 'Enum' fromRank :: Enum a => Rank -> a-fromRank = toEnum . rankId+fromRank = toEnum . fromIntegral . rankId type MPIRequest = {# type MPI_Request #} {-| Haskell representation of the @MPI_Request@ type. Returned by@@ -1193,13 +1280,13 @@ 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)+ <$> liftM (MkRank . fromIntegral) ({#get MPI_Status->MPI_SOURCE #} p)+ <*> liftM (MkTag . fromIntegral) ({#get MPI_Status->MPI_TAG #} p)+ <*> liftM fromIntegral ({#get MPI_Status->MPI_ERROR #} p) 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)+ {#set MPI_Status.MPI_ERROR #} p (fromIntegral $ status_error x) -- NOTE: Int here is picked arbitrary allocaCast f =@@ -1210,7 +1297,7 @@ {-| 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+newtype Tag = MkTag { tagVal :: CInt -- ^ Extract numeric value of the Tag } deriving (Eq, Ord, Enum, Integral, Real) @@ -1229,13 +1316,13 @@ -- | Map arbitrary 'Enum' value to 'Tag' toTag :: Enum a => a -> Tag-toTag x = MkTag { tagVal = fromEnum x }+toTag x = MkTag { tagVal = fromIntegral (fromEnum x) } -- | Map 'Tag' to arbitrary 'Enum' fromTag :: Enum a => Tag -> a-fromTag = toEnum . tagVal+fromTag = toEnum . fromIntegral . tagVal -foreign import ccall unsafe "&mpi_any_tag" anyTag_ :: Ptr Int+foreign import ccall unsafe "&mpi_any_tag" anyTag_ :: Ptr CInt -- | Predefined tag value that allows reception of the messages with -- arbitrary tag values. Corresponds to @MPI_ANY_TAG@.@@ -1302,6 +1389,6 @@ -- with an infinite loop if we called checkError here. _ <- errorString' code ptr lenPtr len <- peek lenPtr- peekCStringLen (ptr, cIntConv len)+ peekCStringLen (ptr, fromIntegral len) where errorString' = {# call unsafe Error_string as errorString_ #}
src/Control/Parallel/MPI/Simple.hs view
@@ -65,8 +65,8 @@ , getFutureStatus , pollFuture , cancelFuture- , recvFuture - + , recvFuture+ -- ** Low-level (operating on ByteStrings). , sendBS , recvBS@@ -108,11 +108,10 @@ , 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)@@ -125,6 +124,10 @@ import Control.Parallel.MPI.Base import qualified Data.Array.Storable as SA import Data.List (unfoldr)+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.C.Types -- | Serializes the supplied value to ByteString and sends to specified process as the array of 'byte's using 'Internal.send'. --@@ -143,7 +146,7 @@ -- -- 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@ +-- 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.@@ -159,7 +162,7 @@ (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+ let cCount = fromIntegral $ BS.length bs unsafeUseAsCString bs $ \cString -> send_function (castPtr cString) cCount byte rank tag comm @@ -167,7 +170,7 @@ -- 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. +-- 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@@ -180,7 +183,7 @@ recvBS :: Comm -> Rank -> Tag -> IO (BS.ByteString, Status) recvBS comm rank tag = do count <- getCount comm rank tag byte- let cCount = cIntConv count+ let cCount = fromIntegral count allocaBytes count (\bufferPtr -> do recvStatus <- Internal.recv bufferPtr cCount byte rank tag comm@@ -218,7 +221,7 @@ (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+ let cCount = fromIntegral $ BS.length bs unsafeUseAsCString bs $ \cString -> do send_function (castPtr cString) cCount byte rank tag comm @@ -233,7 +236,7 @@ waitall reqs = do withArrayLen reqs $ \len reqPtr -> allocaArray len $ \statPtr -> do- Internal.waitall (cIntConv len) reqPtr (castPtr statPtr)+ Internal.waitall (fromIntegral len) reqPtr (castPtr statPtr) peekArray len statPtr -- | A value to be computed by some thread in the future.@@ -269,7 +272,7 @@ -- | 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'. +-- and extract actual value using either `waitFuture' or `pollFuture'. -- Internally this uses the blocking 'recv' in a separate execution thread. -- -- Example:@@ -318,7 +321,7 @@ where doSend bs = do -- broadcast the size of the message first- Fast.bcastSend comm rootRank (cIntConv (BS.length bs) :: CInt)+ Fast.bcastSend comm rootRank (fromIntegral (BS.length bs) :: CInt) -- then broadcast the actual message Fast.bcastSend comm rootRank bs @@ -348,12 +351,12 @@ gatherSend comm root msg = do let enc_msg = encode msg -- Send length- Fast.gatherSend comm root (cIntConv (BS.length enc_msg) :: CInt)+ Fast.gatherSend comm root (fromIntegral (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. +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'.@@ -376,7 +379,7 @@ 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)+ (lengthsArr :: SA.StorableArray Int CInt) <- Fast.intoNewArray_ (0,numProcs-1) $ Fast.gatherRecv comm root (fromIntegral (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)@@ -390,7 +393,7 @@ decodeNext ((l:ls),bs) = case decode bs of Left e -> fail e- Right val -> Just (val, (ls, BS.drop (cIntConv l) bs))+ Right val -> Just (val, (ls, BS.drop (fromIntegral 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.@@ -436,7 +439,7 @@ where doSend = do let enc_msgs = map encode msgs- lengths = map (cIntConv . BS.length) enc_msgs+ lengths = map (fromIntegral . BS.length) enc_msgs payload = BS.concat enc_msgs numProcs = length msgs -- scatter numProcs ints - sizes of payloads to be sent to other processes@@ -470,7 +473,7 @@ 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)+ (lengthsArr :: SA.StorableArray Int CInt) <- Fast.intoNewArray_ (0, numProcs-1) $ Fast.allgather comm (fromIntegral (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)@@ -497,7 +500,7 @@ alltoall :: (Serialize msg) => Comm -> [msg] -> IO [msg] alltoall comm msgs = do let enc_msgs = map encode msgs- sendLengths = map (cIntConv . BS.length) enc_msgs+ sendLengths = map (fromIntegral . BS.length) enc_msgs sendPayload = BS.concat enc_msgs isInter <- commTestInter comm numProcs <- if isInter then commRemoteSize comm else commSize comm@@ -512,4 +515,3 @@ -- 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
@@ -1,6 +1,8 @@ module Control.Parallel.MPI.Utils (asBool, asInt, asEnum, debugOut) where -import C2HS+import Foreign+import Foreign.C.Types+import System.IO.Unsafe as Unsafe asBool :: (Ptr CInt -> IO ()) -> IO Bool asBool f =@@ -14,16 +16,16 @@ alloca $ \ptr -> do f ptr res <- peek ptr- return $ cIntConv res+ return $ fromIntegral res asEnum :: Enum a => (Ptr CInt -> IO ()) -> IO a asEnum f = alloca $ \ptr -> do f ptr res <- peek ptr- return $ cToEnum res+ return $ toEnum $ fromIntegral res debugOut :: Show a => a -> Bool-debugOut x = unsafePerformIO $ do+debugOut x = Unsafe.unsafePerformIO $ do print x return False
src/cbits/constants.c view
@@ -40,6 +40,7 @@ MPI_CONST (int, mpi_universe_size, MPI_UNIVERSE_SIZE) MPI_CONST (char **, mpi_argv_null, MPI_ARGV_NULL) MPI_CONST (int *, mpi_errcodes_ignore, MPI_ERRCODES_IGNORE)+MPI_CONST (int, mpi_max_port_name, MPI_MAX_PORT_NAME) /* MPI predefined handles */ MPI_CONST (MPI_Comm, mpi_comm_world, MPI_COMM_WORLD)
test/CompileRunClean.hs view
@@ -23,7 +23,7 @@ module Main where import System.Environment (getArgs)-import System.Cmd (system)+import System.Process (system) import System.Exit (ExitCode (..), exitWith) import Control.Monad (when) import Data.List (isSuffixOf)
test/OtherTests.hs view
@@ -22,6 +22,8 @@ , testCase "queryThread" $ queryThreadTest threadSupport , testCase "test requestNull" $ testRequestNull , testCase "Info objects" $ testInfoObjects+ , testCase "anySource/anySize values" anySourceTagTest+ , testCase "openClosePort" openClosePortTest ] queryThreadTest :: ThreadSupport -> IO ()@@ -104,3 +106,15 @@ infoDelete i "foo" v'' <- infoGet i "foo" v'' == Nothing @? "Key 'foo' was not deleted"++anySourceTagTest :: IO ()+anySourceTagTest = do+ if (anySource) == (toEnum (-1)) then return ()+ else putStrLn ("anySource is not -1, but rather " ++ show anySource)+ if (anyTag) == (toEnum (-1)) then return ()+ else putStrLn ("anyTag is not -1, but rather " ++ show anyTag)++openClosePortTest :: IO ()+openClosePortTest = do+ port <- openPort infoNull+ closePort port
test/PrimTypeTests.hs view
@@ -4,8 +4,9 @@ import TestHelpers import Control.Parallel.MPI.Fast-import C2HS import Data.Typeable+import Foreign+import Foreign.C.Types primTypeTests :: Rank -> [(String,TestRunnerTest)] primTypeTests rank =@@ -26,11 +27,11 @@ , 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 "word8MinBound" (sendRecvSingleValTest (minBound :: Word8)) , mpiTestCase rank "word16MaxBound" (sendRecvSingleValTest (maxBound :: Word16))- , mpiTestCase rank "word16MinBound" (sendRecvSingleValTest (minBound :: Word16)) + , mpiTestCase rank "word16MinBound" (sendRecvSingleValTest (minBound :: Word16)) , mpiTestCase rank "word32MaxBound" (sendRecvSingleValTest (maxBound :: Word32))- , mpiTestCase rank "word32MinBound" (sendRecvSingleValTest (minBound :: 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))@@ -52,7 +53,7 @@ ] sendRecvSingleValTest :: forall a . (Typeable a, RecvInto (Ptr a), Repr a, SendFrom a, Storable a, Eq a, Show a) => a -> Rank -> IO ()-sendRecvSingleValTest val rank +sendRecvSingleValTest val rank | rank == 0 = send commWorld 1 unitTag (val :: a) | rank == 1 = do (result :: a, _status) <- intoNewVal $ recv commWorld 0 unitTag
+ test/examples/clientserver/Client.c view
@@ -0,0 +1,28 @@+#include <stdlib.h>+#include <stdio.h>+#include <string.h>+#include "mpi.h"++int main( int argc, char **argv )+{+ MPI_Comm server;+ char port_name[MPI_MAX_PORT_NAME];+ int i, tag;++ if (argc < 2) {+ fprintf(stderr, "server port name required.\n");+ exit(EXIT_FAILURE);+ }++ MPI_Init(&argc, &argv);+ strcpy(port_name, argv[1]); /* assume server's name is cmd-line arg */+ MPI_Comm_connect(port_name, MPI_INFO_NULL, 0, MPI_COMM_WORLD, &server);+ for (i = 0; i < 5; i++) {+ tag = 2; /* Action to perform */+ MPI_Send(&i, 1, MPI_INT, 0, tag, server);+ }+ MPI_Send(&i, 0, MPI_INT, 0, 1, server);+ MPI_Comm_disconnect(&server);+ MPI_Finalize();+ return 0;+}
+ test/examples/clientserver/Client.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- Based on the simple client-server example from page 326/327 of +-- "MPI Standard version 2.2"++module Main where++import System.Environment (getArgs)+import System.Exit+import Foreign.C.Types+import Control.Monad (forM_, when)+import Control.Parallel.MPI.Fast++main :: IO ()+main = do+ args <- getArgs+ when (length args /= 1) $ do+ putStr "server port name required.\n"+ exitWith (ExitFailure 1)+ sendRequest $ head args+ +sendRequest :: String -> IO ()+sendRequest port = mpi $ do+ server <- commConnect port infoNull 0 commWorld+ forM_ [0..4] $ \(i::CInt) -> send server 0 2 i+ send server 0 1 (0xdeadbeef::CInt)+ commDisconnect server
+ test/examples/clientserver/Server.c view
@@ -0,0 +1,45 @@+#include <stdlib.h>+#include <stdio.h>+#include "mpi.h"++int main(int argc, char **argv)+{+ MPI_Comm client;+ MPI_Status status;+ char port_name[MPI_MAX_PORT_NAME];+ int size, again, i;++ MPI_Init(&argc, &argv);+ MPI_Comm_size(MPI_COMM_WORLD, &size);+ if (size != 1) {+ fprintf(stderr, "Server too big");+ exit(EXIT_FAILURE);+ }++ MPI_Open_port(MPI_INFO_NULL, port_name);+ printf("Server available at port: %s\n", port_name);+ while (1) {+ MPI_Comm_accept(port_name, MPI_INFO_NULL, 0, MPI_COMM_WORLD, &client);+ again = 1;+ while (again) {+ MPI_Recv(&i, 1, MPI_INT, MPI_ANY_SOURCE, MPI_ANY_TAG, client, &status);+ switch (status.MPI_TAG) {+ case 0:+ MPI_Comm_free(&client);+ MPI_Close_port(port_name);+ MPI_Finalize();+ return 0;+ case 1:+ MPI_Comm_disconnect(&client);+ again = 0;+ break;+ case 2: /* do something */+ printf("Received: %d\n", i);+ break;+ default:+ /* Unexpected message type */+ MPI_Abort(MPI_COMM_WORLD, 1);+ }+ }+ }+}
+ test/examples/clientserver/Server.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- Based on the simple client-server example from page 326/327 of +-- "MPI Standard version 2.2"++module Main where++import System.Exit+import Foreign.C.Types+import Control.Monad (forever)+import Control.Parallel.MPI.Fast++main :: IO ()+main = mpi $ do+ size <- commSize commWorld+ if size == 1+ then do+ port <- openPort infoNull+ putStrLn $ "Server available at port: " ++ show port ++ "."+ forever $ do+ clientComm <- commAccept port infoNull 0 commWorld+ handleRequest port clientComm+ else putStrLn $ "Server too big."++handleRequest :: String -> Comm -> IO ()+handleRequest port client = do+ (msg::CInt, status) <- intoNewVal $ recv client anySource anyTag+ case (status_tag status) of+ 0 -> do+ commFree client+ closePort port+ exitWith (ExitFailure 1)+ 1 -> commDisconnect client+ 2 -> do+ putStrLn $ "Received: " ++ (show msg)+ handleRequest port client+ _ -> abort commWorld 1