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

Max Cantor

Jan-Willem Maessen

Max Cantor

wren ng thornton

wren ng thornton

Andrea Vezzosi

wren ng thornton

Andrea Vezzosi

wren ng thornton

Andrea Vezzosi

Antoine Latter

wren ng thornton

Henning Thielemann

Derek Elkins

Antoine Latter

Derek Elkins

Max Cantor

Derek Elkins

Antoine Latter

Derek Elkins

roconnor＠theorem.ca

tags

participants (8)