[Haskell-cafe] Speed of Error handling with Continuations vs. Eithers

10 May 2010

      Based on some discussions in #haskell, it seemed to be a consensus that using a modified continuation monad for Error handling instead of Eithers would be a significant optimization since it would eliminate a lot of conditional branching (everytime >>= is called in the Either monad, there is a conditional.  

I implemented a ErrCPS monad which does exactly that, but the speed has been disappointing.  It runs almost exactly 3x slower than a drop in replacement using the MonadError instance of Either from mtl.  

mkEMA and midError are basically toy functions but I dont know why Either is so much faster.  I've experimented with putting some seq's in the bindErrCPS and even {-# INLINE (>>=) #-} in the Monad instance, but to no avail.

I've copy/pasted the code below, any suggestions on optimization, or if this is simply a bad idea would be much appreciated.  Strangely, compiling with -O2 seems to have no effect on the speed:

-Max
...
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
module Main  where
import Control.Applicative
import Control.Monad.Error -- hiding (foldM)
import Control.Monad.Trans
import Control.Monad hiding (foldM)
import System.Random
import Control.Monad.Identity (runIdentity, Identity)
import Control.Monad.Reader.Class
import Data.Time.LocalTime as Time -- for benchmarking
import Data.Time.Calendar (Day)
import Data.Time.LocalTime (getZonedTime)
...
midError :: MonadError String m => Double -> Double -> m Double
midError a b = if (b < 1) then throwError "check val"
                             else let r = (a + b) / 2 in r `seq` (return r)
mkEMA l = foldM midError  1 l
...
newtype ErrCPS e m a = ErrCPS { runErrCPS :: forall r . (e -> m r) --  error handler
                                          -> (a -> m r) --  success handler
                                          -> m r }

...
{-# INLINE retErrCPS  #-}
retErrCPS ::  a -> ErrCPS e m a 
retErrCPS x = ErrCPS $ \_ good -> good x
{-# INLINE bindErrCPS  #-} 
bindErrCPS ::  ErrCPS e m b -> (b -> ErrCPS e m a) -> ErrCPS e m a
bindErrCPS m f =  ErrCPS $ \err good -> runErrCPS m err $ \x -> runErrCPS (f x) err good
instance Monad m => Monad (ErrCPS e m)  where
  return = retErrCPS 
  (>>=) = bindErrCPS
...
main :: IO ()
main = do
  let n = 500000
      runEither e b g = either b g e
      runTest f s = do
        sg <- newStdGen
        let l = take n $ randomRs (2, 50000) sg
        mapM_ (\e -> e `seq` return ()) l
        stopwatch $ f (mkEMA l) 
                      (putStr . show) 
                      (putStr . (s ++) . show)
forever $ do runTest runEither "either:  "
               runTest runErrCPS "errCPS:  "
ErrCPS based code seems to run almost exactly 3x slower than the
Either based code: 
  errCPS:  37453.226  Action ran in: 30 msec
  either:  26803.055  Action ran in: 11 msec
  errCPS:  15840.626  Action ran in: 34 msec
  either:  32556.881  Action ran in: 10 msec
  errCPS:  38933.121  Action ran in: 30 msec
  either:  35370.820  Action ran in: 11 msec
  ...
...
instance (Error e, Monad m) => MonadError e (ErrCPS e m) where
  throwError = errCPS
  catchError m f = ErrCPS $ \err good -> runErrCPS m (\e -> runErrCPS (f e) err good) good
-- * MTL stuff
instance MonadTrans (ErrCPS e ) where lift m = ErrCPS $ \_ good -> m >>= good
instance (MonadIO m) => MonadIO (ErrCPS e m ) where liftIO = lift . liftIO
Random utility stuff
...
stopwatch :: IO () -> IO ()
stopwatch act = do
  t1 <- getFastTimeOfDay
  act
  t2 <- getFastTimeOfDay
  putStrLn $ "  Action ran in: " ++ show (t2 - t1) ++ " msec"
type FastTimeOfDay = Int
-- | Return the current trading day.  This should respect the 
--   fact that the Trading Day ranges from 
--   SingTime 6am (UTC -02:00) to SST 5:59 am (UTC -1:59).  
getTradingDay :: IO Day
getTradingDay = error "getTradingDay undefined"
getFastTimeOfDay :: IO FastTimeOfDay
getFastTimeOfDay = getZonedTime >>= 
                   (return . fastFromTimeOfDay .  Time.localTimeOfDay .  Time.zonedTimeToLocalTime)
timeOfDayFromFast :: FastTimeOfDay -> Time.TimeOfDay
timeOfDayFromFast fast = Time.TimeOfDay
  { Time.todHour = fromIntegral (fast `div` (3600 * 1000))
  , Time.todMin =  fromIntegral (fast `div` (60 * 1000)) `mod` 60
  , Time.todSec = fromRational $ (fromIntegral fast) / 1000
  }
fastFromTimeOfDay :: Time.TimeOfDay -> FastTimeOfDay
fastFromTimeOfDay t = fromIntegral $ 
  ((Time.todHour t) * 3600000) + 
  ((Time.todMin t) * 60000) + 
  (round $ 1000 * Time.todSec t)

...
instance (Monad m) => Functor (ErrCPS e m) where
  fmap f m = ErrCPS $ \err good -> runErrCPS m err (good . f)
instance (Monad m) => Applicative (ErrCPS e m) where
  pure = return
  f <*> a = do f' <- f
               a' <- a
               return $ f' a'
errCPS :: forall e m a . e -> ErrCPS e m a
errCPS e = ErrCPS $ \err _ -> err e

[Haskell-cafe] Speed of Error handling with Continuations vs. Eithers

Max Cantor