packages feed

haskell-mpi 0.5.0 → 1.0.0

raw patch · 17 files changed

+669/−2 lines, 17 files

Files

haskell-mpi.cabal view
@@ -1,5 +1,5 @@ name:                haskell-mpi-version:             0.5.0+version:             1.0.0 cabal-version:       >= 1.6 synopsis:            Distributed parallel programming in Haskell using MPI. description:@@ -69,7 +69,7 @@ category:            FFI, Distributed Computing license:             BSD3 license-file:        LICENSE-copyright:           (c) 2010 Bernard James Pope+copyright:           (c) 2010 Bernard James Pope, Dmitry Astapov author:              Bernard James Pope (Bernie Pope) maintainer:          florbitous@gmail.com homepage:            http://github.com/bjpop/haskell-mpi@@ -77,6 +77,15 @@ stability:           experimental tested-with:         GHC==6.10.4, GHC==6.12.1 extra-source-files:  src/cbits/*.c src/include/*.h README.txt+                     test/examples/HaskellAndC/Makefile+                     test/examples/HaskellAndC/*.c+                     test/examples/HaskellAndC/*.hs+                     test/examples/PiByIntegration/*.hs+                     test/examples/PiByIntegration/*.test+                     test/examples/simple/*.hs+                     test/examples/simple/*.test+                     test/examples/speed/*.hs+                     test/examples/speed/simple-api/*.hs  source-repository head   type: git
+ test/examples/HaskellAndC/Makefile view
@@ -0,0 +1,25 @@+EXE = rank0C rank1C rank0H rank1H+all: $(EXE)++# Set C compiler to use -m32 if ghc is set to produce 32 bit executables+# as is usually (always?) the case on OS X and ghc 6.12++rank0C: Rank0.c+	mpicc -O2 -Wall Rank0.c -o rank0C+#	mpicc -m32 -O2 -Wall Rank0.c -o rank0C++rank1C: Rank1.c+	mpicc -O2 -Wall Rank1.c -o rank1C+#	mpicc -m32 -O2 -Wall Rank0.c -o rank0C++rank0H: Rank0.hs+	ghc --make -O2 Rank0.hs -o rank0H++rank1H: Rank1.hs+	ghc --make -O2 Rank1.hs -o rank1H++clean:+	/bin/rm -f *.o *.hi++clobber: clean+	/bin/rm -f $(EXE)
+ test/examples/HaskellAndC/Rank0.c view
@@ -0,0 +1,39 @@+#include <mpi.h>+#include <stdio.h>++#define MAX_MSG 100++int main(int argc, char **argv)+{+   int rank, size, i;+   int msg[MAX_MSG];+   MPI_Status status;++   MPI_Init(NULL, NULL);+   MPI_Comm_rank(MPI_COMM_WORLD, &rank);+   MPI_Comm_size(MPI_COMM_WORLD, &size);++   printf("C process with rank %d world with size %d\n", rank, size);++   if (rank == 0)+   {+      for (i = 0; i < MAX_MSG; i++)+      {+         msg[i] = i+1;+      }+      MPI_Send(msg, MAX_MSG, MPI_INT, 1, 0, MPI_COMM_WORLD);+      MPI_Recv(msg, MAX_MSG, MPI_INT, 1, 0, MPI_COMM_WORLD, &status);++      for (i = 0; i < MAX_MSG; i++)+      {+         printf("%d ", msg[i]);+      }+   }+   else+   {+      printf ("This program must be rank 0\n");+   }+   MPI_Finalize();++   return 0;+}
+ test/examples/HaskellAndC/Rank0.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Fast+import Data.Array.Storable+import Foreign.C.Types (CInt)++type Msg = StorableArray Int CInt+bounds :: (Int, Int)+bounds@(lo,hi) = (1,100)+tag :: Tag+tag = 0++main :: IO ()+main = mpiWorld $ \size rank -> do+   putStrLn $ "Haskell process with rank " ++ show rank ++ " world with size " ++ show size+   if rank == 0+      then do+         (msg :: Msg) <- newListArray bounds [fromIntegral lo .. fromIntegral hi]+         send commWorld 1 tag msg+         _status <- recv commWorld 1 tag msg+         elems <- getElems msg+         putStrLn $ unwords $ map show elems+      else+         putStrLn "This program must be rank 0"
+ test/examples/HaskellAndC/Rank1.c view
@@ -0,0 +1,34 @@+#include <mpi.h>+#include <stdio.h>++#define MAX_MSG 100++int main(int argc, char **argv)+{+   int rank, size, i;+   int msg[MAX_MSG];+   MPI_Status status;++   MPI_Init(NULL, NULL);+   MPI_Comm_rank(MPI_COMM_WORLD, &rank);+   MPI_Comm_size(MPI_COMM_WORLD, &size);++   printf("C process with rank %d world with size %d\n", rank, size);++   if (rank == 1)+   {+      MPI_Recv(msg, MAX_MSG, MPI_INT, 0, 0, MPI_COMM_WORLD, &status);+      for (i = 0; i < MAX_MSG; i++)+      {+         msg[i] *= msg[i];+      }+      MPI_Send(msg, MAX_MSG, MPI_INT, 0, 0, MPI_COMM_WORLD);+   }+   else+   {+      printf ("This program must be rank 1\n");+   }+   MPI_Finalize();++   return 0;+}
+ test/examples/HaskellAndC/Rank1.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Fast+import Data.Array.Storable+import Foreign.C.Types (CInt)+import Control.Monad (forM_)++type Msg = StorableArray Int CInt+bounds :: (Int, Int)+bounds@(lo,hi) = (1,100)+tag :: Tag+tag = 0++main :: IO ()+main = mpiWorld $ \size rank -> do+   putStrLn $ "Haskell process with rank " ++ show rank ++ " world with size " ++ show size+   if rank == 1+      then do+         (msg :: Msg) <- newArray bounds 0+         _status <- recv commWorld 0 tag msg+         forM_ [lo .. hi] $ \i -> do+            val <- readArray msg i+            writeArray msg i (val*val)+         send commWorld 0 tag msg+      else+         putStrLn "This program must be rank 1"
+ test/examples/PiByIntegration/Pi.hs view
@@ -0,0 +1,55 @@+{-+   This program calculates Pi by integrating+   f(x) = 4 / (1 + x^2)+   in the range 0 <= x <= 1.++   It is not a particularly clever or efficient way+   to caculuate Pi. Rather it is intended to demonstrate+   a simple use of MPI.+-}++module Main where++import Control.Parallel.MPI.Simple+import Data.Char (isDigit)+import Text.Printf++main :: IO ()+main = mpiWorld $ \size rank -> do+   let root = 0+   n <- if rank == root+           then do+              input <- getNumber+              bcastSend commWorld root input+              return input+           else+              bcastRecv commWorld root+   let part = integrate (fromRank rank + 1) size n (1 / fromIntegral n)+   if rank == root+      then do+         parts <- gatherRecv commWorld root part+         printf "%1.8f\n" $ sum parts+      else+         gatherSend commWorld root part++integrate :: Int -> Int -> Int -> Double -> Double+integrate rank size n h =+   -- XXX superfluous type annotation needed to work around+   -- confirmed GHC bug, see ticket #4321+   -- http://hackage.haskell.org/trac/ghc/ticket/4321+   -- (nothng to do with MPI)+   h * (sum (map area steps) :: Double)+   where+   steps = [rank, rank + size .. n]+   area :: Int -> Double+   area i+      = 4 / (1 + x * x)+      where+      x = h * (fromIntegral i - 0.5)++getNumber :: IO Int+getNumber = do+   line <- getLine+   if all isDigit line+      then return $ read line+      else return 0
+ test/examples/PiByIntegration/Pi.test view
@@ -0,0 +1,7 @@+haskell-mpi-comprunclean -np 2 Pi.hs+<<<+10+>>>+3.14242599+>>>2+>>>=0
+ test/examples/PiByIntegration/PiSerial.hs view
@@ -0,0 +1,20 @@+module Main where++import Control.Applicative ((<$>))+import System (getArgs)++main :: IO ()+main = do+   n <- read <$> head <$> getArgs+   print $ integrate n (1 / fromIntegral n)++integrate :: Int -> Double -> Double+integrate n h =+   h * (sum (map area [1..n]) :: Double)+   -- h * (sum (map area [1..n]))+   where+   area :: Int -> Double+   area i+      = 4 / (1 + x*x)+      where+      x = h * (fromIntegral i - 0.5)
+ test/examples/simple/Greetings.hs view
@@ -0,0 +1,16 @@+-- Based on the example program from page 41/42 of +-- Pacheco "Parallel programming with MPI"++module Main where++import Control.Parallel.MPI.Simple++main :: IO ()+main = mpiWorld $ \_size rank -> do+   let root = 0+   if rank == root+      then mapM_ putStrLn =<< (gatherRecv commWorld root $ msg rank)+      else gatherSend commWorld root $ msg rank++msg :: Rank -> String+msg r = "Greetings from process " ++ show r ++ "!"
+ test/examples/simple/Greetings.test view
@@ -0,0 +1,15 @@+haskell-mpi-comprunclean -np 10 Greetings.hs+<<<+>>>+Greetings from process 0!+Greetings from process 1!+Greetings from process 2!+Greetings from process 3!+Greetings from process 4!+Greetings from process 5!+Greetings from process 6!+Greetings from process 7!+Greetings from process 8!+Greetings from process 9!+>>>2+>>>=0
+ test/examples/simple/PingPongFactorial.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+   Ping Pong Factorial.++   Two processes calculate the factorial of the input.++   Note: this is not a fast, nor sensible way to compute factorials.+   It is merely intended to be used to demonstrate point-to-point+   communications.+-}+module Main where++import Control.Monad (when)+import Control.Parallel.MPI.Simple+import Control.Applicative ((<$>))+import Data.Char (isDigit)++type Msg = Either (Integer, Integer, Integer) Integer++zero, one :: Rank+zero = 0+one = 1++main :: IO ()+main = mpiWorld $ \size rank -> do+   when (size == 2) $ do+      when (rank == zero) $ do+         n <- getNumber+         send commWorld one unitTag (Left (n, 0, 1) :: Msg)+      result <- factorial $ switch rank+      when (rank == zero) $ print result++factorial :: Rank -> IO Integer+factorial rank = do+   (msg :: Msg) <- fst <$> recv commWorld rank unitTag+   case msg of+      Right answer -> return answer+      Left (n, count, acc)+         | count == n -> do+              send commWorld rank unitTag (Right acc :: Msg)+              return acc+         | otherwise -> do+              let nextCount = count + 1+              send commWorld rank unitTag (Left (n, nextCount, nextCount * acc) :: Msg)+              factorial rank++switch :: Rank -> Rank+switch rank+   | rank == zero = one+   | otherwise = zero++getNumber :: IO Integer+getNumber = do+    line <- getLine+    if all isDigit line+       then return $ read line+       else return 0
+ test/examples/simple/PingPongFactorial.test view
@@ -0,0 +1,7 @@+haskell-mpi-comprunclean -np 2 PingPongFactorial.hs+<<<+100+>>>+93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000+>>>2+>>>=0
+ test/examples/speed/AllToAll.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Fast+import Foreign (sizeOf)+import Foreign.C.Types+import Text.Printf+import Control.Monad+import System.Time+import Data.IORef+import Data.Array.Storable++benchmark="OSU MPI All-to-All Personalized Exchange Latency Test"++max_msg_size = 2^20+skip_normal = 300+iterations_normal = 1000+skip_large = 10+iterations_large = 100+max_alignment = 16384+large_message_size = 8192++field_width = 20+float_precision = 2++get_us :: IO Integer+get_us = do+  (TOD sec picosec) <- getClockTime+  return (sec*1000000000000 + picosec)++main = mpi $ do+  rank <- commRank commWorld+  numprocs <- commSize commWorld+  +  let bufferSize = sizeOf ( undefined :: CChar ) * max_msg_size * numprocs + max_alignment+  +  (sendbuf :: StorableArray Int CChar) <- newArray (1,bufferSize) 0+  (recvbuf :: StorableArray Int CChar) <- newArray (1,bufferSize) 0+  +  -- align_size <- getPageSize++  when (rank == 0) $ do+    putStrLn $ printf "# %s" benchmark+    putStrLn $ printf "%-10s%20s\n" "# Size" "Latency (us)"++  barrier commWorld+  forM_ (takeWhile (<= max_msg_size) $ iterate (*2) 1) $ \size -> do+    let (skip, iterations) = if size > large_message_size+                             then (skip_large, iterations_large)+                             else (skip_normal, iterations_normal)+    t1ref <- newIORef 0+    forM_ (takeWhile (< (iterations+skip)) [0..]) $ \i -> do+      when (i == skip) $ do t <- wtime+                            writeIORef t1ref t+      alltoall commWorld sendbuf size recvbuf+    +    when (rank == 0) $ do+      t2 <- wtime+      t1 <- readIORef t1ref+      putStrLn $ printf ("%-10d%" ++ show field_width ++ "." ++ show float_precision ++ "f") size ((t2-t1)/(fromIntegral iterations)*1e6 :: Double)+    +  return ()
+ test/examples/speed/Bandwidth.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Fast+import Data.Array.Storable+import System.Exit++import Foreign.C.Types+import Foreign.Marshal.Array (advancePtr)+import Control.Monad+import Data.IORef+import Text.Printf++benchmark = "OSU MPI Bandwidth Test"++max_req_num = 1000++max_alignment = 65536+max_msg_size = 2^22+mybufsize = (max_msg_size + max_alignment)++loop_normal = 100+window_size_normal = 64+skip_normal = 10++loop_large = 20+window_size_large = 64+skip_large = 2++large_message_size = 8192++field_width = 20+float_precision = 2++main = mpi $ do++  myid <- commRank commWorld+  numprocs <- commSize commWorld++  when (numprocs /= 2) $ do+    when (myid == 0) $ do+      putStrLn "This test requires exactly two processes"+    exitWith (ExitFailure 1)++  when (myid == 0) $ do+    putStrLn $ printf "# %s" benchmark+    putStrLn $ printf "%-10s%20s\n" "# Size" "Bandwidth (MB/s)"++  forM_ (takeWhile (<= max_msg_size) $ iterate (*2) 1) $ \size -> do+    s_buf :: StorableArray Int CChar <- newArray (1,size) 666+    r_buf :: StorableArray Int CChar <- newArray (1,size) 999+    +    let (loop, skip, window_size) = if (size > large_message_size) +                                    then (loop_large, skip_large, window_size_large)+                                    else (loop_normal, skip_normal, window_size_normal)+    +    request :: StorableArray Int Request <- newArray_ (1,window_size)+    reqstat :: StorableArray Int Status  <- newArray_ (1,window_size)++    withStorableArray request $ \reqPtr -> do+      tref <- newIORef 0+      if myid == 0 then do+        forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do+          when (i == skip) $ do+            t_start <- wtime+            writeIORef tref t_start++          forM_ (takeWhile (<window_size) [0..]) $ \j ->+            isendPtr commWorld 1 100 (advancePtr reqPtr j) s_buf++          waitall request reqstat++          (deadbeef::CInt) <- intoNewVal_ $ recv commWorld 1 101+          return ()++        t_end <- wtime+        t_start <- readIORef tref+        let t = t_end - t_start+            total :: Integer = fromIntegral size * fromIntegral loop * fromIntegral window_size+            tmp = (fromIntegral $ total)/1e6;+        putStrLn $ printf ("%-10d%" ++ show field_width ++ "." ++ show float_precision ++ "f") size (tmp / t)+        else do -- myid == 1+        forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do++          forM_ (takeWhile (<window_size) [0..]) $ \j -> do+            irecvPtr commWorld 0 100 (advancePtr reqPtr j) r_buf++          waitall request reqstat+          send commWorld 0 101 (0xdeadbeef::CInt)
+ test/examples/speed/BidirectionalBandwidth.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Fast+import Data.Array.Storable+import System.Exit++import Foreign.C.Types+import Foreign.Marshal.Array (advancePtr)+import Control.Monad+import Data.IORef+import Text.Printf++benchmark = "OSU MPI Bi-Directional Bandwidth Test"++max_req_num = 1000++max_alignment = 65536+max_msg_size = 2^22+mybufsize = (max_msg_size + max_alignment)++loop_normal = 100+window_size_normal = 64+skip_normal = 10++loop_large = 20+window_size_large = 64+skip_large = 2++large_message_size = 8192++field_width = 20+float_precision = 2++main = mpi $ do++  myid <- commRank commWorld+  numprocs <- commSize commWorld++  when (numprocs /= 2) $ do+    when (myid == 0) $ do+      putStrLn "This test requires exactly two processes"+    exitWith (ExitFailure 1)++  when (myid == 0) $ do+    putStrLn $ printf "# %s" benchmark+    putStrLn $ printf "%-10s%20s\n" "# Size" "Bi-Bandwidth (MB/s)"++  forM_ (takeWhile (<= max_msg_size) $ iterate (*2) 1) $ \size -> do+    s_buf :: StorableArray Int CChar <- newArray (1,size) 666+    r_buf :: StorableArray Int CChar <- newArray (1,size) 999+    let (loop, skip, window_size) = if (size > large_message_size) +                                    then (loop_large, skip_large, window_size_large)+                                    else (loop_normal, skip_normal, window_size_normal)+    +    recv_request :: StorableArray Int Request <- newArray_ (1,window_size)+    send_request :: StorableArray Int Request <- newArray_ (1,window_size)+    reqstat      :: StorableArray Int Status  <- newArray_ (1,window_size)++    withStorableArray send_request $ \sendReqPtr ->+      withStorableArray recv_request $ \recvReqPtr -> do+        tref <- newIORef 0+        if myid == 0 then do+          forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do+            when (i == skip) $ do+              t_start <- wtime+              writeIORef tref t_start++            forM_ (takeWhile (<window_size) [0..]) $ \j ->+              irecvPtr commWorld 1 10 (advancePtr recvReqPtr j) r_buf+            forM_ (takeWhile (<window_size) [0..]) $ \j ->+              isendPtr commWorld 1 100 (advancePtr sendReqPtr j) s_buf++            waitall send_request reqstat+            waitall recv_request reqstat++            return ()+          t_end <- wtime+          t_start <- readIORef tref+          let t = t_end - t_start+              total :: Integer = fromIntegral size * fromIntegral loop * fromIntegral window_size * 2+              tmp = (fromIntegral $ total)/1e6;+          putStrLn $ printf ("%-10d%" ++ show field_width ++ "." ++ show float_precision ++ "f") size (tmp / t)+          else do -- myid == 1+          forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do++            forM_ (takeWhile (<window_size) [0..]) $ \j -> do+              irecvPtr commWorld 0 100 (advancePtr recvReqPtr j) r_buf+            forM_ (takeWhile (<window_size) [0..]) $ \j -> do+              isendPtr commWorld 0 10 (advancePtr sendReqPtr j) s_buf++            waitall send_request reqstat+            waitall recv_request reqstat
+ test/examples/speed/simple-api/Bandwidth.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Parallel.MPI.Simple+import System.Exit++import Foreign.C.Types+import Data.Int+import Control.Monad+import Data.IORef+import Text.Printf+import Data.Array.Storable++import qualified Data.ByteString.Char8 as BS++benchmark = "OSU MPI Bandwidth Test (Serializable)"++max_req_num = 1000++max_alignment = 65536+max_msg_size = 2^22+mybufsize = (max_msg_size + max_alignment)++loop_normal = 100+window_size_normal = 64+skip_normal = 10++loop_large = 20+window_size_large = 64+skip_large = 2++large_message_size = 8192++field_width = 20+float_precision = 2++main = mpi $ do++  myid <- commRank commWorld+  numprocs <- commSize commWorld++  when (numprocs /= 2) $ do+    when (myid == 0) $ do+      putStrLn "This test requires exactly two processes"+    exitWith (ExitFailure 1)++  when (myid == 0) $ do+    putStrLn $ printf "# %s" benchmark+    putStrLn $ printf "%-10s%20s\n" "# Size" "Bandwidth (MB/s)"++  forM_ (takeWhile (<= max_msg_size) $ iterate (*2) 1) $ \size -> do+    let s_buf :: BS.ByteString = BS.replicate size 's'+    +    let (loop, skip, window_size) = if (size > large_message_size) +                                    then (loop_large, skip_large, window_size_large)+                                    else (loop_normal, skip_normal, window_size_normal)+    +    tref <- newIORef 0+    if myid == 0 then do+      forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do+        when (i == skip) $ do+          t_start <- wtime+          writeIORef tref t_start++        requests <- forM (takeWhile (<window_size) [0..]) $ \j ->+          isend commWorld 1 100 s_buf++        waitall requests++        (deadbeef::Int, _) <- recv commWorld 1 101+        return ()++      t_end <- wtime+      t_start <- readIORef tref+      let t = t_end - t_start+          total :: Integer = fromIntegral size * fromIntegral loop * fromIntegral window_size+          tmp = (fromIntegral $ total)/1e6;+      putStrLn $ printf ("%-10d%" ++ show field_width ++ "." ++ show float_precision ++ "f") size (tmp / t)+      else do -- myid == 1+      forM_ (takeWhile (< loop+skip) [0..]) $ \i -> do++        futures :: [Future BS.ByteString] <- forM (takeWhile (<window_size) [0..]) $ \j -> do+          recvFuture commWorld 0 100 ++        mapM_ waitFuture futures+        send commWorld 0 101 (0xdeadbeef::Int)