Commit c7e6c907 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

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
parent 576aee6c
...@@ -3,7 +3,7 @@ include $(TOP)/mk/boilerplate.mk ...@@ -3,7 +3,7 @@ include $(TOP)/mk/boilerplate.mk
SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \ SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \
grep hidden hpg infer lift linear maillist mkhprog parser pic prolog \ 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 include $(TOP)/mk/target.mk
......
{-# 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
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
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -stdout-binary
SRC_HC_OPTS += -fglasgow-exts -package transformers
include $(TOP)/mk/target.mk
{-# 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 #-}
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)
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -stdout-binary
SRC_HC_OPTS += -fglasgow-exts
include $(TOP)/mk/target.mk
{-# 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'
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
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -stdout-binary
SRC_HC_OPTS += -fglasgow-exts
include $(TOP)/mk/target.mk
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SUBDIRS = CS S FS VS VSM CSD VSD
include $(TOP)/mk/target.mk
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
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
{-# 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 #-}
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
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -stdout-binary
SRC_HC_OPTS += -fglasgow-exts -package transformers
include $(TOP)/mk/target.mk
{-# 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
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)
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
{-# 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
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
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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment