Enhance benchmarks & bug fixes (#823)

* parse allocations

* WaitForShakeQueue

* Measure user time and shake time in experiments

* clean ups

* Prevent a potential crash of the shake enqueue thread

* Fix a bug that was preventing reenqueud actions from getting flushed

* Avoid running the check-project action per file

What we really want is to check the project once per cradle

* Backwards compat.

* Review feedback

* Fix typo

Co-authored-by: Neil Mitchell <[email protected]>

Co-authored-by: Neil Mitchell <[email protected]>

Author: pepeiborra

bench/lib/Experiments.hs

@@ -36,6 +36,8 @@ import System.Process
 import System.Time.Extra
 import Text.ParserCombinators.ReadP (readP_to_S)
 import System.Environment.Blank (getEnv)
+import Development.IDE.Plugin.Test
+import Data.Aeson (Value(Null))
 
 -- Points to a string in the target file,
 -- convenient for hygienic edits
@@ -71,7 +73,7 @@ experiments =
       ---------------------------------------------------------------------------------------
       bench "edit" 10 $ \doc -> do
         changeDoc doc [hygienicEdit]
-        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
+        waitForProgressDone
         return True,
       ---------------------------------------------------------------------------------------
       bench "hover after edit" 10 $ \doc -> do
@@ -97,7 +99,7 @@ experiments =
         10
         ( \doc -> do
             changeDoc doc [breakingEdit]
-            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
+            waitForProgressDone
             return identifierP
         )
         ( \p doc -> do
@@ -239,15 +241,28 @@ runBenchmarks allBenchmarks = do
                 in (b,) <$> runBench run b
 
   -- output raw data as CSV
-  let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"]
+  let headers =
+        [ "name"
+        , "success"
+        , "samples"
+        , "startup"
+        , "setup"
+        , "userTime"
+        , "delayedTime"
+        , "totalTime"
+        , "maxResidency"
+        , "allocatedBytes"]
       rows =
         [ [ name,
             show success,
             show samples,
             show startup,
             show runSetup',
+            show userWaits,
+            show delayedWork,
             show runExperiment,
-            showMB maxResidency
+            show maxResidency,
+            show allocations
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -265,8 +280,11 @@ runBenchmarks allBenchmarks = do
             show samples,
             showDuration startup,
             showDuration runSetup',
+            showDuration userWaits,
+            showDuration delayedWork,
             showDuration runExperiment,
-            showMB maxResidency
+            showMB maxResidency,
+            showMB allocations
           ]
           | (Bench {name, samples}, BenchRun {..}) <- results,
             let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -280,6 +298,7 @@ runBenchmarks allBenchmarks = do
       unwords $
         [ ghcide ?config,
           "--lsp",
+          "--test",
           "--cwd",
           dir,
           "+RTS",
@@ -288,9 +307,9 @@ runBenchmarks allBenchmarks = do
         ]
           ++ ghcideOptions ?config
           ++ concat
-            [ ["--shake-profiling", path]
-              | Just path <- [shakeProfiling ?config]
+            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
             ]
+          ++ ["--verbose" | verbose ?config]
     lspTestCaps =
       fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
     conf =
@@ -305,12 +324,15 @@ data BenchRun = BenchRun
   { startup :: !Seconds,
     runSetup :: !Seconds,
     runExperiment :: !Seconds,
+    userWaits :: !Seconds,
+    delayedWork :: !Seconds,
     success :: !Bool,
-    maxResidency :: !Int
+    maxResidency :: !Int,
+    allocations :: !Int
   }
 
 badRun :: BenchRun
-badRun = BenchRun 0 0 0 False 0
+badRun = BenchRun 0 0 0 0 0 False 0 0
 
 waitForProgressDone :: Session ()
 waitForProgressDone =
@@ -328,27 +350,36 @@ runBench runSess Bench {..} = handleAny (\e -> print e >> return badRun)
       changeDoc doc [hygienicEdit]
       waitForProgressDone
 
-
     liftIO $ output $ "Running " <> name <> " benchmark"
     (runSetup, userState) <- duration $ benchSetup doc
-    let loop 0 = return True
-        loop n = do
+    let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)
+        loop !userWaits !delayedWork n = do
           (t, res) <- duration $ experiment userState doc
           if not res
-            then return False
+            then return Nothing
             else do
               output (showDuration t)
-              loop (n -1)
-
-    (runExperiment, success) <- duration $ loop samples
+              -- Wait for the delayed actions to finish
+              waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue
+              (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId
+              case resp of
+                  ResponseMessage{_result=Right Null} -> do
+                    loop (userWaits+t) (delayedWork+td) (n -1)
+                  _ ->
+                  -- Assume a ghcide build lacking the WaitForShakeQueue command
+                    loop (userWaits+t) delayedWork (n -1)
+
+    (runExperiment, result) <- duration $ loop 0 0 samples
+    let success = isJust result
+        (userWaits, delayedWork) = fromMaybe (0,0) result
 
     -- sleep to give ghcide a chance to GC
     liftIO $ threadDelay 1100000
 
-    maxResidency <- liftIO $
+    (maxResidency, allocations) <- liftIO $
         ifM (doesFileExist gcStats)
-            (parseMaxResidency <$> readFile gcStats)
-            (pure 0)
+            (parseMaxResidencyAndAllocations <$> readFile gcStats)
+            (pure (0,0))
 
     return BenchRun {..}
   where
@@ -400,13 +431,15 @@ setup = do
 
 --------------------------------------------------------------------------------------------
 
--- Parse the max residency in RTS -s output
-parseMaxResidency :: String -> Int
-parseMaxResidency input =
-  case find ("maximum residency" `isInfixOf`) (reverse $ lines input) of
-    Just l -> read $ filter isDigit $ head (words l)
-    Nothing -> -1
-
+-- Parse the max residency and allocations in RTS -s output
+parseMaxResidencyAndAllocations :: String -> (Int, Int)
+parseMaxResidencyAndAllocations input =
+    (f "maximum residency", f "bytes allocated in the heap")
+  where
+    inps = reverse $ lines input
+    f label = case find (label `isInfixOf`) inps of
+        Just l -> read $ filter isDigit $ head $ words l
+        Nothing -> -1
 
 escapeSpaces :: String -> String
 escapeSpaces = map f

session-loader/Development/IDE/Session.hs

@@ -199,7 +199,7 @@ loadSession dir = do
 
 
     let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-                -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath]))
