diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -7,6 +7,8 @@ Use "cabal install --extra-include-dirs=/usr/include/mpi" or something similar. Make sure that you have libmpi.a and libmpi.so available. +When building against MPICH 1.4, pass extra flag "-fmpich14" + Testing ------- diff --git a/haskell-mpi.cabal b/haskell-mpi.cabal --- a/haskell-mpi.cabal +++ b/haskell-mpi.cabal @@ -1,5 +1,5 @@ name: haskell-mpi -version: 1.0.0 +version: 1.1.0 cabal-version: >= 1.6 synopsis: Distributed parallel programming in Haskell using MPI. description: @@ -95,8 +95,14 @@ description: Build testsuite and code coverage tests default: False +flag mpich14 + description: Link with extra libraries for MPICH 1.4 + default: False + Library extra-libraries: mpi + if flag(mpich14) + extra-libraries: mpl build-tools: c2hs ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans c-sources: @@ -128,6 +134,8 @@ ./src build-tools: c2hs extra-libraries: mpi + if flag(mpich14) + extra-libraries: mpl ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans c-sources: src/cbits/init_wrapper.c, diff --git a/src/Control/Parallel/MPI/Base.hs b/src/Control/Parallel/MPI/Base.hs --- a/src/Control/Parallel/MPI/Base.hs +++ b/src/Control/Parallel/MPI/Base.hs @@ -31,9 +31,10 @@ , Request , Status (..) , probe - , test - , cancel - , wait + , test, testPtr + , cancel, cancelPtr + , wait, waitPtr + , requestNull -- * Communicators and error handlers. , Comm diff --git a/src/Control/Parallel/MPI/Internal.chs b/src/Control/Parallel/MPI/Internal.chs --- a/src/Control/Parallel/MPI/Internal.chs +++ b/src/Control/Parallel/MPI/Internal.chs @@ -38,7 +38,7 @@ getProcessorName, Version (..), getVersion, Implementation(..), getImplementation, -- * Requests and statuses. - Request, Status (..), probe, test, cancel, wait, waitall, + Request, Status (..), probe, test, testPtr, cancel, cancelPtr, wait, waitPtr, waitall, requestNull, -- * Process management. -- ** Communicators. @@ -439,10 +439,15 @@ -- | 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*- #} +-- This function corresponds to @MPI_Wait@. Request pointer could +-- be changed to point to @requestNull@. See @wait@ for variant that does not mutate request value. +{# fun unsafe Wait as waitPtr + {castPtr `Ptr Request', allocaCast- `Status' peekCast*} -> `()' checkError*- #} +-- | Same as @waitPtr@, but does not change Haskell @Request@ value to point to @procNull@. +-- Usually, this is harmless - your request just would be considered inactive. +wait request = withRequest request waitPtr + -- | 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 ^ @@ -451,22 +456,42 @@ -- | 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. +-- it returns @Just status@. +-- +-- Note that while MPI would modify +-- request to be @requestNull@ if the operation is complete, +-- Haskell value would not be changed. So, if you got (Just status) +-- as a result, consider your request to be @requestNull@. Or use @testPtr@. +-- +-- See 'wait' for a blocking variant. -- This function corresponds to @MPI_Test@. test :: Request -> IO (Maybe Status) -test request = do - (flag, status) <- test' request +test request = withRequest request testPtr + +-- | 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 + request' <- peek reqPtr 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*- #} + 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*- #} -- | Cancel a pending communication request. --- This function corresponds to @MPI_Cancel@. -{# fun unsafe Cancel as ^ - {withRequest* `Request'} -> `()' checkError*- #} +-- This function corresponds to @MPI_Cancel@. Sets pointer to point to @requestNull@. +{# fun unsafe Cancel as cancelPtr + {castPtr `Ptr Request'} -> `()' checkError*- #} + + +-- | Same as @cancelPtr@, but does not change Haskell @Request@ value to point to @procNull@. +-- Usually, this is harmless - your request just would be considered inactive. +cancel request = withRequest request cancelPtr + withRequest req f = do alloca $ \ptr -> do poke ptr req f (castPtr ptr) @@ -969,9 +994,10 @@ | 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 Int +foreign import ccall "&mpi_root" theRoot_ :: Ptr Int +foreign import ccall "&mpi_proc_null" procNull_ :: Ptr Int +foreign import ccall "&mpi_request_null" requestNull_ :: Ptr MPIRequest -- | Predefined rank number that allows reception of point-to-point messages -- regardless of their source. Corresponds to @MPI_ANY_SOURCE@ @@ -988,6 +1014,11 @@ procNull :: Rank procNull = toRank $ unsafePerformIO $ peek procNull_ +-- | Predefined request handle value that specifies non-existing or finished request. +-- Corresponds to @MPI_REQUEST_NULL@ +requestNull :: Request +requestNull = unsafePerformIO $ peekRequest requestNull_ + instance Show Rank where show = show . rankId @@ -1003,7 +1034,7 @@ {-| 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 +newtype Request = MkRequest MPIRequest deriving (Storable,Eq) peekRequest ptr = MkRequest <$> peek ptr {- diff --git a/src/cbits/constants.c b/src/cbits/constants.c --- a/src/cbits/constants.c +++ b/src/cbits/constants.c @@ -25,6 +25,7 @@ /* Misc */ MPI_CONST (int, mpi_any_source, MPI_ANY_SOURCE) MPI_CONST (int, mpi_proc_null, MPI_PROC_NULL) +MPI_CONST (MPI_Request, mpi_request_null, MPI_REQUEST_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) diff --git a/test/OtherTests.hs b/test/OtherTests.hs --- a/test/OtherTests.hs +++ b/test/OtherTests.hs @@ -6,6 +6,7 @@ import Foreign.Marshal (alloca) import Foreign.C.Types (CInt) import Control.Parallel.MPI.Base +import Data.Maybe (isJust) otherTests :: ThreadSupport -> Rank -> [(String,TestRunnerTest)] otherTests threadSupport _ = @@ -17,6 +18,7 @@ , testCase "finalized" finalizedTest , testCase "tag value upper bound" tagUpperBoundTest , testCase "queryThread" $ queryThreadTest threadSupport + , testCase "test requestNull" $ testRequestNull ] queryThreadTest :: ThreadSupport -> IO () @@ -68,3 +70,13 @@ tagUpperBoundTest = do putStrLn $ "Maximum tag value is " ++ show tagUpperBound tagUpperBound /= (-1) @? "tagUpperBound has no value" + +testRequestNull :: IO () +testRequestNull = do + status <- test requestNull + isJust status @? "test requestNull does not return status" + let (Just s) = status + status_source s == anySource @? "status returned from (test requestNull) does not have source set to anySource" + status_tag s == anyTag @? "status returned from (test requestNull) does not have tag set to anyTag" + status_error s == 0 @? "status returned from (test requestNull) does not have error set to success" + diff --git a/test/SimpleTests.hs b/test/SimpleTests.hs --- a/test/SimpleTests.hs +++ b/test/SimpleTests.hs @@ -1,10 +1,11 @@ -module SimpleTests (simpleTests) where +module SimpleTests where import TestHelpers import Control.Parallel.MPI.Simple import Control.Concurrent (threadDelay) import Data.Serialize () +import Data.Maybe (isJust) root :: Rank root = 0 @@ -13,12 +14,13 @@ simpleTests rank = [ mpiTestCase rank "send+recv simple message" $ syncSendRecv send , mpiTestCase rank "send+recv simple message (with sending process blocking)" syncSendRecvBlock + , mpiTestCase rank "send+recv simple message using anySource" $ syncSendRecvAnySource send , 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+recv two messages + test instead of wait" 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 @@ -28,7 +30,7 @@ , mpiTestCase rank "allgather message" allgatherTest , mpiTestCase rank "alltoall message" alltoallTest ] -syncSendRecv :: (Comm -> Rank -> Tag -> SmallMsg -> IO ()) -> Rank -> IO () +syncSendRecv, syncSendRecvAnySource :: (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 () @@ -45,6 +47,13 @@ result == smallMsg @? "Got garbled result " ++ show result | otherwise = return () -- idling +syncSendRecvAnySource sendf rank + | rank == sender = sendf commWorld receiver 234 smallMsg + | rank == receiver = do (result, status) <- recv commWorld anySource 234 + checkStatus status sender 234 + 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 @@ -85,7 +94,10 @@ asyncSendRecv2 rank | rank == sender = do req1 <- isend commWorld receiver 123 smallMsg req2 <- isend commWorld receiver 456 bigMsg - stat1 <- wait req1 + threadDelay (10^(6 :: Integer)) + status <- test req1 + isJust status @? "Got Nothing out of test, expected Just" + let Just stat1 = status checkStatusIfNotMPICH2 stat1 sender 123 stat2 <- wait req2 checkStatusIfNotMPICH2 stat2 sender 456