@@ -64,7 +64,7 @@ import Data.Proxy
6464import Data.These
6565import Data.Traversable
6666import Data.Witherable (Filterable, mapMaybe)
67−import GHC.Exts
67+import GHC.Exts hiding (toList)
6868import GHC.IORef (IORef (..))
6969import GHC.Stack
7070import Reflex.FastWeak
@@ -86,8 +86,9 @@ import Data.Monoid (mempty)
8686import Data.Tree (Forest, Tree (..), drawForest)
8787#endif
8888
89−import Data.FastWeakBag (FastWeakBag)
89+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
9090import qualified Data.FastWeakBag as FastWeakBag
91+
9192import Data.Reflection
9293import Data.Some (Some(Some))
9394import Data.Type.Coercion
@@ -239,7 +240,7 @@ headE originalE = do
239240 when (isJust occ) clearParent
240241 return $ Event $ \sub -> do
241242 liftIO (readIORef parent) >>= \case
242− Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
243+ Nothing -> subscribeAndReadNever
243244 Just e -> subscribeAndReadHead e sub
244245
245246data CacheSubscribed x a
@@ -293,25 +294,38 @@ cacheEvent e =
293294 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
294295 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
295296 return subscribedTicket
296− liftIO $ do
297− subscribed <- getFastWeakTicketValue subscribedTicket
298− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
299− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
300− let es = EventSubscription
301− { _eventSubscription_unsubscribe = do
302− FastWeakBag.remove ticket
303− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
304− when isEmpty $ do
305− writeIORef mSubscribedRef emptyFastWeak
306− unsubscribe $ _cacheSubscribed_parent subscribed
307− touch ticket
308− touch subscribedTicket
309− , _eventSubscription_subscribed = EventSubscribed
310− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
311− , eventSubscribedRetained = toAny subscribedTicket
312− }
313− }
314− return (es, occ)
297+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
298+
299+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
300+ -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
301+cacheSubscription sub mSubscribedRef subscribedTicket = do
302+ subscribed <- getFastWeakTicketValue subscribedTicket
303+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
304+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
305+
306+ let parentSub = _cacheSubscribed_parent subscribed
307+ es = EventSubscription
308+ { _eventSubscription_unsubscribe = do
309+ FastWeakBag.remove ticket
310+
311+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
312+ when isEmpty $ do
313+ writeIORef mSubscribedRef emptyFastWeak
314+ unsubscribe parentSub
315+ touch ticket
316+ touch subscribedTicket
317+ , _eventSubscription_subscribed = EventSubscribed
318+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub
319+ , eventSubscribedRetained = toAny subscribedTicket
320+#ifdef DEBUG_CYCLES
321+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
322+ , eventSubscribedHasOwnHeightRef = False
323+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
324+ }
325+#endif
326+ }
327+ return (es, occ)
328+
315329
316330subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
317331subscribe e s = fst <$> subscribeAndRead e s
@@ -326,8 +340,11 @@ wrap tag getSpecificSubscribed sub = do
326340eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
327341eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
328342
343+subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
344+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
345+
329346eventNever :: Event x a
330−eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
347+eventNever = Event $ const subscribeAndReadNever
331348
332349eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
333350eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
@@ -492,7 +509,7 @@ data EventSubscribed x = EventSubscribed
492509 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
493510 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
494511#ifdef DEBUG_CYCLES
495− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
512+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
496513 , eventSubscribedHasOwnHeightRef :: !Bool
497514 , eventSubscribedWhoCreated :: !(IO [String])
498515#endif
@@ -525,7 +542,7 @@ eventSubscribedFan !subscribed = EventSubscribed
525542 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
526543 , eventSubscribedRetained = toAny subscribed
527544#ifdef DEBUG_CYCLES
528− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
545+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
529546 , eventSubscribedHasOwnHeightRef = False
530547 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
531548#endif
@@ -538,7 +555,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
538555#ifdef DEBUG_CYCLES
539556 , eventSubscribedGetParents = do
540557 s <- readIORef $ switchSubscribedCurrentParent subscribed
541− return [Some $ _eventSubscription_subscribed s]
558+ return [_eventSubscription_subscribed s]
542559 , eventSubscribedHasOwnHeightRef = True
543560 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
544561#endif
@@ -551,8 +568,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
551568#ifdef DEBUG_CYCLES
552569 , eventSubscribedGetParents = do
553570 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
554− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
555− innerParents = maybeToList $ fmap Some innerSubscription
571+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
572+ innerParents = maybeToList $ innerSubscription
556573 return $ outerParent : innerParents
557574 , eventSubscribedHasOwnHeightRef = True
558575 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -566,15 +583,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
566583whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
567584whoCreatedEventSubscribed = eventSubscribedWhoCreated
568585
569−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
586+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
570587walkInvalidHeightParents s0 = do
571− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
588+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
572589 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
573590 when (h == invalidHeight) $ do
574591 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
575− modify (Some s :)
592+ modify (s :)
576593 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
577− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
594+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
578595 return subscribers
579596#endif
580597
@@ -1510,16 +1527,16 @@ fanInt p = unsafePerformIO $ do
15101527 { subscriberPropagate = \m -> do
15111528 liftIO $ writeIORef (_fanInt_occRef self) m
15121529 scheduleIntClear $ _fanInt_occRef self
1513− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1514− FastWeakBag.traverse b $ \s -> do
1530+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1531+ FastWeakBag.traverse b $ \s ->
15151532 subscriberPropagate s v
1516− , subscriberInvalidateHeight = \old -> do
1517− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1518− FastWeakBag.traverse b $ \s -> do
1533+ , subscriberInvalidateHeight = \old ->
1534+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1535+ FastWeakBag.traverse b $ \s ->
15191536 subscriberInvalidateHeight s old
1520− , subscriberRecalculateHeight = \new -> do
1521− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1522− FastWeakBag.traverse b $ \s -> do
1537+ , subscriberRecalculateHeight = \new ->
1538+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1539+ FastWeakBag.traverse b $ \s ->
15231540 subscriberRecalculateHeight s new
15241541 }
15251542 liftIO $ do
@@ -1533,10 +1550,25 @@ fanInt p = unsafePerformIO $ do
15331550 FastMutableIntMap.insert (_fanInt_subscribers self) k b
15341551 return b
15351552 Just b -> return b
1536− t <- liftIO $ FastWeakBag.insert sub b
1553+ ticket <- liftIO $ FastWeakBag.insert sub b
15371554 currentOcc <- readIORef (_fanInt_occRef self)
1538− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1539− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1555+
1556+ subscribed <- fanIntSubscribed ticket self
1557+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1558+
1559+fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1560+fanIntSubscribed ticket self = do
1561+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1562+ return $ EventSubscribed
1563+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1564+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1565+#ifdef DEBUG_CYCLES
1566+ , eventSubscribedGetParents = return [subscribedParent]
1567+ , eventSubscribedHasOwnHeightRef = False
1568+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1569+#endif
1570+ }
1571+
15401572
15411573{-# INLINABLE getFanSubscribed #-}
15421574getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
@@ -1734,7 +1766,7 @@ mergeCheap
17341766 => (forall a. q a -> Event x (v a))
17351767 -> DynamicS x (PatchDMap k q)
17361768 -> Event x (DMap k v)
1737−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1769+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy
17381770 where
17391771 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
17401772 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
@@ -1749,7 +1781,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
17491781 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17501782 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
17511783 forM_ mOldSubd $ \oldSubd -> do
1752− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1784+ oldHeight <- liftIO $ getEventSubscribedHeight $
1785+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1786+
17531787 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17541788 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
17551789 foldM f ([], oldParents) $ DMap.toList p
@@ -1774,7 +1808,7 @@ mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
17741808 => (forall a. q a -> Event x (v a))
17751809 -> DynamicS x (PatchDMapWithMove k q)
17761810 -> Event x (DMap k v)
1777−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1811+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy
17781812 where
17791813 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
17801814 updateMe subscriber heightBagRef oldParents p = do
@@ -1793,13 +1827,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
17931827 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17941828 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17951829 Nothing -> do
1796− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1830+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1831+ _mergeSubscribedParentWithMove_subscription parent
1832+
17971833 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17981834 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
17991835 Just toKey -> do
18001836 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
18011837 return Nothing
1802− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1838+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1839+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1840+
18031841 return (toDelete, applyAlways p' oldParents)
18041842 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
18051843 getInitialSubscribers initialParents subscriber = do
@@ -1824,6 +1862,8 @@ type MergeUpdateFunc k v x p s
18241862 -> p
18251863 -> EventM x ([EventSubscription x], DMap k s)
18261864
1865+type MergeGetSubscription x s = forall a. s a -> EventSubscription x
1866+
18271867type MergeInitFunc k v q x s
18281868 = DMap k q
18291869 -> (forall a. EventM x (k a) -> Subscriber x (v a))
@@ -1847,14 +1887,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su
18471887invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
18481888invalidateMergeHeight' heightRef sub = do
18491889 oldHeight <- readIORef heightRef
1850− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1890+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1891+ when (oldHeight /= invalidHeight) $ do
18511892 writeIORef heightRef $! invalidHeight
18521893 subscriberInvalidateHeight sub oldHeight
18531894
18541895revalidateMergeHeight :: Merge x k v s -> IO ()
18551896revalidateMergeHeight m = do
18561897 currentHeight <- readIORef $ _merge_heightRef m
1857− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1898+
1899+ -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1900+ when (currentHeight == invalidHeight) $ do
18581901 heights <- readIORef $ _merge_heightBagRef m
18591902 parents <- readIORef $ _merge_parentsRef m
18601903 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -1870,22 +1913,25 @@ revalidateMergeHeight m = do
18701913scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
18711914scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18721915 vals <- liftIO $ readIORef $ _merge_accumRef m
1873− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1916+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
1917+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1918+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
18741919 --TODO: Assert that m is not empty
18751920 subscriberPropagate (_merge_sub m) vals
18761921
1877−checkCycle :: HasSpiderTimeline x => Height -> EventM x ()
1878−checkCycle height = do
1922+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> Height -> EventM x ()
1923+checkCycle subscribed height = do
18791924 currentHeight <- getCurrentHeight
18801925 when (height <= currentHeight) $ if height /= invalidHeight
18811926 then do
18821927 myStack <- liftIO $ whoCreatedIORef undefined --TODO
18831928 error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1884− else liftIO $ do
1929+ else liftIO $
18851930#ifdef DEBUG_CYCLES
1886− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1887− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1888− throwIO (EventLoopException stacks)
1931+ do
1932+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
1933+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
1934+ throwIO (EventLoopException (listsToForest stacks))
18891935#else
18901936 throwIO EventLoopException
18911937#endif
@@ -1896,12 +1942,12 @@ mergeSubscriber m getKey = Subscriber
18961942 { subscriberPropagate = \a -> do
18971943 oldM <- liftIO $ readIORef $ _merge_accumRef m
18981944 k <- getKey
1899− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1945+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
19001946 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
19011947 liftIO $ writeIORef (_merge_accumRef m) $! newM
19021948 when (DMap.null oldM) $ do -- Only schedule the firing once
19031949 height <- liftIO $ readIORef $ _merge_heightRef m
1904− checkCycle height --TODO: assertions about height
1950+ -- checkCycle (_merge_sub m) height --TODO: assertions about height
19051951
19061952 scheduleMergeSelf m height
19071953 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
@@ -1923,8 +1969,8 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
19231969
19241970{-# INLINE mergeGCheap' #-}
19251971mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1926− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1927−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1972+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1973+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
19281974 initialParents <- readBehaviorUntracked $ dynamicCurrent d
19291975 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
19301976 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1968,9 +2014,18 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
19682014 -- its subscription.
19692015 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
19702016 let unsubscribeAll = destroy =<< readIORef parentsRef
1971− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1972− , occ
1973− )
2017+ getParent' = \(_ :=> v) -> _eventSubscription_subscribed (getParent v)
2018+ subscribed = EventSubscribed
2019+ { eventSubscribedHeightRef = heightRef
2020+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2021+#ifdef DEBUG_CYCLES
2022+ , eventSubscribedGetParents = fmap getParent' . DMap.toList <$> readIORef parentsRef
2023+ , eventSubscribedHasOwnHeightRef = False
2024+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2025+ }
2026+#endif
2027+ return (EventSubscription unsubscribeAll subscribed, occ)
2028+
19742029
19752030mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
19762031mergeInt = cacheEvent . mergeIntCheap
@@ -2005,7 +2060,7 @@ mergeIntCheap d = Event $ \sub -> do
20052060 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
20062061 mySubscriber k = Subscriber
20072062 { subscriberPropagate = \a -> do
2008− liftIO (readIORef heightRef) >>= checkCycle
2063+ -- liftIO (readIORef heightRef) >>= checkCycle
20092064
20102065 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
20112066 liftIO $ FastMutableIntMap.insert accum k a
@@ -2070,9 +2125,17 @@ mergeIntCheap d = Event $ \sub -> do
20702125 -- its subscription.
20712126 liftIO $ writeIORef changeSubdRef (s, changeSubscription)
20722127 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2073− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2074− , occ
2075− )
2128+ subscribed = EventSubscribed
2129+ { eventSubscribedHeightRef = heightRef
2130+ , eventSubscribedRetained = toAny (parents, changeSubdRef)
2131+#ifdef DEBUG_CYCLES
2132+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2133+ , eventSubscribedHasOwnHeightRef = False
2134+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2135+ }
2136+#endif
2137+
2138+ return (EventSubscription unsubscribeAll subscribed, occ)
20762139
20772140newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
20782141newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }