Allocate pinned object blocks from the nursery, not the global

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)

1 files changed, 2 insertions, 0 deletions

diff --git a/rts/Capability.h b/rts/Capability.h
index 2ae2fcf6d7..2f616b5c6f 100644
--- a/rts/Capability.h
+++ b/rts/Capability.h
@@ -76,6 +76,8 @@ struct Capability_ {
 
     // block for allocating pinned objects into
     bdescr *pinned_object_block;
+    // full pinned object blocks allocated since the last GC
+    bdescr *pinned_object_blocks;
 
     // Context switch flag.  When non-zero, this means: stop running
     // Haskell code, and switch threads.