Optimize transitiveDirtyListBottomUpDiff using Pearce-Kelly algorithm for incremental topological ordering

hls-graph/hls-graph.cabal

@@ -63,6 +63,7 @@ library
     Development.IDE.Graph.Internal.Rules
     Development.IDE.Graph.Internal.Types
     Development.IDE.Graph.Internal.Scheduler
+    Development.IDE.Graph.Internal.TopoSort
     Development.IDE.Graph.KeyMap
     Development.IDE.Graph.KeySet
     Development.IDE.Graph.Rule

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -37,6 +37,9 @@ import           Debug.Trace                              (traceEvent)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Rules
+import           Development.IDE.Graph.Internal.TopoSort  (emptyTopoOrder,
+                                                           addEdge,
+                                                           getAffectedKeysInOrder)
 import           Development.IDE.Graph.Internal.Types
 import           Development.IDE.Graph.Internal.Types     ()
 import           Development.IDE.WorkerThread             (DeliverStatus (..))
@@ -83,6 +86,7 @@ newDatabase dataBaseLogger databaseQueue databaseActionQueue databaseExtra datab
     schedulerUpsweepQueue <- newTQueueIO
     schedulerAllDirties <- newTVarIO mempty
     schedulerAllKeysInOrder <- newTVarIO []
+    schedulerTopoOrder <- emptyTopoOrder
     let databaseScheduler = SchedulerState{..}
     pure Database{..}
 
@@ -391,18 +395,23 @@ updateReverseDeps
     -> KeySet -- ^ Current direct dependencies of Id
     -> STM ()
 -- mask to ensure that all the reverse dependencies are updated
-updateReverseDeps myId db prev new = do
+updateReverseDeps myId db@Database{..} prev new = do
+    let SchedulerState{..} = databaseScheduler
+    -- Update reverse dependency edges
     forM_ (toListKeySet $ prev `differenceKeySet` new) $ \d ->
          doOne (deleteKeySet myId) d
-    forM_ (toListKeySet new) $
-        doOne (insertKeySet myId)
+    forM_ (toListKeySet new) $ \d -> do
+        doOne (insertKeySet myId) d
+        -- Maintain topological order using Pearce-Kelly:
+        -- myId depends on d, so d must come before myId in topo order
+        addEdge schedulerTopoOrder (getRunTimeRDeps db) myId d
     where
         alterRDeps f =
             Focus.adjust (onKeyReverseDeps f)
         -- updating all the reverse deps atomically is not needed.
         -- Therefore, run individual transactions for each update
         -- in order to avoid contention
-        doOne f id = SMap.focus (alterRDeps f) id (databaseValues db)
+        doOne f id = SMap.focus (alterRDeps f) id databaseValues
 
 -- compute the transitive reverse dependencies of a set of keys
 
@@ -452,8 +461,10 @@ transitiveDirtyListBottomUp database seeds = do
 
 -- the lefts are keys that are no longer affected, we can try to mark them clean
 -- the rights are new affected keys, we need to mark them dirty
+-- Optimized version using Pearce-Kelly maintained topological order
 transitiveDirtyListBottomUpDiff :: Foldable t => Database -> t Key -> [Key] -> STM ([Key], [Key], KeySet)
-transitiveDirtyListBottomUpDiff database seeds allOldKeys = do
+transitiveDirtyListBottomUpDiff database@Database{..} seeds allOldKeys = do
+  let SchedulerState{..} = databaseScheduler
   acc <- newTVar []
   let go1 x = do
         seen <- State.get
@@ -467,7 +478,9 @@ transitiveDirtyListBottomUpDiff database seeds allOldKeys = do
             lift $ modifyTVar acc (x :)
   -- traverse all seeds
   seen <- snd <$> State.runStateT (do traverse_ go1 seeds) mempty
-  newKeys <- readTVar acc
+  -- Use the maintained topological order to sort the affected keys
+  -- This provides bottom-up order (dependencies before dependents)
+  newKeys <- getAffectedKeysInOrder schedulerTopoOrder seen
   let oldKeys = filter (`notMemberKeySet` seen) allOldKeys
   return (oldKeys, newKeys, seen)
 

