add warshall benchmark
authorSimon Marlow <marlowsd@gmail.com>
Tue, 28 Apr 2009 12:10:28 +0000 (12:10 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Tue, 28 Apr 2009 12:10:28 +0000 (12:10 +0000)
parallel/warshall/Makefile [new file with mode: 0644]
parallel/warshall/warshall.hs [new file with mode: 0644]

diff --git a/parallel/warshall/Makefile b/parallel/warshall/Makefile
new file mode 100644 (file)
index 0000000..2048760
--- /dev/null
@@ -0,0 +1,19 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += 400 400
+SRC_HC_OPTS += -package parallel
+
+include $(TOP)/mk/target.mk
diff --git a/parallel/warshall/warshall.hs b/parallel/warshall/warshall.hs
new file mode 100644 (file)
index 0000000..a51860d
--- /dev/null
@@ -0,0 +1,179 @@
+{-# OPTIONS -cpp #-}
+{- 
+    warshall*.hs
+
+Finding Shortest Paths in a Graph using the 
+Warshall algorithm and a ring topology.
+
+author: Rita Loogen, Jost Berthold
+        Philipps-Universit├Ąt Marburg
+
+based on a  concurrent Clean program in \cite{CleanBook}
+
+Version for recursive ring skeleton and GpH-style ring,
+to use in IFL08 paper on Parallel-Haskell-on-multicore.
+
+------------------------------------------------- -}
+
+module Main(main) where
+import List
+import System
+import Data.List
+
+-- import Eden
+
+-- import EdenRing(badRing',ring,ringRec)
+-- import EdiRing(edirings,ediringnames)
+
+-- import PipeRings
+
+#ifdef EAGER
+import StrategiesEager(parList)
+#else
+import Control.Parallel.Strategies
+#endif
+
+--rings     = {- [seqring,badRing',ring,ringRec] ++ edirings ++ piperings 
+--             ++ -} [gphRing] -- ring size parameter == total no. of sparks
+
+-- ringnames = {- ["seq. ring","Eden badRing'","Eden ring","Eden ringRec"]
+--         ++ ediringnames ++ piperingNames ++ -} ["GpH ring"]
+
+-- gph ring, simply by sparking all ring process outputs
+-- (granularity control by ring size)
+gphRing np splitIn combOut ringF input 
+    =  combOut (outs `using` parList rnf )
+    where ringIns      = splitIn np input
+         (outs,rComm) = foldl' fld ([],rComm) ringIns
+--       fld :: ([o],[r]) -> i -> ([o],[r])
+          fld (outs,rIn) inp = let (out,rOut) = ringF (inp,rIn)
+                               in (out:outs, rOut)
+
+
+-- reference: sequential version
+seqring np splitIn combOut ringF input 
+    = combOut outs
+    where ringIns      = splitIn np input
+         (outs,rComm) = foldl' fld ([],rComm) ringIns
+--       fld :: ([o],[r]) -> i -> ([o],[r])
+          fld (outs,rIn) inp = let (out,rOut) = ringF (inp,rIn)
+                               in (out:outs, rOut)
+
+type Matrix a = [[a]]
+dim :: Matrix a -> Int
+dim = length
+
+-- warshallRing' :: Int -> Matrix Int -> Matrix Int
+-- warshallRing' _ mat = warshallRing (mat, dim mat) 
+-- 
+-- -- ring size = matrix dimension
+-- warshallRing :: (Matrix Int,Int) -> Matrix Int
+-- warshallRing (mat,n) = ring (length mat) split concat rf (mat,n)
+--   where 
+--      split n (mat,_) = zip (splitIntoN n mat) [1..n]
+--      rf  (([row],k), inpleft)  = ([sol],outp) 
+--              where (sol,outp) =  ring_iterate (length row) k 1 row inpleft
+
+-- ring size = parameter np
+wr2 :: Int -> Matrix Int -> Matrix Int
+--wr2 v _ mat | (v == length ringnames - 1) 
+--                -- treat as a special case, want many more sparks!
+--                = wr_ gphRing (length mat) mat
+wr2 np mat = wr_ gphRing np mat
+
+-- wr_ :: ring skel type -> Int -> Matrix Int -> Matrix Int
+wr_ ring np mat = ring np split concat ringf (mat,0) -- ring type issue, 0 is dummy parameter
+    where split :: Int -> (Matrix Int, Int) -> [ (Matrix Int,    Int      )]
+      --       ring size  all input    [ (some rows ,no. of 1st row)]
+         split n (mat,_) = let inputrows = splitIntoN n mat -- [[r1..rk],[r(k+1)..r(2k)]..[r(i*k)..r(dim mat)]]
+                           in zip inputrows  (scanl (+) 1 (map length inputrows)) -- should be "(init (scanl (+)...)"
+         ringf :: ((Matrix Int, Int), [[Int]] )  -> ( Matrix Int  ,   [[Int]])
+      --           ((some rows,start),more rows)  -> ( result rows , rows for ring)
+         ringf ((rows,startrow), fromLeft) = create_procs (length $ head rows) startrow rows fromLeft -- 
+
+-- sequential version from Clean book
+warshall :: Int -> Matrix Int -> Matrix Int
+warshall  _ mat = solution 
+    where (solution, output) = create_procs (length mat) 1 mat output
+
+create_procs :: Int -> Int -> Matrix Int -> [[Int]] -> ([[Int]],[[Int]])
+create_procs size k [rowN] inputleft = ([rowNsolution], output)
+    where (rowNsolution, output) = ring_iterate size k 1 rowN inputleft
+create_procs size k (rowk:restmat) inputleft = (rowksolution:restsolutions, outputN)
+    where (rowksolution, outputk) = ring_iterate size k 1 rowk inputleft
+         (restsolutions, outputN) = create_procs size (k+1) restmat outputk
+
+ring_iterate :: Int -> Int -> Int -> [Int] -> [[Int]] -> ([Int],[[Int]])
+ring_iterate size k i rowk rows 
+    | i > size =  (rowk, []) --iterations_finished
+    | i == k   =  (solution, rowk:restoutput) --  start_sending_this_row
+    | otherwise = (solution, rowi:restoutput)
+    where rowi:xs = rows
+         (solution, restoutput) = rnf nextrowk `seq` 
+                                  ring_iterate size k (i+1) nextrowk xs
+         nextrowk | i == k = rowk -- no update for own row 
+                  | otherwise = updaterow rowk rowi distki
+         distki  = rowk!!(i-1)
+
+--updaterow :: 
+updaterow [] rowi distij = [] 
+updaterow (distjk:restrowj) (distik:restrowi) distji
+       = min distjk (distji + distik):updaterow restrowj restrowi distji
+
+-------------------------------------------------------------------------------
+
+usage :: String
+usage = "Usage:\n" ++
+       "\t #> warshall <size> <ring size: default noPe> <..rest is ignored..>\n"
+
+main =  do [size,noPe] <- fmap (map read) getArgs
+           let res = wr2 noPe (m1 size)
+           -- print res 
+           rnf res `seq` putStrLn "done"
+
+test6 :: Matrix Int
+test6 = [[ 0, 100, 100, 13, 100, 100], [100, 0, 100, 100, 4,9],
+         [11, 100, 0, 100, 100, 100], [100, 3, 100, 0, 100, 7],
+         [15, 5, 100, 1, 0, 100], [11, 100, 100, 14, 100, 0]]
+{-
+Adjacency Matrix                         Shortest Paths:
+
+         - - To - - 
+   [[  0 , 100, 100,  13, 100, 100],        [[ 0,16,100,13,20,20],
+ F  [100 ,   0, 100, 100,   4,   9],         [19, 0,100, 5, 4, 9],
+ r  [ 11 , 100,   0, 100, 100, 100],         [11,27,  0,24,31,31],
+ o  [100 ,   3, 100,   0, 100,   7],         [18, 3,100, 0, 7, 7],
+ m  [ 15 ,   5, 100,   1,   0, 100],         [15, 4,100, 1, 0, 8],
+    [ 11 , 100, 100,  14, 100,   0]]         [11,17,100,14,21, 0]]
+-}
+test3 :: [[Int]]
+test3 = [[0,1,100],[1,0,1],[100,1,0]]   
+
+m1 size = replicate size [1..size]
+m2 size = listToListList size [1..size*size]
+mA size = if size <= 4000 then m1 size else listToListList size (concat (take 20 (repeat [1..(size*size `div` 20)])))
+mB size = if size <= 4000 then m1 size else listToListList size (concat (take 20 (repeat [0,2.. ((size*size) `div` 20)-2])))
+listToListList c m 
+ | length m <= c = [m]
+ | otherwise = c1 : listToListList c resto
+  where (c1,resto) = splitAt c m
+
+---------------------
+splitIntoN :: Int -> [a] -> [[a]]
+splitIntoN n xs = takeIter parts xs
+  where l = length xs
+        parts = zipWith (+) ((replicate (l `mod` n) 1) ++ repeat 0)
+                            (replicate n (l `div` n))
+takeIter :: [Int] -> [a] -> [[a]]
+takeIter [] [] = []
+takeIter [] _  = error "elements left over"
+takeIter (t:ts) xs = hs : takeIter ts rest
+    where (hs,rest) = splitAt t xs
+
+unshuffle :: Int -> [a] -> [[a]]
+unshuffle n xs = [takeEach n (drop i xs) | i <- [0..n-1]]
+ where takeEach n [] = []
+       takeEach n (x:xs) = x : takeEach n (drop (n-1) xs)
+-- inverse to unshuffle
+shuffle :: [[a]] -> [a]
+shuffle = concat . transpose