Commit ec7f5f65 authored by Simon Marlow's avatar Simon Marlow

get a cut-down parallel benchmark suite going

parent 917241ca
......@@ -19,7 +19,7 @@ ifneq "$(way)" "mp"
# if testing GUM don't generate a -S style log file; it may well differ
SRC_RUNTEST_OPTS += -ghc-timing
endif
SRC_RUNTEST_OPTS += +RTS -H10m -K10m -RTS
# SRC_RUNTEST_OPTS += +RTS -H10m -K10m -RTS
#-----------------------------------------------------------------------------
# Setting for Haskell compiler
......
TOP = ..
include $(TOP)/mk/boilerplate.mk
# ToDo: fix these subdir: cfd dcbm linsolv
SUBDIRS = par001 pfib ray prsa soda soda7 coins minimax \
parfact bom NESL
include $(TOP)/mk/target.mk
SUBDIRS = parfib partree sumeuler matmult ray prsa
# partak: program needs work to make it parallel
# bom: bill of materials?
# par001: looks like a test, not a benchmark
# coins: needs updating
# parfact: parallel factorial
# soda, soda7: small word-search algorithm
# minimax: looks like it was written for GRIP, needs a lot of updating
# NESL: a collection of benchmarks based on NESL examples
include $(TOP)/mk/target.mk
module ListAux where
import Data.List
-- splitting into n parts, and its inverse:
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
unSplit :: [[a]] -> [a]
unSplit = concat
-- splitting into parts of same size. Inverse is concat again.
splitAtN :: Int -> [a] -> [[a]]
splitAtN n [] = []
splitAtN n xs = ys : splitAtN n zs
where (ys,zs) = splitAt n xs
----------------------------------------
-- splitting round-robin until list runs empty, and its inverse:
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
TOP = ../..
include $(TOP)/mk/boilerplate.mk
# 0 : sequential
# 1 : linewise
# 2 : blockwise
# 3 : columnwise
FAST_OPTS = 100 1 10
NORM_OPTS = 600 1 10
SLOW_OPTS = 1000 1 10
SRC_HC_OPTS += -package parallel
# FAST_OPTS =
# NORM_OPTS =
# SLOW_OPTS =
include $(TOP)/mk/target.mk
{-# OPTIONS -cpp #-}
{-# LANGUAGE BangPatterns #-}
{- Matrix multiplication using a torus (gentleman algorithm) -- FR10 -- -}
{-
RL/JB ParCo2005: eliminate result communication (Maybe-Type)
JB PhD2008: adapt for simple PhD skeleton tests
JB MSR07/2008: modified to use all available toroid skeletons.
JB MSR07/2008: derived a straight-forward GpH program using identical
helpers and strategies
JB optimised prodEscalar
JB for ghc-6.9: replaced Control.Parallel.Strategies by a workaround
(reexporting what should work)
-}
module Main(main) where
import System
import List
import ListAux
-- replaced by StratWorkaround, excluding what does not work with
-- ghc-6.9
#ifdef WORKAROUND
import StratWorkaround
-- workaround hacks needed for ghc-6.9:
parList :: Strategy a -> Strategy [a]
parList = parListStrict -- as name suggests: it is strict!
parListChunk :: Int -> Strategy a -> Strategy [a]
parListChunk c strat l = let subLs = splitAtN c l
evaluateMe = (map (seqList strat) subLs)::[()]
in parListStrict rnf evaluateMe
#else
import Control.Parallel.Strategies
#endif
----------- matrix strategies here:
strats :: [ Int -> Strategy Matrix {- == Int -> [[Int]] -> Done -} ]
strats = [ undefined, -- do not use it!
lineStrat, blockStrat, columnStrat]
names = ["sequential",
"linewise", "blockwise", "columnwise"]
lineStrat c = parListChunk c rnf -- OK?
columnStrat c matrix = parListChunk c rnf (transpose matrix) -- bad ?
blockStrat c matrix -- best?
= let blocks = concat (splitIntoClusters numB matrix) -- result splitted
-- in numB * numB blocks
numB = round (sqrt (fromIntegral (length matrix) / fromIntegral c))
-- approx. same num/granularity of sparks as in others...
in parList rnf blocks
undef _ _ = error "undefined strategy"
-------------------------------------
type Vector = [Int]
type Matrix = [Vector]
-- main computation, different versions:
mult :: Int -> Matrix -> Matrix -> Int -> [[Maybe Matrix]]
mult 0 m1 m2 _ =
#ifdef OUTPUT
[[Just $ multMatricesTr m1 (transpose m2)]]
#else
rnf (multMatricesTr m1 (transpose m2)) `seq` [[Nothing]]
#endif
mult v m1 m2 c = results
where results :: [[Maybe Matrix]]
#ifdef OUTPUT
results = [[Just computed]]
#else
results = (rnf computed `seq` [[Nothing]])
#endif
computed = multMatricesTr m1 m2Tr `using` (strats'!!v) c
strats' = strats ++ repeat undef
m2Tr = transpose m2
prMM' :: (Matrix,Matrix) -> Matrix
prMM' (c,mt) = [[prVV f c | c <- mt]|f <-c]
prVV :: Vector -> Vector -> Int
prVV f c = sum (zipWith (*) f c)
shiftRight c [] = []
shiftRight c (xs:xss) = (xs2++xs1):shiftRight (c-1) xss
where (xs1,xs2) = splitAt c xs
shiftDown c xss = transpose (shiftRight c (transpose xss))
join2 :: Matrix -> Matrix -> Matrix
join2 xs ys = zipWith (++) xs ys
join :: [Matrix] -> Matrix
join xss = foldr join2 (repeat []) xss
splitIntoClusters :: Int -> Matrix -> [[Matrix]]
splitIntoClusters c m | c < 1 = splitIntoClusters 1 m
splitIntoClusters c m1 = mss
where bh = kPartition (length m1) c
bhsplit [] [] = []
bhsplit [] _ = error "some elements left over"
bhsplit (t:ts) xs = hs : (bhsplit ts rest)
where (hs,rest) = splitAt t xs
ms = bhsplit bh m1 -- blocks of rows
mss = map (colsplit bh) ms
colsplit [] _ = []
colsplit (t:ts) rs
| head rs == [] = []
| otherwise = (cab:colsplit ts resto)
where (cab,resto) = unzip (map (splitAt t) rs)
-- mss = map (repartir (length m1 `div` c)) ms
-- repartir c xs
-- | head xs == [] = []
-- | otherwise = (cab:repartir c resto)
-- where (cab,resto) = unzip (map (splitAt c) xs)
-- helper for splitIntoClusters (formerly bresenham)
kPartition :: Int -> Int -> [Int]
kPartition n k = zipWith (+) ((replicate (n `mod` k) 1) ++ repeat 0)
(replicate k (n `div` k))
mult' :: Int -> Int -> ((Matrix,Matrix),[Matrix],[Matrix]) -> (Maybe Matrix,[Matrix],[Matrix])
mult' nc nr ((sm1,sm2),sm1s,sm2s)
#ifdef OUTPUT
= (Just result,toRight,toDown)
#else
= (rnf result `seq` Nothing ,toRight,toDown)
#endif
where toRight = take (nc-1) (sm1:sm1s)
toDown = take (nr-1) (sm2':sm2s)
sm2' = transpose sm2
sms = zipWith multMatricesTr (sm1:sm1s) (sm2':sm2s)
result = foldl1' addMatrices sms -- foldr1: not enough demand??
addMatrices :: Matrix -> Matrix -> Matrix
addMatrices m1 m2 = zipWith addVectors m1 m2
where addVectors :: Vector -> Vector -> Vector
addVectors v1 v2 = zipWith (+) v1 v2
-- Assumes the second matrix has already been transposed
multMatricesTr :: Matrix -> Matrix -> Matrix
multMatricesTr m1 m2 = [[prodEscalar2 row col | col <- m2] | row <- m1]
-- JB 2008: a lot faster, directly consuming lists, and tail-recursive (optimised with -O2)
prodEscalar2JB :: Vector -> Vector -> Int
prodEscalar2JB v1 v2 = addProd v1 v2 0
where addProd :: Vector -> Vector -> Int -> Int
addProd (v:vs) (w:ws) acc = addProd vs ws (acc + v*w)
addProd [] [] n = n
addProd _ _ _ = error "addProd: length does not match"
-- JB 2008: identical when using ghc-6.8.3, avoids bug in ghc-HEAD. Version suggested by SM
prodEscalar2 :: Vector -> Vector -> Int
prodEscalar2 v1 v2 = addProd v1 v2 0
addProd :: Vector -> Vector -> Int -> Int
addProd (v:vs) (w:ws) !acc = addProd vs ws (acc + v*w)
addProd _ _ !n = n
prodEscalar :: Vector -> Vector -> Int
prodEscalar v1 v2 = sum (zipWith (*) v1 v2)
------- foldl, strict in head element
foldl1' :: NFData a => (a->a->a) -> [a] -> a
foldl1' f (x:xs) = foldl' f x xs
foldl' :: NFData a => (a -> b -> a) -> a -> [b] -> a
foldl' f a [] = a
foldl' f a (x:xs) = -- whnf, not enough( (foldl' f) $! (f a x)) xs
let first = f a x
in rnf first `seq` foldl' f first xs
usage :: String -> String
usage name = "Cannon's algorithm: Usage:\n\t "++
name ++ " <matrix size> <version> <blocksPerRow> \n" ++
"Version selects from " ++ show (zip [0..] names)
main = do
args <- getArgs
let l = length args
if l == 0 then do n <- getProgName
putStrLn (usage n)
putStrLn "\n *** defaults: size 100, seq. computation ***"
else return () --putStrLn "Cannon's algorithm"
let size = if null args then 100 else read (head args)
opt = if length args < 2 then 0 else read (args!!1)
chunk = if length args < 3 then 1
else read (args!!2)
a = "Matrices of size " ++ show size ++
" with skeleton " ++ ((names++repeat "UNDEF")!!opt) ++
" using chunk parameter " ++ show chunk ++ "\n"
res = mult opt (mA size) (mB size) chunk
b = multMatricesTr (mA size) (transpose (mB size))
-- putStrLn a
#ifdef OUTPUT
putStrLn "Output wanted, checking result for correctness..."
let computed = map (map fromJust) res
computed' = concat (map join computed)
printMat computed'
if (b == computed')
then putStrLn "Correct!"
else do putStrLn "WRONG RESULT! Should be"
printMat b
#else
-- putStrLn "No Output, matrix stays distributed."
putStrLn (show res)
#endif
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
printMat :: Matrix -> IO ()
printMat m = putStrLn ("Matrix: " ++ (show (length (head m)))
++ " x " ++ (show $ length m) ++ "\n"
++ (showMat m))
-- instance Show a => Show (Matrix a) where
showMat m_ = "<<" ++ unlines (map (concatMap (\ x -> show x ++ " ")) m_) ++ ">>"
fromJust :: Maybe a -> a
fromJust (Just x) = x
fromJust Nothing = error "fromJust"
-- Time-stamp: <Sun Mar 10 1996 22:24:04 Stardate: [-31]7179.66 hwloidl>
-- Time-stamp: <2008-10-21 13:26:36 simonmar>
-----------------------------------------------------------------------------
module Board where
import Wins
import ParForce
import Control.Parallel
import Control.Parallel.Strategies
type Board = [Row]
type Row = [Piece]
......@@ -46,12 +47,12 @@ empty' 2 [_,Empty,_] = True
empty' 3 [_,_,Empty] = True
empty' _ _ = False
fullBoard b = and (par_map 3 notEmpty (concat b))
fullBoard b = and (parMap rnf notEmpty (concat b))
where
notEmpty x = not (x==Empty)
--newPositions :: Piece -> Board -> [Board]
newPositions piece board = concat (par_map 6 (placePiece piece board)
newPositions piece board = concat (parMap rwhnf (placePiece piece board)
[(x,y) | x<-[1..3],y <-[1..3]])
initialBoard :: Board
......@@ -59,7 +60,7 @@ initialBoard = [[Empty,Empty,Empty],
[Empty,Empty,Empty],
[Empty,Empty,Empty]]
data Evaluation = XWin | OWin | Score Int deriving (Text,Eq)
data Evaluation = XWin | OWin | Score Int deriving (Show,Eq)
{- OLD: partain
instance Eq Evaluation where
XWin == XWin = True
......@@ -89,7 +90,7 @@ eval (-3) = OWin
eval x = Score x
static :: Board -> Evaluation
static board = interpret 0 (par_map 8 (score board) wins)
static board = interpret 0 (parMap rwhnf (score board) wins)
interpret :: Int -> [Evaluation] -> Evaluation
interpret x [] = (Score x)
......@@ -98,7 +99,7 @@ interpret x (XWin:l) = XWin
interpret x (OWin:l) = OWin
score :: Board -> Win -> Evaluation
score board win = eval (sum (par_map 7 sum (zipWith (zipWith scorePiece) board win)))
score board win = eval (sum (parMap rnf sum (zipWith (zipWith scorePiece) board win)))
scorePiece :: Piece -> Int -> Int
scorePiece X score = score
......@@ -113,4 +114,4 @@ map2 f [] x = []
map2 f x [] = []
map2 f (x:xs) (y:ys) = f x y:map2 f xs ys
#endif
-}
\ No newline at end of file
-}
-- Time-stamp: <Fri Oct 20 1995 15:18:17 Stardate: [-31]6467.98 hwloidl>
-- Time-stamp: <2008-10-21 13:23:29 simonmar>
-----------------------------------------------------------------------------
module Game where
......@@ -7,7 +7,8 @@ import Board
import Wins
import Tree
import ParForce
import Control.Parallel
import Control.Parallel.Strategies
type Player = Evaluation -> Evaluation -> Evaluation
type Move = (Board,Evaluation)
......
-- Time-stamp: <Sun Mar 10 1996 23:04:57 Stardate: [-31]7179.80 hwloidl>
-- Time-stamp: <2008-10-21 13:21:24 simonmar>
-----------------------------------------------------------------------------
#if defined(GRAN) || defined(GUM)
module Main where
module Main(mainPrimIO) where
import System.Environment
import Prog
import PreludeGlaST
#else
module Main(main) where
#endif
-- import Random (randomInts) -- Just for testing
import ParForce
--import PreludeMonadicIO
--import PreludeIOError
-- import LibTime
import Prog (prog)
-- main _ = [ReadChan stdin, AppendChan stdout (prog "")]
#if defined(GRAN) || defined(GUM)
#ifdef PRINT
mainPrimIO = getArgsPrimIO `thenPrimIO` \ a ->
let
all_args = args_to_IntList a
echo_str = prog (head all_args) ""
in
appendChanPrimIO stdout ("\nDecaffination argument (dummy!): " ++ (show (head all_args))) `seqPrimIO`
appendChanPrimIO stdout ("\nEcho str: " ++ (show echo_str)) `seqPrimIO`
returnPrimIO ()
#else
mainPrimIO = getArgsPrimIO `thenPrimIO` \ a ->
let
all_args = args_to_IntList a
echo_str = prog (head all_args) ""
in
if sum (map ord echo_str) == 13
then error "Qu'vatlh"
else returnPrimIO ()
#endif
#else /* no PrimIO i.e. std Haskell 1.2 */
#ifdef PRINT
main = getArgs exit ( \ a ->
let
all_args = args_to_IntList a
echo_str = prog (head all_args) ""
in
appendChan stdout ("\nDecaffination argument (dummy!): " ++ (show (head all_args))) exit $
appendChan stdout ("\nEcho str: " ++ (show echo_str)) exit done )
#else
main = getArgs exit ( \ a ->
let
all_args = args_to_IntList a
echo_str = prog (head all_args) ""
in
if sum (map ord echo_str) == 13
then error "Qu'vatlh"
else appendChan stdout "done" exit done)
#endif
#endif
args_to_IntList a = map (\ a1 -> fst ((readDec a1) !! 0)) a
-----------------------------------------------------------------------------
{-
max = 65535
randomList = map (`mod` max) (randomInts (getRandInt max)
(getRandInt (max-1)) )
l' = take 5000 randomList -- [54,53..2]::[Int]
l = par_qsort expensive_le l'
expensive_le x y = (sum [x..x+3]) <= (sum [y..y+3])
sorted l = and (zipWith (<=) l (tail l))
getRandInt :: Int -> Int
getRandInt bound =
unsafePerformPrimIO (
getClockTime `thenPrimIO` \ t ->
returnPrimIO (
case t of
Left _ -> error "error in getClockTime"
Right b -> let
CalendarTime _ _ _ _ _ _ x _ _ _ _ _ = toCalendarTime b
in
((fromInteger x) `mod` bound) :: Int ) )
-}
\ No newline at end of file
main = do
[n] <- fmap (map read) getArgs
putStrLn (prog n)
TOP = ../..
include $(TOP)/mk/boilerplate.mk
-include opts.mk
SRC_HC_OPTS += -package parallel
include $(TOP)/mk/target.mk
{- -------------------------------------------------------------------------
$Id: ParForce.hs,v 1.2 1996/07/25 21:20:41 partain Exp $
Time-stamp: <Sat Apr 27 1996 22:58:48 Stardate: [-31]7419.57 hwloidl>
This is revision: $Revision: 1.2 $
Module for forcing parallelism using par and friends.
It contains three classes of functions:
1) For each _<par-annotation>_ that's hard-wired into the compiler, there is
a function <par-annotation> in this module, doing the same thing as the
annotation but taking boxed values in the annotation positions.
2) Forcing functions like forcelist that cause the evaluation of every
component of the data-structure. The clean way to handle this would be
to define a class Forcable with a force method for each datatype of
interest.
3) Parallel versions of some higher-order functions such as map, filter, zip
etc. Currently par_map is the most often used way to parallelise a program.
The different versions force the argument list in different ways, and have
different ways of expressing the annotation information.
Currently two PP variables are used to decide which versions of the functions
to take:
SEQ ... creates dummy definitions for all annotations and makes the parallel
higher order functions to aliases of their sequential counterparts
GRAN_TNG ... uses the versions of the annotations that provide
sparkname, gran-info, size-info, parallelism-info
different versions of the parallel h.o. fcts pass this info in
different ways
[in the current versions the h.o. fcts just insert dummy values
for the size and parallelism info]
If no PP variable is defined, the parallel version is used, which only
supplies spark names but no gran-, size- or par-info.
Changelog (including older versions not in the correwsponding RCS file):
$Log: ParForce.hs,v $
Revision 1.2 1996/07/25 21:20:41 partain
Bulk of final changes for 2.01
--# Revision 1.3 1994/11/23 01:07:23 hwloidl
--# Version for testing fwd mapping and hom sol.
--#
--# Revision 1.1 1994/11/19 02:00:05 hwloidl
--# Initial revision
--#
---------------------------------------------------------------------- -}
module ParForce (parGlobal, parLocal, parAt, parAtForNow, seq, par,
forcelist, forcelist1,
parmap, parmap0, parmap1, pariterate,
parzip, parzipWith, parfilter,
par_map, par_map0, par_map1, par_iterate,
par_zip, par_zipWith, par_filter ) where
-- import Parallel
-- Basic parallelism annotations
#if defined(SEQ)
parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
parGlobal _ _ _ _ x y = y
parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
parLocal _ _ _ _ x y = y
parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAt _ _ _ _ w x y = y
parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAtForNow _ _ _ _ w x y = y
seq :: a -> b -> b
seq x y = y
par :: a -> b -> b
par x y = y
#elif defined(GRAN)
parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
parGlobal (I# n) (I# g) (I# s) (I# p) = _parGlobal_ n g s p
{-
where n' = case (n) of (I# n') -> n'
g' = case (g) of (I# g') -> g'
s' = case (s) of (I# s') -> s'
p' = case (p) of (I# p') -> p'
-}
parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
parLocal (I# n) (I# g) (I# s) (I# p) = _parLocal_ n g s p
parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAt (I# n) (I# g) (I# s) (I# p) = _parAt_ n g s p
parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAtForNow (I# n) (I# g) (I# s) (I# p) = _parAtForNow_ n g s p
{-# INLINE seq #-}
seq :: a -> b -> b
seq = _seq_
{-# INLINE par #-}
par :: a -> b -> b
par = _par_
#elif defined(PAR) /* i.e.GUM */
import Parallel -- includes definitions of par and seq
parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
parGlobal _ _ _ _ = par
parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
parLocal _ _ _ _ = par
--parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAt _ _ _ _ w = par
--parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAtForNow _ _ _ _ w = par
#else /* e.g. HBCPP */
import Parallel -- renaming (par to hbcpp_par, seq to hbcpp_seq)
{-
--seq :: a -> b -> b
seq = hbcpp_seq
--par :: a -> b -> b
par = hbcpp_par "par"
--parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
parGlobal n _ _ _ = hbcpp_par (show n)
--parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
parLocal n _ _ _ = hbcpp_par (show n)
--parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAt n _ _ _ w = hbcpp_par (show n)
--parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAtForNow n _ _ _ w = hbcpp_par (show n)
-}
--parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
parGlobal n _ _ _ x y = par x y
--parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
parLocal n _ _ _ x y = par x y
--parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAt n _ _ _ w x y = par x y
--parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
parAtForNow n _ _ _ w x y = par x y
#endif
forcelist [] = ()
forcelist (x:xs) = seq x (forcelist xs)
forcelist1 0 (x:xs) = ()
forcelist1 n (x:xs) = seq x (forcelist1 (n-1) xs)