wip

.gitignore

@@ -32,3 +32,5 @@ hsenv.log
 .#*
 /shell.nix
 /ghci-tmp
+*.dump-*
+*.verbose-core2core

default.nix

@@ -4,6 +4,7 @@
 , monad-control, mtl, primitive, ref-tf, semigroupoids
 , semigroups, split, stdenv, stm, syb, template-haskell
 , these, transformers, transformers-compat, prim-uniq
+, ghc_reflex ? null
 }:
 mkDerivation {
   pname = "reflex";
@@ -20,6 +21,9 @@ mkDerivation {
     base bifunctors containers deepseq dependent-map dependent-sum
     hlint mtl ref-tf split transformers
   ];
+  buildDepends = [
+    ghc_reflex
+  ];
   homepage = "https://github.com/reflex-frp/reflex";
   description = "Higher-order Functional Reactive Programming";
   license = stdenv.lib.licenses.bsd3;

src/Reflex/DynamicWriter.hs

@@ -19,6 +19,7 @@ import Control.Monad.Reader
 import Control.Monad.Ref
 import Control.Monad.State.Strict
 import Data.Dependent.Map (DMap, DSum (..))
+import qualified Data.Dependent.Map as DMap
 import Data.Functor.Misc
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -166,15 +167,13 @@ instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Mon
         liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0
         liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $
           mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (Identity . getValue . runIdentity) mr)) p
-        liftedWritten0 :: DMap (Const2 (Some k) (Dynamic t w)) Identity
-        liftedWritten0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> Const2 (Some.This k) :=> Identity (getWritten r)) result0
-        liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchDMap $
-          mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (Identity . getWritten . runIdentity) mr)) p
-    --TODO: We should be able to improve the performance here in two ways
-    -- 1. Incrementally merging the Dynamics
-    -- 2. Incrementally updating the mconcat of the merged Dynamics
+        liftedWritten0 :: Map (Some k) (Dynamic t w)
+        liftedWritten0 = Map.fromDistinctAscList $ fmap (\(WrapArg k :=> Identity r) -> (Some.This k, getWritten r)) $ DMap.toList result0
+        liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchMap $
+          Map.fromDistinctAscList $ fmap (\(WrapArg k :=> ComposeMaybe mr) -> (Some.This k, fmap (getWritten . runIdentity) mr)) $ DMap.toList p
+    --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
     i <- holdIncremental liftedWritten0 liftedWritten'
-    tellDyn $ join $ mconcat . Map.elems . dmapToMap <$> incrementalToDynamic i
+    tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
     return (liftedResult0, liftedResult')
 
 withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)

src/Reflex/Optimizer.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+module Reflex.Optimizer (plugin) where
+
+#ifndef ghcjs_HOST_OS
+
+import GhcPlugins
+import Control.Arrow
+
+plugin :: Plugin
+plugin = defaultPlugin { installCoreToDos = install }
+
+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+install [] p = return $ makeInlinable : p
+
+makeInlinable :: CoreToDo
+makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do
+  let f v = setIdInfo v $ let i = idInfo v in
+        setInlinePragInfo i $ let p = inlinePragInfo i in
+        if isDefaultInlinePragma p
+        then defaultInlinePragma { inl_inline = Inlinable }
+        else p
+      newBinds = flip map (mg_binds modGuts) $ \case
+        NonRec b e -> NonRec (f b) e
+        Rec bes -> Rec $ map (first f) bes
+  return $ modGuts { mg_binds = newBinds }
+
+#else
+
+plugin :: ()
+plugin = ()
+
+#endif

src/Reflex/PerformEvent/Base.hs

@@ -32,6 +32,7 @@ import Data.Dependent.Map (DMap, GCompare (..), Some)
 import qualified Data.Dependent.Map as DMap
 import Data.Dependent.Sum
 import Data.Functor.Misc
+import Data.Maybe
 import Data.Semigroup
 import qualified Data.Some as Some
 import Data.These
@@ -211,7 +212,7 @@ sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response
   childRequestMap <- holdIncremental requests0 requests'
   RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
     mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
