@@ -1730,9 +1730,10 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1730 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1730 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1731 (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1731 (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1732 writeIORef (mergeSubscribedParents m) $! newParents
1732 writeIORef (mergeSubscribedParents m) $! newParents
1733− invalidateMergeHeight m
1734 return subscriptionsToKill
1733 return subscriptionsToKill
1734+ when debugPropagate $ putStrLn "Updating merges"
1735 mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1735 mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1736+ when debugPropagate $ putStrLn "Updating merges done"
1736 toReconnect <- readIORef toReconnectRef
1737 toReconnect <- readIORef toReconnectRef
1737 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1738 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1738 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1739 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
@@ -1748,7 +1749,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1748 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
1749 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
1749 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1750 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1750 sub <- newSubscriberSwitch subscribed
1751 sub <- newSubscriberSwitch subscribed
1751− subscription@(EventSubscription _ subd') <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
1752+ subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
1753 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1754 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1754 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1755 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1757,17 +1758,21 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1757 _ -> "something else"
1758 _ -> "something else"
1759 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1760 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
1761+ return $ SomeEventSubscription oldSubscription
1762+ forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1763+ forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1764+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1765+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1760 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1766 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1761 myHeight <- readIORef $ switchSubscribedHeight subscribed
1767 myHeight <- readIORef $ switchSubscribedHeight subscribed
1762 when (parentHeight /= myHeight) $ do
1768 when (parentHeight /= myHeight) $ do
1763 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1769 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
1764 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1770 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
1765− return $ SomeEventSubscription oldSubscription
1771+ forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> do
1772+ invalidateMergeHeight m --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
1766 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1773 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1767 unsubscribe subscription
1774 unsubscribe subscription
1768 mapM_ invalidateCoincidenceHeight mcs
1775 mapM_ invalidateCoincidenceHeight mcs
1769− forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1770− forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1771 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1776 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1772 forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1777 forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
1773 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1778 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
@@ -1835,6 +1840,7 @@ invalidateSubscriberHeight old s = case s of
1836removeMergeHeight :: Height -> MergeSubscribed k -> IO ()
1841removeMergeHeight :: Height -> MergeSubscribed k -> IO ()
1837removeMergeHeight oldParentHeight subscribed = do
1842removeMergeHeight oldParentHeight subscribed = do
1843+ when debugInvalidateHeight $ putStrLn $ "removeMergeHeight: " <> show oldParentHeight <> " Merge" <> showNodeId subscribed
1838 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1844 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1839 let newHeights = heightBagRemove oldParentHeight oldHeights
1845 let newHeights = heightBagRemove oldParentHeight oldHeights
1840 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1846 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
@@ -1849,20 +1855,26 @@ invalidateMergeHeight subscribed = do
1850addMergeHeight :: Height -> MergeSubscribed k -> IO ()
1856addMergeHeight :: Height -> MergeSubscribed k -> IO ()
1851addMergeHeight newParentHeight subscribed = do
1857addMergeHeight newParentHeight subscribed = do
1858+ when debugInvalidateHeight $ putStrLn $ "addMergeHeight: " <> show newParentHeight <> " Merge" <> showNodeId subscribed
1852 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1859 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1853 let newHeights = heightBagAdd newParentHeight oldHeights
1860 let newHeights = heightBagAdd newParentHeight oldHeights
1854 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1861 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights
1856revalidateMergeHeight :: MergeSubscribed k -> IO ()
1863revalidateMergeHeight :: MergeSubscribed k -> IO ()
1857revalidateMergeHeight subscribed = do
1864revalidateMergeHeight subscribed = do
1865+ currentHeight <- readIORef $ mergeSubscribedHeight subscribed
1866+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1858− heights <- readIORef $ mergeSubscribedHeightBag subscribed
1867+ heights <- readIORef $ mergeSubscribedHeightBag subscribed
1859− parents <- readIORef $ mergeSubscribedParents subscribed
1868+ parents <- readIORef $ mergeSubscribedParents subscribed
1860− -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1869+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1861− when (heightBagSize heights == DMap.size parents) $ do
1870+ case heightBagSize heights `compare` DMap.size parents of
1862− let height = succHeight $ heightBagMax heights
1873+ let height = succHeight $ heightBagMax heights
1863− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1874+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1864− writeIORef (mergeSubscribedHeight subscribed) $! height
1875+ writeIORef (mergeSubscribedHeight subscribed) $! height
1865− WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1876+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
1877+ GT -> error $ "revalidateMergeHeight: more heights than parents for Merge" <> showNodeId subscribed
1867invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1879invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1868invalidateCoincidenceHeight subscribed = do
1880invalidateCoincidenceHeight subscribed = do