Производительность ByteString concatMap

У меня есть файл 37MB bin, который я пытаюсь преобразовать в последовательность ppm. Он отлично работает, и я пытаюсь использовать его в качестве упражнения, чтобы узнать немного о профилировании и узнать больше о ленивых строках байтов в Haskell. Моя программа, кажется, бомбит concatMap, который используется для трехкратной репликации каждого байта, поэтому у меня есть R, G и B. Код довольно прост - каждые 2048 байтов я пишу новый заголовок:

{-# LANGUAGE OverloadedStrings #-}

import System.IO
import System.Environment
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B


main :: IO ()
main = do [from, to] <- getArgs
          withFile from ReadMode $ \inH ->
            withFile to WriteMode $ \outH ->
                loop (B.hGet inH 2048) (process outH) B.null


loop :: (Monad m) => m a -> (a -> m ()) -> (a -> Bool) -> m ()
loop inp outp done = inp >>= \x -> unless (done x) (outp x >> loop inp outp done)


process :: Handle -> B.ByteString -> IO ()
process h bs | B.null bs = return ()
             | otherwise = B.hPut h header >> B.hPut h bs'
                           where header = "P6\n32 64\n255\n" :: B.ByteString
                                 bs'    = B.concatMap (B.replicate 3) bs

Это тянет его чуть более 5s. Это не страшно, и мое единственное сравнение - это моя очень наивная реализация C, которая делает это немного меньше 4s - так что это или в идеале было моей целью.

Вот RTS из приведенного выше кода:

  33,435,345,688 bytes allocated in the heap
      14,963,640 bytes copied during GC
          54,640 bytes maximum residency (77 sample(s))
          21,136 bytes maximum slop
               2 MB total memory in use (0 MB lost due to fragmentation)

                                    Tot time (elapsed)  Avg pause  Max pause
  Gen  0     64604 colls,     0 par    0.20s    0.25s     0.0000s    0.0001s
  Gen  1        77 colls,     0 par    0.00s    0.01s     0.0001s    0.0006s

  INIT    time    0.00s  (  0.00s elapsed)
  MUT     time    5.09s  (  5.27s elapsed)
  GC      time    0.21s  (  0.26s elapsed)
  EXIT    time    0.00s  (  0.00s elapsed)
  Total   time    5.29s  (  5.52s elapsed)

  %GC     time       3.9%  (4.6% elapsed)

  Alloc rate    6,574,783,667 bytes per MUT second

  Productivity  96.1% of total user, 92.1% of total elapsed

Довольно хреновые результаты. Когда я удаляю concatMap и просто копирую все заголовки каждые 2048 байт, это практически мгновенно:

      70,983,992 bytes allocated in the heap
          48,912 bytes copied during GC
          54,640 bytes maximum residency (2 sample(s))
          19,744 bytes maximum slop
               1 MB total memory in use (0 MB lost due to fragmentation)

                                    Tot time (elapsed)  Avg pause  Max pause
  Gen  0       204 colls,     0 par    0.00s    0.00s     0.0000s    0.0000s
  Gen  1         2 colls,     0 par    0.00s    0.00s     0.0001s    0.0001s

  INIT    time    0.00s  (  0.00s elapsed)
  MUT     time    0.01s  (  0.07s elapsed)
  GC      time    0.00s  (  0.00s elapsed)
  EXIT    time    0.00s  (  0.00s elapsed)
  Total   time    0.02s  (  0.07s elapsed)

  %GC     time       9.6%  (2.9% elapsed)

  Alloc rate    5,026,838,892 bytes per MUT second

  Productivity  89.8% of total user, 22.3% of total elapsed

Итак, я думаю, мой вопрос состоит из двух частей:

• Как я могу улучшить общую производительность?
• И если бы узкое место не было столь очевидным, как бы я мог его отследить?

Спасибо.

Изменить

Вот окончательный код и RTS, если кому интересно! Я также смог найти дополнительные узкие места, используя профилировщик ghc с -prof -auto-all -caf-all после прочтения Профилирование и оптимизация главы Real World Haskell.

{-# LANGUAGE OverloadedStrings #-}

import System.IO
import System.Environment
import Control.Monad
import Data.Monoid
import qualified Data.ByteString.Builder    as BU
import qualified Data.ByteString.Lazy.Char8 as BL


main :: IO ()
main = do [from, to] <- getArgs
          withFile from ReadMode $ \inH ->
              withFile to WriteMode $ \outH ->
                  loop (BL.hGet inH 2048) (process outH) BL.null


loop :: (Monad m) => m a -> (a -> m ()) -> (a -> Bool) -> m ()
loop inp outp done = inp >>= \x -> unless (done x) (outp x >> loop inp outp done)


upConcatMap :: Monoid c => (Char -> c) -> BL.ByteString -> c
upConcatMap f bs = mconcat . map f $ BL.unpack bs


process :: Handle -> BL.ByteString -> IO ()
process h bs | BL.null bs = return ()
             | otherwise = BU.hPutBuilder h frame
                           where header = "P6\n32 64\n255\n"
                                 bs'    = BU.toLazyByteString $ upConcatMap trip bs
                                 frame  = BU.lazyByteString $ mappend header bs'
                                 trip c = let b = BU.char8 c in mconcat [b, b, b]

6,383,263,640 bytes allocated in the heap
      18,596,984 bytes copied during GC
          54,640 bytes maximum residency (2 sample(s))
          31,056 bytes maximum slop
               1 MB total memory in use (0 MB lost due to fragmentation)

                                    Tot time (elapsed)  Avg pause  Max pause
  Gen  0     11165 colls,     0 par    0.06s    0.06s     0.0000s    0.0001s
  Gen  1         2 colls,     0 par    0.00s    0.00s     0.0001s    0.0002s

  INIT    time    0.00s  (  0.00s elapsed)
  MUT     time    0.69s  (  0.83s elapsed)
  GC      time    0.06s  (  0.06s elapsed)
  EXIT    time    0.00s  (  0.00s elapsed)
  Total   time    0.75s  (  0.89s elapsed)

  %GC     time       7.4%  (7.2% elapsed)

  Alloc rate    9,194,103,284 bytes per MUT second

  Productivity  92.6% of total user, 78.0% of total elapsed