[Haskell-beginners] missing parallelism

[Maurizio Vitale]

G'day,
  I have a test code that I compile with ghc -threaded -eventlog
-rtsopts --make parallel.hs and run with ./parallel 2 +RTS -ls -N4 on
a laptop with 4 physical cores. I would expect activities in two
threads, but threadscope shows only one active thread.
Can somebody explain me the program's behaviour?

Thanks a lot

   Maurizio

{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TupleSections #-}

import Control.Applicative
import Control.Concurrent.Async (async, waitAny, Async)
import Data.List (delete, sortBy)
import Data.Ord (comparing)
import System.CPUTime
import System.Environment
import GHC.Conc (numCapabilities)

concurrentlyLimited :: Int -> [IO a] -> IO [a]
concurrentlyLimited n tasks = concurrentlyLimited' n (zip [0..] tasks) [] []

concurrentlyLimited' ∷ Int               -- ^ number of concurrent evaluations
                     → [(Int, IO b)]     -- ^ still to run (ordered by
first element)
                     → [Async (Int,b)]   -- ^ currently running
                     → [(Int,b)]         -- ^ partial results (ordered
by first element)
                     → IO [b]
concurrentlyLimited' _ [] [] results = return . map snd $ sortBy
(comparing fst) results
concurrentlyLimited' 0 todo ongoing results = do
    (task, newResult) <- waitAny ongoing
    concurrentlyLimited' 1 todo (delete task ongoing) (newResult:results)

concurrentlyLimited' _ [] ongoing results = concurrentlyLimited' 0 []
ongoing results
concurrentlyLimited' n ((i, task):otherTasks) ongoing results = do
    t <- async $ (i,) <$> task
    concurrentlyLimited' (n-1) otherTasks (t:ongoing) results

euler :: Int → Int
euler n = length (filter (relprime n) [1..n-1])
          where
            relprime x y = gcd x y == 1

sumEuler :: Int → Int
sumEuler = sum . (map euler) . mkList
           where
             mkList n = [1..n-1]

p ∷ IO Int
p = return $ sumEuler 3000

numThreads ∷ [String] → IO Int
numThreads [] = return numCapabilities
numThreads [cores] = return $ read cores

main ∷ IO()
main = do
  threads ← getArgs >>= numThreads
  putStrLn $ "Running up to " ++ show threads ++ " threads in parallel
(on " ++ show numCapabilities ++ " cores)"
  startTime ← getCPUTime
  f ← concurrentlyLimited threads $ replicate 10 p
  endTime ← getCPUTime
  putStrLn $ foldr  ((++) . show ) ""  f
  putStrLn $ "Evaluation took " ++ show (fromIntegral (endTime -
startTime) / 1000000000000∷Double)