@@ -17,6 +17,8 @@
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE MagicHash #-}
21+{-# LANGUAGE UnboxedTuples #-}
20-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
22-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
21-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
23-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
22module Reflex.Spider.Internal where
24module Reflex.Spider.Internal where
@@ -47,6 +49,7 @@ import Data.Maybe
47import Data.Monoid ((<>))
49import Data.Monoid ((<>))
48import Data.Some (Some)
50import Data.Some (Some)
49import qualified Data.Some as Some
51import qualified Data.Some as Some
50import Data.These
53import Data.These
51import Data.Traversable
54import Data.Traversable
52import Data.Type.Coercion
55import Data.Type.Coercion
@@ -57,6 +60,7 @@ import GHC.Stack
57import System.IO.Unsafe
60import System.IO.Unsafe
58import System.Mem.Weak
61import System.Mem.Weak
59import Unsafe.Coerce
62import Unsafe.Coerce
63+import GHC.IO (IO (..))
61#ifdef DEBUG_CYCLES
65#ifdef DEBUG_CYCLES
62import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
66import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
@@ -195,13 +199,61 @@ pushCheap f e = Event $ \sub -> do
195 occ' <- join <$> mapM (runComputeM . f) occ
199 occ' <- join <$> mapM (runComputeM . f) occ
196 return (subscription, occ')
200 return (subscription, occ')
198data CacheSubscribed x a
203data CacheSubscribed x a
199 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))
204 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))
200 , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))
205 , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))
201 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
206 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
202− , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
203 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
207 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
208+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
212+newtype EventCache x a s = EventCache (Object s) deriving Struct
214+allocEventCache :: PrimMonad m => m (EventCache x a (PrimState m))
215+allocEventCache = alloc 4
217+{-# NOINLINE unsafeAllocEventCache #-}
218+unsafeAllocEventCache :: q -> EventCache x a (PrimState IO)
219+unsafeAllocEventCache q = unsafePerformIO $ do
221+ c <- allocEventCache
222+ set eventCache_subscribers_slot c Nil -- We only need to initialize this one; the others will be initialized later
225+clearEventCache :: EventCache x a (PrimState IO) -> IO ()
226+clearEventCache c = do
227+ set eventCache_subscribers_slot c Nil
228+ setField eventCache_weakSelf c $ error "weakSelf has been cleared"
229+ setField eventCache_parent c $ error "parent has been cleared"
230+ set eventCache_occurrence_slot c Nil
232+eventCache_subscribers :: Field (EventCache x a) (WeakBag (Subscriber x a))
233+eventCache_subscribers = field 0
235+eventCache_subscribers_slot :: Slot (EventCache x a) Object
236+eventCache_subscribers_slot = slot 0
238+eventCache_weakSelf :: Field (EventCache x a) (Weak (EventCache x a s))
239+eventCache_weakSelf = field 1
241+eventCache_parent :: Field (EventCache x a) (EventSubscription x)
242+eventCache_parent = field 2
244+eventCache_occurrence :: Field (EventCache x a) a
245+eventCache_occurrence = field 3
247+eventCache_occurrence_slot :: Slot (EventCache x a) Object
248+eventCache_occurrence_slot = slot 3
250+freezeStruct :: Struct t => t (PrimState IO) -> IO ()
251+freezeStruct t = IO $ \s -> case unsafeFreezeSmallArray# (destruct t) s of
252+ (# s', _ #) -> (# s', () #)
254+thawStruct :: Struct t => t (PrimState IO) -> IO ()
255+thawStruct t = IO $ \s -> case unsafeThawSmallArray# (unsafeCoerce# (destruct t)) s of
256+ (# s', _ #) -> (# s', () #)
206-- | Construct an 'Event' whose value is guaranteed not to be recomputed
258-- | Construct an 'Event' whose value is guaranteed not to be recomputed
207-- repeatedly
259-- repeatedly
@@ -211,49 +263,59 @@ data CacheSubscribed x a
211--subscriber joins
263--subscriber joins
212{-# INLINABLE cacheEvent #-}
264{-# INLINABLE cacheEvent #-}
213cacheEvent :: Event x a -> Event x a
265cacheEvent :: Event x a -> Event x a
214−cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
266+cacheEvent e = let !c = unsafeAllocEventCache e in Event $ \sub -> {-# SCC "cacheEvent" #-} do
215− let !mSubscribedRef = unsafeNewIORef e Nothing
267+ subscribersNil <- liftIO $ get eventCache_subscribers_slot c
216− mSubscribed <- liftIO $ readIORef mSubscribedRef
268+ case isNil subscribersNil of
217− case mSubscribed of
269+ False -> liftIO $ {-# SCC "cacheEventFalse" #-} do
218− Just subscribed -> liftIO $ do
270+ subscribers <- getField eventCache_subscribers c
271+ weakSelf <- getField eventCache_weakSelf c
272+ weakSelfRef <- newIORef weakSelf --TODO: Get rid of this extraneous IORef
219− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
273+ ticket <- WeakBag.insert sub subscribers weakSelfRef cleanupCacheSubscribed
220− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
274+ occNil <- get eventCache_occurrence_slot c
275+ occ <- if isNil occNil
277+ else Just <$> getField eventCache_occurrence c
221− let es = EventSubscribed
278+ let es = EventSubscribed
222− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
279+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ unsafeDupablePerformIO $ getField eventCache_parent c
223− , eventSubscribedRetained = toAny subscribed
280+ , eventSubscribedRetained = toAny c
225 return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
282 return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
226− Nothing -> do
283+ True -> {-# SCC "cacheEventTrue" #-} do
227− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
284+ weakSelf <- liftIO $ evaluate =<< mkWeakPtrWithDebug c "CacheEvent"
285+ liftIO $ setField eventCache_weakSelf c weakSelf
286+ weakSelfRef <- liftIO $ newIORef weakSelf --TODO: Get rid of this extraneous IORef
228− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
287+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelfRef cleanupCacheSubscribed
229− occRef <- liftIO $ newIORef undefined
288+ liftIO $ setField eventCache_subscribers c subscribers
230 (parentSub, occ) <- subscribeAndRead e $ Subscriber
289 (parentSub, occ) <- subscribeAndRead e $ Subscriber
231 { subscriberPropagate = \a -> do
290 { subscriberPropagate = \a -> do
232− liftIO $ writeIORef occRef $ Just a
291+-- liftIO $ thawStruct c
233− scheduleClear occRef
292+ liftIO $ setField eventCache_occurrence c a
293+-- liftIO $ freezeStruct c
294+ scheduleClearEventCache c
234 propagate a subscribers
295 propagate a subscribers
235 , subscriberInvalidateHeight = \old -> do
296 , subscriberInvalidateHeight = \old -> do
236 WeakBag.traverse subscribers $ invalidateSubscriberHeight old
297 WeakBag.traverse subscribers $ invalidateSubscriberHeight old
237 , subscriberRecalculateHeight = \new -> do
298 , subscriberRecalculateHeight = \new -> do
238 WeakBag.traverse subscribers $ recalculateSubscriberHeight new
299 WeakBag.traverse subscribers $ recalculateSubscriberHeight new
240− liftIO $ writeIORef occRef occ
301+ liftIO $ setField eventCache_parent c parentSub
241− when (isJust occ) $ scheduleClear occRef
302+ case occ of
242− let !subscribed = CacheSubscribed
303+ Nothing -> liftIO $ set eventCache_occurrence_slot c Nil
243− { _cacheSubscribed_subscribers = subscribers
304+ Just o -> do
244− , _cacheSubscribed_weakSelf = weakSelf
305+ liftIO $ setField eventCache_occurrence c o
245− , _cacheSubscribed_parent = parentSub
306+ scheduleClearEventCache c
246− , _cacheSubscribed_cached = mSubscribedRef
307+-- liftIO $ freezeStruct c
247− , _cacheSubscribed_occurrence = occRef
249− liftIO $ writeIORef mSubscribedRef $ Just subscribed
250− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
251− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)
308+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny c)), occ)
310+{-# INLINE scheduleClearEventCache #-}
311+scheduleClearEventCache :: Defer (SomeClearEventCache x) m => EventCache x a (PrimState IO) -> m ()
312+scheduleClearEventCache r = defer $ SomeClearEventCache r
253−cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
314+cleanupCacheSubscribed :: EventCache x a (PrimState IO) -> IO ()
254cleanupCacheSubscribed self = do
315cleanupCacheSubscribed self = do
316+ parent <- getField eventCache_parent self
255− unsubscribe $ _cacheSubscribed_parent self
317+ unsubscribe parent
256− writeIORef (_cacheSubscribed_cached self) Nothing
318+ clearEventCache self
258subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
320subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
259subscribe e s = fst <$> subscribeAndRead e s
321subscribe e s = fst <$> subscribeAndRead e s
@@ -663,6 +725,7 @@ data EventEnv x
663 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
725 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
664 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
726 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
665 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
727 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
728+ , eventEnvClearEventCaches :: !(IORef [SomeClearEventCache x]) -- Needed for Subscribe
666 , eventEnvRootClears :: !(IORef [SomeRootClear])
729 , eventEnvRootClears :: !(IORef [SomeRootClear])
667 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
730 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
668 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
731 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
@@ -737,6 +800,10 @@ instance Defer SomeClear (EventM x) where
737 {-# INLINE getDeferralQueue #-}
800 {-# INLINE getDeferralQueue #-}
738 getDeferralQueue = EventM $ asks eventEnvClears
801 getDeferralQueue = EventM $ asks eventEnvClears
803+instance Defer (SomeClearEventCache x) (EventM x) where
804+ {-# INLINE getDeferralQueue #-}
805+ getDeferralQueue = EventM $ asks eventEnvClearEventCaches
740{-# INLINE scheduleClear #-}
807{-# INLINE scheduleClear #-}
741scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
808scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
742scheduleClear r = defer $ SomeClear r
809scheduleClear r = defer $ SomeClear r
@@ -1132,6 +1199,8 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1133data SomeClear = forall a. SomeClear (IORef (Maybe a))
1200data SomeClear = forall a. SomeClear (IORef (Maybe a))
1202+data SomeClearEventCache x = forall a. SomeClearEventCache (EventCache x a (PrimState IO))
1135data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1204data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
1137data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1206data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
@@ -1647,10 +1716,11 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1647 mergeInitRef <- newIORef []
1716 mergeInitRef <- newIORef []
1648 heightRef <- newIORef zeroHeight
1717 heightRef <- newIORef zeroHeight
1649 toClearRef <- newIORef []
1718 toClearRef <- newIORef []
1719+ toClearEventCacheRef <- newIORef []
1650 toClearRootRef <- newIORef []
1720 toClearRootRef <- newIORef []
1651 coincidenceInfosRef <- newIORef []
1721 coincidenceInfosRef <- newIORef []
1652 delayedRef <- liftIO $ newIORef IntMap.empty
1722 delayedRef <- liftIO $ newIORef IntMap.empty
1653− let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1723+ let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearEventCacheRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1654 let go = do
1724 let go = do
1655 result <- a
1725 result <- a
1656 runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1726 runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
@@ -1658,6 +1728,11 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do
1658 result <- runEventM go env
1728 result <- runEventM go env
1659 toClear <- readIORef toClearRef
1729 toClear <- readIORef toClearRef
1660 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1730 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1731+ toClearEventCache <- readIORef toClearEventCacheRef
1732+ forM_ toClearEventCache $ \(SomeClearEventCache c) -> {-# SCC "clearEventCache" #-} do
1734+ set eventCache_occurrence_slot c Nil
1661 toClearRoot <- readIORef toClearRootRef
1736 toClearRoot <- readIORef toClearRootRef
1662 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1737 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
1663 toAssign <- readIORef toAssignRef
1738 toAssign <- readIORef toAssignRef