@@ -190,24 +190,23 @@ unsafeNodeId a = unsafePerformIO $ do
190190-- Event
191191--------------------------------------------------------------------------------
192192
193−newtype Event x a = Event { subscribe :: Subscriber x a -> EventM x (EventSubscription x a) }
193+newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (EventSubscription x a, Maybe a) }
194194
195−subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x a, Maybe a)
196−subscribeAndRead e sub = do
197− subscription@(EventSubscription _ subd) <- subscribe e sub
198− occ <- liftIO $ eventSubscribedRead subd
199− return (subscription, occ)
195+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x a)
196+subscribe e s = fst <$> subscribeAndRead e s
200197
201−wrap :: Monad m => (t -> EventSubscribed x a) -> (Subscriber x a -> m (WeakBagTicket (Subscriber x a), t)) -> Subscriber x a -> m (EventSubscription x a)
198+{-# INLINE wrap #-}
199+wrap :: MonadIO m => (t -> EventSubscribed x a) -> (Subscriber x a -> m (WeakBagTicket (Subscriber x a), t, Maybe a)) -> Subscriber x a -> m (EventSubscription x a, Maybe a)
202200wrap tag getSpecificSubscribed sub = do
203− (sln, subd) <- getSpecificSubscribed sub
204− return $ EventSubscription (Just sln) $ tag subd
201+ (sln, subd, occ) <- getSpecificSubscribed sub
202+ let es = tag subd
203+ return (EventSubscription (Just sln) es, occ)
205204
206205eventRoot :: GCompare k => k a -> Root x k -> Event x a
207206eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
208207
209208eventNever :: Event x a
210−eventNever = Event $ \_ -> return $ EventSubscription Nothing eventSubscribedNever
209+eventNever = Event $ \_ -> return (EventSubscription Nothing eventSubscribedNever, Nothing)
211210
212211eventPush :: Push x b a -> Event x a
213212eventPush !p = Event $ wrap eventSubscribedPush $ getPushSubscribed p
@@ -216,7 +215,7 @@ eventMerge :: (GCompare k, a ~ DMap k Identity) => Merge x k -> Event x a
216215eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m
217216
218217eventFan :: GCompare k => k a -> Fan x k -> Event x a
219−eventFan !k !f = Event $ wrap (eventSubscribedFan k) $ getFanSubscribed k f
218+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
220219
221220eventSwitch :: Switch x a -> Event x a
222221eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
@@ -224,7 +223,7 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
224223eventCoincidence :: Coincidence x a -> Event x a
225224eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
226225
227−eventHold :: (a ~ p b, R.Patch p) => Hold x p b -> Event x a
226+eventHold :: a ~ p b => Hold x p b -> Event x a
228227eventHold !h = Event $ subscribeHoldEvent h
229228
230229eventDyn :: (a ~ p b, R.Patch p) => Dyn x p b -> Event x a
@@ -347,6 +346,8 @@ newSubscriberFan subscribed = return $ Subscriber
347346 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
348347 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
349348 tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
349+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
350+ scheduleClear $ fanSubscribedOccurrence subscribed
350351 let f _ (Pair (Identity v) subsubs) = do
351352 propagate v $ _fanSubscribedChildren_list subsubs
352353 return $ Constant ()
@@ -453,10 +454,9 @@ propagate a subscribers = withIncreasedDepth $ do
453454-- EventSubscribed
454455--------------------------------------------------------------------------------
455456
456−data EventSubscribed x a = EventSubscribed
457− { eventSubscribedSubscribe :: !(Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a))))
458− , eventSubscribedRead :: !(IO (Maybe a))
459− , eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
457+data EventSubscribed x a = forall b. EventSubscribed
458+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
459+ , eventSubscribedRetained :: {-# NOUNPACK #-} !b
460460#ifdef DEBUG_CYCLES
461461 , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
462462 , eventSubscribedHasOwnHeightRef :: !Bool
@@ -464,17 +464,10 @@ data EventSubscribed x a = EventSubscribed
464464#endif
465465 }
466466
467−readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)
468−readEventSubscribed = eventSubscribedRead
469−
470−subscribeEventSubscribed :: EventSubscribed x a -> Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a)))
471−subscribeEventSubscribed = eventSubscribedSubscribe
472−
473467eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x a
474468eventSubscribedRoot !r = EventSubscribed
475− { eventSubscribedSubscribe = \sub -> Just <$> subscribeRootSubscribed r sub
476− , eventSubscribedRead = readRootSubscribed r
477− , eventSubscribedHeightRef = zeroRef
469+ { eventSubscribedHeightRef = zeroRef
470+ , eventSubscribedRetained = r
478471#ifdef DEBUG_CYCLES
479472 , eventSubscribedGetParents = return []
480473 , eventSubscribedHasOwnHeightRef = False
@@ -484,9 +477,8 @@ eventSubscribedRoot !r = EventSubscribed
484477
485478eventSubscribedNever :: EventSubscribed x a
486479eventSubscribedNever = EventSubscribed
487− { eventSubscribedSubscribe = \_ -> return Nothing
488− , eventSubscribedRead = return Nothing
489− , eventSubscribedHeightRef = zeroRef
480+ { eventSubscribedHeightRef = zeroRef
481+ , eventSubscribedRetained = ()
490482#ifdef DEBUG_CYCLES
491483 , eventSubscribedGetParents = return []
492484 , eventSubscribedHasOwnHeightRef = False
@@ -496,9 +488,8 @@ eventSubscribedNever = EventSubscribed
496488
497489eventSubscribedPush :: PushSubscribed x b a -> EventSubscribed x a
498490eventSubscribedPush !subscribed = EventSubscribed
499− { eventSubscribedSubscribe = \sub -> Just <$> subscribePushSubscribed subscribed sub
500− , eventSubscribedRead = readPushSubscribed subscribed
501− , eventSubscribedHeightRef = pushSubscribedHeight subscribed
491+ { eventSubscribedHeightRef = pushSubscribedHeight subscribed
492+ , eventSubscribedRetained = subscribed
502493#ifdef DEBUG_CYCLES
503494 , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
504495 , eventSubscribedHasOwnHeightRef = False
@@ -506,11 +497,10 @@ eventSubscribedPush !subscribed = EventSubscribed
506497#endif
507498 }
508499
509−eventSubscribedMerge :: a ~ DMap k Identity => MergeSubscribed x k -> EventSubscribed x a
500+eventSubscribedMerge :: MergeSubscribed x k -> EventSubscribed x a
510501eventSubscribedMerge !subscribed = EventSubscribed
511− { eventSubscribedSubscribe = \sub -> Just <$> subscribeMergeSubscribed subscribed sub
512− , eventSubscribedRead = readMergeSubscribed subscribed
513− , eventSubscribedHeightRef = mergeSubscribedHeight subscribed
502+ { eventSubscribedHeightRef = mergeSubscribedHeight subscribed
503+ , eventSubscribedRetained = subscribed
514504#ifdef DEBUG_CYCLES
515505 , eventSubscribedGetParents = do
516506 ps <- readIORef $ mergeSubscribedParents subscribed
@@ -520,11 +510,10 @@ eventSubscribedMerge !subscribed = EventSubscribed
520510#endif
521511 }
522512
523−eventSubscribedFan :: GCompare k => k a -> FanSubscribed x k -> EventSubscribed x a
524−eventSubscribedFan !k !subscribed = EventSubscribed
525− { eventSubscribedSubscribe = \sub -> Just <$> subscribeFanSubscribed k subscribed sub
526− , eventSubscribedRead = readFanSubscribed k subscribed
527− , eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
513+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x a
514+eventSubscribedFan !subscribed = EventSubscribed
515+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
516+ , eventSubscribedRetained = subscribed
528517#ifdef DEBUG_CYCLES
529518 , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
530519 , eventSubscribedHasOwnHeightRef = False
@@ -534,9 +523,8 @@ eventSubscribedFan !k !subscribed = EventSubscribed
534523
535524eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x a
536525eventSubscribedSwitch !subscribed = EventSubscribed
537− { eventSubscribedSubscribe = \sub -> Just <$> subscribeSwitchSubscribed subscribed sub
538− , eventSubscribedRead = readSwitchSubscribed subscribed
539− , eventSubscribedHeightRef = switchSubscribedHeight subscribed
526+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
527+ , eventSubscribedRetained = subscribed
540528#ifdef DEBUG_CYCLES
541529 , eventSubscribedGetParents = do
542530 s <- readIORef $ switchSubscribedCurrentParent subscribed
@@ -548,9 +536,8 @@ eventSubscribedSwitch !subscribed = EventSubscribed
548536
549537eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x a
550538eventSubscribedCoincidence !subscribed = EventSubscribed
551− { eventSubscribedSubscribe = \sub -> Just <$> subscribeCoincidenceSubscribed subscribed sub
552− , eventSubscribedRead = readCoincidenceSubscribed subscribed
553− , eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
539+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
540+ , eventSubscribedRetained = subscribed
554541#ifdef DEBUG_CYCLES
555542 , eventSubscribedGetParents = do
556543 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
@@ -582,11 +569,8 @@ walkInvalidHeightParents s0 = do
582569#endif
583570
584571{-# INLINE subscribeHoldEvent #-}
585−subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a))
586−subscribeHoldEvent h sub = do
587− EventSubscription _ subd <- getHoldEventSubscription h
588− sln <- liftIO $ subscribeEventSubscribed subd sub
589− return $ EventSubscription sln subd
572+subscribeHoldEvent :: CanSubscribe x m => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a), Maybe (p a))
573+subscribeHoldEvent = subscribeAndRead . holdEvent
590574
591575--------------------------------------------------------------------------------
592576-- EventSubscription
@@ -611,7 +595,8 @@ unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
611595data Hold x p a
612596 = Hold { holdValue :: !(IORef a)
613597 , holdInvalidators :: !(IORef [Weak (Invalidator x)])
614− , holdParent :: !(IORef (Either (Event x (p a)) (EventSubscription x (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
598+ , holdEvent :: !(Event x (p a))
599+ , holdParent :: !(IORef (Maybe (EventSubscription x (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
615600#ifdef DEBUG_NODEIDS
616601 , holdNodeId :: Int
617602#endif
@@ -721,13 +706,14 @@ hold :: (R.Patch p, Defer (SomeHoldInit x) m) => a -> Event x (p a) -> m (Hold x
721706hold v0 e = do
722707 valRef <- liftIO $ newIORef v0
723708 invsRef <- liftIO $ newIORef []
724− parentRef <- liftIO $ newIORef $ Left e
709+ parentRef <- liftIO $ newIORef Nothing
725710#ifdef DEBUG_NODEIDS
726711 nodeId <- liftIO newNodeId
727712#endif
728713 let h = Hold
729714 { holdValue = valRef
730715 , holdInvalidators = invsRef
716+ , holdEvent = e
731717 , holdParent = parentRef
732718#ifdef DEBUG_NODEIDS
733719 , holdNodeId = nodeId
@@ -741,8 +727,9 @@ getHoldEventSubscription :: forall m p a x. (Defer (SomeAssignment x) m, Defer (
741727getHoldEventSubscription h = do
742728 ep <- liftIO $ readIORef $ holdParent h
743729 case ep of
744− Right subd -> return subd
745− Left e -> do
730+ Just subd -> return subd
731+ Nothing -> do
732+ let e = holdEvent h
746733 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
747734 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
748735 liftIO $ writeIORef subscriptionRef $! subscription
@@ -757,7 +744,7 @@ getHoldEventSubscription h = do
757744 v <- liftIO $ evaluate $ holdValue h
758745 i <- liftIO $ evaluate $ holdInvalidators h
759746 defer $ SomeAssignment v i new
760− liftIO $ writeIORef (holdParent h) $ Right subscription
747+ liftIO $ writeIORef (holdParent h) $ Just subscription
761748 return subscription
762749
763750type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
@@ -936,6 +923,7 @@ data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
936923
937924data FanSubscribed (x :: *) k
938925 = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
926+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
939927 , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
940928 , fanSubscribedParent :: !(EventSubscription x (DMap k Identity))
941929#ifdef DEBUG_NODEIDS
@@ -1361,39 +1349,6 @@ getDynHold d = do
13611349 liftIO $ writeIORef (unDyn d) $ Right h
13621350 return h
13631351
1364−readRootSubscribed :: RootSubscribed x a -> IO (Maybe a)
1365−readRootSubscribed = rootSubscribedOccurrence
1366−
1367−readPushSubscribed :: PushSubscribed x b a -> IO (Maybe a)
1368−readPushSubscribed subscribed = do
1369− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1370− touch $ pushSubscribedSelf subscribed
1371− return result
1372−
1373−readMergeSubscribed :: MergeSubscribed x k -> IO (Maybe (DMap k Identity))
1374−readMergeSubscribed subscribed = do
1375− result <- readIORef $ mergeSubscribedOccurrence subscribed
1376− touch $ mergeSubscribedParents subscribed
1377− return result
1378−
1379−readFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> IO (Maybe a)
1380−readFanSubscribed k fs = do
1381− parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs
1382− return $ coerce $ DMap.lookup k =<< parentOcc
1383−
1384−readSwitchSubscribed :: SwitchSubscribed x a -> IO (Maybe a)
1385−readSwitchSubscribed subscribed = do
1386− result <- readIORef $ switchSubscribedOccurrence subscribed
1387− touch $ switchSubscribedOwnInvalidator subscribed
1388− return result
1389−
1390−readCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO (Maybe a)
1391−readCoincidenceSubscribed subscribed = do
1392− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1393− touch $ coincidenceSubscribedOuter subscribed
1394− --TODO: do we need to touch the inner subscriber?
1395− return result
1396−
13971352-- Always refers to 0
13981353{-# NOINLINE zeroRef #-}
13991354zeroRef :: IORef Height
@@ -1409,13 +1364,15 @@ type CanSubscribe x m =
14091364 , m ~ EventM x
14101365 )
14111366
1412−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket (Subscriber x a), RootSubscribed x a)
1367+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket (Subscriber x a), RootSubscribed x a, Maybe a)
14131368getRootSubscribed k r sub = do
14141369 mSubscribed <- readIORef $ rootSubscribed r
1370+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
14151371 case DMap.lookup k mSubscribed of
14161372 Just subscribed -> {-# SCC "hitRoot" #-} do
14171373 sln <- subscribeRootSubscribed subscribed sub
1418− return (sln, subscribed)
1374+ occ <- getOcc
1375+ return (sln, subscribed, occ)
14191376 Nothing -> {-# SCC "missRoot" #-} do
14201377 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
14211378 let !cached = rootSubscribed r
@@ -1427,7 +1384,7 @@ getRootSubscribed k r sub = do
14271384 let subscribed = RootSubscribed
14281385 { rootSubscribedKey = k
14291386 , rootSubscribedCachedSubscribed = cached
1430− , rootSubscribedOccurrence = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1387+ , rootSubscribedOccurrence = getOcc
14311388 , rootSubscribedSubscribers = subs
14321389 , rootSubscribedUninit = uninit
14331390 , rootSubscribedWeakSelf = weakSelf
@@ -1437,7 +1394,8 @@ getRootSubscribed k r sub = do
14371394 }
14381395 writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
14391396 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1440− return (sln, subscribed)
1397+ occ <- getOcc
1398+ return (sln, subscribed, occ)
14411399
14421400{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
14431401cleanupRootSubscribed :: RootSubscribed x a -> IO ()
@@ -1450,14 +1408,15 @@ subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO (WeakBagTi
14501408subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
14511409
14521410-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1453−{-# SPECIALIZE getPushSubscribed :: Push x a b -> Subscriber x b -> EventM x (WeakBagTicket (Subscriber x b), PushSubscribed x a b) #-}
1454−getPushSubscribed :: CanSubscribe x m => Push x a b -> Subscriber x b -> m (WeakBagTicket (Subscriber x b), PushSubscribed x a b)
1411+{-# SPECIALIZE getPushSubscribed :: Push x a b -> Subscriber x b -> EventM x (WeakBagTicket (Subscriber x b), PushSubscribed x a b, Maybe b) #-}
1412+getPushSubscribed :: CanSubscribe x m => Push x a b -> Subscriber x b -> m (WeakBagTicket (Subscriber x b), PushSubscribed x a b, Maybe b)
14551413getPushSubscribed p sub = do
14561414 mSubscribed <- liftIO $ readIORef $ pushSubscribed p
14571415 case mSubscribed of
1458− Just subscribed -> {-# SCC "hitPush" #-} do
1459− sln <- liftIO $ subscribePushSubscribed subscribed sub
1460− return (sln, subscribed)
1416+ Just subscribed -> {-# SCC "hitPush" #-} liftIO $ do
1417+ sln <- subscribePushSubscribed subscribed sub
1418+ occ <- readIORef $ pushSubscribedOccurrence subscribed
1419+ return (sln, subscribed, occ)
14611420 Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
14621421 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
14631422 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1484,7 +1443,7 @@ getPushSubscribed p sub = do
14841443 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
14851444 liftIO $ writeIORef subscribedRef $! subscribed
14861445 liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
1487− return (sln, subscribed)
1446+ return (sln, subscribed, occ)
14881447
14891448cleanupPushSubscribed :: PushSubscribed x a b -> IO ()
14901449cleanupPushSubscribed self = do
@@ -1495,14 +1454,15 @@ cleanupPushSubscribed self = do
14951454subscribePushSubscribed :: PushSubscribed x a b -> Subscriber x b -> IO (WeakBagTicket (Subscriber x b))
14961455subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
14971456
1498−{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge x k -> Subscriber x (DMap k Identity) -> EventM x (WeakBagTicket (Subscriber x (DMap k Identity)), MergeSubscribed x k) #-}
1499−getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge x k -> Subscriber x (DMap k Identity) -> m (WeakBagTicket (Subscriber x (DMap k Identity)), MergeSubscribed x k)
1457+{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge x k -> Subscriber x (DMap k Identity) -> EventM x (WeakBagTicket (Subscriber x (DMap k Identity)), MergeSubscribed x k, Maybe (DMap k Identity)) #-}
1458+getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge x k -> Subscriber x (DMap k Identity) -> m (WeakBagTicket (Subscriber x (DMap k Identity)), MergeSubscribed x k, Maybe (DMap k Identity))
15001459getMergeSubscribed m sub = do
15011460 mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
15021461 case mSubscribed of
1503− Just subscribed -> {-# SCC "hitMerge" #-} do
1504− sln <- liftIO $ subscribeMergeSubscribed subscribed sub
1505− return (sln, subscribed)
1462+ Just subscribed -> {-# SCC "hitMerge" #-} liftIO $ do
1463+ sln <- subscribeMergeSubscribed subscribed sub
1464+ occ <- readIORef $ mergeSubscribedOccurrence subscribed
1465+ return (sln, subscribed, occ)
15061466 Nothing -> {-# SCC "missMerge" #-} do
15071467 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
15081468 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1551,7 +1511,7 @@ getMergeSubscribed m sub = do
15511511 liftIO $ writeIORef subscribedRef $! subscribed
15521512 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
15531513 liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
1554− return (sln, subscribed)
1514+ return (sln, subscribed, occ)
15551515
15561516cleanupMergeSubscribed :: MergeSubscribed x k -> IO ()
15571517cleanupMergeSubscribed subscribed = do
@@ -1564,24 +1524,28 @@ cleanupMergeSubscribed subscribed = do
15641524subscribeMergeSubscribed :: MergeSubscribed x k -> Subscriber x (DMap k Identity) -> IO (WeakBagTicket (Subscriber x (DMap k Identity)))
15651525subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
15661526
1567−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), FanSubscribed x k) #-}
1568−getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), FanSubscribed x k)
1527+{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), FanSubscribed x k, Maybe a) #-}
1528+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), FanSubscribed x k, Maybe a)
15691529getFanSubscribed k f sub = do
15701530 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
15711531 case mSubscribed of
1572− Just subscribed -> {-# SCC "hitFan" #-} do
1573− sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1574− return (sln, subscribed)
1532+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1533+ sln <- subscribeFanSubscribed k subscribed sub
1534+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1535+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
15751536 Nothing -> {-# SCC "missFan" #-} do
15761537 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
15771538 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
15781539 s <- liftIO $ newSubscriberFan subscribedUnsafe
1579− subscription <- subscribe (fanParent f) s
1540+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
15801541 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
15811542 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
15821543 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1544+ occRef <- liftIO $ newIORef parentOcc
1545+ when (isJust parentOcc) $ scheduleClear occRef
15831546 let subscribed = FanSubscribed
15841547 { fanSubscribedCachedSubscribed = fanSubscribed f
1548+ , fanSubscribedOccurrence = occRef
15851549 , fanSubscribedParent = subscription
15861550 , fanSubscribedSubscribers = subscribersRef
15871551#ifdef DEBUG_NODEIDS
@@ -1593,7 +1557,7 @@ getFanSubscribed k f sub = do
15931557 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
15941558 liftIO $ writeIORef subscribedRef $! subscribed
15951559 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1596− return (slnForSub, subscribed)
1560+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
15971561
15981562cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
15991563cleanupFanSubscribed (k, subscribed) = do
@@ -1619,14 +1583,15 @@ subscribeFanSubscribed k subscribed sub = do
16191583 return sln
16201584 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
16211585
1622−{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), SwitchSubscribed x a) #-}
1623−getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderEnv x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), SwitchSubscribed x a)
1586+{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), SwitchSubscribed x a, Maybe a) #-}
1587+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderEnv x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), SwitchSubscribed x a, Maybe a)
16241588getSwitchSubscribed s sub = do
16251589 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
16261590 case mSubscribed of
1627− Just subscribed -> {-# SCC "hitSwitch" #-} do
1628− sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1629− return (sln, subscribed)
1591+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1592+ sln <- subscribeSwitchSubscribed subscribed sub
1593+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1594+ return (sln, subscribed, occ)
16301595 Nothing -> {-# SCC "missSwitch" #-} do
16311596 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
16321597 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1662,7 +1627,7 @@ getSwitchSubscribed s sub = do
16621627 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
16631628 liftIO $ writeIORef subscribedRef $! subscribed
16641629 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1665− return (slnForSub, subscribed)
1630+ return (slnForSub, subscribed, parentOcc)
16661631
16671632cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
16681633cleanupSwitchSubscribed subscribed = do
@@ -1674,14 +1639,15 @@ cleanupSwitchSubscribed subscribed = do
16741639subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO (WeakBagTicket (Subscriber x a))
16751640subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
16761641
1677−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a) #-}
1678−getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a)
1642+{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a, Maybe a) #-}
1643+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a, Maybe a)
16791644getCoincidenceSubscribed c sub = do
16801645 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
16811646 case mSubscribed of
1682− Just subscribed -> {-# SCC "hitCoincidence" #-} do
1683− sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1684− return (sln, subscribed)
1647+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1648+ sln <- subscribeCoincidenceSubscribed subscribed sub
1649+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1650+ return (sln, subscribed, occ)
16851651 Nothing -> {-# SCC "missCoincidence" #-} do
16861652 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
16871653 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
@@ -1716,7 +1682,7 @@ getCoincidenceSubscribed c sub = do
17161682 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
17171683 liftIO $ writeIORef subscribedRef $! subscribed
17181684 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1719− return (slnForSub, subscribed)
1685+ return (slnForSub, subscribed, occ)
17201686
17211687cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
17221688cleanupCoincidenceSubscribed subscribed = do
@@ -2164,10 +2130,11 @@ instance R.ReflexHost (SpiderEnv x) where
21642130 type HostFrame (SpiderEnv x) = SpiderHostFrame x
21652131
21662132instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
2167− {-# INLINABLE readEvent #-}
2133+ {-# NOINLINE readEvent #-}
21682134 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do
2135+ result <- readIORef $ spiderEventHandleValue h
21692136 touch h
2170− readIORef $ spiderEventHandleValue h
2137+ return result
21712138
21722139instance MonadRef (EventM x) where
21732140 type Ref (EventM x) = Ref IO