@@ -17,6 +17,8 @@
1717{-# LANGUAGE TypeFamilies #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
20+{-# LANGUAGE MagicHash #-}
21+{-# LANGUAGE UnboxedTuples #-}
2022-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2123-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2224module Reflex.Spider.Internal where
@@ -47,6 +49,7 @@ import Data.Maybe
4749import Data.Monoid ((<>))
4850import Data.Some (Some)
4951import qualified Data.Some as Some
52+import Data.Struct
5053import Data.These
5154import Data.Traversable
5255import Data.Type.Coercion
@@ -57,6 +60,7 @@ import GHC.Stack
5760import System.IO.Unsafe
5861import System.Mem.Weak
5962import Unsafe.Coerce
63+import GHC.IO (IO (..))
6064
6165#ifdef DEBUG_CYCLES
6266import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
@@ -195,13 +199,61 @@ pushCheap f e = Event $ \sub -> do
195199 occ' <- join <$> mapM (runComputeM . f) occ
196200 return (subscription, occ')
197201
202+{-
198203data CacheSubscribed x a
199204 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))
200205 , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))
201206 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
202− , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
203207 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
208+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))
204209 }
210+-}
211+
212+newtype EventCache x a s = EventCache (Object s) deriving Struct
213+
214+allocEventCache :: PrimMonad m => m (EventCache x a (PrimState m))
215+allocEventCache = alloc 4
216+
217+{-# NOINLINE unsafeAllocEventCache #-}
218+unsafeAllocEventCache :: q -> EventCache x a (PrimState IO)
219+unsafeAllocEventCache q = unsafePerformIO $ do
220+ touch q
221+ c <- allocEventCache
222+ set eventCache_subscribers_slot c Nil -- We only need to initialize this one; the others will be initialized later
223+ return c
224+
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
231+
232+eventCache_subscribers :: Field (EventCache x a) (WeakBag (Subscriber x a))
233+eventCache_subscribers = field 0
234+
235+eventCache_subscribers_slot :: Slot (EventCache x a) Object
236+eventCache_subscribers_slot = slot 0
237+
238+eventCache_weakSelf :: Field (EventCache x a) (Weak (EventCache x a s))
239+eventCache_weakSelf = field 1
240+
241+eventCache_parent :: Field (EventCache x a) (EventSubscription x)
242+eventCache_parent = field 2
243+
244+eventCache_occurrence :: Field (EventCache x a) a
245+eventCache_occurrence = field 3
246+
247+eventCache_occurrence_slot :: Slot (EventCache x a) Object
248+eventCache_occurrence_slot = slot 3
249+
250+freezeStruct :: Struct t => t (PrimState IO) -> IO ()
251+freezeStruct t = IO $ \s -> case unsafeFreezeSmallArray# (destruct t) s of
252+ (# s', _ #) -> (# s', () #)
253+
254+thawStruct :: Struct t => t (PrimState IO) -> IO ()
255+thawStruct t = IO $ \s -> case unsafeThawSmallArray# (unsafeCoerce# (destruct t)) s of
256+ (# s', _ #) -> (# s', () #)
205257
206258-- | Construct an 'Event' whose value is guaranteed not to be recomputed
207259-- repeatedly
@@ -211,49 +263,59 @@ data CacheSubscribed x a
211263--subscriber joins
212264{-# INLINABLE cacheEvent #-}
213265cacheEvent :: Event x a -> Event x a
214−cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
215− let !mSubscribedRef = unsafeNewIORef e Nothing
216− mSubscribed <- liftIO $ readIORef mSubscribedRef
217− case mSubscribed of
218− Just subscribed -> liftIO $ do
219− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
220− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
221− let es = EventSubscribed
222− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
223− , eventSubscribedRetained = toAny subscribed
266+cacheEvent e = let !c = unsafeAllocEventCache e in Event $ \sub -> {-# SCC "cacheEvent" #-} do
267+ subscribersNil <- liftIO $ get eventCache_subscribers_slot c
268+ case isNil subscribersNil of
269+ False -> liftIO $ {-# SCC "cacheEventFalse" #-} do
270+ subscribers <- getField eventCache_subscribers c
271+ weakSelf <- getField eventCache_weakSelf c
272+ weakSelfRef <- newIORef weakSelf --TODO: Get rid of this extraneous IORef
273+ ticket <- WeakBag.insert sub subscribers weakSelfRef cleanupCacheSubscribed
274+ occNil <- get eventCache_occurrence_slot c
275+ occ <- if isNil occNil
276+ then return Nothing
277+ else Just <$> getField eventCache_occurrence c
278+ let es = EventSubscribed
279+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ unsafeDupablePerformIO $ getField eventCache_parent c
280+ , eventSubscribedRetained = toAny c
224281 }
225282 return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
226− Nothing -> do
227− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
228− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
229− occRef <- liftIO $ newIORef undefined
283+ True -> {-# SCC "cacheEventTrue" #-} do
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
287+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelfRef cleanupCacheSubscribed
288+ liftIO $ setField eventCache_subscribers c subscribers
230289 (parentSub, occ) <- subscribeAndRead e $ Subscriber
231290 { subscriberPropagate = \a -> do
232− liftIO $ writeIORef occRef $ Just a
233− scheduleClear occRef
291+-- liftIO $ thawStruct c
292+ liftIO $ setField eventCache_occurrence c a
293+-- liftIO $ freezeStruct c
294+ scheduleClearEventCache c
234295 propagate a subscribers
235296 , subscriberInvalidateHeight = \old -> do
236297 WeakBag.traverse subscribers $ invalidateSubscriberHeight old
237298 , subscriberRecalculateHeight = \new -> do
238299 WeakBag.traverse subscribers $ recalculateSubscriberHeight new
239300 }
240− liftIO $ writeIORef occRef occ
241− when (isJust occ) $ scheduleClear occRef
242− let !subscribed = CacheSubscribed
243− { _cacheSubscribed_subscribers = subscribers
244− , _cacheSubscribed_weakSelf = weakSelf
245− , _cacheSubscribed_parent = parentSub
246− , _cacheSubscribed_cached = mSubscribedRef
247− , _cacheSubscribed_occurrence = occRef
248− }
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)
301+ liftIO $ setField eventCache_parent c parentSub
302+ case occ of
303+ Nothing -> liftIO $ set eventCache_occurrence_slot c Nil
304+ Just o -> do
305+ liftIO $ setField eventCache_occurrence c o
306+ scheduleClearEventCache c
307+-- liftIO $ freezeStruct c
308+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny c)), occ)
309+
310+{-# INLINE scheduleClearEventCache #-}
311+scheduleClearEventCache :: Defer (SomeClearEventCache x) m => EventCache x a (PrimState IO) -> m ()
312+scheduleClearEventCache r = defer $ SomeClearEventCache r
252313
253−cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
314+cleanupCacheSubscribed :: EventCache x a (PrimState IO) -> IO ()
254315cleanupCacheSubscribed self = do
255− unsubscribe $ _cacheSubscribed_parent self
256− writeIORef (_cacheSubscribed_cached self) Nothing
316+ parent <- getField eventCache_parent self
317+ unsubscribe parent
318+ clearEventCache self
257319
258320subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
259321subscribe e s = fst <$> subscribeAndRead e s
@@ -663,6 +725,7 @@ data EventEnv x
663725 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
664726 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
665727 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
728+ , eventEnvClearEventCaches :: !(IORef [SomeClearEventCache x]) -- Needed for Subscribe
666729 , eventEnvRootClears :: !(IORef [SomeRootClear])
667730 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
668731 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
@@ -737,6 +800,10 @@ instance Defer SomeClear (EventM x) where
737800 {-# INLINE getDeferralQueue #-}
738801 getDeferralQueue = EventM $ asks eventEnvClears
739802
803+instance Defer (SomeClearEventCache x) (EventM x) where
804+ {-# INLINE getDeferralQueue #-}
805+ getDeferralQueue = EventM $ asks eventEnvClearEventCaches
806+
740807{-# INLINE scheduleClear #-}
741808scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
742809scheduleClear r = defer $ SomeClear r
@@ -1132,6 +1199,8 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
11321199
11331200data SomeClear = forall a. SomeClear (IORef (Maybe a))
11341201
1202+data SomeClearEventCache x = forall a. SomeClearEventCache (EventCache x a (PrimState IO))
1203+
11351204data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
11361205
11371206data 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
16471716 mergeInitRef <- newIORef []
16481717 heightRef <- newIORef zeroHeight
16491718 toClearRef <- newIORef []
1719+ toClearEventCacheRef <- newIORef []
16501720 toClearRootRef <- newIORef []
16511721 coincidenceInfosRef <- newIORef []
16521722 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
16541724 let go = do
16551725 result <- a
16561726 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
16581728 result <- runEventM go env
16591729 toClear <- readIORef toClearRef
16601730 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1731+ toClearEventCache <- readIORef toClearEventCacheRef
1732+ forM_ toClearEventCache $ \(SomeClearEventCache c) -> {-# SCC "clearEventCache" #-} do
1733+-- thawStruct c
1734+ set eventCache_occurrence_slot c Nil
1735+-- freezeStruct c
16611736 toClearRoot <- readIORef toClearRootRef
16621737 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
16631738 toAssign <- readIORef toAssignRef