Extend benchmark

automaton/src/Data/Automaton.hs

@@ -13,7 +13,7 @@ module Data.Automaton where
 import Control.Applicative (Alternative (..))
 import Control.Arrow
 import Control.Category
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), foldM)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Coerce (coerce)
 import Data.Function ((&))
@@ -257,6 +257,13 @@ instance (Monad m) => ArrowChoice (Automaton m) where
   right (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT $! either (pure . Left) (fmap Right . runReaderT ma)
   {-# INLINE right #-}
 
+  f ||| g = f +++ g >>> arr untag
+    where
+      untag (Left x) = x
+      untag (Right y) = y
+
+  {-# INLINE (|||) #-}
+
 -- | Caution, this can make your program hang. Try to use 'feedback' or 'unfold' where possible, or combine 'loop' with 'delay'.
 instance (MonadFix m) => ArrowLoop (Automaton m) where
   loop (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT (\b -> fst <$> mfix ((. snd) $ ($ b) $ curry $ runReaderT ma))
@@ -364,12 +371,7 @@ embed ::
   -- | The input values
   [a] ->
   m [b]
-embed (Automaton (Stateful StreamT {state, step})) = go state
-  where
-    go _s [] = return []
-    go s (a : as) = do
-      Result s' b <- runReaderT (step s) a
-      (b :) <$> go s' as
+embed (Automaton (Stateful StreamT {state, step})) = fmap (fmap output) $ foldM (\(Result s bs) a -> fmap (: bs) <$> runReaderT (step s) a) $ Result state []
 embed (Automaton (Stateless m)) = mapM $ runReaderT m
 
 -- * Modifying automata
@@ -514,10 +516,12 @@ sumS = sumFrom zeroVector
 -- | Sum up all inputs so far, initialised at 0.
 sumN :: (Monad m, Num a) => Automaton m a a
 sumN = arr Sum >>> mappendS >>> arr getSum
+{-# INLINE sumN #-}
 
 -- | Count the natural numbers, beginning at 1.
 count :: (Num n, Monad m) => Automaton m a n
 count = feedback 0 $! arr (\(_, n) -> let n' = n + 1 in (n', n'))
+{-# INLINE count #-}
 
 -- | Remembers the last 'Just' value, defaulting to the given initialisation value.
 lastS :: (Monad m) => a -> Automaton m (Maybe a) a

rhine/bench/Sum.hs

@@ -9,12 +9,13 @@ Most of the implementations really benchmark 'embed', as the lazy list is create
 module Sum where
 
 import "base" Control.Monad (foldM)
+import "base" Data.Either (fromLeft)
 import "base" Data.Functor.Identity
 import "base" Data.Void (absurd)
-
 import "criterion" Criterion.Main
 
 import "automaton" Data.Stream as Stream (StreamT (..))
+import qualified "automaton" Data.Stream as Stream (reactimate)
 import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))
 import "rhine" FRP.Rhine
 
@@ -25,9 +26,13 @@ benchmarks :: Benchmark
 benchmarks =
   bgroup
     "Sum"
-    [ bench "rhine" $ nf rhine nMax
+    [ bench "rhine embed" $ nf rhine nMax
     , bench "rhine flow" $ nf rhineFlow nMax
-    , bench "automaton" $ nf automaton nMax
+    , bench "rhine flow IO" $ nfAppIO rhineMS nMax
+    , bench "automaton embed" $ nf automaton nMax
+    , bench "automatonNoEmbed" $ nf automatonNoEmbed nMax
+    , bench "automatonEmbed" $ nf automatonEmbed nMax
+    , bench "automatonNoEmbedInlined" $ nf automatonNoEmbedInlined nMax
     , bench "direct" $ nf direct nMax
     , bench "direct monad" $ nf directM nMax
     ]
@@ -47,6 +52,22 @@ rhineFlow n =
           then returnA -< ()
           else arrMCl Left -< s
 
+myclock :: IOClock (ExceptT Int IO) (Millisecond 0)
+myclock = ioClock waitClock
+
+rhineMS :: Int -> IO Int
+rhineMS n =
+  fmap (either id absurd) $
+  runExceptT $
+    flow $
+      (@@ myclock) $ proc () -> do
+        k <- count -< ()
+        s <- sumN -< k
+        if k < n
+          then returnA -< ()
+          else throwS -< s
+
+-- embed cannot be faster because it receives a list of boxed ints, whereas the flow version can unbox it.
 automaton :: Int -> Int
 automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
   where
@@ -59,6 +80,32 @@ automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
             , Stream.step = \s -> return $! Result (s + 1) s
             }
 
+automatonEmbed :: Int -> Int
+automatonEmbed n = fromLeft (error "nope") $ flip embed (repeat ()) $ proc () -> do
+  k <- count -< ()
+  s <- sumN -< k
+  if k < n
+    then returnA -< ()
+    else arrM Left -< s
+
+automatonNoEmbed :: Int -> Int
+automatonNoEmbed n = either id absurd $ reactimate $ proc () -> do
+  k <- count -< ()
+  s <- sumN -< k
+  if k < n
+    then returnA -< ()
+    else arrM Left -< s
+
+automatonNoEmbedInlined :: Int -> Int
+automatonNoEmbedInlined k = either id absurd $ Stream.reactimate StreamT
+            { state = (1, 0)
+            , Stream.step = \(n, s) ->
+              let n' = n + 1
+                  s' = s + n
+              in if n' > k then Left s' else return $! Result (n', s') ()
+            }
+
+
 direct :: Int -> Int
 direct n = sum [0 .. n]
 

rhine/bench/Test.hs

@@ -26,6 +26,9 @@ main =
           "Sum"
           [ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "automaton" $ Sum.automaton Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonNoEmbed" $ Sum.automatonNoEmbed Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonEmbed" $ Sum.automatonEmbed Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonNoEmbedInlined" $ Sum.automatonNoEmbedInlined Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "rhine flow" $ Sum.rhineFlow Sum.nMax @?= Sum.direct Sum.nMax
           ]
       ]

rhine/src/FRP/Rhine/Clock.hs

@@ -148,6 +148,7 @@ instance
       ( runningClock >>> first (arr f)
       , f initTime
       )
+  {-# INLINE initClock #-}
 
 {- | Instead of a mere function as morphism of time domains,
    we can transform one time domain into the other with an effectful morphism.
@@ -205,6 +206,7 @@ instance
       ( runningClock >>> rescaling
       , rescaledInitTime
       )
+  {-# INLINE initClock #-}
 
 -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.
 rescaledClockMToS ::
@@ -242,6 +244,7 @@ instance
       ( hoistS monadMorphism runningClock
       , initialTime
       )
+  {-# INLINE initClock #-}
 
 -- | Lift a clock type into a monad transformer.
 type LiftClock m t cl = HoistClock m (t m) cl

rhine/src/FRP/Rhine/Clock/Realtime.hs

@@ -92,3 +92,4 @@ waitUTC unscaledClockS =
             return (now, (tag, guard (remaining > 0) >> return (fromRational remaining)))
         return (runningClock, initTime)
     }
+{-# INLINE waitUTC #-}

rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs

@@ -41,9 +41,11 @@ instance Clock IO (Millisecond n) where
   type Time (Millisecond n) = UTCTime
   type Tag (Millisecond n) = Maybe Double
   initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second snd))
+  {-# INLINE initClock #-}
 
 instance GetClockProxy (Millisecond n)
 
 -- | Tries to achieve real time by using 'waitUTC', see its docs.
 waitClock :: (KnownNat n) => Millisecond n
 waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger)
+{-# INLINE waitClock #-}

rhine/src/FRP/Rhine/Clock/Unschedule.hs

@@ -43,3 +43,4 @@ instance (TimeDomain (Time cl), Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m
     where
       run :: ScheduleT (Diff (Time cl)) m a -> m a
       run = runScheduleT scheduleWait
+  {-# INLINE initClock #-}

rhine/src/FRP/Rhine/Clock/Util.hs

@@ -35,3 +35,4 @@ genTimeInfo _ initialTime = proc (absolute, tag) -> do
         , sinceInit = absolute `diffTime` initialTime
         , ..
         }
+{-# INLINE genTimeInfo #-}

rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {- | Translate clocked signal processing components to stream functions without explicit clock types.
 
@@ -23,7 +25,7 @@
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.Clock.Util
 import FRP.Rhine.ResamplingBuffer
-import FRP.Rhine.SN
+import FRP.Rhine.Schedule (In, Out, SequentialClock)
 
 {- | Run a clocked signal function as an automaton,
    accepting the timestamps and tags as explicit inputs.
@@ -39,31 +41,44 @@
   runReaderS clsf -< (timeInfo, a)
 {-# INLINE eraseClockClSF #-}
 
-{- | Run a signal network as an automaton.
+-- Andras' trick: Encode in the domain
+newtype SN m cl a b = SN { getSN :: Reader (Time cl) (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)) }
+
+instance GetClockProxy cl => ToClockProxy (SN m cl a b) where
+  type Cl (SN m cl a b) = cl
+
+eraseClockSN :: Time cl -> SN m cl a b -> (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b))
+eraseClockSN time = flip runReader time . getSN
+{-# INLINE eraseClockSN #-}
 
-   Depending on the incoming clock,
-   input data may need to be provided,
-   and depending on the outgoing clock,
-   output data may be generated.
-   There are thus possible invalid inputs,
-   which 'eraseClockSN' does not gracefully handle.
--}
-eraseClockSN ::
-  (Monad m, Clock m cl, GetClockProxy cl) =>
-  Time cl ->
-  SN m cl a b ->
-  Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)
 -- A synchronous signal network is run by erasing the clock from the clocked signal function.
-eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do
-  b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)
+synchronous :: forall cl m a b .     ( cl ~ In cl, cl ~ Out cl, Monad m, Clock m cl, GetClockProxy cl) =>
+    ClSF m cl a b ->
+    SN   m cl a b
+
+synchronous clsf = SN $ reader $ \initialTime -> proc (time, tag, Just a) -> do
+  b <- eraseClockClSF (getClockProxy @cl) initialTime clsf -< (time, tag, a)
   returnA -< Just b
+{-# INLINE synchronous #-}
 
 -- A sequentially composed signal network may either be triggered in its first component,
 -- or its second component. In either case,
 -- the resampling buffer (which connects the two components) may be triggered,
 -- but only if the outgoing clock of the first component ticks,
 -- or the incoming clock of the second component ticks.
-eraseClockSN initialTime (Sequential sn1 resBuf sn2) =
+sequential ::     ( Clock m clab, Clock m clcd
+    , Clock m (Out clab), Clock m (Out clcd)
+    , Clock m (In  clab), Clock m (In  clcd)
+    , GetClockProxy clab, GetClockProxy clcd
+    , Time clab ~ Time clcd
+    , Time clab ~ Time (Out clab)
+    , Time clcd ~ Time (In  clcd), Monad m
+    ) =>
+    SN               m      clab            a b     ->
+    ResamplingBuffer m (Out clab) (In clcd)   b c   ->
+    SN               m                clcd      c d ->
+    SN m (SequentialClock   clab      clcd) a     d
+sequential sn1 resBuf sn2  = SN $ reader $ \initialTime ->
   let
     proxy1 = toClockProxy sn1
     proxy2 = toClockProxy sn2
@@ -81,25 +96,33 @@
           returnA -< Nothing
         Right tagR -> do
           eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)
-eraseClockSN initialTime (Parallel snL snR) = proc (time, tag, maybeA) -> do
+{-# INLINE sequential #-}
+
+parallel snL snR = SN $ reader$ \initialTime -> proc (time, tag, maybeA) -> do
   case tag of
     Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)
     Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)
-eraseClockSN initialTime (Postcompose sn clsf) =
+{-# INLINE parallel #-}
+
+postcompose sn clsf = SN $ reader $ \initialTime  ->
   let
     proxy = toClockProxy sn
    in
     proc input@(time, tag, _) -> do
       bMaybe <- eraseClockSN initialTime sn -< input
       mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time,,) <$> outTag proxy tag <*> bMaybe
-eraseClockSN initialTime (Precompose clsf sn) =
+{-# INLINE postcompose #-}
+
+precompose clsf sn = SN $ reader $ \initialTime ->
   let
     proxy = toClockProxy sn
    in
     proc (time, tag, aMaybe) -> do
       bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe
       eraseClockSN initialTime sn -< (time, tag, bMaybe)
-eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) =
+{-# INLINE precompose #-}
+
+feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime  ->
   let
     proxy = toClockProxy sn
    in
@@ -119,7 +142,9 @@
           timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)
           buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf')
           returnA -< (Just b, buf'')
-eraseClockSN initialTime (FirstResampling sn buf) =
+{-# INLINE feedbackSN #-}
+
+firstResampling sn buf = SN $ reader $ \initialTime ->
   let
     proxy = toClockProxy sn
    in
@@ -132,7 +157,7 @@
           _ -> Nothing
       dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput
       returnA -< (,) <$> bMaybe <*> join dMaybe
-{-# INLINE eraseClockSN #-}
+{-# INLINE firstResampling #-}
 
 {- | Translate a resampling buffer into an automaton.
 

rhine/src/FRP/Rhine/Reactimation/Combinators.hs

@@ -22,10 +22,10 @@ import FRP.Rhine.ClSF.Core
 import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.ResamplingBuffer
-import FRP.Rhine.SN
 import FRP.Rhine.SN.Combinators
 import FRP.Rhine.Schedule
 import FRP.Rhine.Type
+import FRP.Rhine.Reactimation.ClockErasure
 
 -- * Combinators and syntactic sugar for high-level composition of signal networks.
 
@@ -39,11 +39,14 @@ infix 5 @@
 (@@) ::
   ( cl ~ In cl
   , cl ~ Out cl
+  , Monad m
+  , Clock m cl
+  , GetClockProxy cl
   ) =>
   ClSF  m cl a b ->
           cl     ->
   Rhine m cl a b
-(@@) = Rhine . Synchronous
+(@@) = Rhine . synchronous
 {-# INLINE (@@) #-}
 
 {- | A purely syntactical convenience construction
@@ -82,6 +85,7 @@ infixr 1 -->
 (-->) ::
   ( Clock m cl1
   , Clock m cl2
+  , Monad m
   , Time cl1 ~ Time cl2
   , Time (Out cl1) ~ Time cl1
   , Time (In  cl2) ~ Time cl2
@@ -94,7 +98,7 @@ infixr 1 -->
   Rhine m cl2 b c ->
   Rhine m (SequentialClock cl1 cl2) a c
 RhineAndResamplingBuffer (Rhine sn1 cl1) rb --> (Rhine sn2 cl2) =
-  Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2)
+  Rhine (sequential sn1 rb sn2) (SequentialClock cl1 cl2)
 
 {- | The combinators for parallel composition allow for the following syntax:
 
@@ -177,7 +181,7 @@ f ^>>@ Rhine sn cl = Rhine (f ^>>> sn) cl
 
 -- | Postcompose a 'Rhine' with a 'ClSF'.
 (@>-^) ::
-  ( Clock m (Out cl)
+  ( Clock m (Out cl), GetClockProxy cl, Monad m
   , Time cl ~ Time (Out cl)
   ) =>
   Rhine m      cl  a b   ->
@@ -187,7 +191,7 @@ Rhine sn cl @>-^ clsf = Rhine (sn >--^ clsf) cl
 
 -- | Precompose a 'Rhine' with a 'ClSF'.
 (^->@) ::
-  ( Clock m (In cl)
+  ( Clock m (In cl), GetClockProxy cl, Monad m
   , Time cl ~ Time (In cl)
   ) =>
   ClSF  m (In cl) a b   ->