hls-graph/src/Development/IDE/Graph/Internal/TopoSort.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Incremental topological ordering using the Pearce-Kelly algorithm
+--
+-- The Pearce-Kelly algorithm maintains a topological order of a DAG incrementally.
+-- Each node is assigned an integer order value. When edges are added, the algorithm
+-- efficiently reorders only the affected nodes to maintain topological consistency.
+--
+-- Reference: "An Incremental Algorithm for Maintaining the Topological Order of
+-- a Directed Acyclic Graph" by Pearce and Kelly (2006)
+module Development.IDE.Graph.Internal.TopoSort
+    ( emptyTopoOrder
+    , addEdge
+    , removeKey
+    , lookupOrder
+    , getOrderedList
+    , getAffectedKeysInOrder
+    ) where
+
+import           Control.Concurrent.STM.Stats (STM, modifyTVar', readTVar,
+                                               writeTVar)
+import           Control.Monad                (when)
+import qualified Data.HashMap.Strict          as Map
+import           Data.List                    (sortOn)
+import           Data.Maybe                   (mapMaybe)
+import           Development.IDE.Graph.Internal.Types (TopoOrder (..))
+import           Development.IDE.Graph.KeySet
+import           UnliftIO                     (newTVarIO)
+
+-- | Create an empty topological order
+emptyTopoOrder :: IO TopoOrder
+emptyTopoOrder = do
+    topoOrderMap <- newTVarIO Map.empty
+    topoNextOrderNum <- newTVarIO 0
+    return TopoOrder{..}
+
+-- | Look up the order of a key
+lookupOrder :: TopoOrder -> Key -> STM (Maybe Int)
+lookupOrder TopoOrder{..} key = do
+    orderMap <- readTVar topoOrderMap
+    return $ Map.lookup key orderMap
+
+-- | Get all keys sorted by their topological order
+getOrderedList :: TopoOrder -> STM [Key]
+getOrderedList TopoOrder{..} = do
+    orderMap <- readTVar topoOrderMap
+    return $ map fst $ sortOn snd $ Map.toList orderMap
+
+-- | Get affected keys from a KeySet, in topological order
+getAffectedKeysInOrder :: TopoOrder -> KeySet -> STM [Key]
+getAffectedKeysInOrder TopoOrder{..} affected = do
+    orderMap <- readTVar topoOrderMap
+    let affectedList = toListKeySet affected
+        withOrders = mapMaybe (\k -> (\o -> (k, o)) <$> Map.lookup k orderMap) affectedList
+    return $ map fst $ sortOn snd withOrders
+
+-- | Ensure a key has an order assigned
+ensureOrder :: TopoOrder -> Key -> STM Int
+ensureOrder TopoOrder{..} key = do
+    orderMap <- readTVar topoOrderMap
+    case Map.lookup key orderMap of
+        Just ord -> return ord
+        Nothing -> do
+            nextOrd <- readTVar topoNextOrderNum
+            writeTVar topoNextOrderNum (nextOrd + 1)
+            modifyTVar' topoOrderMap (Map.insert key nextOrd)
+            return nextOrd
+
+-- | Add an edge and maintain topological order using Pearce-Kelly
+-- In the dependency graph: edge from 'from' to 'to' means 'from' depends on 'to'
+-- In topological order: 'to' must come before 'from' (to has smaller order)
+addEdge :: TopoOrder -> (Key -> STM (Maybe KeySet)) -> Key -> Key -> STM ()
+addEdge topo@TopoOrder{..} getRDeps from to = do
+    fromOrd <- ensureOrder topo from
+    toOrd <- ensureOrder topo to
+    -- If 'to' already comes before 'from', order is correct
+    -- Otherwise, need to reorder using Pearce-Kelly forward search
+    when (fromOrd <= toOrd) $ do
+        -- Forward search: find all keys that transitively depend on 'from'
+        -- These need to be shifted to maintain topological order
+        affected <- forwardReach topo getRDeps from
+        orderMap <- readTVar topoOrderMap
+        let affectedWithOrders = mapMaybe (\k -> (\o -> (k, o)) <$> Map.lookup k orderMap) affected
+        -- Only reorder if we have affected keys
+        when (not $ null affectedWithOrders) $ do
+            let minAffected = minimum $ map snd affectedWithOrders
+            -- Shift affected keys to come after 'to'
+            when (minAffected <= toOrd) $ do
+                let shift = toOrd - minAffected + 1
+                orderMap' <- readTVar topoOrderMap
+                let newMap = foldr (\k m -> Map.adjust (+ shift) k m) orderMap' affected
+                writeTVar topoOrderMap newMap
+
+-- | Forward reachability: find all keys that transitively depend on a given key
+-- Uses DFS through reverse dependencies
+forwardReach :: TopoOrder -> (Key -> STM (Maybe KeySet)) -> Key -> STM [Key]
+forwardReach _topo getRDeps start = go [start] mempty []
+  where
+    go [] _visited acc = return acc
+    go (k:ks) visited acc
+        | k `memberKeySet` visited = go ks visited acc
+        | otherwise = do
+            let visited' = insertKeySet k visited
+            mrdeps <- getRDeps k
+            let rdeps = maybe [] toListKeySet mrdeps
+            go (rdeps ++ ks) visited' (k : acc)
+
+-- | Remove a key from the topological order
+removeKey :: TopoOrder -> Key -> STM ()
+removeKey TopoOrder{..} key = do
+    modifyTVar' topoOrderMap (Map.delete key)

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -278,6 +278,13 @@ raedAllLeftsDBQue q = do
     mapM_ (writeTaskQueue q . Right) allRight
     return allLeft
 
+-- | Topological ordering structure for Pearce-Kelly algorithm
+-- Maps each Key to its topological order number (smaller = earlier in order)
+data TopoOrder = TopoOrder
+    { topoOrderMap     :: !(TVar (Map.HashMap Key Int))
+    , topoNextOrderNum :: !(TVar Int)
+    }
+
 -- Encapsulated scheduler state, previously scattered on Database
 data SchedulerState = SchedulerState
     { schedulerUpsweepQueue   :: TQueue Key
@@ -293,6 +300,8 @@ data SchedulerState = SchedulerState
     -- ^ Keys that are pending because they are waiting for dependencies to complete
     , schedulerAllDirties     :: TVar KeySet
     , schedulerAllKeysInOrder :: TVar [Key]
+    , schedulerTopoOrder      :: !TopoOrder
+    -- ^ Incremental topological order maintained using Pearce-Kelly algorithm
     }
 
 -- dump scheduler state