Reduce allocations for event dispatch

reactive-banana/src/Control/Monad/Trans/ReaderWriterIO.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, DerivingVia, GeneralisedNewtypeDeriving #-}
 module Control.Monad.Trans.ReaderWriterIO (
     -- * Synopsis
     -- | An implementation of the reader/writer monad transformer
@@ -11,87 +11,38 @@ module Control.Monad.Trans.ReaderWriterIO (
 import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Data.IORef
+import Control.Monad.Trans.Writer.CPS ( WriterT )
+import qualified Control.Monad.Trans.Writer.CPS as W
+import Control.Monad.Trans.Reader ( ReaderT )
+import qualified Control.Monad.Trans.Reader as R
+import Data.Monoid
 
-{-----------------------------------------------------------------------------
-    Type and class instances
-------------------------------------------------------------------------------}
-newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: r -> IORef w -> m a }
+newtype ReaderWriterIOT r w m a = ReaderWriterIOT { run :: ReaderT r (WriterT w m) a }
+    deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
+    deriving (Semigroup, Monoid) via Ap (ReaderT r (WriterT w m)) a
 
-instance Functor m => Functor (ReaderWriterIOT r w m)   where fmap = fmapR
-
-instance Applicative m => Applicative (ReaderWriterIOT r w m) where
-    pure  = pureR
-    (<*>) = apR
-
-instance Monad m => Monad (ReaderWriterIOT r w m) where
-    return = returnR
-    (>>=)  = bindR
-
-instance MonadFix m => MonadFix (ReaderWriterIOT r w m) where mfix = mfixR
-instance MonadIO m => MonadIO (ReaderWriterIOT r w m)   where liftIO = liftIOR
-instance MonadTrans (ReaderWriterIOT r w)               where lift = liftR
-
-instance (Monad m, a ~ ()) => Semigroup (ReaderWriterIOT r w m a) where
-    mx <> my = mx >> my
-
-instance (Monad m, a ~ ()) => Monoid (ReaderWriterIOT r w m a) where
-    mempty  = return ()
-    mappend = (<>)
-
-{-----------------------------------------------------------------------------
-    Functions
-------------------------------------------------------------------------------}
-liftIOR :: MonadIO m => IO a -> ReaderWriterIOT r w m a
-liftIOR m = ReaderWriterIOT $ \_ _ -> liftIO m
-
-liftR :: m a -> ReaderWriterIOT r w m a
-liftR m = ReaderWriterIOT $ \_ _ -> m
-
-fmapR :: Functor m => (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b
-fmapR f m = ReaderWriterIOT $ \x y -> fmap f (run m x y)
-
-returnR :: Monad m => a -> ReaderWriterIOT r w m a
-returnR a = ReaderWriterIOT $ \_ _ -> return a
-
-bindR :: Monad m => ReaderWriterIOT r w m a -> (a -> ReaderWriterIOT r w m b) -> ReaderWriterIOT r w m b
-bindR m k = ReaderWriterIOT $ \x y -> run m x y >>= \a -> run (k a) x y
-
-mfixR :: MonadFix m => (a -> ReaderWriterIOT r w m a) -> ReaderWriterIOT r w m a
-mfixR f = ReaderWriterIOT $ \x y -> mfix (\a -> run (f a) x y)
-
-pureR :: Applicative m => a -> ReaderWriterIOT r w m a
-pureR a = ReaderWriterIOT $ \_ _ -> pure a
-
-apR :: Applicative m => ReaderWriterIOT r w m (a -> b) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m b
-apR f a = ReaderWriterIOT $ \x y -> run f x y <*> run a x y
+instance MonadTrans (ReaderWriterIOT r w) where 
+    lift = ReaderWriterIOT . lift . lift
 
 readerWriterIOT :: (MonadIO m, Monoid w) =>
     (r -> IO (a, w)) -> ReaderWriterIOT r w m a
 readerWriterIOT f = do
     r <- ask
-    (a,w) <- liftIOR $ f r
+    (a,w) <- liftIO $ f r
     tell w
     return a
 
 runReaderWriterIOT :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> r -> m (a,w)
-runReaderWriterIOT m r = do
-    ref <- liftIO $ newIORef mempty
-    a   <- run m r ref
-    w   <- liftIO $ readIORef ref
-    return (a,w)
+runReaderWriterIOT m r = W.runWriterT (R.runReaderT (run m) r)
 
-tell :: (MonadIO m, Monoid w) => w -> ReaderWriterIOT r w m ()
-tell w = ReaderWriterIOT $ \_ ref -> liftIO $ modifyIORef ref (`mappend` w)
+tell :: (Monoid w, Monad m) => w -> ReaderWriterIOT r w m ()
+tell = ReaderWriterIOT . lift . W.tell
 
 listen :: (MonadIO m, Monoid w) => ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w)
-listen m = ReaderWriterIOT $ \r ref -> do
-    a <- run m r ref
-    w <- liftIO $ readIORef ref
-    return (a,w)
+listen = ReaderWriterIOT . R.mapReaderT W.listen . run
 
 local :: MonadIO m => (r -> r) -> ReaderWriterIOT r w m a -> ReaderWriterIOT r w m a
-local f m = ReaderWriterIOT $ \r ref -> run m (f r) ref
+local f = ReaderWriterIOT . R.local f . run
 
 ask :: Monad m => ReaderWriterIOT r w m r
-ask = ReaderWriterIOT $ \r _ -> return r
+ask = ReaderWriterIOT R.ask

reactive-banana/src/Reactive/Banana/Prim/Compile.hs

@@ -27,7 +27,7 @@ compile m state1 = do
     theAlwaysP <- case nAlwaysP state1 of
         Just x   -> return x
         Nothing  -> do
-            (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())
+            (x,_,_) <- runBuildIO (undefined,undefined) $ newPulse "alwaysP" (return $ Just ())
             return x
 
     (a, topology, os) <- runBuildIO (nTime state1, theAlwaysP) m

reactive-banana/src/Reactive/Banana/Prim/Evaluation.hs

@@ -2,6 +2,7 @@
     reactive-banana
 ------------------------------------------------------------------------------}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
 module Reactive.Banana.Prim.Evaluation (
     step
     ) where
