add shakeDatabaseSize function and update logging to include database size

Author: soulomoon

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

@@ -142,6 +142,7 @@ import           Development.IDE.Graph.Database           (ShakeDatabase,
                                                            instantiateDelayedAction,
                                                            mkDelayedAction,
                                                            shakeComputeToPreserve,
+                                                           shakeDatabaseSize,
                                                            shakeGetActionQueueLength,
                                                            shakeGetBuildStep,
                                                            shakeGetDatabaseKeys,
@@ -211,7 +212,7 @@ import           Data.Foldable                            (foldl')
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !ShakeRestartArgs ![DelayedActionInternal] !KeySet !Seconds !Seconds !Int !(Maybe FilePath) !Int ![DeliverStatus] !Seconds ![Key]
+  | LogBuildSessionRestart !ShakeRestartArgs ![DelayedActionInternal] !KeySet !Seconds !Seconds !Int !(Maybe FilePath) !Int ![DeliverStatus] !Seconds ![Key] !Int
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()])
@@ -255,7 +256,7 @@ instance Pretty Log where
       "Initializing exports map from hiedb"
     LogCreateHieDbExportsMapFinish exportsMapSize ->
       "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize
-    LogBuildSessionRestart restartArgs actionQueue _keyBackLog abortDuration computeToPreserveTime lookupNums shakeProfilePath step _delivers prepare _oldUpSweepDirties ->
+    LogBuildSessionRestart restartArgs actionQueue _keyBackLog abortDuration computeToPreserveTime lookupNums shakeProfilePath step _delivers prepare _oldUpSweepDirties dbSize ->
       vcat
         [ "Restarting build session due to" <+> pretty (sraReason restartArgs)
         , "Restarts num:" <+> pretty (sraCount $ restartArgs)
@@ -264,9 +265,10 @@ instance Pretty Log where
         -- , "Keys:" <+> pretty (length $ toListKeySet keyBackLog)
         -- , "Deliveries still alive:" <+> pretty delivers
         , "Current step:" <+> pretty (show step)
-        , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> "(" <> pretty (showDuration computeToPreserveTime) <+> "to compute preserved keys," <+> pretty lookupNums <+> "lookups)"
+        , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> "(" <> pretty (showDuration computeToPreserveTime) <+> "to compute preserved keys," <+> pretty lookupNums <+>"/" <+> pretty dbSize <+> " lookups)"
                     <+> pretty shakeProfilePath
         , "prepare new session took" <+> pretty (showDuration prepare)
+        , "Database size:" <+> pretty dbSize
         -- , "old upsweep dirties:" <+> pretty (oldUpSweepDirties)
         ]
     LogBuildSessionRestartTakingTooLong seconds ->
@@ -984,6 +986,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
             logErrorAfter 10 $ can dirties
             return (toUpSweepKeys, computePreserveTime, lookupsNum, oldUpSweepDirties)
         survivedDelivers <- shakePeekAsyncsDelivers shakeDb
+        dbSize <- shakeDatabaseSize 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]
         atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x newDirtyKeys
@@ -995,7 +998,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
         step <- shakeGetBuildStep shakeDb
 
         -- let logRestart x = logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime computePreserveTime lookupsNum  res step survivedDelivers x $ preservekvs
-        let logRestart x = logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime computePreserveTime lookupsNum  res step survivedDelivers x oldUpSweepDirties
+        let logRestart x = logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime computePreserveTime lookupsNum  res step survivedDelivers x oldUpSweepDirties dbSize
         return (shakeRestartArgs, toUpSweepKeys, fromListKeySet $ map deliverKey survivedDelivers, logRestart)
     )
     -- It is crucial to be masked here, otherwise we can get killed

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

@@ -18,7 +18,8 @@ module Development.IDE.Graph.Database(
     shakePeekAsyncsDelivers,
     instantiateDelayedAction,
     mkDelayedAction,
-    upsweepAction) where
+    upsweepAction,
+    shakeDatabaseSize) where
 import           Control.Concurrent.Extra                 (Barrier, newBarrier,
                                                            signalBarrier,
                                                            waitBarrierMaybe)
@@ -43,6 +44,7 @@ import           Development.IDE.Graph.Internal.Scheduler
 import           Development.IDE.Graph.Internal.Types
 import qualified Development.IDE.Graph.Internal.Types     as Logger
 import           Development.IDE.WorkerThread             (DeliverStatus)
+import qualified StmContainers.Map                        as SMap
 import           System.Time.Extra                        (duration,
                                                            showDuration)
 
@@ -143,6 +145,12 @@ shakeRunDatabaseForKeys (Just x) sdb as2 =
 shakePeekAsyncsDelivers :: ShakeDatabase -> IO [DeliverStatus]
 shakePeekAsyncsDelivers (ShakeDatabase _ _ db) = peekAsyncsDelivers db
 
+shakeDatabaseSize :: ShakeDatabase -> IO Int
+shakeDatabaseSize (ShakeDatabase _ _ db) = databaseSize db
+
+databaseSize :: Database -> IO Int
+databaseSize db = atomically $ SMap.size $ databaseValues db
+
 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
 shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
 shakeProfileDatabase (ShakeDatabase _ _ db) file = writeProfile file db