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/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/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. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3474289b42..2f5aaea0cb 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -21,13 +21,14 @@ 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) +import Data.IORef.Extra (atomicModifyIORef'_) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -67,7 +68,18 @@ 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) + -- fn <- fromAction f + -- xn <- fromAction x + -- merged last two actions + deps <- asks actionDeps + liftIO $ atomicModifyIORef'_ deps mergeLastTwo + return $ fn xn data SAction = SAction { actionDatabase :: !Database, @@ -153,6 +165,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