@@ -17,6 +17,7 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2021-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2122-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2223module Reflex.Spider.Internal where
@@ -180,12 +181,23 @@ unsafeNodeId a = unsafePerformIO $ do
180181-- Event
181182--------------------------------------------------------------------------------
182183
183−newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
184+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
185+
186+{-# INLINE subscribeAndRead #-}
187+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
188+subscribeAndRead = unEvent
189+
190+{-# RULES "pushCheap/cacheEvent" forall f e. pushCheap f (cacheEvent e) = pushCheap f e #-}
191+{-# RULES "hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e #-}
192+{- RULES
193+ "subscribeAndRead/cacheEvent" forall e. subscribeAndRead (cacheEvent e) = subscribeAndRead e
194+ #-}
184195
185196-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
186197-- caching; if the computation function is very cheap, this is (much) more
187198-- efficient than 'push'
188−{-# INLINABLE pushCheap #-}
199+{- INLINABLE pushCheap #-}
200+{-# INLINE [1] pushCheap #-}
189201pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
190202pushCheap f e = Event $ \sub -> do
191203 (subscription, occ) <- subscribeAndRead e $ sub
@@ -210,7 +222,7 @@ data CacheSubscribed x a
210222--TODO: Try a caching strategy where we subscribe directly to the parent when
211223--there's only one subscriber, and then build our own WeakBag only when a second
212224--subscriber joins
213−{-# INLINABLE cacheEvent #-}
225+{-# NOINLINE [1] cacheEvent #-}
214226cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
215227cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
216228 let !mSubscribedRef = unsafeNewIORef e Nothing
@@ -588,7 +600,7 @@ behaviorPull !p = Behavior $ do
588600 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
589601 return a
590602
591−behaviorDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Behavior x (R.PatchTarget p)
603+behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)
592604behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
593605
594606{-# INLINE readHoldTracked #-}
@@ -599,7 +611,7 @@ readHoldTracked h = do
599611 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
600612 return result
601613
602−{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> BehaviorM x a #-}
614+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
603615{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}
604616readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
605617readBehaviorUntracked b = do
@@ -693,7 +705,7 @@ instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
693705 {-# INLINE getDeferralQueue #-}
694706 getDeferralQueue = asksEventEnv eventEnvHoldInits
695707
696−instance HasSpiderTimeline x => Defer (SomeHoldInit x) (BehaviorM x) where
708+instance Defer (SomeHoldInit x) (BehaviorM x) where
697709 {-# INLINE getDeferralQueue #-}
698710 getDeferralQueue = BehaviorM $ asks snd
699711
@@ -752,8 +764,8 @@ instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
752764 getDeferralQueue = asksEventEnv eventEnvResetCoincidences
753765
754766-- Note: hold cannot examine its event until after the phase is over
755−{-# SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
756−{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}
767+{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}
768+{-# INLINE [1] hold #-}
757769hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)
758770hold v0 e = do
759771 valRef <- liftIO $ newIORef v0
@@ -1050,17 +1062,9 @@ instance HasSpiderTimeline x => Functor (Event x) where
10501062instance Functor (Behavior x) where
10511063 fmap f = pull . fmap f . readBehaviorTracked
10521064
1053−{-# INLINABLE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
1065+{-# INLINE push #-}
10541066push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
10551067push f e = cacheEvent (pushCheap f e)
1056−{-
1057−push f e = eventPush $ Push
1058− { pushCompute = f
1059− , pushParent = e
1060− , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
1061− }
1062−-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
1063−-}
10641068
10651069{-# INLINABLE pull #-}
10661070pull :: BehaviorM x a -> Behavior x a
@@ -1089,8 +1093,8 @@ coincidence a = eventCoincidence $ Coincidence
10891093run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
10901094run roots after = do
10911095 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1092− spiderTimeline <- SpiderHost ask
1093− result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do
1096+ t <- SpiderHost ask
1097+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
10941098 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
10951099 occBefore <- liftIO $ do
10961100 occBefore <- readIORef occRef
@@ -1485,7 +1489,11 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS
14851489
14861490{-# INLINE merge #-}
14871491merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
1488−merge d = cacheEvent $ Event $ \sub -> do
1492+merge d = cacheEvent (mergeCheap d)
1493+
1494+{-# INLINE [1] mergeCheap #-}
1495+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)
1496+mergeCheap d = Event $ \sub -> do
14891497 initialParents <- readBehaviorUntracked $ dynamicCurrent d
14901498 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
14911499 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1660,7 +1668,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toCl
16601668
16611669-- | Run an event action outside of a frame
16621670runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1663−runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1671+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
16641672 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
16651673 let go = do
16661674 result <- a
@@ -1822,7 +1830,7 @@ data Global
18221830
18231831{-# NOINLINE globalSpiderTimeline #-}
18241832globalSpiderTimeline :: SpiderTimeline Global
1825−globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
1833+!globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
18261834
18271835-- | Stores all global data relevant to a particular Spider timeline; only one
18281836-- value should exist for each type @x@
@@ -1887,6 +1895,7 @@ instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where
18871895 fail _ = error "Dynamic does not support 'fail'"
18881896
18891897instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
1898+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
18901899 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
18911900 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
18921901 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
18971906 never = SpiderEvent eventNever
18981907 {-# INLINABLE constant #-}
18991908 constant = SpiderBehavior . behaviorConst
1900− {-# INLINABLE push #-}
1909+ {-# INLINE push #-}
19011910 push f = SpiderEvent . push (coerce f) . unSpiderEvent
19021911 {-# INLINABLE pull #-}
19031912 pull = SpiderBehavior . pull . coerce
@@ -1964,11 +1973,11 @@ instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x)
19641973 {-# INLINABLE sample #-}
19651974 sample = runFrame . readBehaviorUntracked . unSpiderBehavior
19661975
1967−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
1976+instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
19681977 {-# INLINABLE sample #-}
19691978 sample = coerce . readBehaviorTracked . unSpiderBehavior
19701979
1971−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
1980+instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
19721981 {-# INLINABLE sample #-}
19731982 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
19741983