[Haskell-cafe] Why is my mappend so slow?

[martin]

Hello all,

I wrote a Logger which, under certain conditions, prepends log-entries to a log and a Monoid instance of it. But as soon
as I mappend two Loggers my performance drops by 50%. This even happens when I mappend  mempty as shown below in --<2--.
I understand that the system has to do *something*, but it seems to cost a bit much. Without the strictness annotation
in --<1-- the performance degradation is even more dramatic (orders of magnitude).

The profile tells me that more that 50% of the time is spent in mappend.

COST CENTRE  MODULE    %time %alloc

mappend.\    Logger     50.6   35.8
logCount'.f  Logger     18.7   40.3
logCount'    Logger      5.4    0.0

Why is that so, and can I do anything about it?  I am willing to change the overall design if required.


This is the code

-- | A writer does the formatting
newtype Wtr a log = Wtr {runWtr :: a -> log}

-- | A looger is a writer plus an internal state
data Logger a log = Lgr {runLogger :: a -> log -> (log, Logger a log)}

instance Monoid (Logger a log) where
        mempty = Lgr (\_ l -> (l,mempty))
        mappend lgr1 lgr2 = Lgr $ \a l -> let !(log1',!lgr1') = runLogger lgr1 a l      --<1--
                                              !(log2',!lgr2') = runLogger lgr2 a log1'  --<1--
                                          in (log2', mappend lgr1' lgr2')


and this is how I test it

-- | Count calls __s__ and write log when s has reached nxt and then every dn calls
logCount' :: Monoid log => Int -> Int -> Int ->  Wtr (Int,a) log -> Logger a log
logCount' dn nxt s wtr = Lgr f
        where
            f a l = if s == nxt
                       then (runWtr wtr (s,a)  <> l, logCount'  dn (nxt+dn) (s+1) wtr)
                       else (l,                      logCount'  dn nxt      (s+1) wtr)


-- | Count calls and write log every dn calls
logCount dn = logCount' dn dn 0


-- testLogger :: Logger Int Int [String] -> [String]
testLogger lgr xs = fst $ foldl' f ([],lgr) xs
        where
            f (log', lgr') x = runLogger lgr' x log'

ex_wtr :: Wtr (Int,a) [String]
ex_wtr = Wtr $ \(x,_) -> ["Counted to " ++ (show x)]

ex_wtr2 :: Wtr Int [String]
ex_wtr2 = Wtr $ \x -> ["Counted to " ++ (show x)]

ex_inputs :: [Int]
ex_inputs = [1..10000000]

ex_logger = mempty <> logCount 300000 ex_wtr <> mempty                 --<2--
-- ex_logger = logCount 300000 ex_wtr


ex_main = do
    timeIt $ putStrLn $ ppShow $ testLogger ex_logger ex_inputs

main = ex_main