+                -> IO (IdeResult HscEnvEq,[FilePath])
         session args@(hieYaml, _cfp, _opts, _libDir) = do
           (hscEnv, new, old_deps) <- packageSetup args
 
@@ -245,11 +245,21 @@ loadSession dir = do
           invalidateShakeCache
           restartShakeSession [kick]
 
-          let resultCachedTargets = concatMap targetLocations all_targets
-
-          return (resultCachedTargets, second Map.keys res)
-
-    let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))
+          -- Typecheck all files in the project on startup
+          unless (null cs || not checkProject) $ do
+                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)
+                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
+                    mmt <- uses GetModificationTime cfps'
+                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+                    modIfaces <- uses GetModIface cs_exist
+                    -- update exports map
+                    extras <- getShakeExtras
+                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
+                    liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)
+
+          return (second Map.keys res)
+
+    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         consultCradle hieYaml cfp = do
            lfp <- flip makeRelative cfp <$> getCurrentDirectory
            logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)
@@ -276,7 +286,7 @@ loadSession dir = do
                  InstallationNotFound{..} ->
                      error $ "GHC installation not found in libdir: " <> libdir
                  InstallationMismatch{..} ->
-                     return ([],(([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]))
+                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
                  InstallationChecked _compileTime _ghcLibCheck ->
                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
@@ -286,12 +296,12 @@ loadSession dir = do
                let res = (map (renderCradleError ncfp) err, Nothing)
                modifyVar_ fileToFlags $ \var -> do
                  pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
-               return ([ncfp],(res,[]))
+               return (res,[])
 
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]
     -- Returns the Ghc session and the cradle dependencies
     let sessionOpts :: (Maybe FilePath, FilePath)
-                    -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))
+                    -> IO (IdeResult HscEnvEq, [FilePath])
         sessionOpts (hieYaml, file) = do
           v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
           cfp <- canonicalizePath file
@@ -306,37 +316,25 @@ loadSession dir = do
                   -- Keep the same name cache
                   modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
                   consultCradle hieYaml cfp
