Commit 0cd6ee4a authored by hwloidl's avatar hwloidl

[project @ 2001-04-03 20:12:37 by hwloidl]

Cleanup in parallel section of nofib suite. The fibish fcts are ok, i.e.
std way should succeed, parallel way should build.
Parallel way has to be run by hand (problems redirecting stdout), so not
automatic check whether output is identical to the provided file.
Added a bunch of test prgs for GdH in distributed section. Still need
to be integrated into nofib build machinery (currently standalone Makefiles).
Modified Makefiles to work with a parallel build. Have to omit runtest for now.
parent 250f1ea7
-- Now you want to recompile Channel,ChannelVar, Merge,SampleVar,Semaphore
-- to use this module rather than the the Concurrent module...
-- I ignore the fact that the file handling stuff needs MVars too, so maybe
-- we should be replacing PrelConc in the longrun! The dependencies will be
-- fun to sort out though.
module Distributed
( PEId -- abstract
, Immobile -- abstract class
, myPEId -- :: IO PEId
, allPEId -- :: IO [PEId]
, owningPE -- :: a -> IO PEId
, revalIO -- :: IO a -> b -> IO a -- (b is PEId, MVar, ThreadId)
, on -- :: a -> PEId -> a
, mainPE -- :: PEId
, ThreadId -- abstract
, killThread -- :: ThreadId -> IO ()
, raiseInThread -- :: ThreadId -> Exception -> IO ()
, yield -- :: IO ()
, threadDelay -- :: Int -> IO ()
, myThreadId -- :: IO ThreadId
, forkIO -- :: IO () -> IO ThreadId
, rforkIO -- :: IO () -> PEId -> IO ThreadId
, MVar -- abstract
, newMVar -- :: a -> IO (MVar a)
, newEmptyMVar -- :: IO (MVar a)
, takeMVar -- :: MVar a -> IO a
, putMVar -- :: MVar a -> a -> IO ()
, readMVar -- :: MVar a -> IO a
, swapMVar -- :: MVar a -> a -> IO a
, isEmptyMVar -- :: MVar a -> IO Bool
, tryPutMVar -- :: MVar a -> a -> IO Bool
, takeMaybeMVar -- :: MVar a -> IO (Maybe a)
) where
import PrelDistributed
import Concurrent (ThreadId, MVar, forkIO, yield, threadDelay, myThreadId, newMVar, newEmptyMVar)
import qualified Concurrent
import qualified PrelConc
import Exception ( Exception(..),ArithException(..), AsyncException(..))
import qualified Exception
import PrelPack (packString)
import qualified PrelIOBase
import PrelAddr (Addr)
---------------------------
-- basic PEId stuff
myPEId :: IO PEId
myPEId = do
p <- _ccall_ cGetMyPEId
return (PEId p)
allPEId :: IO [PEId]
allPEId = do
(cnt :: Int) <- _ccall_ cGetPECount
let getPE (n :: Int) = do
p <- _ccall_ cGetPEId n
return (PEId p)
mapM getPE [1..cnt]
instance Show PEId where
showsPrec _ (PEId p) s = ("PE:"++(show p)) ++ s
---------------------------
-- basic immobile resources stuff
class Immobile a where
owningPE :: a -> IO PEId
revalIO :: IO b -> a -> IO b
revalIO job x = do
p <- owningPE x
doRevalIO job p
owningPE x = primGetCertainOwner x
-- General GpH Problems:
-- 1 - signal handlers not installed... so can't catch div-by-zero yet
data Status a = Okay a | Fail Exception
doRevalIO :: IO a -> PEId -> IO a
doRevalIO job p = do
i <- myPEId
if p==i
then job -- keep it simple if its local
else do
primRevalIO result p
-- block until we know the result is Okay or not.
case result of
Okay r -> return r
Fail e -> Exception.throw e
where
-- we wrap job up to return an 'okay' result.
okayJob = do
r <- job
return (Okay r)
-- if something goes wrong we return a 'Fail' result.
safeJob = Exception.catchAllIO okayJob (\e -> return (Fail e))
-- we return the result via a single variable so we can
-- use GpH's synchronisation mechanisms ie FETCHME, BQ, etc. (hackity, hack.)
result = PrelIOBase.unsafePerformIO safeJob
---------------------------
-- utility functions
on :: a -> PEId -> a
on x p = PrelIOBase.unsafePerformIO (revalIO (x `seq` return x) p)
mainPE :: PEId
mainPE = (PEId (PrelIOBase.unsafePerformIO (_ccall_ cGetPEId (1::Int))))
---------------------------
-- immobile PEIds - well it fits in nicely :)
instance Immobile PEId where
owningPE p = return p
---------------------------
-- immobile MVars
instance Immobile (MVar a)
---------------------------
-- immobile ThreadIds
-- The big issue is should the reval thread have the same threadId as its parent?
-- I think we should say NO! If you want to know your parents Id then let the
-- programmer pass it explicitly. Why make my life hard!
-- This opinion could require rethinking later...
instance Immobile ThreadId
---------------------------
-- immobile Host Names (RFP playing around)
instance Immobile ([Char]) where
owningPE h = do
p <- _ccall_ cGetHostOwner (packString h)
case p of
0 -> error "no such host"
_ -> return (PEId p)
---------------------------
-- forking stuff
rforkIO :: IO () -> PEId -> IO ThreadId
rforkIO job p = revalIO (forkIO job) p
---------------------------
-- killing
killThread :: ThreadId -> IO ()
killThread th = revalIO (Concurrent.killThread th) th
raiseInThread :: ThreadId -> Exception -> IO ()
raiseInThread th ex = revalIO (Concurrent.raiseInThread th ex) th
---------------------------
-- MVAR primitives
takeMVar :: MVar a -> IO a
takeMVar mv = revalIO (Concurrent.takeMVar mv) mv
putMVar :: MVar a -> a -> IO ()
putMVar mv r = revalIO (Concurrent.putMVar mv r) mv
readMVar :: MVar a -> IO a
readMVar mv = revalIO (Concurrent.readMVar mv) mv
swapMVar :: MVar a -> a -> IO a
swapMVar mv r = revalIO (Concurrent.swapMVar mv r) mv
isEmptyMVar :: MVar a -> IO Bool
isEmptyMVar mv = revalIO (Concurrent.isEmptyMVar mv) mv
tryPutMVar :: MVar a -> a -> IO Bool
tryPutMVar mv r = Exception.catchAllIO (do;putMVar mv r;return True) (\e->return False)
takeMaybeMVar :: MVar a -> IO (Maybe a)
takeMaybeMVar mv = revalIO (PrelConc.takeMaybeMVar mv) mv
Time-stamp: <Tue Apr 03 2001 01:37:07 Stardate: [-30]6425.12 hwloidl>
This directory contains very simple GdH test programs.
GdH, Glasgow distributed Haskell, is an extension of Haskell98 for executing
programs on a network of machines, each running an instance of the
distributed runtime-system (RTS). The RTS ("sticky GUM") is an extension
of the parallel RTS (GUM) adding explicit task placement. GdH uses
a virtual shared heap and implicit communication. For more details see
http://www.cee.hw.ac.uk/~dsg/gdh
At the moment GdH is still in an experimental stage.
The compiler should know about a way "md" for building the distributed
version of the RTS (no modifications in the compiler are necessary).
This whole subdir needs integration into the nofib build machinery.
At the moment they are standalone makefiles.
If you want to play with them:
- Do a make all in the GdH dir for building modified versions of some
libraries.
- Go into one of the other dirs, containing one file test programs, and
do a make (prbly have to add -i../GdH)
module Main(main) where
import Distributed
import System
import IO
data Link a = Link (MVar a) (MVar ())
instance Immobile (Link a) where
owningPE (Link i o) = owningPE i
newLink :: IO (Link a)
newLink = do
i <- newEmptyMVar
o <- newMVar ()
return (Link i o)
readLink :: Link a -> IO a
readLink (Link i o) = do
v <- takeMVar i
putMVar o ()
return v
writeLink :: Link a -> a -> IO ()
writeLink (Link i o) v = do
takeMVar o
putMVar i v
main = do
putStrLn "Chain..."
pes <- allPEId
o <- newLink
let spawn p = do
i <- newLink
let work = do
v <- readLink i
writeLink o ((v*2),p)
work
forkIO work
return i
is <- mapM (\p -> revalIO (spawn p) p) pes
let
work 0 = return True
work n = do
writeLink (is!!(n `mod` (length is))) n
(v,p) <- readLink o
if v==(n*2)
then do
putStrLn "Okay"
work (n-1)
else do
putStrLn ("ERROR: "++show p++" says 2*"++show n++"="++ show v)
return False
rs <- work ((length pes)*6)
if rs
then putStrLn "Test PASSED"
else putStrLn "Test FAILED"
return ()
{-
*Creates a slave thread on each PE which has the job of reading a number and returning
double the result.
*Tests MVar communication, and thread creation.
-}
\ No newline at end of file
module Main(main) where
import Distributed
import System
import Exception
main = do
putStrLn "Error test..."
pes <- allPEId
m <- newEmptyMVar
let
work p = catchAllIO (revalIO remote p) fails
remote = do
i <- myPEId
mo <- owningPE m
putMVar m (if i==mo then "Owner" else "Other")
return True
fails PutFullMVar = do
name <- takeMVar m
putStrLn ("Writer= "++name)
return True
fails e = do
putStrLn ("Error: "++show e)
return False
rs <- mapM work pes
catchAllIO (putMVar m "Main") (\e-> return ())
name <- takeMVar m
putStrLn ("Writer= "++name)
if rs==(replicate (length pes) True)
then putStrLn "Test PASSED"
else putStrLn "Test FAILED"
{-
* tests the handling of remote exceptions.
-}
\ No newline at end of file
module Main(main) where
import Distributed
import System
import List
import IO
import Time
import PrelNum
-- we are only interested in ms accuracy < 60 seconds
runTime :: ClockTime -> ClockTime -> Int
runTime t1 t2 =
let
TimeDiff _ _ d h m s p = diffClockTimes t1 t2
(dp,mp) = divModInteger p 1000000000
b = integer2Int dp
(nb,es) = if(b<0) then (b+1000,s-1) else (b,s)
ns = if(es<0) then es+60 else es
in nb+1000*ns
timeit :: IO a -> IO (a, Int)
timeit job = do
start <- getClockTime
res <- job
done <- getClockTime
return (res,(runTime done start))
type PeNames = [(PEId,[String])]
host2pe :: PeNames -> String -> PEId
host2pe pns n =
case (filter (\(p,xs) -> elem n xs) pns) of
[(p,_)] -> p
_ -> error "unknown Host"
pe2host :: PeNames -> PEId -> String
pe2host pns t =
case (filter (\(p,xs) -> p==t) pns) of
[(_,h:_)] -> h
_ -> error "unknown PEId"
peNames :: IO PeNames
peNames = do
pes@(m:_) <- allPEId
let work p = do
n <- revalIO (getEnv "HOST") p
return (p,n)
ws <- mapM work pes
let
us = map (\n -> (n,0)) (nub (map (\(_,n)->n) ws))
reduce = foldl (\acc (t,x) -> if t then (acc++[x]) else acc) []
unique (us,acc) (p,n) = (nus,acc++[(p,nn)])
where
(nus,nn) = loop us
loop ((x,c):t) =
if x==n
then ((x,c+1):t, reduce [(p==m,"MainPE"),(c==0,x),(True,(show c)++"@"++x)])
else let (rt,rn) = (loop t) in ((x,c):rt,rn)
(_,ns) = foldl unique (us,[]) ws
return ns
main = do
pes <- allPEId
putStrLn "PE Names..."
ns <- peNames
mapM (\x -> putStrLn (show x)) ns
putStrLn "\nTiming..."
let
timePing p = do
putStr ("Pinging "++(pe2host ns p)++" ... ")
(_,ms) <- timeit (revalIO (return ()) p)
putStrLn (" time="++show ms++"ms")
mapM timePing pes
return ()
{-
* Generates unique and meaningful names for each PE, then times communication.
* Tests remote host lookup and timing.
-}
\ No newline at end of file
import Distributed
import System
import IO
main = do
putStrLn "Place Test..."
pes <- allPEId
let
tot = length pes
check mv = do
i <- myPEId
o <- owningPE mv
return (i,o)
same = map (\(x,y) -> x==y)
test n = (replicate n False)++[True]++(replicate (tot-1-n) False)
loop n = do
let pe = pes!!n
mv <- revalIO (newEmptyMVar) pe
rs <- mapM (\p -> revalIO (check mv) p) pes
if (same rs)==(test n)
then do
putStrLn "Okay"
return True
else do
putStrLn ("ERROR: MVar should be located at "++show pe ++". Results "++show rs)
return False
rs <- mapM loop [0..tot-1]
if rs==(replicate tot True)
then putStrLn "Test PASSED"
else putStrLn "Test FAILED"
return ()
{-
* Creates an MVar on each PE and then checks that it can be correctly
located from all other PEs.
* Tests owningPE on MVars.
-}
\ No newline at end of file
......@@ -2,7 +2,7 @@
#
# nofib/mk/opts.mk
#
# $Id: opts.mk,v 1.5 2001/02/14 14:57:43 rrt Exp $
# $Id: opts.mk,v 1.6 2001/04/03 20:12:38 hwloidl Exp $
#
#################################################################################
......@@ -15,7 +15,11 @@
RUNTEST_OPTS = $(SRC_RUNTEST_OPTS) $(WAY$(_way)_RUNTEST_OPTS) \
$($(NOFIB_PROG)_RUNTEST_OPTS) $(EXTRA_RUNTEST_OPTS)
SRC_RUNTEST_OPTS += -ghc-timing +RTS -H10m -K10m -RTS
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
#-----------------------------------------------------------------------------
# Setting for Haskell compiler
......
......@@ -38,12 +38,19 @@ ifeq "$(way)" "mp"
# The parallel prg is actually a Perl skript => can't strip it -- HWL
size :: $(NOFIB_PROG_WAY)
@echo ==nofib== $(NOFIB_PROG): cannot strip parallel program, omitting size info
runtests :: $(NOFIB_PROG_WAY) size
@echo ==nofib== $(NOFIB_PROG): cannot do an automatic check of stdout with the parallel system, sorry
@echo ==nofib== $(NOFIB_PROG): run the following command by hand
@echo ./$< $(RUNTEST_OPTS)
@echo ==nofib== $(NOFIB_PROG): output should be
@cat $(wildcard $(NOFIB_PROG).stdout*)
else
size :: $(NOFIB_PROG_WAY)
@$(STRIP) $(NOFIB_PROG_WAY)$(exeext)
@echo ==nofib== $(NOFIB_PROG): size of $(NOFIB_PROG) follows...
@$(SIZE) $(NOFIB_PROG_WAY)$(exeext)
endif
runtests :: $(NOFIB_PROG_WAY) size
@echo ==nofib== $(NOFIB_PROG): time to run $(NOFIB_PROG) follows...
......@@ -52,6 +59,8 @@ runtests :: $(NOFIB_PROG_WAY) size
$(addprefix -o1 ,$(wildcard $(NOFIB_PROG).stdout*)) \
$(addprefix -o2 ,$(wildcard $(NOFIB_PROG).stderr*)) \
$(RUNTEST_OPTS)
endif
else
size ::
@:
......
-- Time-stamp: <Wed Mar 21 2001 17:09:08 Stardate: [-30]6363.57 hwloidl>
--
-- Good old nfib, now in parallel!
--
-----------------------------------------------------------------------------
#if 0
-- Currently unused; see ../pfib instead
module Main(main) where
import Parallel
main = getArgs exit ( \ args ->
munch_input (args_to_IntList args) )
munch_input [n] = appendChan stdout ("\nparfib " ++ (show n) ++ {- " (with CUT_OFF=" ++ (show CUT_OFF) ++ -} " = " ++ (show (parfib n)) ++ "\n") exit done
args_to_IntList a = if length a < 1
then error "Usage: parfib <n>\n"
else map (\ a1 -> fst ((readDec a1) !! 0)) a
nfib :: Int -> Int
nfib 0 = 1
nfib 1 = 1
nfib x = nfib (x-2) + nfib (x-1) + 1
parfib :: Int -> Int
parfib 0 = 1
parfib 1 = 1
parfib x = par nf'' (seq nf' (nf'+nf''+1) )
where nf' = parfib (x-1)
nf'' = parfib (x-2)
parfib_cutoff :: Int -> Int
parfib_cutoff 0 = 1
parfib_cutoff 1 = 1
parfib_cutoff x
| x<CUT_OFF = nfib x
| otherwise = par nf'' (seq nf' (nf'+nf''+1) )
where nf' = parfib_cutoff (x-1)
nf'' = parfib_cutoff (x-2)
par_non_fib :: Int -> Int -> Int -> Int
par_non_fib a b 0 = 1
par_non_fib a b 1 = 1
par_non_fib a b x =
par ab (
seq nf' (
seq nf'' (
(nf'+nf''+ab+1) ) ) )
where nf' = a * (par_non_fib a' b' (x-1))
nf'' = b * (par_non_fib a' b' (x-2))
a' = max 1 (max (a-1) b)
b' = max 1 (min (a-1) b)
ab = gcd a' b'
#endif
-- Time-stamp: <Wed Mar 21 2001 17:08:35 Stardate: [-30]6363.57 hwloidl>
--
-- partree
-- parallel map over a tree
-- To be used for GranSim
-----------------------------------------------------------------------------
#if 0 && defined(GLA_EXTS)
-- Currently unused; should go into another dir!
module Main(mainPrimIO) where
import PreludeGlaST
import Parallel
import Tree
mainPrimIO = getArgsPrimIO `thenPrimIO` \ a ->
munch_input (args_to_IntList a)
munch_input [n] = appendChanPrimIO stdout ("\npartree " ++ show n ++ " = " ++ (show (partree n)) ++ "\n") `seqPrimIO` returnPrimIO ()
#else
module Main(main) where
import Parallel
import Tree
main = getArgs exit ( \ args ->
munch_input (args_to_IntList args) )
munch_input [n] = appendChan stdout ("\npartree " ++ show n ++ " = " ++ (show (partree n)) ++ "\n") exit done
#endif
args_to_IntList a = if length a < 1
then error "Usage: partree <n>\n"
else map (\ a1 -> fst ((readDec a1) !! 0)) a
nfib :: Int -> Int
nfib 0 = 1
nfib 1 = 1
nfib n = nfib (n-1) + nfib (n-2) + 1
foo :: Int -> Int
foo n
| n < 5 = foo (5+n)
| n > 20 = foo (n `rem` 20)
| otherwise = nfib n
bar :: Int -> Int
bar n = (force_tree t) `par` x
where forest = [ let
l = take n (iterate (+i) i)
in
list2tree l
| i <- [1..n] ]
t = foldl1 (^:) forest
x = tree_fold (\x y -> (x+y) `quot` 2) 0 t
partree :: Int -> Int
partree n = (force_tree t) `par` (tree_fold max 0 t)
where t = par_tree_map bar (list2tree [1..n])
-- Time-stamp: <Wed Mar 21 2001 17:08:29 Stardate: [-30]6363.57 hwloidl>
--
-- tak benchmark program
-- Divide-and-conquer structure with tertiary parallelism.
-----------------------------------------------------------------------------
#if 0
-- Currently unused; should go into another dir!
#if defined(GRAN) || defined(PAR)
module Main(mainPrimIO) where
import PreludeGlaST
#else
module Main(main) where
#endif
import Parallel
#if defined(GRAN) || defined(PAR)
# ifdef ARGS
mainPrimIO = getArgsPrimIO `thenPrimIO` \ a ->
munch_input a
args_to_IntList a = map (\ a1 -> fst ((readDec a1) !! 0)) a
# else
mainPrimIO = munch_input []
# endif
#else /* e.g. HBCPP */
# ifdef ARGS
main = getArgs exit ( \ a -> munch_input a )
args_to_IntList a = map (\ a1 -> fst ((readDec a1) !! 0)) a
# else
main = munch_input []
# endif
#endif
#if defined(GRAN) || defined(PAR)
# ifdef PRINT
munch_input a = appendChanPrimIO stdout ("\ntak " ++ show x ++ " " ++ show y ++ " " ++ show z ++ " = " ++ (show (tak x y z)) ++ "\n") `seqPrimIO`
returnPrimIO ()
# else
munch_input a = if (tak x y z) == 0
then error "Qu'vatlh"
else returnPrimIO ()
# endif
#else /* e.g. HBCPP */
# ifdef PRINT
munch_input a = appendChan stdout ("\ntak " ++ show x ++ " " ++ show y ++ " " ++ show z ++ " = " ++ (show (tak x y z)) ++ "\n") exit done
# else
munch_input a = if (tak x y z) == 0
then error "Qu'vatlh"
else appendChan stdout "Ok" exit done
# endif
#en