[Haskell-cafe] True parallelism missing :-(

[Dusan Kolar]

Dear all,

  I've thought the following three (dummy) programs would run some of 
their parts in parallel (on dual core) if compiled with option threaded 
(smp). The truth is that only the first one exploits multicore CPU. Why?

  Moreover, using RTS option -sstderr makes runtime not to evaluate in 
parallel even for the first program. Why?

  Thanks for tips

    Dusan

My arch:
Linux pcx 2.6.24-ARCH #1 SMP PREEMPT Sun Feb 10 15:44:59 CET 2008 x86_64 
Intel(R) Core(TM)2 CPU 6600 @ 2.40GHz GenuineIntel GNU/Linux

My ghc:
The Glorious Glasgow Haskell Compilation System, version 6.8.2
/64bit, binary distro for FC/


----------------------------------------------------
Prog 1:

module Main() where

import Control.Parallel
import Control.Parallel.Strategies

fibs :: Integer -> Integer
fibs n | n > 1  = fibs (n-1) + fibs (n-2)
       | n == 1 = 1
       | True   = 0

fib n = if n<0 then error "Negative input to fib!"
        else f1+f2
  where
    [f1,f2] = parMap rnf fibs [(n-1),(n-2)]

main = do
  putStrLn "Starting..."
  putStrLn $ "Fib 43: " ++ show (fib 43)
  putStrLn "Done!"


----------------------------------------------------
Prog 2:

module Main() where

import Control.Concurrent
import Control.Concurrent.MVar

fibs :: Integer -> Integer
fibs n | n > 1  = fibs (n-1) + fibs (n-2)
       | n == 1 = 1
       | True   = 0

fib n = if n<0 then error "Negative input to fib!"
        else do
          v1 <- newEmptyMVar
          v2 <- newEmptyMVar
          h1 <- forkIO $ putMVar v1 $ fibs (n-1)
          h2 <- forkIO $ putMVar v2 $ fibs (n-2)
          f1 <- takeMVar v1
          f2 <- takeMVar v2
          killThread h1
          killThread h2
          return (f1+f2)

main = do
  putStrLn "Starting..."
  f <- fib 43
  putStrLn $ "Fib 43: " ++ show f
  putStrLn "Done!"


----------------------------------------------------
Prog 3:

module Main() where

import Control.Concurrent
import Control.Concurrent.MVar

fibs :: Integer -> Integer
fibs n | n > 1  = fibs (n-1) + fibs (n-2)
       | n == 1 = 1
       | True   = 0

fib n = if n<0 then error "Negative input to fib!"
        else do
          v1 <- newEmptyMVar
          v2 <- newEmptyMVar
          h1 <- forkOS $ putMVar v1 $ fibs (n-1)
          h2 <- forkOS $ putMVar v2 $ fibs (n-2)
          f1 <- takeMVar v1
          f2 <- takeMVar v2
          killThread h1
          killThread h2
          return (f1+f2)

main = do
  putStrLn "Starting..."
  f <- fib 43
  putStrLn $ "Fib 43: " ++ show f
  putStrLn "Done!"