@@ -129,9 +129,33 @@ withStackOneLine expr = unsafePerformIO $ do
132+debugPropagate :: Bool
134+debugInvalidateHeight :: Bool
136+debugInvalidate :: Bool
132#ifdef DEBUG
138#ifdef DEBUG
133#define DEBUG_NODEIDS
139#define DEBUG_NODEIDS
141+#ifdef DEBUG_TRACE_PROPAGATION
142+debugPropagate = True
144+debugPropagate = False
147+#ifdef DEBUG_TRACE_HEIGHT
148+debugInvalidateHeight = True
150+debugInvalidateHeight = False
153+#ifdef DEBUG_TRACE_INVALIDATION
154+debugInvalidate = True
156+debugInvalidate = False
135class HasNodeId a where
159class HasNodeId a where
136 getNodeId :: a -> Int
160 getNodeId :: a -> Int
@@ -169,6 +193,10 @@ showNodeId' = ("#"<>) . show
196+debugPropagate = False
197+debugInvalidateHeight = False
198+debugInvalidate = False
172-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
173{-# INLINE showNodeId #-}
201{-# INLINE showNodeId #-}
174showNodeId :: a -> String
202showNodeId :: a -> String
@@ -1351,11 +1379,11 @@ tracePropagate p = when debugPropagate . trace p
1352{-# INLINE traceInvalidate #-}
1380{-# INLINE traceInvalidate #-}
1353traceInvalidate :: String -> IO ()
1381traceInvalidate :: String -> IO ()
1354−traceInvalidate = liftIO . debugStrLn
1382+traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1356{-# INLINE traceInvalidateHeight #-}
1384{-# INLINE traceInvalidateHeight #-}
1357traceInvalidateHeight :: String -> IO ()
1385traceInvalidateHeight :: String -> IO ()
1358−traceInvalidateHeight = liftIO . debugStrLn
1386+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1360{-# INLINE trace #-}
1388{-# INLINE trace #-}
1361trace :: (CanTrace x m) => proxy x -> String -> m ()
1389trace :: (CanTrace x m) => proxy x -> String -> m ()
@@ -1454,7 +1482,7 @@ instance Show EventLoopException where
1454{-# INLINE propagateSubscriberHold #-}
1482{-# INLINE propagateSubscriberHold #-}
1455propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1483propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1456propagateSubscriberHold h a = do
1484propagateSubscriberHold h a = do
1457− traceM (Proxy :: Proxy x) $ liftIO $ do
1485+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1458 invalidators <- liftIO $ readIORef $ holdInvalidators h
1486 invalidators <- liftIO $ readIORef $ holdInvalidators h
1459 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1487 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
@@ -1462,7 +1490,7 @@ propagateSubscriberHold h a = do
1462 case {-# SCC "apply" #-} apply a v of
1490 case {-# SCC "apply" #-} apply a v of
1463 Nothing -> return ()
1491 Nothing -> return ()
1464 Just v' -> do
1492 Just v' -> do
1465− withIncreasedDepth (Proxy :: Proxy x) $
1493+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1466 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1494 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1467 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1495 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1468 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1496 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
@@ -1994,7 +2022,7 @@ revalidateMergeHeight m = do
1994 LT -> return ()
2022 LT -> return ()
1995 EQ -> do
2023 EQ -> do
1996 let height = succHeight $ heightBagMax heights
2024 let height = succHeight $ heightBagMax heights
1997− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2025+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1998 writeIORef (_merge_heightRef m) $! height
2026 writeIORef (_merge_heightRef m) $! height
1999 subscriberRecalculateHeight (_merge_sub m) height
2027 subscriberRecalculateHeight (_merge_sub m) height
2000 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
2028 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -2158,7 +2186,7 @@ mergeIntCheap d = Event $ \sub -> do
2158 LT -> return ()
2186 LT -> return ()
2159 EQ -> do
2187 EQ -> do
2160 let height = succHeight $ heightBagMax heights
2188 let height = succHeight $ heightBagMax heights
2161− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2189+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2162 writeIORef heightRef $! height
2190 writeIORef heightRef $! height
2163 subscriberRecalculateHeight sub height
2191 subscriberRecalculateHeight sub height
2164 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2192 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"