write reverse deps directly

Author: soulomoon

ghcide/src/Development/IDE/Core/Rules.hs

@@ -838,6 +838,9 @@ getModIfaceFromDiskAndIndexRule recorder =
   se@ShakeExtras{withHieDb} <- getShakeExtras
 
   -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db
+
+  -- this might not happens if the changes to cache dir does not actually inroduce a change to GetModIfaceFromDisk
+    
   let ms = hirModSummary x
       hie_loc = Compat.ml_hie_file $ ms_location ms
   fileHash <- liftIO $ Util.getFileHash hie_loc

ghcide/src/Development/IDE/Core/Shake.hs

@@ -154,9 +154,9 @@ import           Development.IDE.Graph.Database          (ShakeDatabase,
                                                           shakePeekAsyncsDelivers,
                                                           shakeProfileDatabase,
                                                           shakeRunDatabaseForKeysSep,
-                                                          shakeShutDatabase,
-                                                          shakedatabaseRuntimeDep)
-import           Development.IDE.Graph.Internal.Action   (runActionInDbCb)
+                                                          shakeShutDatabase)
+import           Development.IDE.Graph.Internal.Action   (isAsyncException,
+                                                          runActionInDbCb)
 import           Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill))
 import           Development.IDE.Graph.Internal.Types    (DBQue, Step (..),
                                                           getShakeQueue,
@@ -261,7 +261,7 @@ instance Pretty Log where
         , "Current step:" <+> pretty (show step)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
-        "Build restart is taking too long (" <> pretty seconds <> " seconds)"
+        "Build restart is taking too long (" <> pretty (showDuration seconds) <> ")"
     LogDelayedAction delayedAct seconds ->
       hsep
         [ "Finished:" <+> pretty (actionName delayedAct)
@@ -949,10 +949,11 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
     shakeSession
     ( \runner -> do
         newDirtyKeys <- sraBetweenSessions shakeRestartArgs
-        reverseMap <- shakedatabaseRuntimeDep shakeDb
-        (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys
-        logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys [] reverseMap
-        (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs
+        -- reverseMap <- shakedatabaseRuntimeDep shakeDb
+        -- logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys [] reverseMap
+        (stopTime, ()) <- duration $ do
+            (preservekvs, _allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys
+            logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs
         survivedDelivers <- shakePeekAsyncsDelivers shakeDb
         -- it is every important to update the dirty keys after we enter the critical section
         -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
@@ -1041,7 +1042,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe
         -- Runs actions from the work queue sequentially
         logResult :: Show a => String -> [Either SomeException a] -> IO ()
         logResult label results = for_ results $ \case
-            Left e | Just (AsyncParentKill _ _) <- fromException e  -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " failed: " ++ show e)
+            Left e | isAsyncException e -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " failed: " ++ show e)
             Left e  -> logWith recorder Error $ LogShakeText (T.pack $ label ++ " failed: " ++ show e)
             Right r -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " finished: " ++ show r)
         pumpActionThread = do

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

@@ -14,16 +14,16 @@ module Development.IDE.Graph.Database(
     shakeShutDatabase,
     shakeGetActionQueueLength,
     shakeComputeToPreserve,
-    shakedatabaseRuntimeDep,
+    -- shakedatabaseRuntimeDep,
     shakePeekAsyncsDelivers,
-    upSweepAction) where
+    upSweepAction,
+    shakeGetTransitiveDirtyListBottomUp) where
 import           Control.Concurrent.Async                (Async)
 import           Control.Concurrent.STM.Stats            (atomically,
                                                           readTVarIO)
 import           Control.Exception                       (SomeException)
-import           Control.Monad                           (forM, join)
+import           Control.Monad                           (join)
 import           Data.Dynamic
-import           Data.HashMap.Strict                     (toList)
 import           Data.Maybe
 import           Data.Set                                (Set)
 import           Debug.Trace                             (traceEvent)
@@ -79,7 +79,7 @@ shakeRunDatabaseForKeysSep
     -> [Action a]
     -> IO (IO [Either SomeException a])
 shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
-    traceEvent ("upsweep dirties " ++ show keysChanged) $ incDatabase db keysChanged
+    bottomUp <- traceEvent ("upsweep dirties " ++ show keysChanged) $ incDatabase db keysChanged
     -- Prepare upsweep actions for changed keys if provided
     ups <- case keysChanged of
         Nothing   -> pure []
@@ -91,39 +91,16 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
     -- as2Delayed <- mapM (mkDelayedActionI "user" 1) as2
     return $ drop lenAs1 <$> runActions  (newKey "root") db (map unvoid (as1 ++ ups) ++ as2)
 
--- shakeRunDatabaseForDelayedActionsSep
---     :: Maybe [Key]
---       -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
---     -> ShakeDatabase
---     -> [Action a]
---     -> [(Key, Async ())]
---     -> Maybe KeySet
---     -> KeySet
---     -> IO (IO [Either SomeException a])
--- shakeRunDatabaseForDelayedActionsSep keysChanged (ShakeDatabase _lenAs1 as1 db) as2 preservedKeys affected newDirtyKeys = do
---     incDatabase db keysChanged
---     -- todo run as2 too
---     let preservedKeyset = fromListKeySet $ map fst preservedKeys
---         das1  = filter (\da -> shouldRun $ actionName da) as1
---         lenAs1 = length das1
---         shouldRun k = case (keysChanged, affected) of
---             (Nothing, _)       -> k `notMemberKeySet` preservedKeyset
---             (Just _, Just afs) -> k `memberKeySet` afs
---             (Just _, Nothing)  -> True
---     Step s <- readTVarIO (databaseStep db)
---     -- we don't know the child that triggered; use a self-child to kick the chain
---     ups <- mapM (\k -> mkDelayedActionFixed ("upsweep-" ++ show k) 1 (upSweepAction (Step s) k k)) (toListKeySet newDirtyKeys)
---     return $ drop lenAs1 <$> runActions db (map unvoid (das1 ++ ups) ++ filter (\da -> actionName da `notMemberKeySet` preservedKeyset) as2 )
-
-shakedatabaseRuntimeDep :: ShakeDatabase -> IO [(Key, KeySet)]
-shakedatabaseRuntimeDep (ShakeDatabase _ _ db) =
-    atomically $ toList <$> computeReverseRuntimeMap db
-
 
 shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], KeySet)
 shakeComputeToPreserve (ShakeDatabase _ _ db) ks = atomically (computeToPreserve db ks)
 
---a dsfds
+-- | Compute the transitive closure of the given keys over reverse dependencies
+-- and return them in bottom-up order (children before parents).
+shakeGetTransitiveDirtyListBottomUp :: ShakeDatabase -> [Key] -> IO [Key]
+shakeGetTransitiveDirtyListBottomUp (ShakeDatabase _ _ db) seeds =
+    transitiveDirtyListBottomUp db seeds
+
 -- fds make it possible to do al ot of jobs
 shakeRunDatabaseForKeys
     :: Maybe [Key]

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

@@ -14,6 +14,7 @@ module Development.IDE.Graph.Internal.Action
 , Development.IDE.Graph.Internal.Action.getDirtySet
 , getKeysAndVisitedAge
 , runActionInDbCb
+, isAsyncException
 ) where
 
 import           Control.Concurrent.Async