I have two parallel algorithms that use the lightweight GHC thread and
forkIO. I compile them using the -threaded (or -smp) option, and run
both with +RTS -N2 -RTS command line option.
QSort is able to make use of the dual cores on my laptop -- "top"
shows that two threads show up and both CPUs are utilized, and "time"
it will give something like this:
real 0m0.502s
user 0m0.872s
sys 0m0.004s
But Prime can only make use of one core, as shown by "top". "time" gives
real 0m9.112s
user 0m9.093s
sys 0m0.028s
Because forkOS is not used anywhere, the decision of running them on 1
or 2 OS threads seem rather arbitary. Why?
Regards,
Paul L
import Control.Concurrent
import System.Random
import Data.Array.MArray
import Data.Array.IO
import System.IO.Unsafe
import Control.Exception
1. Quick Sort
testQSort' n verbose = do
let b = (0, n - 1)
arr <- newArray b 0 :: IO (IOUArray Int Int)
initM' (mkStdGen 0) b arr
waitForChildren
qsortM' b arr
waitForChildren
if verbose then getElems arr >>= putStrLn . show else return ()
Initialize an array with random numbers.
initM' g (i, j) arr | j - i < 10000 = fillArr g i j
where
fillArr g i j = if i > j then return () else do
let (v, g') = next g
writeArray arr i v >> fillArr g' (i + 1) j
initM' g (i, j) arr = do
let k = (i + j) `div` 2
(g1, g2) = split g
forkChild $ initM' g1 (i, k) arr
forkChild $ initM' g2 (k + 1, j) arr
return ()
qsortM' (i, j) arr = qsort' (i, j)
where
qsort' (i, j) =
if j <= i then return () else do
k <- split i j
if j - i > 10000 then (forkChild $ qsort' (i, k - 1)) >> return ()
else qsort' (i, k - 1)
qsort' (k + 1, j)
split left right = do
v <- readArray arr right
let split' i j = if j == right then swap i right v >> return i else do
b <- readArray arr j
if b <= v
then (swap i j b) >> split' (i + 1) (j + 1)
else split' i (j + 1)
split' left left
swap i j b = do
a <- readArray arr i
writeArray arr i b
writeArray arr j a
2. Prime
testPrime' n verbose = do
arr <- newArray (0, n) True :: IO (IOUArray Int Bool)
primeM' arr n
waitForChildren
if verbose
then getElems arr >>= putStrLn . show . map fst . filter snd . zip [0..]
else return ()
primeM' arr n = do
let p = truncate $ sqrt (fromIntegral n) + 1
remove i = if i > p then return () else do
spawnRemover (i + 1)
remove' (i + i)
where
remove' j = if j > n then return () else do
writeArray arr j False
remove' (j + i)
spawnRemover j = if j > n then return () else do
t <- readArray arr j
if t then forkChild (remove j) else spawnRemover (j + 1)
remove 2
Manage thread termination
children :: MVar [MVar ()]
children = unsafePerformIO (newMVar [])
waitForChildren :: IO ()
waitForChildren = do
cs <- takeMVar children
case cs of
[] -> putMVar children cs
m:ms -> do
putMVar children ms
takeMVar m
waitForChildren
forkChild :: IO () -> IO ()
forkChild io = do
mvar <- newEmptyMVar
childs <- takeMVar children
putMVar children (mvar:childs)
forkIO (io `finally` putMVar mvar ())
return ()
_______________________________________________
Haskell-Cafe mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell-cafe