@@ -107,14 +108,14 @@ insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Que
 insertNodes (RWS.Tuple (time,_) _ _) = go
     where
     go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
-    go []              q = return q
-    go (node@(P p):xs) q = do
+    go []              !q = return q
+    go (node@(P p):xs) !q = do
         Pulse{..} <- readRef p
         if time <= _seenP
             then go xs q        -- pulse has already been put into the queue once
             else do             -- pulse needs to be scheduled for evaluation
                 put p $! (let p = Pulse{..} in p { _seenP = time })
                 go xs (Q.insert _levelP node q)
-    go (node:xs)      q = go xs (Q.insert ground node q)
+    go (node:xs)      !q = go xs (Q.insert ground node q)
             -- O and L nodes have only one parent, so
             -- we can insert them at an arbitrary level

reactive-banana/src/Reactive/Banana/Prim/IO.hs

@@ -39,7 +39,7 @@ newInput = mdo
         }
     -- Also add the  alwaysP  pulse to the inputs.
     let run :: a -> Step
-        run a = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty)
+        run a n = step ([P pulse, P always], Lazy.insert key (Just a) Lazy.empty) n
     return (pulse, run)
 
 -- | Register a handler to be executed whenever a pulse occurs.

reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs

@@ -2,6 +2,7 @@
     reactive-banana
 ------------------------------------------------------------------------------}
 {-# LANGUAGE RecordWildCards, RecursiveDo, ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
 module Reactive.Banana.Prim.Plumbing where
 
 import           Control.Monad                                (join)
@@ -129,20 +130,21 @@ addOutput p = do
     Build monad
 ------------------------------------------------------------------------------}
 runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])
-runBuildIO i m = do
-        (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m
+runBuildIO !i m = do
+        (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold i mempty m
         doit liftIOLaters          -- execute late IOs
         return (a,Action $ Deps.buildDependencies topologyUpdates,os)
-    where
-    -- Recursively execute the  buildLater  calls.
-    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)
-    unfold w m = do
-        (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i
-        let w' = w <> BuildW (w1,w2,w3,mempty)
-        w'' <- case later of
-            Just m  -> snd <$> unfold w' m
-            Nothing -> return w'
-        return (a,w'')
+{-# inline runBuildIO #-}
+
+-- Recursively execute the  buildLater  calls.
+unfold :: BuildR -> BuildW -> BuildIO a -> IO (a, BuildW)
+unfold !i w m = do
+    (a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i
+    let !w' = w <> BuildW (w1,w2,w3,mempty)
+    w'' <- case later of
+        Just m  -> snd <$> unfold i w' m
+        Nothing -> return w'
+    return (a,w'')
 
 buildLater :: Build () -> Build ()
 buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)
@@ -211,6 +213,7 @@ runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)
 runEvalP s1 m = RW.readerWriterIOT $ \r2 -> do
     (a,_,(w1,w2)) <- RWS.runRWSIOT m r2 s1
     return ((a,w1), w2)
+{-# inline runEvalP #-}
 
 liftBuildP :: Build a -> EvalP a
 liftBuildP m = RWS.rwsT $ \r2 s -> do

reactive-banana/src/Reactive/Banana/Prim/Types.hs

@@ -23,7 +23,7 @@ import Reactive.Banana.Prim.Util
 -- | A 'Network' represents the state of a pulse/latch network,
 data Network = Network
     { nTime           :: !Time                 -- Current time.
-    , nOutputs        :: !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.
+    , nOutputs        :: {-# unpack #-} !(OrderedBag Output)  -- Remember outputs to prevent garbage collection.
     , nAlwaysP        :: !(Maybe (Pulse ()))   -- Pulse that always fires.
     }