Thread creation benchmark in Haskell

tcbench.hs

import Control.Concurrent
import Control.Concurrent.Chan
import System.Environment
import System.Exit
import System.Time

main = getArgs >>= start

start [s1,s2] = do
  stopCh <- newChan
  startTime <- getClockTime
  createThreads 0 [] (read s1 :: Int) (read s2 :: Int) startTime stopCh

createThreads rounds chans total step lastTime stopCh
  | rounds == total       = exitWith ExitSuccess
  | length chans == step  = waitThreads rounds (reverse chans) total step lastTime stopCh
  | otherwise             = do ch <- newChan
                               forkIO (thread ch stopCh)
                               createThreads rounds (ch:chans) total step lastTime stopCh

waitThreads rounds [] total step lastTime stopCh = do
  currentTime <- getClockTime
  putStrLn $ show $ diffToMillisec $ diffClockTimes currentTime lastTime
  createThreads (rounds + 1) [] total step currentTime stopCh

waitThreads rounds (ch:chans) total step lastTime stopCh =
  readChan ch >>= \_ -> waitThreads rounds chans total step lastTime stopCh

thread ch stopCh = writeChan ch 1 >> readChan stopCh >>= \_ -> putStrLn "WTF?!"

diffToMillisec diff = toInteger (seconds * 1000) + (p `div` 1000000000)
  where h = tdHour diff
        m = tdMin diff
        s = tdSec diff
        p = tdPicosec diff
        seconds = (h * 60 + m) * 60 + s