---  RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)
+  RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
   return (result0, result')
 
 instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

src/Reflex/PostBuild/Class.hs

@@ -98,7 +98,6 @@ instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m
     postBuild <- getPostBuild
     let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0
     rec (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
-        delayedResult' <- performEvent $ return () <$ result' -- Delaying this result seems to be faster than making RequestT (and thus PerformEvent) more prompt
         let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
-              DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE (void delayedResult')) . getComposeMaybe) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence
+              DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE (void result')) . getComposeMaybe) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence
     return (result0, result')

src/Reflex/Spider/Internal.hs

@@ -17,6 +17,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
 -- | This module is the implementation of the 'Spider' 'Reflex' engine.  It uses
 -- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
 module Reflex.Spider.Internal where
@@ -180,12 +181,23 @@ unsafeNodeId a = unsafePerformIO $ do
 -- Event
 --------------------------------------------------------------------------------
 
-newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
+
+{-# INLINE subscribeAndRead #-}
+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
+subscribeAndRead = unEvent
+
+{-# RULES "pushCheap/cacheEvent" forall f e. pushCheap f (cacheEvent e) = pushCheap f e #-}
+{-# RULES "hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e #-}
+{- RULES
+    "subscribeAndRead/cacheEvent" forall e. subscribeAndRead (cacheEvent e) = subscribeAndRead e
+  #-}
 
 -- | Construct an 'Event' equivalent to that constructed by 'push', but with no
 -- caching; if the computation function is very cheap, this is (much) more
 -- efficient than 'push'
-{-# INLINABLE pushCheap #-}
+{- INLINABLE pushCheap #-}
+{-# INLINE [1] pushCheap #-}
 pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
 pushCheap f e = Event $ \sub -> do
   (subscription, occ) <- subscribeAndRead e $ sub
@@ -210,7 +222,7 @@ data CacheSubscribed x a
 --TODO: Try a caching strategy where we subscribe directly to the parent when
 --there's only one subscriber, and then build our own WeakBag only when a second
 --subscriber joins
-{-# INLINABLE cacheEvent #-}
+{-# NOINLINE [1] cacheEvent #-}
 cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
 cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
   let !mSubscribedRef = unsafeNewIORef e Nothing
@@ -588,7 +600,7 @@ behaviorPull !p = Behavior $ do
         askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
         return a
 
-behaviorDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Behavior x (R.PatchTarget p)
+behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)
 behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
 
 {-# INLINE readHoldTracked #-}
@@ -599,7 +611,7 @@ readHoldTracked h = do
   askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
   return result
 
-{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> BehaviorM x a #-}
+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
 {-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}
 readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
 readBehaviorUntracked b = do
@@ -693,7 +705,7 @@ instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
   {-# INLINE getDeferralQueue #-}
   getDeferralQueue = asksEventEnv eventEnvHoldInits
 
-instance HasSpiderTimeline x => Defer (SomeHoldInit x) (BehaviorM x) where
+instance Defer (SomeHoldInit x) (BehaviorM x) where
   {-# INLINE getDeferralQueue #-}
   getDeferralQueue = BehaviorM $ asks snd
 
@@ -752,8 +764,8 @@ instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
   getDeferralQueue = asksEventEnv eventEnvResetCoincidences
 
 -- Note: hold cannot examine its event until after the phase is over
-{-# SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
-{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}
+{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
+{-# INLINE [1] hold #-}
 hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)
 hold v0 e = do
   valRef <- liftIO $ newIORef v0
@@ -1050,17 +1062,9 @@ instance HasSpiderTimeline x => Functor (Event x) where
 instance Functor (Behavior x) where
   fmap f = pull . fmap f . readBehaviorTracked
 
-{-# INLINABLE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
+{-# INLINE push #-}
 push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
 push f e = cacheEvent (pushCheap f e)
-{-
-push f e = eventPush $ Push
-  { pushCompute = f
-  , pushParent = e
-  , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
-  }
--- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
--}
 
 {-# INLINABLE pull #-}
 pull :: BehaviorM x a -> Behavior x a
@@ -1089,8 +1093,8 @@ coincidence a = eventCoincidence $ Coincidence
 run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
 run roots after = do
   tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
-  spiderTimeline <- SpiderHost ask
-  result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do
+  t <- SpiderHost ask
+  result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
     rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
       occBefore <- liftIO $ do
         occBefore <- readIORef occRef
@@ -1485,7 +1489,11 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS
 
 {-# INLINE merge #-}
 merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
-merge d = cacheEvent $ Event $ \sub -> do
+merge d = cacheEvent (mergeCheap d)
+
+{-# INLINE [1] mergeCheap #-}
+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
+mergeCheap d = Event $ \sub -> do
   initialParents <- readBehaviorUntracked $ dynamicCurrent d
   accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
   heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1660,7 +1668,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toCl
 
 -- | Run an event action outside of a frame
 runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
-runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
   let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
   let go = do
         result <- a
@@ -1822,7 +1830,7 @@ data Global
 
 {-# NOINLINE globalSpiderTimeline #-}
 globalSpiderTimeline :: SpiderTimeline Global
-globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
+!globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
 
 -- | Stores all global data relevant to a particular Spider timeline; only one
 -- value should exist for each type @x@
@@ -1887,6 +1895,7 @@ instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where
   fail _ = error "Dynamic does not support 'fail'"
 
 instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
+  {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
   newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
   newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
   newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
@@ -1897,7 +1906,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
   never = SpiderEvent eventNever
   {-# INLINABLE constant #-}
   constant = SpiderBehavior . behaviorConst
-  {-# INLINABLE push #-}
+  {-# INLINE push #-}
   push f = SpiderEvent . push (coerce f) . unSpiderEvent
   {-# INLINABLE pull #-}
   pull = SpiderBehavior . pull . coerce
@@ -1964,11 +1973,11 @@ instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x)
   {-# INLINABLE sample #-}
   sample = runFrame . readBehaviorUntracked . unSpiderBehavior
 
-instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
+instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
   {-# INLINABLE sample #-}
   sample = coerce . readBehaviorTracked . unSpiderBehavior
 
-instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
+instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
   {-# INLINABLE sample #-}
   sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b