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

[Max Cantor]

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
> 
>