[Haskell-cafe] GHC threads and SMP

[Paul L]

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 ()