gistfile1.hs

module Main where

import Control.Concurrent
import Control.Exception
import System.IO.Unsafe


proc :: MVar Int -> IO ()
proc m = do
	v <- takeMVar m
	putMVar m (v+1)
	return ()

children :: MVar [MVar ()]
children = unsafePerformIO (newMVar [])

waitForChildren :: IO ()
waitForChildren = do
	cs <- takeMVar children
	case cs of
		[]   -> return ()
		m:ms -> do
			putMVar children ms
			takeMVar m
			waitForChildren

forkChild :: IO () -> IO ThreadId
forkChild io = do
	mvar <- newEmptyMVar
	childs <- takeMVar children
	putMVar children (mvar:childs)
	forkIO (io `finally` putMVar mvar ())

runChildren _ 0 = return ()
runChildren m n = do
	forkChild (proc m)
	runChildren m (n-1)

main = do
	m <- newEmptyMVar
	putMVar m 0
	runChildren m 1000000
	waitForChildren
	v <- takeMVar m
	putStrLn ("total = " ++ show v)