[Haskell-cafe] Re: GHC threads and SMP

[Paul L]

replying to my own message... the behavior is only when -O is used
during compilation, otherwise they both run on 2 cores but at a much
lower (1/100) speed.

On 7/6/07, Paul L <ninegua at gmail.com> wrote:
> 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 ()
>