Last active
November 8, 2023 22:42
-
-
Save noughtmare/cccda38eb7c67c1ea6df6a3377f1da0d to your computer and use it in GitHub Desktop.
The fastest effect system approaches translate operations into a fast concrete monad like IO or State.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE UnboxedTuples #-} | |
import Control.Monad | |
import Test.Tasty.Bench | |
import Data.IORef | |
{-# NOINLINE countdownIO #-} | |
countdownIO :: IO Integer -> (Integer -> IO ()) -> IO Integer | |
countdownIO get put = go where | |
go = do | |
n <- get | |
if n <= 0 then pure n | |
else put (n - 1) *> go | |
-- this inline version "cheats" because it will inline the concrete definitions of `get` and `put` | |
{-# INLINE countdownIO' #-} | |
countdownIO' :: IO Integer -> (Integer -> IO ()) -> IO Integer | |
countdownIO' get put = go where | |
go = do | |
n <- get | |
if n <= 0 then pure n | |
else put (n - 1) *> go | |
newtype State s a = State (s -> (# a, s #)) | |
instance Functor (State s) where | |
fmap = liftM | |
instance Applicative (State s) where | |
pure x = State (\s -> (# x, s #)) | |
(<*>) = ap | |
instance Monad (State s) where | |
State f >>= k = State (\s -> case f s of (# x, s' #) -> case k x of State f -> f s') | |
evalState :: State s a -> s -> a | |
evalState (State f) s = case f s of (# x, _ #) -> x | |
{-# NOINLINE countdownState #-} | |
countdownState :: State Integer Integer -> (Integer -> State Integer ()) -> State Integer Integer | |
countdownState get put = go where | |
go = do | |
n <- get | |
if n <= 0 then pure n | |
else put (n - 1) *> go | |
-- this inline version "cheats" because it will inline the concrete definitions of `get` and `put` | |
{-# INLINE countdownState' #-} | |
countdownState' :: State Integer Integer -> (Integer -> State Integer ()) -> State Integer Integer | |
countdownState' get put = go where | |
go = do | |
n <- get | |
if n <= 0 then pure n | |
else put (n - 1) *> go | |
main :: IO () | |
main = | |
defaultMain | |
[ bench "io" $ nfIO $ do | |
ref <- newIORef 10000 | |
countdownIO (readIORef ref) (\s -> writeIORef ref s) | |
, bench "io cheat" $ nfIO $ do | |
ref <- newIORef 10000 | |
countdownIO' (readIORef ref) (\s -> writeIORef ref s) | |
, bench "state" $ nf (evalState (countdownState (State (\s -> (# s, s #))) (\s -> State (\_ -> (# (), s #))))) 10000 | |
, bench "state cheat" $ nf (evalState (countdownState' (State (\s -> (# s, s #))) (\s -> State (\_ -> (# (), s #))))) 10000 | |
] |
For those wondering how to make an actual effect system out of this:
data StateE s m = StateE
{ getImpl :: m s
, putImpl :: s -> m ()
}
get = perform (\x -> getImpl x)
put s = perform (\x -> putImpl x s)
newtype Eff e a = Eff { runEff :: e IO -> IO a } deriving (Functor, Applicative, Monad) via ReaderT (e IO) IO
perform :: (e IO -> IO a) -> Eff e a
perform f = Eff f
{-# NOINLINE countdownEff #-}
countdownEff :: Eff (StateE Integer) Integer
countdownEff = do
n <- get
if n <= 0 then pure n
else put *> countdownEff
evalStateE :: Eff (StateE s) a -> s -> IO a
evalStateE (Eff f) s = do
ref <- newIORef s
f StateE { getImpl = readIORef ref, putImpl = writeIORef ref }
Bench:
bench "eff" $ nfIO (evalStateE countdownEff 10000)
io: OK
179 μs ± 13 μs, 390 KB allocated, 22 B copied, 6.0 MB peak memory
state: OK
175 μs ± 13 μs, 390 KB allocated, 17 B copied, 6.0 MB peak memory
eff: OK
172 μs ± 13 μs, 390 KB allocated, 19 B copied, 6.0 MB peak memory
(This time with my laptop unplugged)
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Results: