Mysterious rise in CPU usage and execution time when run on multiple cores

README.md

+RTS -N1 -RTS
2.31s, 36% CPU, 108128 bytes of memory

+RTS -N8 -RTS
8.42s, 423% CPU, 131308 bytes of memory

Why does increasing the core count from 1 to 8 cause such drastic rise in CPU usage?

It seems to be due to GC, but why?

+RTS -N1 -s -RTS
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0      1668 colls,     0 par    0.120s   0.147s     0.0001s    0.0009s
  Gen  1        20 colls,     0 par    0.056s   0.061s     0.0031s    0.0065s

+RTS -N8 -s -RTS
                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0      1048 colls,  1048 par    7.828s   1.869s     0.0018s    0.0347s
  Gen  1        21 colls,    20 par    0.364s   0.085s     0.0041s    0.0265s

The default allocation area size of -A512K was too small - setting it to -A2G brought GC close to the single-threaded version.

index-files.hs

{-# LANGUAGE OverloadedStrings #-}

import Streaming
import qualified Streaming.Prelude as S
import Streaming.Prelude (next, yield, each)
import Control.Concurrent hiding (yield)
import Control.Concurrent.Async
import qualified Control.Concurrent.SSem as Sem
import Network.Wreq
import Data.Aeson
import Data.Aeson.Lens
import Control.Lens ((^.), (^?), (^..))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BSS
import Data.ByteString.Builder
import Data.String
import Data.String.Conversions
import qualified Data.Text as T
import Control.Exception
import Control.Exception.Enclosed

main :: IO ()
main = do
  S.effects $ pMapM 20 indexPaths $ listsOf 100 $ S.stdinLn
  where
  indexPaths paths = do
    payload <- toLazyByteString . mconcat <$> (flip mapM paths $ \path -> do
      content <- BSS.readFile path
      return $ mconcat $ map ((<> "\n") . lazyByteString . encode)
        [ object ["index" .= object [("_index", "code"), ("_type", "file"), ("_id" .= path)]],
          object [("path" .= path), ("file" .= (cs content :: T.Text))]
        ])
    let loop = do
        response <- post "http://localhost:9200/_bulk" payload
        if response ^? responseBody . _Value . key "errors" . _Bool == Just False
          then return ()
          else loop
    loop

pMapM :: Int -> (a -> IO b) -> Stream (Of a) IO r -> Stream (Of (Either SomeException b)) IO r
pMapM n f stream = effect $ do
  sem <- Sem.new n
  initialHole <- newEmptyMVar

  let fill hole a = do
      nextHole <- newEmptyMVar
      Sem.wait sem
      async $ tryAny (f a) >>= \b -> putMVar hole $ effect $ do
        Sem.signal sem
        return $ yield b >> effect (takeMVar nextHole)
      return nextHole

  async $ do
    (hole :> r) <- S.foldM fill (return initialHole) return stream
    putMVar hole (return r)

  return $ effect $ takeMVar initialHole

listsOf n = S.mapped S.toList . chunksOf n