From 745b207447160cf4b6fc365780e4ba041897086d Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 06:36:04 +0800 Subject: [PATCH 1/4] Modify applicative to do direct concurrent --- ghcide/src/Development/IDE/Core/Rules.hs | 6 +++--- .../Development/IDE/Graph/Internal/Types.hs | 21 ++++++++++++++++--- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 1e96a99f2b..cc3f2b7e03 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -614,9 +614,9 @@ readHieFileFromDisk recorder hie_loc = do -- | Typechecks a module. typeCheckRule :: Recorder (WithPriority Log) -> Rules () typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do - pm <- use_ GetParsedModule file - hsc <- hscEnv <$> use_ GhcSessionDeps file - foi <- use_ IsFileOfInterest file + (pm, hsc, foi) <- (,,) <$> use_ GetParsedModule file + <*> (hscEnv <$> use_ GhcSessionDeps file) + <*> use_ IsFileOfInterest file -- We should only call the typecheck rule for files of interest. -- Keeping typechecked modules in memory for other files is -- very expensive. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3474289b42..a4249d117c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -21,13 +21,13 @@ import Data.Maybe import Data.Typeable import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key -import GHC.Conc (TVar, atomically) +import GHC.Conc (TVar, atomically, par) import GHC.Generics (Generic) import qualified ListT import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) -import UnliftIO (MonadUnliftIO) +import UnliftIO (MonadUnliftIO, concurrently) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -67,7 +67,16 @@ data SRules = SRules { -- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is -- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'. newtype Action a = Action {fromAction :: ReaderT SAction IO a} - deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO) + deriving newtype (Monad, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO) + +instance Applicative Action where + pure a = Action $ pure a + (<*>) f x = Action $ do + (fn, xn) <- concurrently (fromAction f) (fromAction x) + -- merged last two actions + deps <- asks actionDeps + liftIO $ modifyIORef' deps mergeLastTwo + return $ fn xn data SAction = SAction { actionDatabase :: !Database, @@ -153,6 +162,12 @@ data Result = Result { data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet] deriving (Eq, Show) +-- | mergeLastTwo is used to merge the last two ResultDeps in the list +-- so applicative actions can be run in parallel. +mergeLastTwo :: ResultDeps -> ResultDeps +mergeLastTwo (ResultDeps (x:y:xs)) = ResultDeps $ (x <> y) : xs +mergeLastTwo x = x + getResultDepsDefault :: KeySet -> ResultDeps -> KeySet getResultDepsDefault _ (ResultDeps ids) = fold ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids From 684b934cd554d9d5d5b3e3523c161dc9dc97bec8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 07:32:23 +0800 Subject: [PATCH 2/4] did not run con but merge deps --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index a4249d117c..cb889c3b34 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -72,10 +72,12 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a} instance Applicative Action where pure a = Action $ pure a (<*>) f x = Action $ do - (fn, xn) <- concurrently (fromAction f) (fromAction x) + -- (fn, xn) <- concurrently (fromAction f) (fromAction x) + fn <- fromAction f + xn <- fromAction x -- merged last two actions deps <- asks actionDeps - liftIO $ modifyIORef' deps mergeLastTwo + liftIO $ atomicModifyIORef' deps (\x -> (mergeLastTwo x, ())) return $ fn xn data SAction = SAction { From eaa4a94b7f62533132c437a460971cdf9f3af8bd Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 16:14:26 +0800 Subject: [PATCH 3/4] do thing atomictically --- hls-graph/src/Development/IDE/Graph/Internal/Action.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 6d47d9b511..7a37efab34 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -31,6 +31,7 @@ import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Types import System.Exit +import Data.IORef.Extra (atomicModifyIORef'_) type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) @@ -38,7 +39,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) alwaysRerun :: Action () alwaysRerun = do ref <- Action $ asks actionDeps - liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) + liftIO $ atomicModifyIORef'_ ref (AlwaysRerunDeps mempty <>) parallel :: [Action a] -> Action [a] parallel [] = pure [] @@ -52,7 +53,7 @@ parallel xs = do liftIO $ mapConcurrently (ignoreState a) xs deps -> do (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs - liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps + liftIO $ atomicWriteIORef (actionDeps a) $ mconcat $ deps : newDeps pure res where usingState a x = do @@ -117,7 +118,8 @@ apply ks = do (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps let !ks = force $ fromListKeySet $ toList is - liftIO $ modifyIORef' ref (ResultDeps [ks] <>) + -- liftIO $ modifyIORef' ref (ResultDeps [ks] <>) + liftIO $ atomicModifyIORef'_ ref (ResultDeps [ks]<>) pure vs -- | Evaluate a list of keys without recording any dependencies. From 153e91fe80a91f9a34d7fb33980dfff6b0cd90f5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 23:34:02 +0800 Subject: [PATCH 4/4] shut the session before shut the reactor --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 9 +++++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..19f2d93b16 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logWith recorder Debug LogServerShutdownMessage - -- stop the reactor to free up the hiedb connection - liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide + -- stop the reactor to free up the hiedb connection + liftIO stopReactor resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index cb889c3b34..2f5aaea0cb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -28,6 +28,7 @@ import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO, concurrently) +import Data.IORef.Extra (atomicModifyIORef'_) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -72,12 +73,12 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a} instance Applicative Action where pure a = Action $ pure a (<*>) f x = Action $ do - -- (fn, xn) <- concurrently (fromAction f) (fromAction x) - fn <- fromAction f - xn <- fromAction x + (fn, xn) <- concurrently (fromAction f) (fromAction x) + -- fn <- fromAction f + -- xn <- fromAction x -- merged last two actions deps <- asks actionDeps - liftIO $ atomicModifyIORef' deps (\x -> (mergeLastTwo x, ())) + liftIO $ atomicModifyIORef'_ deps mergeLastTwo return $ fn xn data SAction = SAction {