allocator.

Prompted by a benchmark posted to parallel-haskell@haskell.org by
Andreas Voellmy <andreas.voellmy@gmail.com>.  This program exhibits
contention for the block allocator when run with -N2 and greater
without the fix:

{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
module Main where

import Control.Monad
import Control.Concurrent
import System.Environment
import GHC.IO
import GHC.Exts
import GHC.Conc

main = do
 [m] <- fmap (fmap read) getArgs
 n <- getNumCapabilities
 ms <- replicateM n newEmptyMVar
 sequence [ forkIO $ busyWorkerB (m `quot` n) >> putMVar mv () | mv <- ms ]
 mapM takeMVar ms

busyWorkerB :: Int -> IO ()
busyWorkerB n_loops = go 0
  where go !n | n >= n_loops = return ()
              | otherwise    =
          do p <- (IO $ \s ->
                    case newPinnedByteArray# 1024# s      of
                      { (# s', mbarr# #) ->
                           (# s', () #)
                      }
                  )
             go (n+1)