Haskell MVar : How to execute shortest job first? - multithreading

Question

When more than one thread is waiting to write an MVar, they are executed in first-in first-out scheme. I want to execute thread as per shortest job scheduling.
I have tired to code this using MVar. Here job is to calculate a Fibonacci number and write a MVar. 1st thread calculates Fibonacci 30 and 2nd thread calculates Fibonacci 10. As time taken for calculating Fibonacci 10 is less than 30, thus 2nd thread should execute first. I a not getting the desired result from the following block of code.
How to implement shortest job first scheduling in Haskell (or may be using Haskell STM)?
Code
module Main
where
import Control.Parallel
import Control.Concurrent
import System.IO
nfib :: Int -> Int
nfib n | n <= 2 = 1
| otherwise = par n1 (pseq n2 (n1 + n2 ))
where n1 = nfib (n-1)
n2 = nfib (n-2)
type MInt = MVar Int
updateMVar :: MInt -> Int -> IO ()
updateMVar n v = do x1 <- readMVar n
let y = nfib v
x2 <- readMVar n
if x1 == x2
then do t <- takeMVar n
putMVar n y
else return()
main :: IO ()
main = do
n <- newEmptyMVar
putMVar n 0
forkIO(updateMVar n 30)
t <- readMVar n
putStrLn("n is : " ++ (show t))
forkIO(updateMVar n 10)
t <- readMVar n
putStrLn("n is : " ++ (show t))
Output
n is : 832040
n is : 55

Answer 1

To implement scheduling you need to use MVars and threads together. Start with an empty MVar. Fork the jobs you wish to run in the background. The main thread can then block on each result in turn. The fastest will come first. Like so:
{-# LANGUAGE BangPatterns #-}
import Control.Parallel
import Control.Concurrent
import System.IO
nfib :: Int -> Int
nfib n | n <= 2 = 1
| otherwise = par n1 (pseq n2 (n1 + n2 ))
where n1 = nfib (n-1)
n2 = nfib (n-2)
main :: IO ()
main = do
result <- newEmptyMVar
forkIO $ do
let !x = nfib 40
putMVar result x
forkIO $ do
let !x = nfib 30
putMVar result x
t <- takeMVar result
print $ "Fastest result was: " ++ show t
t <- takeMVar result
print $ "Slowest result was: " ++ show t
Note that it is important to use bang patterns to evaluate the fibonacci calls outside of the MVar (don't want to simply return an unevaluated thunk to the main thread).
Compile with the threaded runtime:
$ ghc -o A --make A.hs -threaded -fforce-recomp -rtsopts
[1 of 1] Compiling Main ( A.hs, A.o )
Linking A.exe ...
And run on two cores:
$ ./A.exe +RTS -N2
"Fastest result was: 832040"
"Slowest result was: 102334155"
Productivity is pretty good as well (use +RTS -s to see runtime performance statistics).
Productivity 89.3% of total user, 178.1% of total elapsed
The first thread to finish will have its result printed first. The main thread will then block until the second thread is done.
The main thing is to take advantage of MVar empty/full semantics to block the main thread on each of the children threads.