[Haskell-cafe] GHC threads and SMP

6 Jul 2007

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