[Haskell-cafe] Strange parallel behaviour with Ubuntu Karmic / GHC 6.10.4

[Michael Lesniak]

Hello,

I've written a smaller example which reproduces the unusual behaviour.
Should I open a GHC-Ticket, too?


-- A small working example which describes the problems (I have) with GHC
-- 6.10.4, Ubuntu Karmic 9.10, explicit threading and core usage.
--
-- See http://www.haskell.org/pipermail/haskell-cafe/2009-November/069144.html
-- for the general description of the problem.
--
-- For comparsion:
-- Compilation on both machines with
-- 
--     ghc --make -O2 -threaded Example.hs -o e -Wall
--
-- 
-- 1. Machine B: (Quadcore, Ubuntu 9.04)
-- a. With 1 thread:
-- time e +RTS -N1 -RTS 16
-- e +RTS -N1 -RTS 16  11,00s user 5,00s system 100% cpu 16,004 total
--
-- b. With 2 threads:
-- time e +RTS -N2 -RTS 16
-- e +RTS -N2 -RTS 16  11,44s user 4,58s system 197% cpu 8,102 total
--
--
-- 2. Machine C: (Dualcore, Ubuntu 9.10)
-- a. With 1 thread:
-- time e +RTS -N1 -RTS  16
--
-- real 0m16.414s
-- user 0m11.360s
-- sys  0m4.650s
--
-- b. With 2 threads:
-- time e +RTS -N2 -RTS  16
--
-- real 0m18.484s
-- user 0m14.320s
-- sys  0m5.940s
--
-------------------------------------------------------------------------------
module Main where

import GHC.Conc
import Control.Concurrent
import Control.Monad
import System.Posix.Clock
import System.Environment



-------------------------------------------------------------------------------
main :: IO ()
main = do
    -- Configuration
    args <- getArgs
    let threads = numCapabilities    -- number of threads determined by -N<...>
        taskDur = 1.0                -- seconds each task takes
        taskNum = (read . head) args -- Number of tasks is 1st parameter

    -- Generate a channel for the tasks to do and fill it with uniform and
    -- independent tasks. The other channel receives a message for each task
    -- which is finished.
    queue    <- newChan
    finished <- newChan
    writeList2Chan queue (replicate taskNum taskDur)

    -- Fork threads
    replicateM_ threads (forkIO (thread queue finished))

    -- Wait until the queue is empty
    replicateM_ taskNum (readChan finished)


-------------------------------------------------------------------------------
thread :: Chan Double -> Chan Int -> IO ()
thread queue finished =
    forever $ do
        task <- readChan queue
        workFor task
        writeChan finished 1



-------------------------------------------------------------------------------
-- | Generates work for @s@ seconds.
workFor :: Double -> IO ()
workFor s = do
    now <- getTime ThreadCPUTime
    repeat (time2Double now + s)
  where repeat fs = do
            now <- nSqrt 10000 `pseq` getTime ThreadCPUTime
            let f = time2Double now
            unless (f >= fs) $ repeat fs
        time2Double t =
            fromIntegral (sec t) + (fromIntegral (nsec t) / 1000000000)
        -- Calculates the sqrt of 2^1000. The parameter n is to ensure
        -- that GHC does not optimize it away.
        -- (In fact, I'm not sure this is needed...)
        nSqrt n =
            let sqs = map (\_ -> iterate sqrt (2^1000) !! 50) [1..n]
            in foldr seq 1 sqs