{-# LANGUAGE BangPatterns #-}

import Text.Printf
import Control.Monad
import Control.Concurrent
import Control.Concurrent.QSem

nTasks = 10
beginOffset = 10

fib x | x < 3 = 1
      | otherwise = (fib $ x - 1) + (fib $ x - 2)

routine :: QSem -> (MVar Int, Int) -> IO ()
routine outputMutex (resultMVar, x) = do
    safeIOWithSem outputMutex $ printf "Thread id = %d start\n" x
    let !result = fib x
    putMVar resultMVar result
    safeIOWithSem outputMutex $ printf "Thread id = %d end\n" x

safeIOWithSem :: QSem -> IO () -> IO ()
safeIOWithSem m f = waitQSem m >> f >> signalQSem m

main :: IO ()
main = do
    outputMutex <- newQSem 1
    resultMVars <- replicateM nTasks newEmptyMVar
    let tasks = zip resultMVars [beginOffset .. beginOffset + nTasks]

    safeIOWithSem outputMutex $ getNumCapabilities >>= printf "Processors = %d\n"
    safeIOWithSem outputMutex $ putStrLn "Start"

    mapM_ (forkIO . routine outputMutex) tasks

    forM_ tasks $ \(m, x) -> safeIOWithSem outputMutex $ takeMVar m >>= printf "Fib(%d) = %d\n" x

    safeIOWithSem outputMutex $ putStrLn "End"