Add State monad benchmarks by Andras Kovacs

Summary:
They are originally from
https://github.com/AndrasKovacs/misc-stuff/blob/master/haskell/Eff/EffBench.hs

They show interesting interactions with call arity, spec constr and SAT.

Reviewers: O26 nofib, michalt, simonpj, bgamari

Reviewed By: bgamari

Subscribers: RyanGlScott

GHC Trac Issues: #13892

Differential Revision: https://phabricator.haskell.org/D3683

real/Makefile

@@ -3,7 +3,7 @@ include $(TOP)/mk/boilerplate.mk
 
 SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \
           grep hidden hpg infer lift linear maillist mkhprog parser pic prolog \
-          reptile rsa scs symalg veritas
+          reptile rsa scs symalg veritas eff
 
 
 include $(TOP)/mk/target.mk

real/eff/CS/CS.stdout

+CS

real/eff/CS/EffBench.hs

+{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+
+-- inlined church free state
+--------------------------------------------------------------------------------
+-- IF, we run a late pass of SAT and modify the bound to run SAT on one
+-- static argument AND add an additional run of the simplifier then this
+-- optimises well. AND also need to run specConstr after doing SAT.
+
+newtype CS s a = CS {runCS ::
+     forall r.
+     (a -> r)          -- pure
+  -> ((s -> r) -> r)   -- get
+  -> (s -> r -> r)     -- put
+  -> r
+  }
+
+instance Functor (CS s) where
+
+  fmap f (CS g) = CS $ \pure get put -> g (pure . f) get put
+  {-# inline fmap #-}
+
+instance Applicative (CS s) where
+  pure a = CS $ \pure get put -> pure a
+  {-# inline pure #-}
+  CS mf <*> CS ma = CS $ \pure get put ->
+    mf (\f -> ma (pure . f) get put) get put
+  {-# inline (<*>) #-}
+
+instance Monad (CS s) where
+  return a = CS $ \pure get put -> pure a
+  {-# inline return #-}
+  CS ma >>= f = CS $ \pure get put ->
+    ma (\a -> runCS (f a) pure get put) get put
+  {-# inline (>>=) #-}
+  CS ma >> CS mb = CS $ \pure get put -> ma (\_ -> mb pure get put) get put
+  {-# inline (>>) #-}
+
+cmodify :: (s -> s) -> CS s ()
+cmodify f = CS $ \pure get put ->
+  get $ \s -> let !s' = f s in
+  put s' $
+  pure ()
+{-# inline cmodify #-}
+
+crunState :: CS s a -> s -> (a, s)
+crunState (CS f) = f
+  (\a s -> (a, s))
+  (\got s -> got s s)
+  (\s' put s -> put s')
+{-# inline crunState #-}
+
+test2 :: Int -> ((), Int)
+test2 n = crunState (times n (cmodify (+1))) 0
+
+

real/eff/CS/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "CS"
+  evaluate $ crunState (times n $ cmodify (+1)) 0
+

real/eff/CS/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts -package transformers
+
+include $(TOP)/mk/target.mk
+

real/eff/CSD/CSD.stdout

+CSD

real/eff/CSD/EffBench.hs

+{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+import qualified Control.Monad.State.Strict as S
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+
+-- Classy chruch state
+--------------------------------------------------------------------------------
+--
+-- This optimises well as it's the role of the specialiser to specialise
+-- each `pure`, `get`, `put`.
+
+class PureD r a where cpure :: a -> r
+class GetD  s r where cget  :: (s -> r) -> r
+class PutD  s r where cput  :: s -> r -> r
+
+csmodify :: (GetD s r, PutD s r, PureD r ()) => (s -> s) -> r
+csmodify f = cget $ \s -> let !s' = f s in cput s' $ cpure ()
+
+cstimes :: forall r. (GetD Int r, PutD Int r, PureD r ()) => Int -> r
+cstimes 0 = cpure ()
+cstimes n = (cget :: (Int -> r) -> r) $ \s -> let !s' = s + 1 in (cput :: (Int -> r -> r)) s' $ cstimes (n - 1)
+
+instance PureD (s -> (a, s)) a where
+  cpure a s = (a, s)
+  {-# inline cpure #-}
+instance GetD  s (s -> (a, s)) where
+  cget got s = got s s
+  {-# inline cget #-}
+instance PutD s (s -> (a, s)) where
+  cput s' r _ = r s'
+  {-# inline cput #-}
+
+

real/eff/CSD/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "CSD"
+  evaluate $ (cstimes :: Int -> (Int -> ((), Int))) n (0 :: Int)
+

real/eff/CSD/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts
+
+include $(TOP)/mk/target.mk
+

real/eff/FS/EffBench.hs

+{-# LANGUAGE RankNTypes, LambdaCase, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+-- inlined free state
+--------------------------------------------------------------------------------
+
+data FS s a = Pure a | Get (s -> FS s a) | Put !s (FS s a)
+
+instance Functor (FS s) where
+  fmap f = go where
+    go = \case
+      Pure a  -> Pure (f a)
+      Get k   -> Get (fmap f . k)
+      Put s k -> Put s (fmap f k)
+  {-#  inline fmap #-}
+
+instance Applicative (FS s) where
+  pure = Pure
+  Pure f  <*> ma = fmap f ma
+  Get k   <*> ma = Get ((<*> ma) . k)
+  Put s k <*> ma = Put s (k <*> ma)
+  {-# inline pure #-}
+  {-# inline (<*>) #-}
+
+instance Monad (FS s) where
+  return = Pure
+  Pure a  >>= f = f a
+  Get k   >>= f = Get ((>>= f) . k)
+  Put s k >>= f = Put s (k >>= f)
+  {-# inline return #-}
+  {-# inline (>>=) #-}
+
+fmodify :: (s -> s) -> FS s ()
+fmodify f =
+  Get $ \s ->
+  Put (f s) $
+  Pure ()
+{-# inline fmodify #-}
+
+frunState :: FS s a -> s -> (a, s)
+frunState (Pure a)   s = (a, s)
+frunState (Get k)    s = frunState (k s) s
+frunState (Put s' k) s = frunState k s'
+

real/eff/FS/FS.stdout

+FS

real/eff/FS/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "FS"
+  evaluate $ frunState (times n $ (fmodify (+1))) 0
+

real/eff/FS/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts
+
+include $(TOP)/mk/target.mk
+

real/eff/Makefile

+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+SUBDIRS = CS S FS VS VSM CSD VSD
+
+
+include $(TOP)/mk/target.mk
+

real/eff/S/Main.hs

+module Main (main) where
+
+import Control.Exception.Base
+import qualified Control.Monad.State.Strict as S
+
+n :: Int
+n = 10000000
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+main = do
+
+  putStrLn "S"
+  evaluate $ S.runState (times n $ (S.modify (+1))) 0
+

real/eff/S/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts -package transformers -package mtl -O2
+
+include $(TOP)/mk/target.mk
+

real/eff/S/S.stdout

+S

real/eff/VS/EffBench.hs

+{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+
+
+-- inlined van Laarhoven free state
+--------------------------------------------------------------------------------
+
+newtype S s a = S {runS :: s -> (a, s)}
+
+newtype VS s a = VS { runVS ::
+     forall m.
+     (forall a. a -> m a)                   -- pure
+  -> (forall a b. m a -> (a -> m b) -> m b) -- bind
+  -> m s                                  -- get
+  -> (s -> m ())                            -- put
+  -> m a
+  }
+
+instance Functor (VS s) where
+  fmap f (VS g) = VS $ \pure (>>=) get put ->
+    g pure (>>=) get put >>= \a -> pure (f a)
+  {-# inline fmap #-}
+
+instance Applicative (VS s) where
+  pure a = VS $ \pure (>>=) get put -> pure a
+  VS mf <*> VS ma = VS $ \pure (>>=) get put ->
+    mf pure (>>=) get put >>= \f ->
+    ma pure (>>=) get put >>= \a -> pure (f a)
+  {-# inline pure #-}
+  {-# inline (<*>) #-}
+
+instance Monad (VS s) where
+  return a = VS $ \pure (>>=) get put -> pure a
+  VS ma >>= f = VS $ \pure (>>=) get put ->
+    ma pure (>>=) get put >>= \a -> runVS (f a) pure (>>=) get put
+  {-# inline return #-}
+
+vmodify :: (s -> s) -> VS s ()
+vmodify f = VS $ \pure (>>=) get put ->
+  get >>= \s ->
+  let !s' = f s in
+  put s'
+{-# inline vmodify #-}
+
+vrunState' :: VS s a -> S s a
+vrunState' (VS f) = f
+  (\a -> S $ \s -> (a, s))
+  (\(S ma) f -> S $ \s -> let !(!a, !s') = ma s; !(!b, !s'') = runS (f a) s' in (b, s''))
+  (S $ \s -> (s, s))
+  (\s' -> S $ const ((), s'))
+{-# inline vrunState' #-}
+
+vrunState :: VS s a -> s -> (a, s)
+vrunState x = runS (vrunState' x)
+{-# inline vrunState #-}
+

real/eff/VS/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "VS"
+  evaluate $ vrunState (times n $ (vmodify (+1))) 0
+

real/eff/VS/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts -package transformers
+
+include $(TOP)/mk/target.mk
+

real/eff/VS/VS.stdout

+VS

real/eff/VSD/EffBench.hs

+{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+import qualified Control.Monad.State.Strict as S
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+-- classy van Laarhoven state (same as mtl)
+--------------------------------------------------------------------------------
+
+class VPutD s m where vput :: s -> m ()
+class VGetD s m where vget :: m s
+
+vmdmodify :: (Monad m, VPutD s m, VGetD s m) => (s -> s) -> m ()
+vmdmodify f = do
+  s <- vget
+  let !s' = f s
+  vput s'
+
+instance VPutD s (S.State s) where vput = S.put
+instance VGetD s (S.State s) where vget = S.get
+
+
+

real/eff/VSD/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+import qualified Control.Monad.State.Strict as S
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "VSD"
+  evaluate $ S.runState (times n $ (vmdmodify :: (Int -> Int) -> S.State Int ())  (+1)) (0 :: Int)
+

real/eff/VSD/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts -package transformers -package mtl
+
+include $(TOP)/mk/target.mk
+

real/eff/VSD/VSD.stdout

+VSD

real/eff/VSM/EffBench.hs

+{-# LANGUAGE RankNTypes, BangPatterns, ScopedTypeVariables,
+  MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+
+{-# OPTIONS -fexpose-all-unfoldings #-}
+
+
+
+module EffBench where
+
+import qualified Control.Monad.State.Strict as S
+
+
+times :: Monad m => Int -> m a -> m ()
+times n ma = go n where
+  go 0 = pure ()
+  go n = ma >> go (n - 1)
+{-# inline times #-}
+
+
+-- van Laarhoven state translated to mtl State
+--------------------------------------------------------------------------------
+
+newtype VSM s a = VSM { runVSM :: forall m. Monad m => m s -> (s -> m ()) -> m a}
+
+instance Functor (VSM s) where
+  fmap f (VSM g) = VSM $ \get put ->
+    g get put >>= \a -> pure (f a)
+  {-# inline fmap #-}
+
+instance Applicative (VSM s) where
+  pure a = VSM $ \get put -> pure a
+  VSM mf <*> VSM ma = VSM $ \get put ->
+    mf get put >>= \f ->
+    ma get put >>= \a -> pure (f a)
+  {-# inline pure #-}
+  {-# inline (<*>) #-}
+
+instance Monad (VSM s) where
+  return a = VSM $ \get put -> pure a
+  VSM ma >>= f = VSM $ \get put ->
+    ma get put >>= \a -> runVSM (f a) get put
+  {-# inline return #-}
+
+vmmodify :: (s -> s) -> VSM s ()
+vmmodify f = VSM $ \get put ->
+  get >>= \s ->
+  let !s' = f s in
+  put s'
+{-# inline vmmodify #-}
+
+vmrunState :: VSM s a -> s -> (a, s)
+vmrunState (VSM ma) = S.runState (ma S.get S.put)
+{-# inline vmrunState #-}
+
+test :: Int -> ((), Int)
+test n = vmrunState (times n $ vmmodify (+1)) n
+
+

real/eff/VSM/Main.hs

+module Main (main) where
+
+import EffBench
+import Control.Exception.Base
+
+n :: Int
+n = 10000000
+
+main = do
+
+  putStrLn "VSM"
+  evaluate $ vmrunState (times n $ vmmodify (+1)) 0
+

real/eff/VSM/Makefile

+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_RUNTEST_OPTS += -stdout-binary
+
+SRC_HC_OPTS += -fglasgow-exts -package transformers -package mtl
+
+include $(TOP)/mk/target.mk
+

real/eff/VSM/VSM.stdout

+VSM