packages feed

haskell-mpi 1.0.0 → 1.1.0

raw patch · 7 files changed

+94/−27 lines, 7 files

Files

README.txt view
@@ -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 -------
haskell-mpi.cabal view
@@ -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,
src/Control/Parallel/MPI/Base.hs view
@@ -31,9 +31,10 @@    , Request    , Status (..)    , probe-   , test-   , cancel-   , wait+   , test, testPtr+   , cancel, cancelPtr+   , wait, waitPtr+   , requestNull     -- * Communicators and error handlers.    , Comm
src/Control/Parallel/MPI/Internal.chs view
@@ -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  {-
src/cbits/constants.c view
@@ -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)
test/OtherTests.hs view
@@ -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"+
test/SimpleTests.hs view
@@ -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