From 72263206a265a09a21ad4c8b1574639c366ea0ec Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 25 Nov 2021 13:25:19 +0000 Subject: [PATCH] lock-less progress-reporting --- ghcide/ghcide.cabal | 3 + .../Development/IDE/Core/ProgressReporting.hs | 69 +++++++++++-------- ghcide/test/exe/Progress.hs | 46 +++++++++++-- 3 files changed, 84 insertions(+), 34 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 2471bf0e38..7fe94ceafb 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -385,6 +385,7 @@ test-suite ghcide-tests hls-plugin-api, network-uri, lens, + list-t, lsp-test ^>= 0.14, optparse-applicative, process, @@ -395,6 +396,8 @@ test-suite ghcide-tests safe, safe-exceptions, shake, + stm, + stm-containers, hls-graph, tasty, tasty-expected-failure, diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2dc567ba33..0cc4241397 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -9,27 +9,31 @@ module Development.IDE.Core.ProgressReporting , mRunLspTCallback -- for tests , recordProgress - , InProgress(..) + , InProgressState(..) ) where import Control.Concurrent.Async +import Control.Concurrent.STM.Stats (STM, TVar, atomically, + newTVarIO, readTVar, + readTVarIO, writeTVar) import Control.Concurrent.Strict import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Foldable (for_) import Data.Functor (($>)) -import qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import Data.Unique import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options +import qualified Focus import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP +import qualified StmContainers.Map as STM import System.Time.Extra import UnliftIO.Exception (bracket_) @@ -69,26 +73,37 @@ updateState _ StopProgress (Running a) = cancel a $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project -data InProgress = InProgress - { todo :: !Int -- ^ Number of files to do - , done :: !Int -- ^ Number of files done - , current :: !(HMap.HashMap NormalizedFilePath Int) +data InProgressState = InProgressState + { todoVar :: TVar Int -- ^ Number of files to do + , doneVar :: TVar Int -- ^ Number of files done + , currentVar :: STM.Map NormalizedFilePath Int } -recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress -recordProgress file shift InProgress{..} = case HMap.alterF alter file current of - ((prev, new), m') -> - let (done',todo') = - case (prev,new) of - (Nothing,0) -> (done+1, todo+1) - (Nothing,_) -> (done, todo+1) - (Just 0, 0) -> (done , todo) - (Just 0, _) -> (done-1, todo) - (Just _, 0) -> (done+1, todo) - (Just _, _) -> (done , todo) - in InProgress todo' done' m' +newInProgress :: IO InProgressState +newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO + +recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> STM () +recordProgress InProgressState{..} file shift = do + done <- readTVar doneVar + todo <- readTVar todoVar + (prev, new) <- STM.focus alterPrevAndNew file currentVar + let (done',todo') = + case (prev,new) of + (Nothing,0) -> (done+1, todo+1) + (Nothing,_) -> (done, todo+1) + (Just 0, 0) -> (done , todo) + (Just 0, _) -> (done-1, todo) + (Just _, 0) -> (done+1, todo) + (Just _, _) -> (done , todo) + writeTVar todoVar todo' + writeTVar doneVar done' where - alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') + alterPrevAndNew = do + prev <- Focus.lookup + Focus.alter alter + new <- Focus.lookupWithDefault 0 + return (prev, new) + alter x = let x' = maybe (shift 0) shift x in Just x' -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new -- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives @@ -100,17 +115,16 @@ delayedProgressReporting -> ProgressReportingStyle -> IO ProgressReporting delayedProgressReporting before after lspEnv optProgressStyle = do - inProgressVar <- newVar $ InProgress 0 0 mempty + inProgressState <- newInProgress progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) + updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState) - inProgress :: NormalizedFilePath -> Action a -> Action a - inProgress = withProgressVar inProgressVar + inProgress = updateStateForFile inProgressState return ProgressReporting{..} where - lspShakeProgress inProgress = do + lspShakeProgress InProgressState{..} = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) liftIO $ sleep before @@ -143,7 +157,8 @@ delayedProgressReporting before after lspEnv optProgressStyle = do loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop id prev = do - InProgress{..} <- liftIO $ readVar inProgress + done <- liftIO $ readTVarIO doneVar + todo <- liftIO $ readTVarIO todoVar liftIO $ sleep after if todo == 0 then loop id 0 else do let next = 100 * fromIntegral done / fromIntegral todo @@ -166,12 +181,12 @@ delayedProgressReporting before after lspEnv optProgressStyle = do } loop id next - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. -- Do not remove the eta-expansion without profiling a session with at -- least 1000 modifications. where - f shift = modifyVar' var $ recordProgress file shift + f shift = atomically $ recordProgress inProgress file shift mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f diff --git a/ghcide/test/exe/Progress.hs b/ghcide/test/exe/Progress.hs index 72691947c9..3e1b2f1583 100644 --- a/ghcide/test/exe/Progress.hs +++ b/ghcide/test/exe/Progress.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE PackageImports #-} module Progress (tests) where +import Control.Concurrent.STM +import Data.Foldable (for_) import qualified Data.HashMap.Strict as Map +import Development.IDE (NormalizedFilePath) import Development.IDE.Core.ProgressReporting +import qualified "list-t" ListT +import qualified StmContainers.Map as STM import Test.Tasty import Test.Tasty.HUnit @@ -10,6 +16,11 @@ tests = testGroup "Progress" [ reportProgressTests ] +data InProgressModel = InProgressModel { + done, todo :: Int, + current :: Map.HashMap NormalizedFilePath Int +} + reportProgressTests :: TestTree reportProgressTests = testGroup "recordProgress" [ test "addNew" addNew @@ -18,11 +29,32 @@ reportProgressTests = testGroup "recordProgress" , test "done" done ] where - p0 = InProgress 0 0 mempty - addNew = recordProgress "A" succ p0 - increase = recordProgress "A" succ addNew - decrease = recordProgress "A" succ increase - done = recordProgress "A" pred decrease - model InProgress{..} = + p0 = pure $ InProgressModel 0 0 mempty + addNew = recordProgressModel "A" succ p0 + increase = recordProgressModel "A" succ addNew + decrease = recordProgressModel "A" succ increase + done = recordProgressModel "A" pred decrease + recordProgressModel key change state = + model state $ \st -> atomically $ recordProgress st key change + model stateModelIO k = do + state <- fromModel =<< stateModelIO + k state + toModel state + test name p = testCase name $ do + InProgressModel{..} <- p (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) - test name p = testCase name $ model p + +fromModel :: InProgressModel -> IO InProgressState +fromModel InProgressModel{..} = do + doneVar <- newTVarIO done + todoVar <- newTVarIO todo + currentVar <- STM.newIO + atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar + return InProgressState{..} + +toModel :: InProgressState -> IO InProgressModel +toModel InProgressState{..} = atomically $ do + done <- readTVar doneVar + todo <- readTVar todoVar + current <- Map.fromList <$> ListT.toList (STM.listT currentVar) + return InProgressModel{..}