-                else return (HM.keys v, (opts, Map.keys old_di))
+                else return (opts, Map.keys old_di)
             Nothing -> consultCradle hieYaml cfp
 
     -- The main function which gets options for a file. We only want one of these running
     -- at a time. Therefore the IORef contains the currently running cradle, if we try
     -- to get some more options then we wait for the currently running action to finish
     -- before attempting to do so.
-    let getOptions :: FilePath -> IO ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath]))
+    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         getOptions file = do
             hieYaml <- cradleLoc file
             sessionOpts (hieYaml, file) `catch` \e ->
-                return ([],(([renderPackageSetupException file e], Nothing),[]))
+                return (([renderPackageSetupException file e], Nothing),[])
 
     returnWithVersion $ \file -> do
-      (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
+      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
         -- If the cradle is not finished, then wait for it to finish.
         void $ wait as
         as <- async $ getOptions file
-        return (fmap snd as, wait as)
-      unless (null cs) $ do
-        cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs
-        -- Typecheck all files in the project on startup
-        void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-          when checkProject $ do
-            mmt <- uses GetModificationTime cfps'
-            let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
-            modIfaces <- uses GetModIface cs_exist
-            -- update xports map
-            extras <- getShakeExtras
-            let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
-            liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)
+        return (as, wait as)
       pure opts
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.

src/Development/IDE/Core/Shake.hs

@@ -562,15 +562,14 @@ shakeRestart IdeState{..} acts =
     withMVar'
         shakeSession
         (\runner -> do
-              (stopTime,queue) <- duration (cancelShakeSession runner)
+              (stopTime,()) <- duration (cancelShakeSession runner)
               res <- shakeDatabaseProfile shakeProfileDir shakeDb
               let profile = case res of
                       Just fp -> ", profile saved at " <> fp
                       _ -> ""
               logDebug (logger shakeExtras) $ T.pack $
                   "Restarting build session (aborting the previous one took " ++
                   showDuration stopTime ++ profile ++ ")"
-              return queue
         )
         -- It is crucial to be masked here, otherwise we can get killed
         -- between spawning the new thread and updating shakeSession.
@@ -621,9 +620,8 @@ newSession ShakeExtras{..} shakeDb acts = do
                 "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")"
 
         workRun restore = do
-          let acts' = pumpActionThread : map getAction (reenqueued ++ acts)
-          res <- try @SomeException
-                 (restore $ shakeRunDatabase shakeDb acts')
+          let acts' = pumpActionThread : map run (reenqueued ++ acts)
+          res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')
           let res' = case res of
                       Left e -> "exception: " <> displayException e
                       Right _ -> "completed"
@@ -658,8 +656,8 @@ instantiateDelayedAction (DelayedAction _ s p a) = do
         alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b
         unless alreadyDone $ do
           x <- actionCatch @SomeException (Right <$> a) (pure . Left)
-          liftIO $ do
-            signalBarrier b x
+          -- ignore exceptions if the barrier has been filled concurrently
+          liftIO $ void $ try @SomeException $ signalBarrier b x
       d' = DelayedAction (Just u) s p a'
   return (b, d')
 

src/Development/IDE/Plugin/Test.hs

@@ -20,11 +20,14 @@ import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import System.Time.Extra
 import Development.IDE.Core.RuleTypes
+import Control.Monad
 
 data TestRequest
     = BlockSeconds Seconds           -- ^ :: Null
     | GetInterfaceFilesDir FilePath  -- ^ :: String
     | GetShakeSessionQueueCount      -- ^ :: Number
+    | WaitForShakeQueue
+      -- ^ Block until the Shake queue is empty. Returns Null
     deriving Generic
     deriving anyclass (FromJSON, ToJSON)
 
@@ -61,4 +64,9 @@ requestHandler _ s (GetInterfaceFilesDir fp) = do
 requestHandler _ s GetShakeSessionQueueCount = do
     n <- atomically $ countQueue $ actionQueue $ shakeExtras s
     return $ Right (toJSON n)
+requestHandler _ s WaitForShakeQueue = do
+    atomically $ do
+        n <- countQueue $ actionQueue $ shakeExtras s
+        when (n>0) retry
+    return $ Right Null