From 58b8b687ad578f1ee305ae0e549a6198928582e3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 2 Nov 2024 09:44:33 +0800 Subject: [PATCH 01/55] Refactor session loading to manage pending files so we can batch load them to improve performance fix #4381 --- .../session-loader/Development/IDE/Session.hs | 55 +++++++++++-------- 1 file changed, 33 insertions(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a1d778ab0e..dab01c982f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -424,7 +424,7 @@ getHieDbLoc dir = do loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - cradle_files <- newIORef [] + cradle_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -434,6 +434,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) + pendingFilesTQueue <- newTQueueIO + -- Pending files waiting to be loaded -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) @@ -550,7 +552,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) + -> IO ((IdeResult HscEnvEq,[FilePath]), HashSet FilePath) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -562,13 +564,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let new_cache = newComponentCache recorder optExtensions _cfp hscEnv all_target_details <- new_cache old_deps new_deps + let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + all_targets' = concat all_target_details + newLoaded = HM.keys flags_map' this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + where this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) @@ -580,27 +584,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + -- Typecheck all files in the project on startup + checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- invalidateShakeCache restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache keys1 <- extendKnownTargets all_targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + 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 + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - 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 - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - - return $ second Map.keys this_options + + return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do @@ -615,11 +619,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" + + pendingFiles <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ pendingFiles <> old_files) addTag "result" (show res) return res @@ -633,8 +639,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + (results, newLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + -- put back to pending que if not listed in the results + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` newLoaded + atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + atomicModifyIORef' cradle_files (\xs -> (pendingFiles `Set.intersection` newLoaded <> xs,())) + return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do @@ -708,6 +718,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do + atomically $ writeTQueue pendingFilesTQueue $ toAbsolutePath file -- see Note [Serializing runs in separate thread] awaitRunInThread que $ getOptions file From ea002d7ef8f2c8be8663e2689bced7e67b8884ac Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 3 Nov 2024 15:28:16 +0800 Subject: [PATCH 02/55] distribute errors to all pending files are being loading --- .../session-loader/Development/IDE/Session.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dab01c982f..8683b5ada1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -425,6 +425,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef (Set.fromList []) +-- error_loading_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -606,6 +607,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + let makeError hieYaml cradle err cfp = do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) + void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) + void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + return (fst res) + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp @@ -648,13 +658,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + errors <- mapM (makeError hieYaml cradle err) $ Set.toList pendingFiles + return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let -- | We allow users to specify a loading strategy. From c78b197000c093e76f5277b7814b81ec32a85564 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 3 Nov 2024 16:15:57 +0800 Subject: [PATCH 03/55] better filter loading files --- cabal.project | 6 ++++++ ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- .../session-loader/Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 08d743c24e..3cae5e5181 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,7 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils +-- ../hiebios index-state: 2024-10-21T00:00:00Z @@ -46,3 +47,8 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False + +source-repository-package + type: git + location: https://github.com/soulomoon/hie-bios.git + tag: 7dd19b547ba30b760053b5f796c439cba6ac6a07 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8683b5ada1..a4e8678d43 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -658,7 +658,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - errors <- mapM (makeError hieYaml cradle err) $ Set.toList pendingFiles + let failedLoadingFiles = nub $ cfp:concatMap cradleErrorLoadingFiles err + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` Set.fromList failedLoadingFiles + atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + errors <- mapM (makeError hieYaml cradle err) $ failedLoadingFiles return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index a8e35e5965..ac18ff2025 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp +renderCradleError (CradleError deps _ec ms _fps) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From b87937580e8239024b58d3013cb12f38ec50d0d8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:20:25 +0800 Subject: [PATCH 04/55] fallback to non-batch load --- cabal.project | 6 -- .../session-loader/Development/IDE/Session.hs | 64 ++++++++++++------- .../Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 43 insertions(+), 29 deletions(-) diff --git a/cabal.project b/cabal.project index 3cae5e5181..08d743c24e 100644 --- a/cabal.project +++ b/cabal.project @@ -6,7 +6,6 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils --- ../hiebios index-state: 2024-10-21T00:00:00Z @@ -47,8 +46,3 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False - -source-repository-package - type: git - location: https://github.com/soulomoon/hie-bios.git - tag: 7dd19b547ba30b760053b5f796c439cba6ac6a07 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a4e8678d43..1dc4135923 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -146,10 +146,13 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogSessionNewLoadedFiles ![FilePath] deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionNewLoadedFiles files -> + "New loaded files:" <+> pretty files LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -425,7 +428,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef (Set.fromList []) --- error_loading_files <- newIORef (Set.fromList []) + error_loading_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -603,19 +606,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - - return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) - let makeError hieYaml cradle err cfp = do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (fst res) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp @@ -630,12 +622,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + -- remove the file from error loading files + errorFiles <- readIORef error_loading_files + -- remove error files from pending files since error loading need to load one by one + let pendingFiles = pendingFiles' `Set.difference` errorFiles + -- if the file is in error loading files, we fall back to single loading mode + let toLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ pendingFiles <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ toLoads <> old_files) addTag "result" (show res) return res @@ -649,20 +648,37 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (results, newLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- put back to pending que if not listed in the results - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` newLoaded + -- delete cfp even if ew report No cradle target found for cfp + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded + let newLoadedT = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) - atomicModifyIORef' cradle_files (\xs -> (pendingFiles `Set.intersection` newLoaded <> xs,())) + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT + atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) + atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - let failedLoadingFiles = nub $ cfp:concatMap cradleErrorLoadingFiles err - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` Set.fromList failedLoadingFiles - atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) - errors <- mapM (makeError hieYaml cradle err) $ failedLoadingFiles - return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + if (length toLoads > 1) + then do + succLoaded_files <- readIORef cradle_files + -- mark as less loaded files as failedLoadingFiles possible + let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files + atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) + -- retry without other files + atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) + consultCradle hieYaml cfp + else do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) + void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) + void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let -- | We allow users to specify a loading strategy. @@ -703,6 +719,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do deps_ok <- checkDependencyInfo old_di if not deps_ok then do + -- todo invoke the action to recompile the file + -- if deps are old, we can try to load the error files again + atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) + atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) -- If the dependencies are out of date then clear both caches and start -- again. modifyVar_ fileToFlags (const (return Map.empty)) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index ac18ff2025..a8e35e5965 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms _fps) cradle nfp +renderCradleError (CradleError deps _ec ms) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From 8953aec8f4eac9f8c87b6ddf955eeb383ebcf959 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:23:51 +0800 Subject: [PATCH 05/55] typo --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1dc4135923..9eac2ce279 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -665,7 +665,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do if (length toLoads > 1) then do succLoaded_files <- readIORef cradle_files - -- mark as less loaded files as failedLoadingFiles possible + -- mark as less loaded files as failedLoadingFiles as possible let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files From 4bdc2c87c8aead0b14a988e9c0b19b8d2d735558 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:24:59 +0800 Subject: [PATCH 06/55] update inline doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 9eac2ce279..7df8fc0240 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -623,7 +623,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do <> " (for " <> T.pack lfpLog <> ")" pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) - -- remove the file from error loading files errorFiles <- readIORef error_loading_files -- remove error files from pending files since error loading need to load one by one let pendingFiles = pendingFiles' `Set.difference` errorFiles @@ -656,6 +655,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT + -- remove the file from error loading files atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results From c4bb53a267c5173394ce330f33e84d6da497541a Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:26:22 +0800 Subject: [PATCH 07/55] update inline doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7df8fc0240..70a882b337 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -438,8 +438,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) - pendingFilesTQueue <- newTQueueIO -- Pending files waiting to be loaded + pendingFilesTQueue <- newTQueueIO -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) From 112bc951555bf0c1e542ad05586457d351e079af Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:36:03 +0800 Subject: [PATCH 08/55] add LogSessionReloadOnError to log errors during file reloads; cleanup error loading and cradle files --- ghcide/session-loader/Development/IDE/Session.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 70a882b337..793c6b3669 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -147,10 +147,13 @@ data Log | LogHieBios HieBios.Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] + | LogSessionReloadOnError FilePath ![FilePath] deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionReloadOnError path files -> + "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files LogSessionNewLoadedFiles files -> "New loaded files:" <+> pretty files LogNoneCradleFound path -> @@ -649,14 +652,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | compileTime == runTime -> do (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- put back to pending que if not listed in the results - -- delete cfp even if ew report No cradle target found for cfp + -- delete cfp even if we report No cradle target found for the cfp let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded let newLoadedT = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT - -- remove the file from error loading files atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) + -- remove the file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) @@ -711,6 +714,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do modifyVar_ filesMap (const (return HM.empty)) -- Don't even keep the name cache, we start from scratch here! modifyVar_ hscEnvs (const (return Map.empty)) + -- cleanup error loading files and cradle files + atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) + atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags let cfp = toAbsolutePath file From 6e04d289fe57145153128b44bf1aacb42992456b Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 23:35:57 +0800 Subject: [PATCH 09/55] refactor loadSessionWithOptions to improve error handling and clarify variable names --- ghcide/session-loader/Development/IDE/Session.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 793c6b3669..bcf29f85b4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -630,13 +630,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- remove error files from pending files since error loading need to load one by one let pendingFiles = pendingFiles' `Set.difference` errorFiles -- if the file is in error loading files, we fall back to single loading mode - let toLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + let extraToLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ toLoads <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) addTag "result" (show res) return res @@ -660,16 +660,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) -- remove the file from error loading files - atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) + atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - if (length toLoads > 1) + if (not $ null extraToLoads) then do succLoaded_files <- readIORef cradle_files -- mark as less loaded files as failedLoadingFiles as possible - let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files + let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` succLoaded_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) @@ -681,6 +681,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let From 67aebc42b01d46c9f699cd4a4f045c548c0960c2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 02:03:00 +0800 Subject: [PATCH 10/55] refactor loadSessionWithOptions to improve pending file handling and error management --- .../session-loader/Development/IDE/Session.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index bcf29f85b4..cb2571e046 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -625,17 +625,18 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) errorFiles <- readIORef error_loading_files - -- remove error files from pending files since error loading need to load one by one - let pendingFiles = pendingFiles' `Set.difference` errorFiles + old_files <- readIORef cradle_files -- if the file is in error loading files, we fall back to single loading mode - let extraToLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + let extraToLoads = if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else Set.delete cfp $ pendingFiles `Set.difference` errorFiles eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - old_files <- readIORef cradle_files res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) addTag "result" (show res) return res @@ -654,22 +655,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- put back to pending que if not listed in the results -- delete cfp even if we report No cradle target found for the cfp let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded - let newLoadedT = pendingFiles `Set.intersection` allNewLoaded + let newLoaded = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT - atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) - -- remove the file from error loading files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) + atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do if (not $ null extraToLoads) then do - succLoaded_files <- readIORef cradle_files -- mark as less loaded files as failedLoadingFiles as possible - let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` succLoaded_files + let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) From 98ae44677d0f4295ed2e461b838f5f938e1f4a50 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 02:25:56 +0800 Subject: [PATCH 11/55] add doc about limitation --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cb2571e046..127af00f2d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -669,6 +669,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do if (not $ null extraToLoads) then do -- mark as less loaded files as failedLoadingFiles as possible + -- limitation is that when we are loading files, and the dependencies of old_files + -- are changed, and old_files are not valid anymore. + -- but they will still be in the old_files, and will not move to error_loading_files. + -- And make other files failed to load in batch mode. let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files @@ -726,7 +730,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do deps_ok <- checkDependencyInfo old_di if not deps_ok then do - -- todo invoke the action to recompile the file -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) From f3eb580d1217f8fde81d2dc334df22482b6588a3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 16:51:10 +0800 Subject: [PATCH 12/55] absolute file at the beginning --- ghcide/session-loader/Development/IDE/Session.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 127af00f2d..57c9a73024 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -677,6 +677,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) consultCradle hieYaml cfp else do dep_info <- getDependencyInfo (maybeToList hieYaml) @@ -724,8 +725,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - let cfp = toAbsolutePath file - case HM.lookup (toNormalizedFilePath' cfp) v of + case HM.lookup (toNormalizedFilePath' file) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di if not deps_ok @@ -739,9 +739,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do modifyVar_ filesMap (const (return HM.empty)) -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - consultCradle hieYaml cfp + consultCradle hieYaml file else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp + Nothing -> consultCradle hieYaml file -- 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 @@ -749,16 +749,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- before attempting to do so. let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) + let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - atomically $ writeTQueue pendingFilesTQueue $ toAbsolutePath file + let absFile = toAbsolutePath file + atomically $ writeTQueue pendingFilesTQueue absFile -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions file + awaitRunInThread que $ getOptions absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From e7bd3d42045fb9680c23f995ff8b98c63a4772c8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 01:45:56 +0800 Subject: [PATCH 13/55] run session loader and worker in sperate --- ghcide/ghcide.cabal | 2 + .../session-loader/Development/IDE/Session.hs | 137 +++++++++++++----- .../Development/IDE/Session/OrderedSet.hs | 39 +++++ 3 files changed, 141 insertions(+), 37 deletions(-) create mode 100644 ghcide/session-loader/Development/IDE/Session/OrderedSet.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index bf88a55ed3..81e33aa2fa 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -110,6 +110,7 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector + , ListT if os(windows) build-depends: Win32 @@ -204,6 +205,7 @@ library Development.IDE.GHC.CPP Development.IDE.GHC.Warnings Development.IDE.Types.Action + Development.IDE.Session.OrderedSet if flag(pedantic) ghc-options: diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 57c9a73024..6cbf6ea370 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -25,6 +25,7 @@ import Control.Exception.Safe as Safe import Control.Monad import Control.Monad.Extra as Extra import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H import Data.Aeson hiding (Error) import Data.Bifunctor @@ -103,8 +104,7 @@ import qualified Data.HashSet as Set import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (awaitRunInThread, - withWorkerQueue) +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -119,12 +119,17 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) +import Control.Concurrent.STM (STM) +import qualified Control.Monad.STM as STM +import qualified Development.IDE.Session.OrderedSet as S +import qualified Focus import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import qualified StmContainers.Map as STM data Log = LogSettingInitialDynFlags @@ -148,10 +153,14 @@ data Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] | LogSessionReloadOnError FilePath ![FilePath] + | LogGetOptionsLoop !FilePath + | LogGetSessionRetry !FilePath deriving instance Show Log instance Pretty Log where pretty = \case + LogGetSessionRetry path -> "Retrying get session for" <+> pretty path + LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files LogSessionNewLoadedFiles files -> @@ -435,14 +444,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + fileToFlags <- STM.newIO :: IO FlagsMap -- Mapping from a Filepath to its 'hie.yaml' location. -- Should hold the same Filepaths as 'fileToFlags', otherwise -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) + filesMap <- STM.newIO :: IO FilesMap -- Pending files waiting to be loaded - pendingFilesTQueue <- newTQueueIO + pendingFileSet <- S.newIO :: IO (S.OrderedSet FilePath) -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) @@ -559,7 +568,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,[FilePath]), HashSet FilePath) + -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -589,8 +598,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" ] - void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs + atomically $ do + STM.insert this_flags_map hieYaml fileToFlags + insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -609,9 +621,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + return $ (this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog @@ -625,7 +637,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ S.toUnOrderedList pendingFileSet) errorFiles <- readIORef error_loading_files old_files <- readIORef cradle_files -- if the file is in error loading files, we fall back to single loading mode @@ -652,18 +664,20 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ((runTime, _):_) | compileTime == runTime -> do (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- put back to pending que if not listed in the results -- delete cfp even if we report No cradle target found for the cfp - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded let newLoaded = pendingFiles `Set.intersection` allNewLoaded - atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + -- delete all new loaded + atomically $ forM_ allNewLoaded $ flip S.delete pendingFileSet -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) return results - | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + | otherwise -> do + -- delete cfp from pending files + atomically $ S.delete cfp pendingFileSet + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) -- Failure case, either a cradle error or the none cradle Left err -> do if (not $ null extraToLoads) @@ -676,18 +690,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files - atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) consultCradle hieYaml cfp else do - dep_info <- getDependencyInfo (maybeToList hieYaml) + dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + -- remove cfp from pending files + atomically $ S.delete cfp pendingFileSet + atomically $ do + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags + STM.insert hieYaml ncfp filesMap atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + return (res, dep_info) let -- | We allow users to specify a loading strategy. @@ -710,21 +725,22 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) + -> IO (IdeResult HscEnvEq, DependencyInfo) sessionOpts (hieYaml, file) = do Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ do + STM.reset filesMap + STM.reset fileToFlags -- Don't even keep the name cache, we start from scratch here! modifyVar_ hscEnvs (const (return Map.empty)) -- cleanup error loading files and cradle files atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags + v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags case HM.lookup (toNormalizedFilePath' file) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di @@ -735,31 +751,77 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ do + STM.reset filesMap + STM.reset fileToFlags -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file - else return (opts, Map.keys old_di) + else return (opts, old_di) Nothing -> consultCradle hieYaml file + let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) + checkInCache ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp filesMap + m <- MaybeT $ STM.lookup cachedHieYamlLocation fileToFlags + MaybeT $ pure $ HM.lookup ncfp m + -- 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 (IdeResult HscEnvEq, [FilePath]) + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) getOptions file = do let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap + cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - + let hieLoc = join cachedHieYamlLocation <|> hieYaml + result <- sessionOpts (hieLoc, file) `Safe.catch` \e -> do + dep <- getDependencyInfo $ maybe [] pure hieYaml + return (([renderPackageSetupException file e], Nothing), dep) + atomically $ STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp result)) hieLoc fileToFlags + return result + + let getOptionsLoop :: IO () + getOptionsLoop = do + -- Get the next file to load + absFile <- atomically $ S.readQueue pendingFileSet + logWith recorder Info (LogGetOptionsLoop absFile) + void $ getOptions absFile + getOptionsLoop + + let getSessionRetry :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + getSessionRetry absFile = do + let ncfp = toNormalizedFilePath' absFile + -- check if in the cache + res <- atomically $ checkInCache ncfp + logWith recorder Info $ LogGetSessionRetry absFile + updateDateRes <- case res of + Just r -> do + depOk <- checkDependencyInfo (snd r) + if depOk + then return $ Just r + else return Nothing + _ -> return Nothing + case updateDateRes of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ do + S.insert absFile pendingFileSet + atomically $ do + -- wait until pendingFiles is not in pendingFiles + Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + getSessionRetry absFile + + -- Start the getOptionsLoop if the queue is empty + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file - atomically $ writeTQueue pendingFilesTQueue absFile + second Map.keys <$> getSessionRetry absFile + -- atomically $ writeTQueue pendingFiles absFile -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions absFile + -- awaitRunInThread que $ second Map.keys <$> getOptions absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -1034,10 +1096,11 @@ setCacheDirs recorder CacheDirs{..} dflags = do type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) -- | Maps a Filepath to its respective "hie.yaml" location. -- It aims to be the reverse of 'FlagsMap'. -type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) +type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) + -- This is pristine information about a component data RawComponentInfo = RawComponentInfo diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs new file mode 100644 index 0000000000..e1a5f123c2 --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -0,0 +1,39 @@ +module Development.IDE.Session.OrderedSet where + +import Control.Concurrent.STM (STM, TQueue, newTQueueIO) +import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Data.Hashable (Hashable) +import qualified ListT as LT +import qualified StmContainers.Set as S +import StmContainers.Set (Set) + + +type OrderedSet a = (TQueue a, Set a) + +insert :: Hashable a => a -> OrderedSet a -> STM () +insert a (que, s) = do + S.insert a s + writeTQueue que a + return () + +newIO :: Hashable a => IO (OrderedSet a) +newIO = do + que <- newTQueueIO + s <- S.newIO + return (que, s) + +readQueue :: Hashable a => OrderedSet a -> STM a +readQueue rs@(que, s) = do + f <- readTQueue que + b <- S.lookup f s + -- retry if the file is already in done + if b then return f else readQueue rs + +lookup :: Hashable a => a -> OrderedSet a -> STM Bool +lookup a (_, s) = S.lookup a s + +delete :: Hashable a => a -> OrderedSet a -> STM () +delete a (_, s) = S.delete a s + +toUnOrderedList :: Hashable a => OrderedSet a -> STM [a] +toUnOrderedList (_, s) = LT.toList $ S.listT s From 1f97c401b5aa5cc86c1e52d397bcd91154662a88 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 02:26:23 +0800 Subject: [PATCH 14/55] cleanup --- .../session-loader/Development/IDE/Session.hs | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6cbf6ea370..99ca786506 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -790,8 +790,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ getOptions absFile getOptionsLoop - let getSessionRetry :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) - getSessionRetry absFile = do + -- | Given a file, this function will return the HscEnv and the dependencies + -- it would look up the cache first, if the cache is not available, it would + -- submit a request to the getOptionsLoop to get the options for the file + -- and wait until the options are available + let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + lookupOrWaitCache absFile = do let ncfp = toNormalizedFilePath' absFile -- check if in the cache res <- atomically $ checkInCache ncfp @@ -807,21 +811,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Just r -> return r Nothing -> do -- if not ok, we need to reload the session - atomically $ do - S.insert absFile pendingFileSet - atomically $ do - -- wait until pendingFiles is not in pendingFiles - Extra.whenM (S.lookup absFile pendingFileSet) STM.retry - getSessionRetry absFile + atomically $ S.insert absFile pendingFileSet + -- wait until pendingFiles is not in pendingFiles + atomically $ Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + lookupOrWaitCache absFile + -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file - second Map.keys <$> getSessionRetry absFile - -- atomically $ writeTQueue pendingFiles absFile - -- see Note [Serializing runs in separate thread] - -- awaitRunInThread que $ second Map.keys <$> getOptions absFile + second Map.keys <$> lookupOrWaitCache absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From 4c998bd487e48dcf85abbb14cc58d217c5dafd6a Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 15:24:17 +0800 Subject: [PATCH 15/55] rename LogGetSessionRetry to LogLookupSessionCache for clarity in logging --- ghcide/session-loader/Development/IDE/Session.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 99ca786506..c6d2dcbb84 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -154,12 +154,12 @@ data Log | LogSessionNewLoadedFiles ![FilePath] | LogSessionReloadOnError FilePath ![FilePath] | LogGetOptionsLoop !FilePath - | LogGetSessionRetry !FilePath + | LogLookupSessionCache !FilePath deriving instance Show Log instance Pretty Log where pretty = \case - LogGetSessionRetry path -> "Retrying get session for" <+> pretty path + LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files @@ -799,7 +799,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile -- check if in the cache res <- atomically $ checkInCache ncfp - logWith recorder Info $ LogGetSessionRetry absFile + logWith recorder Info $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do depOk <- checkDependencyInfo (snd r) From 79a43a0cbfa32a226c831a7eb9da0279d9049ab7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 9 Nov 2024 18:34:13 +0800 Subject: [PATCH 16/55] extract attempt to load files from errors --- cabal.project | 5 +++++ ghcide/session-loader/Development/IDE/Session.hs | 8 +++++--- .../session-loader/Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 2c872ed46f..2b46365f1f 100644 --- a/cabal.project +++ b/cabal.project @@ -46,3 +46,8 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False + +source-repository-package + type: git + location: https://github.com/soulomoon/hie-bios.git + tag: 93582c21372af573e5103bad198777a3317a2df2 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c6d2dcbb84..f3bbc4d899 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -680,17 +680,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) -- Failure case, either a cradle error or the none cradle Left err -> do - if (not $ null extraToLoads) + let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) + `Set.difference` old_files + if (not $ null attemptToLoadFiles) then do -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files + let failedLoadingFiles = (Set.insert cfp attemptToLoadFiles) atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files - logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index a8e35e5965..8b1136c0c8 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp +renderCradleError (CradleError deps _ec ms _attemptToLoadFiles) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From beb1764608b01d8e659ce38ad914474f98880f50 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 12 Nov 2024 19:53:35 +0800 Subject: [PATCH 17/55] refactor session loading to wait for pending files before cache check --- ghcide/session-loader/Development/IDE/Session.hs | 9 +++++---- .../session-loader/Development/IDE/Session/OrderedSet.hs | 7 ++++--- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f3bbc4d899..c47cb7b381 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -799,8 +799,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) lookupOrWaitCache absFile = do let ncfp = toNormalizedFilePath' absFile - -- check if in the cache - res <- atomically $ checkInCache ncfp + res <- atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + -- check if in the cache + checkInCache ncfp logWith recorder Info $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do @@ -814,8 +817,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet - -- wait until pendingFiles is not in pendingFiles - atomically $ Extra.whenM (S.lookup absFile pendingFileSet) STM.retry lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index e1a5f123c2..ff67abd8b1 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -2,7 +2,9 @@ module Development.IDE.Session.OrderedSet where import Control.Concurrent.STM (STM, TQueue, newTQueueIO) import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Control.Monad (when) import Data.Hashable (Hashable) +import qualified Focus import qualified ListT as LT import qualified StmContainers.Set as S import StmContainers.Set (Set) @@ -12,9 +14,8 @@ type OrderedSet a = (TQueue a, Set a) insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do - S.insert a s - writeTQueue que a - return () + (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s + when inserted $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do From 61395222f11eb3c1751daf437b936f41ef712961 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 19 Nov 2024 05:18:13 +0800 Subject: [PATCH 18/55] add LogTime to logging for improved time tracking during session loading --- .../session-loader/Development/IDE/Session.hs | 58 +++++++++++-------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c47cb7b381..2b75329c1b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -155,10 +155,12 @@ data Log | LogSessionReloadOnError FilePath ![FilePath] | LogGetOptionsLoop !FilePath | LogLookupSessionCache !FilePath + | LogTime !String deriving instance Show Log instance Pretty Log where pretty = \case + LogTime s -> "Time:" <+> pretty s LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> @@ -582,7 +584,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details - newLoaded = HM.keys flags_map' this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) = case HM.lookup _cfp flags_map' of @@ -599,9 +600,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ] let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs + newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map atomically $ do STM.insert this_flags_map hieYaml fileToFlags insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete pendingFileSet -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -621,9 +624,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return $ (this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + return $ (this_options, newLoaded) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog @@ -658,32 +661,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do + let ncfp = toNormalizedFilePath' cfp let compileTime = fullCompilerVersion case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- delete cfp even if we report No cradle target found for the cfp + (_results, allNewLoaded) <- session (hieYaml, ncfp, opts, libDir) let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- delete all new loaded - atomically $ forM_ allNewLoaded $ flip S.delete pendingFileSet -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) - return results | otherwise -> do -- delete cfp from pending files - atomically $ S.delete cfp pendingFileSet - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) + atomically $ do + STM.focus (Focus.insertOrMerge HM.union + (HM.singleton ncfp (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty))) + hieYaml fileToFlags + STM.insert hieYaml ncfp filesMap + S.delete cfp pendingFileSet -- Failure case, either a cradle error or the none cradle Left err -> do let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) `Set.difference` old_files if (not $ null attemptToLoadFiles) + then do + -- we are loading more files and failed, we need to retry + -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. @@ -695,16 +702,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do + -- we are only loading this file and it failed dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) -- remove cfp from pending files - atomically $ S.delete cfp pendingFileSet + atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) atomically $ do STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - return (res, dep_info) + STM.insert hieYaml ncfp filesMap + S.delete cfp pendingFileSet let -- | We allow users to specify a loading strategy. @@ -727,7 +734,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, DependencyInfo) + -> IO () sessionOpts (hieYaml, file) = do Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged @@ -744,10 +751,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags case HM.lookup (toNormalizedFilePath' file) v of - Just (opts, old_di) -> do + Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do + when (not deps_ok) $ do -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) @@ -759,7 +765,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file - else return (opts, old_di) Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) @@ -772,24 +777,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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 (IdeResult HscEnvEq, DependencyInfo) + let getOptions :: FilePath -> IO () getOptions file = do let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file let hieLoc = join cachedHieYamlLocation <|> hieYaml - result <- sessionOpts (hieLoc, file) `Safe.catch` \e -> do + sessionOpts (hieLoc, file) `Safe.catch` \e -> do dep <- getDependencyInfo $ maybe [] pure hieYaml - return (([renderPackageSetupException file e], Nothing), dep) - atomically $ STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp result)) hieLoc fileToFlags - return result + let errorResult = (([renderPackageSetupException file e], Nothing), dep) + atomically $ do + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp errorResult)) hieLoc fileToFlags + STM.insert hieYaml ncfp filesMap + -- delete file from pending files + S.delete file pendingFileSet let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load absFile <- atomically $ S.readQueue pendingFileSet logWith recorder Info (LogGetOptionsLoop absFile) - void $ getOptions absFile + getOptions absFile getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From 73145097fbff80f27d7d8d6411411a96de97bf22 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 19 Nov 2024 18:13:49 +0800 Subject: [PATCH 19/55] refactor session loading to handle dependency checks more clearly --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2b75329c1b..02f3988f29 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -753,7 +753,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do case HM.lookup (toNormalizedFilePath' file) v of Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - when (not deps_ok) $ do + if (not deps_ok) + then do -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) @@ -765,6 +766,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file + -- if deps are ok, we can just remove the file from pending files + else atomically $ S.delete file pendingFileSet Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) From cddcc55b9bbe40659ba5e7f25a3584ce20c41c8a Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 20 Nov 2024 07:14:55 +0800 Subject: [PATCH 20/55] Refactors session loading logic Renames getOptions to getOptionsWorker for clarity Removes redundant getOptionsLoop function Ensures session loading is called under the same `Action` context --- ghcide/session-loader/Development/IDE/Session.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 02f3988f29..74eabcc021 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -780,8 +780,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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 () - getOptions file = do + let getOptionsWorker :: FilePath -> IO () + getOptionsWorker file = do + logWith recorder Info (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -795,14 +796,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- delete file from pending files S.delete file pendingFileSet - let getOptionsLoop :: IO () - getOptionsLoop = do - -- Get the next file to load - absFile <- atomically $ S.readQueue pendingFileSet - logWith recorder Info (LogGetOptionsLoop absFile) - getOptions absFile - getOptionsLoop - -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file @@ -828,11 +821,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet + -- line up the session to load + atomically $ writeTQueue que (getOptionsWorker absFile) lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty - liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file second Map.keys <$> lookupOrWaitCache absFile From bb78a36f473aa7439203d6e33e71d2b3a9a7fada Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 7 Dec 2024 03:52:07 +0800 Subject: [PATCH 21/55] delay the restart --- .../session-loader/Development/IDE/Session.hs | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 74eabcc021..9b31bb0188 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -570,7 +570,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath) + -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath, IO ()) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -610,21 +610,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - restartShakeSession VFSUnmodified "new component" [] $ do - keys2 <- invalidateShakeCache - keys1 <- extendKnownTargets all_targets - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - 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 - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return [keys1, keys2] - return $ (this_options, newLoaded) + let restart = restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache + keys1 <- extendKnownTargets all_targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + 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 + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] + return (this_options, newLoaded, restart) let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do @@ -667,13 +667,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, allNewLoaded) <- session (hieYaml, ncfp, opts, libDir) + (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) let newLoaded = pendingFiles `Set.intersection` allNewLoaded -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) + restart | otherwise -> do -- delete cfp from pending files atomically $ do @@ -782,7 +783,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- before attempting to do so. let getOptionsWorker :: FilePath -> IO () getOptionsWorker file = do - logWith recorder Info (LogGetOptionsLoop file) + logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -808,7 +809,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Extra.whenM (S.lookup absFile pendingFileSet) STM.retry -- check if in the cache checkInCache ncfp - logWith recorder Info $ LogLookupSessionCache absFile + logWith recorder Debug $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do depOk <- checkDependencyInfo (snd r) From 58ec7eac149a4504d4084519a97bb3ffa255595b Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 18 Feb 2025 05:16:01 +0800 Subject: [PATCH 22/55] re-inline the old file instead of loading it twice --- ghcide/session-loader/Development/IDE/Session.hs | 16 +++++++++++----- .../Development/IDE/Session/OrderedSet.hs | 14 +++++++++++--- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1b19561c54..3ec7db2e6c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -772,9 +772,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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 getOptionsWorker :: FilePath -> IO () - getOptionsWorker file = do - logWith recorder Debug (LogGetOptionsLoop file) + let getOptions :: FilePath -> IO () + getOptions file = do let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -788,6 +787,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- delete file from pending files S.delete file pendingFileSet + let getOptionsLoop :: IO () + getOptionsLoop = do + -- Get the next file to load + absFile <- atomically $ S.readQueue pendingFileSet + logWith recorder Debug (LogGetOptionsLoop absFile) + getOptions absFile + getOptionsLoop + -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file @@ -813,12 +820,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet - -- line up the session to load - atomically $ writeTQueue que (getOptionsWorker absFile) lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file second Map.keys <$> lookupOrWaitCache absFile diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index ff67abd8b1..a2b0a76565 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -1,6 +1,7 @@ module Development.IDE.Session.OrderedSet where -import Control.Concurrent.STM (STM, TQueue, newTQueueIO) +import Control.Concurrent.STM (STM, TQueue, flushTQueue, + newTQueueIO) import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) import Control.Monad (when) import Data.Hashable (Hashable) @@ -15,7 +16,14 @@ type OrderedSet a = (TQueue a, Set a) insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s - when inserted $ writeTQueue que a + -- if already in the set + -- update the position of the element in the queue + when (not inserted) $ do + items <- filter (==a) <$> flushTQueue que + mapM_ (writeTQueue que) items + return () + writeTQueue que a + -- when que $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do @@ -27,7 +35,7 @@ readQueue :: Hashable a => OrderedSet a -> STM a readQueue rs@(que, s) = do f <- readTQueue que b <- S.lookup f s - -- retry if the file is already in done + -- retry if no files are left in the queue if b then return f else readQueue rs lookup :: Hashable a => a -> OrderedSet a -> STM Bool From d9439637ec7f5ccee4491bb9fb396aef4d3a44f3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 19 Feb 2025 01:05:49 +0800 Subject: [PATCH 23/55] update upload artifact action version --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 659352e4e6..b9d6d49059 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 5d015001976a1562b0f9ca612ab44a494656c081 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 26 Feb 2025 05:01:54 +0800 Subject: [PATCH 24/55] update hie-bios tag --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 2e32d6715f..b45f1ba86d 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/soulomoon/hie-bios.git - tag: 93582c21372af573e5103bad198777a3317a2df2 \ No newline at end of file + tag: 84febb04ba152b03fd42b551ffb2ea6e7506cf9b From 10a6f7e7c69dfc150aff34e0c6cebc37a127eca6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 27 Feb 2025 05:17:54 +0800 Subject: [PATCH 25/55] Update hie-bios tag to latest commit --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index b45f1ba86d..54c46e6eca 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/soulomoon/hie-bios.git - tag: 84febb04ba152b03fd42b551ffb2ea6e7506cf9b + tag: 3351cfc5becee6a09df47df4772598fb2207b746 From 45b124137d7111274bcb06470ed855bb0377b8eb Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 3 Mar 2025 00:18:43 +0800 Subject: [PATCH 26/55] update hie-bios --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 54c46e6eca..794ccb4fb2 100644 --- a/cabal.project +++ b/cabal.project @@ -65,5 +65,5 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git - location: https://github.com/soulomoon/hie-bios.git - tag: 3351cfc5becee6a09df47df4772598fb2207b746 + location: https://github.com/haskell/hie-bios + tag: bc502c94b891719f07e5ada9f6f59ca4ba8e08ff From 219db463049bfac6408f6cde3f9a0b3262a9e059 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 3 Mar 2025 01:19:42 +0800 Subject: [PATCH 27/55] update index-state to reflect the latest project state --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 794ccb4fb2..4c9d2b25e0 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2024-12-02T00:00:00Z +index-state: 2025-03-02T16:10:12Z tests: True test-show-details: direct From 2f86db0b0abd5f86af42ec96a0b2e7f4da077a1f Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 4 Mar 2025 00:13:35 +0800 Subject: [PATCH 28/55] update index-state to reflect the new date --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 4c9d2b25e0..794ccb4fb2 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2025-03-02T16:10:12Z +index-state: 2024-12-02T00:00:00Z tests: True test-show-details: direct From de98232569ab0104b5ad34a7fbf1e49316e63375 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:08:57 +0800 Subject: [PATCH 29/55] update fourmolu dependency version constraints --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index dcbb546733..eece96f992 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1497,7 +1497,7 @@ library hls-fourmolu-plugin build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 + , fourmolu ^>= 0.14 || ^>= 0.15 || >= 0.16 && < 0.16.2 , ghc-boot-th , ghcide == 2.9.0.1 , hls-plugin-api == 2.9.0.1 From f0a881d1a5b24ca648230e53ef63d28c14524a49 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:23:24 +0800 Subject: [PATCH 30/55] remove ListT from library dependencies --- ghcide/ghcide.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3b88a2024c..1468128d9a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -111,7 +111,6 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector - , ListT if os(windows) build-depends: Win32 From 14f6a3b93a693e1daf141a2f9172c32509fcb166 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:23:46 +0800 Subject: [PATCH 31/55] update hie-bios to a new tag --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 794ccb4fb2..66fa8a3ff8 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/haskell/hie-bios - tag: bc502c94b891719f07e5ada9f6f59ca4ba8e08ff + tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 From 8b0e246a9be0f513813ac8728801ecd3b3a81873 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:24:01 +0800 Subject: [PATCH 32/55] update fourmolu dependency version constraints to allow 0.16 --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index eece96f992..dcbb546733 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1497,7 +1497,7 @@ library hls-fourmolu-plugin build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>= 0.14 || ^>= 0.15 || >= 0.16 && < 0.16.2 + , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 , ghc-boot-th , ghcide == 2.9.0.1 , hls-plugin-api == 2.9.0.1 From 2dd71c00f30032d30e339f250c6c334e5a978f29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:34:50 +0800 Subject: [PATCH 33/55] add allow-newer constraint for Cabal-syntax --- cabal.project | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cabal.project b/cabal.project index 66fa8a3ff8..f46df91127 100644 --- a/cabal.project +++ b/cabal.project @@ -63,6 +63,8 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) constraints: ghc-lib-parser==9.8.4.20241130 +allow-newer: + Cabal-syntax source-repository-package type: git location: https://github.com/haskell/hie-bios From b8406d60b991a8d92435405579a77ff6f80bbf5b Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:37:53 +0800 Subject: [PATCH 34/55] remove allow-newer constraint for Cabal-syntax --- cabal.project | 2 -- 1 file changed, 2 deletions(-) diff --git a/cabal.project b/cabal.project index f46df91127..66fa8a3ff8 100644 --- a/cabal.project +++ b/cabal.project @@ -63,8 +63,6 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) constraints: ghc-lib-parser==9.8.4.20241130 -allow-newer: - Cabal-syntax source-repository-package type: git location: https://github.com/haskell/hie-bios From 5ea3d87b8ef711949a4fb73eab2472bc21dc19cd Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:50:27 +0800 Subject: [PATCH 35/55] bump actions/checkout and actions/upload-artifact to v3 --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index b9d6d49059..659352e4e6 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v3 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v3 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v3 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 3e0c27b1de952c84cd4f8598907be79d0be4d735 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:53:05 +0800 Subject: [PATCH 36/55] Revert "bump actions/checkout and actions/upload-artifact to v3" This reverts commit 5ea3d87b8ef711949a4fb73eab2472bc21dc19cd. --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 659352e4e6..b9d6d49059 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 8c27e3479bd4ba7fd699ba76396a8f4419d60ce6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 22:21:37 +0800 Subject: [PATCH 37/55] add allow-older constraint for optparse-applicative in cabal.project --- cabal.project | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cabal.project b/cabal.project index 66fa8a3ff8..efc8e3a895 100644 --- a/cabal.project +++ b/cabal.project @@ -67,3 +67,5 @@ source-repository-package type: git location: https://github.com/haskell/hie-bios tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 +-- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 +allow-older: hie-bios:optparse-applicative From b0af63434ea35f4c40911a630f043c4eb51215cf Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 24 Apr 2025 19:03:06 +0800 Subject: [PATCH 38/55] update hie-bios --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index c69496e295..e54c7f4bfe 100644 --- a/cabal.project +++ b/cabal.project @@ -56,7 +56,7 @@ allow-newer: source-repository-package type: git location: https://github.com/haskell/hie-bios - tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 + tag: e372a62b780b1314a35238a698a9e3813096b122 -- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 allow-older: hie-bios:optparse-applicative From 06fa5de52bd4b10e28bab42c9c076f409b356d43 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 27 Apr 2025 16:19:26 +0800 Subject: [PATCH 39/55] introduce SessionState --- .../session-loader/Development/IDE/Session.hs | 259 ++++++++++++------ 1 file changed, 173 insertions(+), 86 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fd50fa5bc0..76d10c9d66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -418,6 +418,125 @@ getHieDbLoc dir = do createDirectoryIfMissing True cDir pure (cDir db) +data SessionState = SessionState + { cradle_files :: !(IORef (HashSet FilePath)) + , error_loading_files :: !(IORef (HashSet FilePath)) + , hscEnvs :: !(Var HieMap) + , fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))) + , filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)) + , pendingFileSet :: !(S.OrderedSet FilePath) + , version :: !(Var Int) + } + +-- | Helper functions for SessionState management +-- These functions encapsulate common operations on the SessionState + +-- | Add a file to the set of files with errors during loading +addErrorLoadingFile :: SessionState -> FilePath -> IO () +addErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.insert file xs, ())) + +addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () +addErrorLoadingFiles = mapM_ . addErrorLoadingFile + +-- | Remove a file from the set of files with errors during loading +removeErrorLoadingFile :: SessionState -> FilePath -> IO () +removeErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.delete file xs, ())) + +addCradleFiles :: SessionState -> HashSet FilePath -> IO () +addCradleFiles state files = + atomicModifyIORef' (cradle_files state) (\xs -> (files <> xs, ())) + +-- | Remove a file from the cradle files set +removeCradleFile :: SessionState -> FilePath -> IO () +removeCradleFile state file = + atomicModifyIORef' (cradle_files state) (\xs -> (Set.delete file xs, ())) + +-- | Clear error loading files and reset to empty set +clearErrorLoadingFiles :: SessionState -> IO () +clearErrorLoadingFiles state = + atomicModifyIORef' (error_loading_files state) (\_ -> (Set.empty, ())) + +-- | Clear cradle files and reset to empty set +clearCradleFiles :: SessionState -> IO () +clearCradleFiles state = + atomicModifyIORef' (cradle_files state) (\_ -> (Set.empty, ())) + +-- | Reset the file maps in the session state +resetFileMaps :: SessionState -> STM () +resetFileMaps state = do + STM.reset (filesMap state) + STM.reset (fileToFlags state) + +-- | Insert or update file flags for a specific hieYaml and normalized file path +insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM () +insertFileFlags state hieYaml ncfp flags = + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state) + +-- | Insert a file mapping from normalized path to hieYaml location +insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMapping state hieYaml ncfp = + STM.insert hieYaml ncfp (filesMap state) + +-- | Remove a file from the pending file set +removeFromPending :: SessionState -> FilePath -> STM () +removeFromPending state file = + S.delete file (pendingFileSet state) + +-- | Add a file to the pending file set +addToPending :: SessionState -> FilePath -> STM () +addToPending state file = + S.insert file (pendingFileSet state) + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +completeFileProcessing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> FilePath -> (IdeResult HscEnvEq, DependencyInfo) -> IO () +completeFileProcessing state hieYaml ncfp file flags = do +-- remove cfp from pending files + addErrorLoadingFile state file + removeCradleFile state file + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + removeFromPending state file + +-- | Insert multiple file mappings at once +insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () +insertAllFileMappings state mappings = + mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings + +-- | Increment the version counter +incrementVersion :: SessionState -> IO Int +incrementVersion state = modifyVar' (version state) succ + +-- | Get files from the pending file set +getPendingFiles :: SessionState -> IO (HashSet FilePath) +getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFileSet state) + +-- | Handle errors during session loading by recording file as having error and removing from pending +handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSessionError state hieYaml file e = do + dep <- getDependencyInfo $ maybe [] pure hieYaml + let ncfp = toNormalizedFilePath' file + let errorResult = (([renderPackageSetupException file e], Nothing), dep) + completeFileProcessing state hieYaml ncfp file errorResult + +-- | Get the set of extra files to load based on the current file path +-- If the current file is in error loading files, we fallback to single loading mode (empty set) +-- Otherwise, we remove error files from pending files and also exclude the current file +getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] +getExtraFilesToLoad state cfp = do + pendingFiles <- getPendingFiles state + errorFiles <- readIORef (error_loading_files state) + old_files <- readIORef (cradle_files state) + -- if the file is in error loading files, we fall back to single loading mode + return $ + Set.toList $ + if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -435,23 +554,20 @@ getHieDbLoc dir = do loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - cradle_files <- newIORef (Set.fromList []) - error_loading_files <- newIORef (Set.fromList []) - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- STM.newIO :: IO FlagsMap - -- Mapping from a Filepath to its 'hie.yaml' location. - -- Should hold the same Filepaths as 'fileToFlags', otherwise - -- they are inconsistent. So, everywhere you modify 'fileToFlags', - -- you have to modify 'filesMap' as well. - filesMap <- STM.newIO :: IO FilesMap - -- Pending files waiting to be loaded - pendingFileSet <- S.newIO :: IO (S.OrderedSet FilePath) - -- Version of the mappings above - version <- newVar 0 + + -- Initialize SessionState + sessionState <- SessionState + <$> newIORef (Set.fromList []) -- cradle_files + <*> newIORef (Set.fromList []) -- error_loading_files + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> S.newIO -- pendingFileSet + <*> newVar 0 -- version + biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) + -- This caches the mapping from Mod.hs -> hie.yaml cradleLoc <- liftIO $ memoIO $ \v -> do res <- findCradle v @@ -466,7 +582,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras let invalidateShakeCache = do - void $ modifyVar' version succ + void $ incrementVersion sessionState return $ toNoFileKey GhcSessionIO IdeOptions{ optTesting = IdeTesting optTesting @@ -523,7 +639,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do + modifyVar (hscEnvs sessionState) $ \m -> do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv let oldDeps = Map.lookup hieYaml m @@ -594,12 +710,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs - newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map atomically $ do - STM.insert this_flags_map hieYaml fileToFlags - insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete pendingFileSet + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -635,19 +750,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ S.toUnOrderedList pendingFileSet) - errorFiles <- readIORef error_loading_files - old_files <- readIORef cradle_files - -- if the file is in error loading files, we fall back to single loading mode - let extraToLoads = if cfp `Set.member` errorFiles - then Set.empty - -- remove error files from pending files since error loading need to load one by one - else Set.delete cfp $ pendingFiles `Set.difference` errorFiles - + extraToLoads <- getExtraFilesToLoad sessionState cfp eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp extraToLoads addTag "result" (show res) return res @@ -663,51 +770,42 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ((runTime, _):_) | compileTime == runTime -> do (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + pendingFiles <- getPendingFiles sessionState let newLoaded = pendingFiles `Set.intersection` allNewLoaded -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files - atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) - atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) + addCradleFiles sessionState newLoaded restart | otherwise -> do - -- delete cfp from pending files - atomically $ do - STM.focus (Focus.insertOrMerge HM.union - (HM.singleton ncfp (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty))) - hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - S.delete cfp pendingFileSet + -- Use the common pattern here: updateFileState + completeFileProcessing sessionState hieYaml ncfp cfp + (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty) -- Failure case, either a cradle error or the none cradle Left err -> do - let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) - `Set.difference` old_files - if (not $ null attemptToLoadFiles) - + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- readIORef (cradle_files sessionState) + let errorToLoadNewFiles = attemptToLoadFiles `Set.difference` old_files + if not (null errorToLoadNewFiles) then do -- we are loading more files and failed, we need to retry - -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - let failedLoadingFiles = (Set.insert cfp attemptToLoadFiles) - atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) + addErrorLoadingFiles sessionState (Set.toList errorToLoadNewFiles) -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do -- we are only loading this file and it failed - dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) + dep_info <- getDependencyInfo (maybeToList hieYaml ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - -- remove cfp from pending files - atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - atomically $ do - STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - S.delete cfp pendingFileSet + completeFileProcessing sessionState hieYaml ncfp cfp (res, dep_info) let -- | We allow users to specify a loading strategy. @@ -736,40 +834,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ do - STM.reset filesMap - STM.reset fileToFlags + atomically $ resetFileMaps sessionState -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) + modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) -- cleanup error loading files and cradle files - atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) - atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState - v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags - case HM.lookup (toNormalizedFilePath' file) v of + v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - if (not deps_ok) + if not deps_ok then do -- if deps are old, we can try to load the error files again - atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) - atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) + removeErrorLoadingFile sessionState file + removeCradleFile sessionState file -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ do - STM.reset filesMap - STM.reset fileToFlags + atomically $ resetFileMaps sessionState -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) + modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) consultCradle hieYaml file -- if deps are ok, we can just remove the file from pending files - else atomically $ S.delete file pendingFileSet + else atomically $ removeFromPending sessionState file Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) checkInCache ncfp = runMaybeT $ do - cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp filesMap - m <- MaybeT $ STM.lookup cachedHieYamlLocation fileToFlags + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) MaybeT $ pure $ HM.lookup ncfp m -- The main function which gets options for a file. We only want one of these running @@ -779,22 +873,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let getOptions :: FilePath -> IO () getOptions file = do let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap + cachedHieYamlLocation <- atomically $ STM.lookup ncfp (filesMap sessionState) hieYaml <- cradleLoc file let hieLoc = join cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` \e -> do - dep <- getDependencyInfo $ maybe [] pure hieYaml - let errorResult = (([renderPackageSetupException file e], Nothing), dep) - atomically $ do - STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp errorResult)) hieLoc fileToFlags - STM.insert hieYaml ncfp filesMap - -- delete file from pending files - S.delete file pendingFileSet + sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - absFile <- atomically $ S.readQueue pendingFileSet + absFile <- atomically $ S.readQueue (pendingFileSet sessionState) logWith recorder Debug (LogGetOptionsLoop absFile) getOptions absFile getOptionsLoop @@ -808,7 +895,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile res <- atomically $ do -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + Extra.whenM (S.lookup absFile (pendingFileSet sessionState)) STM.retry -- check if in the cache checkInCache ncfp logWith recorder Debug $ LogLookupSessionCache absFile @@ -823,7 +910,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Just r -> return r Nothing -> do -- if not ok, we need to reload the session - atomically $ S.insert absFile pendingFileSet + atomically $ addToPending sessionState absFile lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] From 80d016094abba178ecff317b186bfe3c52517c43 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 27 Apr 2025 22:45:14 +0800 Subject: [PATCH 40/55] update hiebois --- cabal.project | 9 +----- ghcide/ghcide.cabal | 2 +- .../session-loader/Development/IDE/Session.hs | 32 +++++++++++-------- 3 files changed, 21 insertions(+), 22 deletions(-) diff --git a/cabal.project b/cabal.project index e54c7f4bfe..59f565677b 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2025-04-19T07:34:07Z +index-state: 2025-04-26T07:34:07Z tests: True test-show-details: direct @@ -53,13 +53,6 @@ allow-newer: cabal-install-parsers:Cabal-syntax, -source-repository-package - type: git - location: https://github.com/haskell/hie-bios - tag: e372a62b780b1314a35238a698a9e3813096b122 --- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 -allow-older: hie-bios:optparse-applicative - if impl(ghc >= 9.11) benchmarks: False allow-newer: diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0ae7b15ce9..eed0ed5919 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -73,7 +73,7 @@ library , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>=0.14.0 + , hie-bios ^>=0.15.0 , hie-compat ^>=0.3.0.0 , hiedb ^>= 0.6.0.2 , hls-graph == 2.10.0.0 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 76d10c9d66..a153e15119 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -500,6 +500,23 @@ completeFileProcessing state hieYaml ncfp file flags = do insertFileMapping state hieYaml ncfp removeFromPending state file +-- | Handle successful loading by updating session state with the new file maps +updateSessionOnSuccess :: Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> [TargetDetails] -> IO () +updateSessionOnSuccess recorder state hieYaml this_flags_map all_targets = do + let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags state) + insertAllFileMappings state $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet state) + pendingFiles <- getPendingFiles state + let newLoaded = pendingFiles `Set.intersection` newLoaded + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile state) (Set.toList newLoaded) + addCradleFiles state newLoaded + return () + -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -711,11 +728,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) - + updateSessionOnSuccess recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -769,14 +782,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) - pendingFiles <- getPendingFiles sessionState - let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) - addCradleFiles sessionState newLoaded + (_results, _allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) restart | otherwise -> do -- Use the common pattern here: updateFileState From 24269f6e085d1edda2c2d5c3131c3e4282ab760e Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 18:00:58 +0800 Subject: [PATCH 41/55] revert --- .../session-loader/Development/IDE/Session.hs | 32 ++++++++----------- 1 file changed, 13 insertions(+), 19 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a153e15119..76d10c9d66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -500,23 +500,6 @@ completeFileProcessing state hieYaml ncfp file flags = do insertFileMapping state hieYaml ncfp removeFromPending state file --- | Handle successful loading by updating session state with the new file maps -updateSessionOnSuccess :: Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> [TargetDetails] -> IO () -updateSessionOnSuccess recorder state hieYaml this_flags_map all_targets = do - let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags state) - insertAllFileMappings state $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet state) - pendingFiles <- getPendingFiles state - let newLoaded = pendingFiles `Set.intersection` newLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile state) (Set.toList newLoaded) - addCradleFiles state newLoaded - return () - -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -728,7 +711,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - updateSessionOnSuccess recorder sessionState hieYaml this_flags_map all_targets + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -782,7 +769,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, _allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + pendingFiles <- getPendingFiles sessionState + let newLoaded = pendingFiles `Set.intersection` allNewLoaded + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) + addCradleFiles sessionState newLoaded restart | otherwise -> do -- Use the common pattern here: updateFileState From 98999f55b674cfcd5cd649f180f9f45366b8e5dc Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 19:20:10 +0800 Subject: [PATCH 42/55] restart the shake if cabal file changed --- .../session-loader/Development/IDE/Session.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 76d10c9d66..96c1016399 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -840,6 +840,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- cleanup error loading files and cradle files clearErrorLoadingFiles sessionState clearCradleFiles sessionState + cacheKey <- invalidateShakeCache + restartShakeSession VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) case v >>= HM.lookup (toNormalizedFilePath' file) of @@ -870,20 +872,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- 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 () - getOptions file = do - let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- atomically $ STM.lookup ncfp (filesMap sessionState) - hieYaml <- cradleLoc file - let hieLoc = join cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - absFile <- atomically $ S.readQueue (pendingFileSet sessionState) - logWith recorder Debug (LogGetOptionsLoop absFile) - getOptions absFile + file <- atomically $ S.readQueue (pendingFileSet sessionState) + logWith recorder Debug (LogGetOptionsLoop file) + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) + hieYaml <- cradleLoc file + let hieLoc = cachedHieYamlLocation <|> hieYaml + sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From 21dd23314329a989dd5069817c51549a3f761888 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:30:05 +0800 Subject: [PATCH 43/55] better error handling in session loader --- .../session-loader/Development/IDE/Session.hs | 65 +++++++++---------- 1 file changed, 29 insertions(+), 36 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 96c1016399..738af0944a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -489,16 +489,6 @@ addToPending :: SessionState -> FilePath -> STM () addToPending state file = S.insert file (pendingFileSet state) --- | Common pattern: Insert file flags, insert file mapping, and remove from pending -completeFileProcessing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> FilePath -> (IdeResult HscEnvEq, DependencyInfo) -> IO () -completeFileProcessing state hieYaml ncfp file flags = do --- remove cfp from pending files - addErrorLoadingFile state file - removeCradleFile state file - atomically $ do - insertFileFlags state hieYaml ncfp flags - insertFileMapping state hieYaml ncfp - removeFromPending state file -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () @@ -516,10 +506,20 @@ getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pending -- | Handle errors during session loading by recording file as having error and removing from pending handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () handleSessionError state hieYaml file e = do - dep <- getDependencyInfo $ maybe [] pure hieYaml + handleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () +handleFileProcessingError state hieYaml file diags extraDepFiles = do + addErrorLoadingFile state file + removeCradleFile state file + dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file - let errorResult = (([renderPackageSetupException file e], Nothing), dep) - completeFileProcessing state hieYaml ncfp file errorResult + let flags = ((diags, Nothing), dep) + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + removeFromPending state file -- | Get the set of extra files to load based on the current file path -- If the current file is in error loading files, we fallback to single loading mode (empty set) @@ -679,8 +679,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath, IO ()) + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> IO () session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -695,7 +694,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, this_options) + let (all_targets, this_flags_map, _this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) @@ -710,17 +709,24 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + pendingFiles <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendingFiles `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded -- Typecheck all files in the project on startup checkProject <- getCheckProject + -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - let restart = restartShakeSession VFSUnmodified "new component" [] $ do + restartShakeSession VFSUnmodified "new component" [] $ do keys2 <- invalidateShakeCache keys1 <- extendKnownTargets all_targets unless (null new_deps || not checkProject) $ do @@ -734,7 +740,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return (this_options, newLoaded, restart) let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do @@ -759,29 +764,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return res logWith recorder Debug $ LogSessionLoadingResult eopts + let ncfp = toNormalizedFilePath' cfp case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do - let ncfp = toNormalizedFilePath' cfp let compileTime = fullCompilerVersion case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) - | compileTime == runTime -> do - (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) - pendingFiles <- getPendingFiles sessionState - let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) - addCradleFiles sessionState newLoaded - restart + | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) | otherwise -> do -- Use the common pattern here: updateFileState - completeFileProcessing sessionState hieYaml ncfp cfp - (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty) + handleFileProcessingError sessionState hieYaml cfp [renderPackageSetupException cfp GhcVersionMismatch{..}] mempty -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? @@ -802,10 +797,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do consultCradle hieYaml cfp else do -- we are only loading this file and it failed - dep_info <- getDependencyInfo (maybeToList hieYaml ++ concatMap cradleErrorDependencies err) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - completeFileProcessing sessionState hieYaml ncfp cfp (res, dep_info) + let res = map (\err' -> renderCradleError err' cradle ncfp) err + handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err let -- | We allow users to specify a loading strategy. From f140a2afc3a19f1e56babc1dd6e9a4a5b627ea7a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:37:10 +0800 Subject: [PATCH 44/55] refactor error handling in loadSessionWithOptions to improve clarity and logic --- ghcide/session-loader/Development/IDE/Session.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 738af0944a..caa8bec577 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -782,8 +782,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err old_files <- readIORef (cradle_files sessionState) - let errorToLoadNewFiles = attemptToLoadFiles `Set.difference` old_files - if not (null errorToLoadNewFiles) + let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) + if length errorToLoadNewFiles > 1 then do -- we are loading more files and failed, we need to retry -- mark as less loaded files as failedLoadingFiles as possible @@ -791,7 +791,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - addErrorLoadingFiles sessionState (Set.toList errorToLoadNewFiles) + addErrorLoadingFiles sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp From e339c1d3e4869aebd104cc9b0dadb80aba03ae13 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:54:37 +0800 Subject: [PATCH 45/55] refactor SessionState management for improved batch loading logic --- .../session-loader/Development/IDE/Session.hs | 93 ++++++++++++------- 1 file changed, 58 insertions(+), 35 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index caa8bec577..3f20e93fc1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -418,14 +418,33 @@ getHieDbLoc dir = do createDirectoryIfMissing True cDir pure (cDir db) +{- Note [SessionState and batch load] +SessionState manages the state for batch loading files in the session loader. + +- When a new file needs to be loaded, it is added to the pendingFiles set. +- The loader processes files from pendingFiles, attempting to load them in batches. +- If a file is already in failedFiles, it is loaded individually (single-file mode). +- Otherwise, the loader tries to load as many files as possible together (batch mode). + +On success: + - All successfully loaded files are removed from pendingFiles and failedFiles, + and added to loadedFiles. + +On failure: + - If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. + - If batch loading fails, all files attempted are added to failedFiles. + +This approach ensures efficient batch loading while isolating problematic files for individual handling. +-} + data SessionState = SessionState - { cradle_files :: !(IORef (HashSet FilePath)) - , error_loading_files :: !(IORef (HashSet FilePath)) - , hscEnvs :: !(Var HieMap) - , fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))) - , filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)) - , pendingFileSet :: !(S.OrderedSet FilePath) - , version :: !(Var Int) + { loadedFiles :: !(IORef (HashSet FilePath)), + failedFiles :: !(IORef (HashSet FilePath)), + pendingFiles :: !(S.OrderedSet FilePath), + hscEnvs :: !(Var HieMap), + fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))), + filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)), + version :: !(Var Int) } -- | Helper functions for SessionState management @@ -434,7 +453,7 @@ data SessionState = SessionState -- | Add a file to the set of files with errors during loading addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = - atomicModifyIORef' (error_loading_files state) (\xs -> (Set.insert file xs, ())) + atomicModifyIORef' (failedFiles state) (\xs -> (Set.insert file xs, ())) addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () addErrorLoadingFiles = mapM_ . addErrorLoadingFile @@ -442,26 +461,26 @@ addErrorLoadingFiles = mapM_ . addErrorLoadingFile -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = - atomicModifyIORef' (error_loading_files state) (\xs -> (Set.delete file xs, ())) + atomicModifyIORef' (failedFiles state) (\xs -> (Set.delete file xs, ())) addCradleFiles :: SessionState -> HashSet FilePath -> IO () addCradleFiles state files = - atomicModifyIORef' (cradle_files state) (\xs -> (files <> xs, ())) + atomicModifyIORef' (loadedFiles state) (\xs -> (files <> xs, ())) -- | Remove a file from the cradle files set removeCradleFile :: SessionState -> FilePath -> IO () removeCradleFile state file = - atomicModifyIORef' (cradle_files state) (\xs -> (Set.delete file xs, ())) + atomicModifyIORef' (loadedFiles state) (\xs -> (Set.delete file xs, ())) -- | Clear error loading files and reset to empty set clearErrorLoadingFiles :: SessionState -> IO () clearErrorLoadingFiles state = - atomicModifyIORef' (error_loading_files state) (\_ -> (Set.empty, ())) + atomicModifyIORef' (failedFiles state) (\_ -> (Set.empty, ())) -- | Clear cradle files and reset to empty set clearCradleFiles :: SessionState -> IO () clearCradleFiles state = - atomicModifyIORef' (cradle_files state) (\_ -> (Set.empty, ())) + atomicModifyIORef' (loadedFiles state) (\_ -> (Set.empty, ())) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -482,12 +501,12 @@ insertFileMapping state hieYaml ncfp = -- | Remove a file from the pending file set removeFromPending :: SessionState -> FilePath -> STM () removeFromPending state file = - S.delete file (pendingFileSet state) + S.delete file (pendingFiles state) -- | Add a file to the pending file set addToPending :: SessionState -> FilePath -> STM () addToPending state file = - S.insert file (pendingFileSet state) + S.insert file (pendingFiles state) -- | Insert multiple file mappings at once @@ -501,7 +520,7 @@ incrementVersion state = modifyVar' (version state) succ -- | Get files from the pending file set getPendingFiles :: SessionState -> IO (HashSet FilePath) -getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFileSet state) +getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () @@ -527,8 +546,8 @@ handleFileProcessingError state hieYaml file diags extraDepFiles = do getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] getExtraFilesToLoad state cfp = do pendingFiles <- getPendingFiles state - errorFiles <- readIORef (error_loading_files state) - old_files <- readIORef (cradle_files state) + errorFiles <- readIORef (failedFiles state) + old_files <- readIORef (loadedFiles state) -- if the file is in error loading files, we fall back to single loading mode return $ Set.toList $ @@ -537,6 +556,19 @@ getExtraFilesToLoad state cfp = do -- remove error files from pending files since error loading need to load one by one else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files +newSessionState :: IO SessionState +newSessionState = do + -- Initialize SessionState + sessionState <- SessionState + <$> newIORef (Set.fromList []) -- loadedFiles + <*> newIORef (Set.fromList []) -- failedFiles + <*> S.newIO -- pendingFiles + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> newVar 0 -- version + return sessionState + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -555,16 +587,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - -- Initialize SessionState - sessionState <- SessionState - <$> newIORef (Set.fromList []) -- cradle_files - <*> newIORef (Set.fromList []) -- error_loading_files - <*> newVar Map.empty -- hscEnvs - <*> STM.newIO -- fileToFlags - <*> STM.newIO -- filesMap - <*> S.newIO -- pendingFileSet - <*> newVar 0 -- version - + sessionState <- newSessionState biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) @@ -709,13 +732,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - pendingFiles <- getPendingFiles sessionState + pendings <- getPendingFiles sessionState -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendingFiles `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + forM_ newLoaded $ flip S.delete (pendingFiles sessionState) logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files @@ -781,7 +804,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readIORef (cradle_files sessionState) + old_files <- readIORef (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do @@ -789,7 +812,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. - -- but they will still be in the old_files, and will not move to error_loading_files. + -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. addErrorLoadingFiles sessionState errorToLoadNewFiles -- retry without other files @@ -869,7 +892,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - file <- atomically $ S.readQueue (pendingFileSet sessionState) + file <- atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) @@ -887,7 +910,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile res <- atomically $ do -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile (pendingFileSet sessionState)) STM.retry + Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry -- check if in the cache checkInCache ncfp logWith recorder Debug $ LogLookupSessionCache absFile From 1425289cc8fa2ece6b6382e2fb56f76a9eb692d7 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 29 Apr 2025 00:13:18 +0800 Subject: [PATCH 46/55] refactor session loading error handling for improved clarity and separation of concerns --- .../session-loader/Development/IDE/Session.hs | 39 ++++++++++++------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3f20e93fc1..7f10528e86 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -122,7 +122,6 @@ import Control.Concurrent.STM (STM) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus -import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, @@ -423,20 +422,37 @@ SessionState manages the state for batch loading files in the session loader. - When a new file needs to be loaded, it is added to the pendingFiles set. - The loader processes files from pendingFiles, attempting to load them in batches. -- If a file is already in failedFiles, it is loaded individually (single-file mode). -- Otherwise, the loader tries to load as many files as possible together (batch mode). +- (SBL1) If a file is already in failedFiles, it is loaded individually (single-file mode). +- (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode). On success: - - All successfully loaded files are removed from pendingFiles and failedFiles, + - (SBL3) All successfully loaded files are removed from pendingFiles and failedFiles, and added to loadedFiles. On failure: - - If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. - - If batch loading fails, all files attempted are added to failedFiles. + - (SBL4) If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. + - (SBL5) If batch loading fails, all files attempted are added to failedFiles. This approach ensures efficient batch loading while isolating problematic files for individual handling. -} +handleLoadingSucc :: SessionState -> HashSet FilePath -> IO () +handleLoadingSucc sessionState files = do + atomically $ forM_ (Set.toList files) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList files) + addCradleFiles sessionState files + +handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () +handleLoadingFailureBatch sessionState files = do + addErrorLoadingFiles sessionState files + +handleLoadingFailureSingle :: SessionState -> FilePath -> IO () +handleLoadingFailureSingle sessionState file = do + addErrorLoadingFile sessionState file + removeErrorLoadingFile sessionState file + atomically $ S.delete file (pendingFiles sessionState) + removeCradleFile sessionState file + data SessionState = SessionState { loadedFiles :: !(IORef (HashSet FilePath)), failedFiles :: !(IORef (HashSet FilePath)), @@ -530,15 +546,13 @@ handleSessionError state hieYaml file e = do -- | Common pattern: Insert file flags, insert file mapping, and remove from pending handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () handleFileProcessingError state hieYaml file diags extraDepFiles = do - addErrorLoadingFile state file - removeCradleFile state file dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) + handleLoadingFailureSingle state file atomically $ do insertFileFlags state hieYaml ncfp flags insertFileMapping state hieYaml ncfp - removeFromPending state file -- | Get the set of extra files to load based on the current file path -- If the current file is in error loading files, we fallback to single loading mode (empty set) @@ -738,12 +752,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFiles sessionState) logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) - addCradleFiles sessionState newLoaded + handleLoadingSucc sessionState newLoaded -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -814,7 +825,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. - addErrorLoadingFiles sessionState errorToLoadNewFiles + handleLoadingFailureBatch sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp From de6eb9cefebdf27a5487d6251c79b8132a449c79 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 16:39:37 +0800 Subject: [PATCH 47/55] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7f10528e86..483487c552 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -454,13 +454,13 @@ handleLoadingFailureSingle sessionState file = do removeCradleFile sessionState file data SessionState = SessionState - { loadedFiles :: !(IORef (HashSet FilePath)), - failedFiles :: !(IORef (HashSet FilePath)), + { loadedFiles :: !(IORef (HashSet FilePath)), + failedFiles :: !(IORef (HashSet FilePath)), pendingFiles :: !(S.OrderedSet FilePath), - hscEnvs :: !(Var HieMap), - fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))), - filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)), - version :: !(Var Int) + hscEnvs :: !(Var HieMap), + fileToFlags :: !FlagsMap, + filesMap :: !FilesMap, + version :: !(Var Int) } -- | Helper functions for SessionState management From c9926d43536cf576521d19dd86d600427e2e2aba Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 16:56:00 +0800 Subject: [PATCH 48/55] fix --- .../session-loader/Development/IDE/Session.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7b574a492f..597d7cffaf 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -893,13 +893,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do checkInCache ncfp = runMaybeT $ do cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) - -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action - -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. - -- The GlobPattern of a FileSystemWatcher can be absolute or relative. - -- We use the absolute one because it is supported by more LSP clients. - -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern. - let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath deps) - MaybeT $ pure $ absolutePathsCradleDeps <$> HM.lookup ncfp m + MaybeT $ pure $ HM.lookup ncfp m -- 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 @@ -947,9 +941,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop + + -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action + -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. + -- The GlobPattern of a FileSystemWatcher can be absolute or relative. + -- We use the absolute one because it is supported by more LSP clients. + -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern. + let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) returnWithVersion $ \file -> do let absFile = toAbsolutePath file - second Map.keys <$> lookupOrWaitCache absFile + absolutePathsCradleDeps <$> lookupOrWaitCache absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From 48a46d1d084eb295383ebc040a8d68c46556edd9 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 17:27:50 +0800 Subject: [PATCH 49/55] add sessionLoadingPreferenceConfig var to SessionState --- .../session-loader/Development/IDE/Session.hs | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 597d7cffaf..87edfc0513 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -78,7 +78,8 @@ import Ide.Logger (Pretty (pretty), nest, toCologActionWithPrio, vcat, viaShow, (<+>)) -import Ide.Types (SessionLoadingPreferenceConfig (..), +import Ide.Types (Config, + SessionLoadingPreferenceConfig (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -460,7 +461,8 @@ data SessionState = SessionState hscEnvs :: !(Var HieMap), fileToFlags :: !FlagsMap, filesMap :: !FilesMap, - version :: !(Var Int) + version :: !(Var Int), + sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig)) } -- | Helper functions for SessionState management @@ -570,6 +572,24 @@ getExtraFilesToLoad state cfp = do -- remove error files from pending files since error loading need to load one by one else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files +-- | We allow users to specify a loading strategy. +-- Check whether this config was changed since the last time we have loaded +-- a session. +-- +-- If the loading configuration changed, we likely should restart the session +-- in its entirety. +didSessionLoadingPreferenceConfigChange :: SessionState -> Config -> IO Bool +didSessionLoadingPreferenceConfigChange s clientConfig = do + let biosSessionLoadingVar = sessionLoadingPreferenceConfig s + mLoadingConfig <- readVar biosSessionLoadingVar + case mLoadingConfig of + Nothing -> do + writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure False + Just loadingConfig -> do + writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure (loadingConfig /= sessionLoading clientConfig) + newSessionState :: IO SessionState newSessionState = do -- Initialize SessionState @@ -581,6 +601,7 @@ newSessionState = do <*> STM.newIO -- fileToFlags <*> STM.newIO -- filesMap <*> newVar 0 -- version + <*> newVar Nothing -- sessionLoadingPreferenceConfig return sessionState -- | Given a root directory, return a Shake 'Action' which setups an @@ -602,7 +623,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] sessionState <- newSessionState - biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) -- This caches the mapping from Mod.hs -> hie.yaml @@ -833,31 +853,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err - - let - -- | We allow users to specify a loading strategy. - -- Check whether this config was changed since the last time we have loaded - -- a session. - -- - -- If the loading configuration changed, we likely should restart the session - -- in its entirety. - didSessionLoadingPreferenceConfigChange :: IO Bool - didSessionLoadingPreferenceConfigChange = do - mLoadingConfig <- readVar biosSessionLoadingVar - case mLoadingConfig of - Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure False - Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) - -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) -> IO () sessionOpts (hieYaml, file) = do - Extra.whenM didSessionLoadingPreferenceConfigChange $ do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. From 702e36752cd63c91c97d4cffbe3332c11cae9881 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 14 May 2025 18:56:12 +0800 Subject: [PATCH 50/55] refactor SessionState to use Var instead of IORef for loaded and failed files --- .../session-loader/Development/IDE/Session.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 87edfc0513..5d34423c6c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -455,8 +455,8 @@ handleLoadingFailureSingle sessionState file = do removeCradleFile sessionState file data SessionState = SessionState - { loadedFiles :: !(IORef (HashSet FilePath)), - failedFiles :: !(IORef (HashSet FilePath)), + { loadedFiles :: !(Var (HashSet FilePath)), + failedFiles :: !(Var (HashSet FilePath)), pendingFiles :: !(S.OrderedSet FilePath), hscEnvs :: !(Var HieMap), fileToFlags :: !FlagsMap, @@ -471,7 +471,7 @@ data SessionState = SessionState -- | Add a file to the set of files with errors during loading addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = - atomicModifyIORef' (failedFiles state) (\xs -> (Set.insert file xs, ())) + modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () addErrorLoadingFiles = mapM_ . addErrorLoadingFile @@ -479,26 +479,26 @@ addErrorLoadingFiles = mapM_ . addErrorLoadingFile -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = - atomicModifyIORef' (failedFiles state) (\xs -> (Set.delete file xs, ())) + modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) addCradleFiles :: SessionState -> HashSet FilePath -> IO () addCradleFiles state files = - atomicModifyIORef' (loadedFiles state) (\xs -> (files <> xs, ())) + modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) -- | Remove a file from the cradle files set removeCradleFile :: SessionState -> FilePath -> IO () removeCradleFile state file = - atomicModifyIORef' (loadedFiles state) (\xs -> (Set.delete file xs, ())) + modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) -- | Clear error loading files and reset to empty set clearErrorLoadingFiles :: SessionState -> IO () clearErrorLoadingFiles state = - atomicModifyIORef' (failedFiles state) (\_ -> (Set.empty, ())) + modifyVar_' (failedFiles state) (const $ return Set.empty) -- | Clear cradle files and reset to empty set clearCradleFiles :: SessionState -> IO () clearCradleFiles state = - atomicModifyIORef' (loadedFiles state) (\_ -> (Set.empty, ())) + modifyVar_' (loadedFiles state) (const $ return Set.empty) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -562,8 +562,8 @@ handleFileProcessingError state hieYaml file diags extraDepFiles = do getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] getExtraFilesToLoad state cfp = do pendingFiles <- getPendingFiles state - errorFiles <- readIORef (failedFiles state) - old_files <- readIORef (loadedFiles state) + errorFiles <- readVar (failedFiles state) + old_files <- readVar (loadedFiles state) -- if the file is in error loading files, we fall back to single loading mode return $ Set.toList $ @@ -594,8 +594,8 @@ newSessionState :: IO SessionState newSessionState = do -- Initialize SessionState sessionState <- SessionState - <$> newIORef (Set.fromList []) -- loadedFiles - <*> newIORef (Set.fromList []) -- failedFiles + <$> newVar (Set.fromList []) -- loadedFiles + <*> newVar (Set.fromList []) -- failedFiles <*> S.newIO -- pendingFiles <*> newVar Map.empty -- hscEnvs <*> STM.newIO -- fileToFlags @@ -835,7 +835,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readIORef (loadedFiles sessionState) + old_files <- readVar (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do From 09213d333342398b46aba48f12764c05cd490926 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 19 May 2025 22:24:59 +0800 Subject: [PATCH 51/55] simplified --- .../session-loader/Development/IDE/Session.hs | 54 +++++++++---------- 1 file changed, 25 insertions(+), 29 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5d34423c6c..42290e87e5 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -437,16 +437,26 @@ On failure: This approach ensures efficient batch loading while isolating problematic files for individual handling. -} -handleLoadingSucc :: SessionState -> HashSet FilePath -> IO () -handleLoadingSucc sessionState files = do - atomically $ forM_ (Set.toList files) $ flip S.delete (pendingFiles sessionState) - mapM_ (removeErrorLoadingFile sessionState) (Set.toList files) - addCradleFiles sessionState files +-- SBL3 +handleLoadingSuccBatch :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets = do + pendings <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded +-- SBL5 handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () handleLoadingFailureBatch sessionState files = do - addErrorLoadingFiles sessionState files + mapM_ (addErrorLoadingFile sessionState) files +-- SBL4 handleLoadingFailureSingle :: SessionState -> FilePath -> IO () handleLoadingFailureSingle sessionState file = do addErrorLoadingFile sessionState file @@ -473,9 +483,6 @@ addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) -addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () -addErrorLoadingFiles = mapM_ . addErrorLoadingFile - -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = @@ -526,7 +533,6 @@ addToPending :: SessionState -> FilePath -> STM () addToPending state file = S.insert file (pendingFiles state) - -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -541,13 +547,13 @@ getPendingFiles :: SessionState -> IO (HashSet FilePath) getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending -handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () -handleSessionError state hieYaml file e = do - handleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty +handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSingleFileProcessingError' state hieYaml file e = do + handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty -- | Common pattern: Insert file flags, insert file mapping, and remove from pending -handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () -handleFileProcessingError state hieYaml file diags extraDepFiles = do +handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () +handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) @@ -766,15 +772,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - pendings <- getPendingFiles sessionState - -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - handleLoadingSucc sessionState newLoaded + handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -828,9 +826,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) - | otherwise -> do - -- Use the common pattern here: updateFileState - handleFileProcessingError sessionState hieYaml cfp [renderPackageSetupException cfp GhcVersionMismatch{..}] mempty + | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? @@ -852,7 +848,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do else do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err - handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err + handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) @@ -909,7 +905,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) hieYaml <- cradleLoc file let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file + sessionOpts (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From f768db08e2b737604bc72b854602a0ec244ce85d Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 21 Jun 2025 13:06:55 +0200 Subject: [PATCH 52/55] Extract top-level functions for session initialisation The session initialisation has too many implicit dependencies. To break these apart, we extract local functions and turn them into top-level definition with all parameters explicitly given. This commit only makes sure session initialisation functions are promoted to top-level definitions and tries to simplify them. The top-level definitions are lacking type signatures to make it easier to change them, but we plan to add them back. --- .../session-loader/Development/IDE/Session.hs | 641 +++++++++--------- 1 file changed, 333 insertions(+), 308 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6060f5ca05..045bdcbc54 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -27,7 +27,7 @@ import Control.Monad.Extra as Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Key) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -59,7 +59,7 @@ import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util -import Development.IDE.Graph (Action) +import Development.IDE.Graph (Action, Key) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -438,27 +438,27 @@ This approach ensures efficient batch loading while isolating problematic files -} -- SBL3 -handleLoadingSuccBatch :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () -handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets = do - pendings <- getPendingFiles sessionState - -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) - mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) - addCradleFiles sessionState newLoaded +handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets = do + pendings <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded -- SBL5 -handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () -handleLoadingFailureBatch sessionState files = do +handleBatchLoadFailure :: SessionState -> [FilePath] -> IO () +handleBatchLoadFailure sessionState files = do mapM_ (addErrorLoadingFile sessionState) files -- SBL4 -handleLoadingFailureSingle :: SessionState -> FilePath -> IO () -handleLoadingFailureSingle sessionState file = do +handleSingleLoadFailure :: SessionState -> FilePath -> IO () +handleSingleLoadFailure sessionState file = do addErrorLoadingFile sessionState file removeErrorLoadingFile sessionState file atomically $ S.delete file (pendingFiles sessionState) @@ -557,7 +557,7 @@ handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) - handleLoadingFailureSingle state file + handleSingleLoadFailure state file atomically $ do insertFileFlags state hieYaml ncfp flags insertFileMapping state hieYaml ncfp @@ -642,302 +642,29 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return $ do clientConfig <- getClientConfigAction - extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv + extras@ShakeExtras{ideNc, knownTargetsVar } <- getShakeExtras let invalidateShakeCache = do void $ incrementVersion sessionState return $ toNoFileKey GhcSessionIO - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optExtensions - } <- getIdeOptions - - -- populate the knownTargetsVar with all the - -- files in the project so that `knownFiles` can learn about them and - -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> - case targetTarget of - TargetFile f -> do - -- If a target file has multiple possible locations, then we - -- assume they are all separate file targets. - -- This happens with '.hs-boot' files if they are in the root directory of the project. - -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. - -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the - -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. - -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either - -- - -- * TargetFile Foo.hs-boot - -- * TargetModule Foo - -- - -- If we don't generate a TargetFile for each potential location, we will only have - -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' - -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) - TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return [(targetTarget, Set.fromList found)] - hasUpdate <- atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - pure hasUpdate - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) - return $ toNoFileKey GetKnownTargets - - -- Create a new HscEnv from a hieYaml root and a set of options - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ([ComponentInfo], [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do - -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar (hscEnvs sessionState) $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - _inplace = map rawComponentUnitId $ NE.toList all_deps - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let cacheDirOpts = componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> IO () - session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- packageSetup args - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - -- For GHC's supporting multi component sessions, we create a shared - -- HscEnv but set the active component accordingly - hscEnv <- emptyHscEnv ideNc _libDir - let new_cache = newComponentCache recorder optExtensions _cfp hscEnv - all_target_details <- new_cache old_deps new_deps - - let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - all_targets' = concat all_target_details - this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, _this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - (T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ]) - Nothing - - handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - - -- The VFS doesn't change on cradle edits, re-use the old one. - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - restartShakeSession VFSUnmodified "new component" [] $ do - keys2 <- invalidateShakeCache - keys1 <- extendKnownTargets all_targets - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - 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 - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return [keys1, keys2] - - let consultCradle :: Maybe FilePath -> FilePath -> IO () - consultCradle hieYaml cfp = do - let lfpLog = makeRelative rootDir cfp - logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ - logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir - when optTesting $ mRunLspT lspEnv $ - sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) - - -- Display a user friendly progress message here: They probably don't know what a cradle is - let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfpLog <> ")" - - extraToLoads <- getExtraFilesToLoad sessionState cfp - eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ - withTrace "Load cradle" $ \addTag -> do - addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp extraToLoads - addTag "result" (show res) - return res - - logWith recorder Debug $ LogSessionLoadingResult eopts - let ncfp = toNormalizedFilePath' cfp - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir, version) -> do - let compileTime = fullCompilerVersion - case reverse $ readP_to_S parseVersion version of - [] -> error $ "GHC version could not be parsed: " <> version - ((runTime, _):_) - | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) - | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) - -- Failure case, either a cradle error or the none cradle - Left err -> do - -- what if the error to load file is one of old_files ? - let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readVar (loadedFiles sessionState) - let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) - if length errorToLoadNewFiles > 1 - then do - -- we are loading more files and failed, we need to retry - -- mark as less loaded files as failedLoadingFiles as possible - -- limitation is that when we are loading files, and the dependencies of old_files - -- are changed, and old_files are not valid anymore. - -- but they will still be in the old_files, and will not move to failedFiles. - -- And make other files failed to load in batch mode. - handleLoadingFailureBatch sessionState errorToLoadNewFiles - -- retry without other files - logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) - consultCradle hieYaml cfp - else do - -- we are only loading this file and it failed - let res = map (\err' -> renderCradleError err' cradle ncfp) err - handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) - -> IO () - sessionOpts (hieYaml, file) = do - Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do - logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState - -- Don't even keep the name cache, we start from scratch here! - modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) - -- cleanup error loading files and cradle files - clearErrorLoadingFiles sessionState - clearCradleFiles sessionState - cacheKey <- invalidateShakeCache - restartShakeSession VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) - - v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) - case v >>= HM.lookup (toNormalizedFilePath' file) of - Just (_opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- if deps are old, we can try to load the error files again - removeErrorLoadingFile sessionState file - removeCradleFile sessionState file - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState - -- Keep the same name cache - modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) - consultCradle hieYaml file - -- if deps are ok, we can just remove the file from pending files - else atomically $ removeFromPending sessionState file - Nothing -> consultCradle hieYaml file - - let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) - checkInCache ncfp = runMaybeT $ do - cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) - m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) - MaybeT $ pure $ HM.lookup ncfp m - - -- 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 getOptionsLoop :: IO () - getOptionsLoop = do - -- Get the next file to load - file <- atomically $ S.readQueue (pendingFiles sessionState) - logWith recorder Debug (LogGetOptionsLoop file) - let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) - hieYaml <- cradleLoc file - let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file - getOptionsLoop - - -- | Given a file, this function will return the HscEnv and the dependencies - -- it would look up the cache first, if the cache is not available, it would - -- submit a request to the getOptionsLoop to get the options for the file - -- and wait until the options are available - let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) - lookupOrWaitCache absFile = do - let ncfp = toNormalizedFilePath' absFile - res <- atomically $ do - -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry - -- check if in the cache - checkInCache ncfp - logWith recorder Debug $ LogLookupSessionCache absFile - updateDateRes <- case res of - Just r -> do - depOk <- checkDependencyInfo (snd r) - if depOk - then return $ Just r - else return Nothing - _ -> return Nothing - case updateDateRes of - Just r -> return r - Nothing -> do - -- if not ok, we need to reload the session - atomically $ addToPending sessionState absFile - lookupOrWaitCache absFile + ideOptions <- getIdeOptions -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty - liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ do + let newSessionLoadingOptions = SessionLoadingOptions + { findCradle = cradleLoc + , .. + } + sessionShake = SessionShake + { restartSession = restartShakeSession extras + , invalidateCache = invalidateShakeCache + , enqueueActions = shakeEnqueue extras + , lspContext = lspEnv extras + } + + writeTQueue que (getOptionsLoop recorder sessionShake sessionState newSessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc) -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. @@ -947,7 +674,305 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) returnWithVersion $ \file -> do let absFile = toAbsolutePath file - absolutePathsCradleDeps <$> lookupOrWaitCache absFile + absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile + +-- | Given a file, this function will return the HscEnv and the dependencies +-- it would look up the cache first, if the cache is not available, it would +-- submit a request to the getOptionsLoop to get the options for the file +-- and wait until the options are available +lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) +lookupOrWaitCache recorder sessionState absFile = do + let ncfp = toNormalizedFilePath' absFile + res <- atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry + -- check if in the cache + checkInCache sessionState ncfp + logWith recorder Debug $ LogLookupSessionCache absFile + updateDateRes <- case res of + Just r -> do + depOk <- checkDependencyInfo (snd r) + if depOk + then return $ Just r + else return Nothing + _ -> return Nothing + case updateDateRes of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ addToPending sessionState absFile + lookupOrWaitCache recorder sessionState absFile + +checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) +checkInCache sessionState ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) + MaybeT $ pure $ HM.lookup ncfp m + +data SessionShake = SessionShake + { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () + , invalidateCache :: IO Key + , enqueueActions :: DelayedAction () -> IO (IO ()) + , lspContext :: Maybe (LanguageContextEnv Config) + } + +-- 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. +getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc = do + -- Get the next file to load + file <- atomically $ S.readQueue (pendingFiles sessionState) + logWith recorder Debug (LogGetOptionsLoop file) + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) + hieYaml <- findCradle sessionLoadingOptions file + let hieLoc = cachedHieYamlLocation <|> hieYaml + sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieLoc, file) + `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file + getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc + +-- | This caches the mapping from hie.yaml + Mod.hs -> [String] +-- Returns the Ghc session and the cradle dependencies +sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieYaml, file) = do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do + logWith recorder Info LogSessionLoadingChanged + -- If the dependencies are out of date then clear both caches and start + -- again. + atomically $ resetFileMaps sessionState + -- Don't even keep the name cache, we start from scratch here! + modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + -- cleanup error loading files and cradle files + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState + cacheKey <- invalidateCache sessionShake + restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) + + v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of + Just (_opts, old_di) -> do + deps_ok <- checkDependencyInfo old_di + if not deps_ok + then do + -- if deps are old, we can try to load the error files again + removeErrorLoadingFile sessionState file + removeCradleFile sessionState file + -- If the dependencies are out of date then clear both caches and start + -- again. + atomically $ resetFileMaps sessionState + -- Keep the same name cache + modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + -- if deps are ok, we can just remove the file from pending files + else atomically $ removeFromPending sessionState file + Nothing -> consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + +consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp = do + (cradle, eopts) <- loadCradleWithNotifications recorder (optTesting ideOptions) + (lspContext sessionShake) sessionState (sessionLoading clientConfig) + (loadCradle sessionLoadingOptions) + rootDir hieYaml cfp + logWith recorder Debug $ LogSessionLoadingResult eopts + let ncfp = toNormalizedFilePath' cfp + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir, version) -> do + let compileTime = fullCompilerVersion + case reverse $ readP_to_S parseVersion version of + [] -> error $ "GHC version could not be parsed: " <> version + ((runTime, _):_) + | compileTime == runTime -> session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, ncfp, opts, libDir) + | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) + -- Failure case, either a cradle error or the none cradle + Left err -> do + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- readVar (loadedFiles sessionState) + let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) + if length errorToLoadNewFiles > 1 + then do + -- we are loading more files and failed, we need to retry + -- mark as less loaded files as failedLoadingFiles as possible + -- limitation is that when we are loading files, and the dependencies of old_files + -- are changed, and old_files are not valid anymore. + -- but they will still be in the old_files, and will not move to failedFiles. + -- And make other files failed to load in batch mode. + handleBatchLoadFailure sessionState errorToLoadNewFiles + -- retry without other files + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) + consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp + else do + -- we are only loading this file and it failed + let res = map (\err' -> renderCradleError err' cradle ncfp) err + handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err + +session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, cfp, opts, libDir) = do + let initEmptyHscEnv = emptyHscEnv ideNc libDir + (new_deps, old_deps) <- packageSetup recorder sessionState rootDir (getCacheDirs sessionLoadingOptions) initEmptyHscEnv (hieYaml, cfp, opts) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- For GHC's supporting multi component sessions, we create a shared + -- HscEnv but set the active component accordingly + hscEnv <- initEmptyHscEnv + let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv + all_target_details <- new_cache old_deps new_deps + (all_targets, this_flags_map) <- addErrorTargetIfUnknown all_target_details hieYaml cfp + + handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + -- Typecheck all files in the project on startup + loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets + +-- | Create a new HscEnv from a hieYaml root and a set of options +packageSetup recorder sessionState rootDir getCacheDirs newEmptyHscEnv (hieYaml, cfp, opts) = do + -- Parse DynFlags for the newly discovered component + hscEnv <- newEmptyHscEnv + newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + let deps = componentDependencies opts ++ maybeToList hieYaml + dep_info <- getDependencyInfo deps + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar (hscEnvs sessionState) $ + addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) + +addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let cacheDirOpts = componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + +addErrorTargetIfUnknown all_target_details hieYaml cfp = do + let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + all_targets' = concat all_target_details + this_dep_info <- getDependencyInfo $ maybeToList hieYaml + let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of + Just _ -> (all_targets', flags_map') + Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map') + where + this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing + pure (all_targets, this_flags_map) + +-- | Populate the knownTargetsVar with all the +-- files in the project so that `knownFiles` can learn about them and +-- we can generate a complete module graph +extendKnownTargets recorder knownTargetsVar newTargets = do + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> do + -- If a target file has multiple possible locations, then we + -- assume they are all separate file targets. + -- This happens with '.hs-boot' files if they are in the root directory of the project. + -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. + -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the + -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. + -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either + -- + -- * TargetFile Foo.hs-boot + -- * TargetModule Foo + -- + -- If we don't generate a TargetFile for each potential location, we will only have + -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' + -- and also not find 'TargetModule Foo'. + fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + TargetModule _ -> do + found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return [(targetTarget, Set.fromList found)] + hasUpdate <- atomically $ do + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + pure hasUpdate + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + return $ toNoFileKey GetKnownTargets + +loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps targets = do + checkProject <- getCheckProject + + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + restartSession sessionShake VFSUnmodified "new component" [] $ do + keys2 <- invalidateCache sessionShake + keys1 <- extendKnownTargets recorder knownTargetsVar targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations targets) + void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] + +loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState sessionPref loadCradle rootDir hieYaml cfp= do + let lfpLog = makeRelative rootDir cfp + logWith recorder Info $ LogCradlePath lfpLog + when (isNothing hieYaml) $ + logWith recorder Warning $ LogCradleNotFound lfpLog + cradle <- loadCradle recorder hieYaml rootDir + when (isTesting) $ mRunLspT lspEnv $ + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) + + -- Display a user friendly progress message here: They probably don't know what a cradle is + let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) + <> " (for " <> T.pack lfpLog <> ")" + + extraToLoads <- getExtraFilesToLoad sessionState cfp + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + withTrace "Load cradle" $ \addTag -> do + addTag "file" lfpLog + res <- cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads + addTag "result" (show res) + return res + pure (cradle, eopts) + -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From d4fbc2c339e16b60df12788b2d272bd0884640ff Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 18:42:25 +0200 Subject: [PATCH 53/55] Remove unused _removeInplacePackages function --- .../session-loader/Development/IDE/Session.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 045bdcbc54..f6ebe43481 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1324,24 +1324,6 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -_removeInplacePackages --Only used in ghc < 9.4 - :: UnitId -- ^ fake uid to use for our internal component - -> [UnitId] - -> DynFlags - -> (DynFlags, [UnitId]) -_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ - df { packageFlags = ps }, uids) - where - (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) - -- | Memoize an IO function, with the characteristics: -- -- * If multiple people ask for a result simultaneously, make sure you only compute it once. From ff807c335960be11df8c8d08271a2c6e73c628c1 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 19:37:36 +0200 Subject: [PATCH 54/55] Introduce SessionM for bundling read-only variables --- .../session-loader/Development/IDE/Session.hs | 207 +++++++++++------- 1 file changed, 131 insertions(+), 76 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f6ebe43481..abeb9cb5d1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -28,7 +28,6 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H import Data.Aeson hiding (Error, Key) -import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B import Data.Default @@ -36,7 +35,6 @@ import Data.Either.Extra import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM -import Data.IORef import Data.List import Data.List.Extra as L import Data.List.NonEmpty (NonEmpty (..)) @@ -119,7 +117,7 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) -import Control.Concurrent.STM (STM) +import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus @@ -129,6 +127,7 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State import qualified StmContainers.Map as STM +import Control.Monad.Trans.Reader #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) @@ -479,33 +478,33 @@ data SessionState = SessionState -- These functions encapsulate common operations on the SessionState -- | Add a file to the set of files with errors during loading -addErrorLoadingFile :: SessionState -> FilePath -> IO () +addErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () addErrorLoadingFile state file = - modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) -- | Remove a file from the set of files with errors during loading -removeErrorLoadingFile :: SessionState -> FilePath -> IO () +removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () removeErrorLoadingFile state file = - modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) -addCradleFiles :: SessionState -> HashSet FilePath -> IO () +addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m () addCradleFiles state files = - modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) -- | Remove a file from the cradle files set -removeCradleFile :: SessionState -> FilePath -> IO () +removeCradleFile :: MonadIO m => SessionState -> FilePath -> m () removeCradleFile state file = - modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) -- | Clear error loading files and reset to empty set -clearErrorLoadingFiles :: SessionState -> IO () +clearErrorLoadingFiles :: MonadIO m => SessionState -> m () clearErrorLoadingFiles state = - modifyVar_' (failedFiles state) (const $ return Set.empty) + liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty) -- | Clear cradle files and reset to empty set -clearCradleFiles :: SessionState -> IO () +clearCradleFiles :: MonadIO m => SessionState -> m () clearCradleFiles state = - modifyVar_' (loadedFiles state) (const $ return Set.empty) + liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -547,13 +546,13 @@ getPendingFiles :: SessionState -> IO (HashSet FilePath) getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending -handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM () handleSingleFileProcessingError' state hieYaml file e = do handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty -- | Common pattern: Insert file flags, insert file mapping, and remove from pending -handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () -handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do +handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM () +handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) @@ -584,16 +583,17 @@ getExtraFilesToLoad state cfp = do -- -- If the loading configuration changed, we likely should restart the session -- in its entirety. -didSessionLoadingPreferenceConfigChange :: SessionState -> Config -> IO Bool -didSessionLoadingPreferenceConfigChange s clientConfig = do +didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool +didSessionLoadingPreferenceConfigChange s = do + clientConfig <- asks sessionClientConfig let biosSessionLoadingVar = sessionLoadingPreferenceConfig s - mLoadingConfig <- readVar biosSessionLoadingVar + mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar case mLoadingConfig of Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure False Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure (loadingConfig /= sessionLoading clientConfig) newSessionState :: IO SessionState @@ -661,10 +661,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do { restartSession = restartShakeSession extras , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras - , lspContext = lspEnv extras + } + sessionEnv = SessionEnv + { sessionLspContext = lspEnv extras + , sessionRootDir = rootDir + , sessionIdeOptions = ideOptions + , sessionClientConfig = clientConfig + , sessionSharedNameCache = ideNc + , sessionLoadingOptions = newSessionLoadingOptions } - writeTQueue que (getOptionsLoop recorder sessionShake sessionState newSessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc) + writeTQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. @@ -713,45 +720,55 @@ data SessionShake = SessionShake { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () , invalidateCache :: IO Key , enqueueActions :: DelayedAction () -> IO (IO ()) - , lspContext :: Maybe (LanguageContextEnv Config) } --- The main function which gets options for a file. We only want one of these running +data SessionEnv = SessionEnv + { sessionLspContext :: Maybe (LanguageContextEnv Config) + , sessionRootDir :: FilePath + , sessionIdeOptions :: IdeOptions + , sessionClientConfig :: Config + , sessionSharedNameCache :: NameCache + , sessionLoadingOptions :: SessionLoadingOptions + } + +type SessionM = ReaderT SessionEnv IO + +-- | 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. -getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc = do +getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM () +getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do + sessionLoadingOptions <- asks sessionLoadingOptions -- Get the next file to load - file <- atomically $ S.readQueue (pendingFiles sessionState) + file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) - hieYaml <- findCradle sessionLoadingOptions file + cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp (filesMap sessionState))) + hieYaml <- liftIO $ findCradle sessionLoadingOptions file let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieLoc, file) + sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file - getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc -- | This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies -sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieYaml, file) = do - Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do +sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM () +sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState + liftIO $ atomically $ resetFileMaps sessionState -- Don't even keep the name cache, we start from scratch here! - modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) -- cleanup error loading files and cradle files clearErrorLoadingFiles sessionState clearCradleFiles sessionState - cacheKey <- invalidateCache sessionShake - restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) + cacheKey <- liftIO $ invalidateCache sessionShake + liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) - v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState) case v >>= HM.lookup (toNormalizedFilePath' file) of Just (_opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di + deps_ok <- liftIO $ checkDependencyInfo old_di if not deps_ok then do -- if deps are old, we can try to load the error files again @@ -759,19 +776,22 @@ sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions removeCradleFile sessionState file -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ resetFileMaps sessionState + liftIO $ atomically $ resetFileMaps sessionState -- Keep the same name cache - modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) - consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file -- if deps are ok, we can just remove the file from pending files - else atomically $ removeFromPending sessionState file - Nothing -> consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file - -consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp = do - (cradle, eopts) <- loadCradleWithNotifications recorder (optTesting ideOptions) - (lspContext sessionShake) sessionState (sessionLoading clientConfig) - (loadCradle sessionLoadingOptions) - rootDir hieYaml cfp + else liftIO $ atomically $ removeFromPending sessionState file + Nothing -> + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file + +consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM () +consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do + loadingOptions <- asks sessionLoadingOptions + (cradle, eopts) <- loadCradleWithNotifications recorder + sessionState + (loadCradle loadingOptions recorder) + hieYaml cfp logWith recorder Debug $ LogSessionLoadingResult eopts let ncfp = toNormalizedFilePath' cfp case eopts of @@ -782,13 +802,13 @@ consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOption case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) - | compileTime == runTime -> session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, ncfp, opts, libDir) + | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir) | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readVar (loadedFiles sessionState) + old_files <- liftIO $ readVar (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do @@ -798,46 +818,66 @@ consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOption -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. - handleBatchLoadFailure sessionState errorToLoadNewFiles + liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) - consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp else do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err -session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, cfp, opts, libDir) = do - let initEmptyHscEnv = emptyHscEnv ideNc libDir - (new_deps, old_deps) <- packageSetup recorder sessionState rootDir (getCacheDirs sessionLoadingOptions) initEmptyHscEnv (hieYaml, cfp, opts) +session :: + Recorder (WithPriority Log) -> + SessionShake -> + SessionState -> + TVar (Hashed KnownTargets) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> + SessionM () +session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do + let initEmptyHscEnv = emptyHscEnv libDir + (new_deps, old_deps) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) -- For each component, now make a new HscEnvEq which contains the -- HscEnv for the hie.yaml file but the DynFlags for that component -- For GHC's supporting multi component sessions, we create a shared -- HscEnv but set the active component accordingly hscEnv <- initEmptyHscEnv + ideOptions <- asks sessionIdeOptions let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv - all_target_details <- new_cache old_deps new_deps - (all_targets, this_flags_map) <- addErrorTargetIfUnknown all_target_details hieYaml cfp + all_target_details <- liftIO $ new_cache old_deps new_deps + (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp - handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + liftIO $ handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup - loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets + liftIO $ loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets -- | Create a new HscEnv from a hieYaml root and a set of options -packageSetup recorder sessionState rootDir getCacheDirs newEmptyHscEnv (hieYaml, cfp, opts) = do +packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) +packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do + getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions) + rootDir <- asks sessionRootDir -- Parse DynFlags for the newly discovered component hscEnv <- newEmptyHscEnv - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps + dep_info <- liftIO $ getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - modifyVar (hscEnvs sessionState) $ + liftIO $ modifyVar (hscEnvs sessionState) $ addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) +addComponentInfo :: + MonadUnliftIO m => + Recorder (WithPriority Log) -> + (String -> [String] -> IO CacheDirs) -> + DependencyInfo -> + NonEmpty (DynFlags, [GHC.Target]) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + Map.Map (Maybe FilePath) [RawComponentInfo] -> + m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv @@ -876,6 +916,7 @@ addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) let (new,old) = NE.splitAt (NE.length new_deps) all_deps' pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) +addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details @@ -898,6 +939,7 @@ addErrorTargetIfUnknown all_target_details hieYaml cfp = do -- | Populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph +extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key extendKnownTargets recorder knownTargetsVar newTargets = do knownTargets <- concatForM newTargets $ \TargetDetails{..} -> case targetTarget of @@ -931,6 +973,7 @@ extendKnownTargets recorder knownTargetsVar newTargets = do logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) return $ toNoFileKey GetKnownTargets +loadKnownTargets :: Recorder (WithPriority Log) -> SessionShake -> IO Bool -> TVar (Hashed KnownTargets) -> [ComponentInfo] -> [TargetDetails] -> IO () loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps targets = do checkProject <- getCheckProject @@ -951,12 +994,23 @@ loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] -loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState sessionPref loadCradle rootDir hieYaml cfp= do +loadCradleWithNotifications :: + Recorder (WithPriority Log) -> + SessionState -> + (Maybe FilePath -> FilePath -> IO (Cradle Void)) -> + Maybe FilePath -> + FilePath -> + SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String)) +loadCradleWithNotifications recorder sessionState loadCradle hieYaml cfp = do + IdeTesting isTesting <- asks (optTesting . sessionIdeOptions) + sessionPref <- asks (sessionLoading . sessionClientConfig) + lspEnv <- asks sessionLspContext + rootDir <- asks sessionRootDir let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir + cradle <- liftIO $ loadCradle hieYaml rootDir when (isTesting) $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) @@ -964,11 +1018,11 @@ loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - extraToLoads <- getExtraFilesToLoad sessionState cfp + extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads + res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads addTag "result" (show res) return res pure (cradle, eopts) @@ -1008,11 +1062,12 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do PreferSingleComponentLoading -> LoadFile PreferMultiComponentLoading -> LoadWithContext old_fps -emptyHscEnv :: NameCache -> FilePath -> IO HscEnv -emptyHscEnv nc libDir = do +emptyHscEnv :: FilePath -> SessionM HscEnv +emptyHscEnv libDir = do + nc <- asks sessionSharedNameCache -- We call setSessionDynFlags so that the loader is initialised -- We need to do this before we call initUnits. - env <- runGhc (Just libDir) $ + env <- liftIO $ runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) From 1aa1e2c55b621e8edad45baf4dfc0ebe1124005e Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 20:10:33 +0200 Subject: [PATCH 55/55] Extract ghc specific functions into separate module --- ghcide/ghcide.cabal | 2 + .../session-loader/Development/IDE/Session.hs | 541 +----------------- .../Development/IDE/Session/Dependency.hs | 35 ++ .../Development/IDE/Session/Ghc.hs | 522 +++++++++++++++++ 4 files changed, 587 insertions(+), 513 deletions(-) create mode 100644 ghcide/session-loader/Development/IDE/Session/Dependency.hs create mode 100644 ghcide/session-loader/Development/IDE/Session/Ghc.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8218883077..dead03f36c 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -180,7 +180,9 @@ library Development.IDE.Plugin.Test Development.IDE.Plugin.TypeLenses Development.IDE.Session + Development.IDE.Session.Dependency Development.IDE.Session.Diagnostics + Development.IDE.Session.Ghc Development.IDE.Session.Implicit Development.IDE.Spans.AtPoint Development.IDE.Spans.Common diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index abeb9cb5d1..996f757303 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-| @@ -31,40 +30,31 @@ import Data.Aeson hiding (Error, Key) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B import Data.Default -import Data.Either.Extra -import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM import Data.List import Data.List.Extra as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy import qualified Data.Text as T -import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Compat.CmdLine import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, Var, Warning, getOptions) -import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) -import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util import Development.IDE.Graph (Action, Key) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) +import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.ResponseFile import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) @@ -92,24 +82,20 @@ import Data.Void import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) import Control.Concurrent.STM.TQueue -import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (ContT (ContT, runContT)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Core.WorkerThread (withWorkerQueue) -import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) +import Development.IDE.Session.Dependency +import Development.IDE.Session.Ghc hiding (Log) import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..), toNoFileKey) -import GHC.Data.Graph.Directed import HieDb.Create import HieDb.Types import Ide.PluginUtils (toAbsolute) @@ -121,17 +107,9 @@ import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus -import GHC.Driver.Env (hsc_all_home_unit_ids) -import GHC.Driver.Errors.Types -import GHC.Types.Error (errMsgDiagnostic, - singleMessage) -import GHC.Unit.State import qualified StmContainers.Map as STM import Control.Monad.Trans.Reader - -#if MIN_VERSION_ghc(9,13,0) -import GHC.Driver.Make (checkHomeUnitsClosed) -#endif +import qualified Development.IDE.Session.Ghc as Ghc data Log = LogSettingInitialDynFlags @@ -141,16 +119,12 @@ data Log | LogHieDbRetriesExhausted !Int !Int !Int !SomeException | LogHieDbWriterThreadSQLiteError !SQLError | LogHieDbWriterThreadException !SomeException - | LogInterfaceFilesCacheDir !FilePath | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) - | LogMakingNewHscEnv ![UnitId] - | LogDLLLoadError !String | LogCradlePath !FilePath | LogCradleNotFound !FilePath | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) | LogCradle !(Cradle Void) | LogNoneCradleFound FilePath - | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] @@ -158,6 +132,7 @@ data Log | LogGetOptionsLoop !FilePath | LogLookupSessionCache !FilePath | LogTime !String + | LogSessionGhc Ghc.Log deriving instance Show Log instance Pretty Log where @@ -209,18 +184,12 @@ instance Pretty Log where vcat [ "HieDb writer thread exception:" , pretty (displayException e) ] - LogInterfaceFilesCacheDir path -> - "Interface files cache directory:" <+> pretty path LogKnownFilesUpdated targetToPathsMap -> nest 2 $ vcat [ "Known files updated:" , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap ] - LogMakingNewHscEnv inPlaceUnitIds -> - "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) - LogDLLLoadError errorString -> - "Error dynamically loading libm.so.6:" <+> pretty errorString LogCradlePath path -> "Cradle path:" <+> pretty path LogCradleNotFound path -> @@ -232,9 +201,8 @@ instance Pretty Log where "Session loading result:" <+> viaShow e LogCradle cradle -> "Cradle:" <+> viaShow cradle - LogNewComponentCache componentCache -> - "New component cache HscEnvEq:" <+> viaShow componentCache LogHieBios msg -> pretty msg + LogSessionGhc msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." @@ -242,9 +210,6 @@ instance Pretty Log where hiedbDataVersion :: String hiedbDataVersion = "1" -data CacheDirs = CacheDirs - { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} - data SessionLoadingOptions = SessionLoadingOptions { findCradle :: FilePath -> IO (Maybe FilePath) -- | Load the cradle with an optional 'hie.yaml' location. @@ -733,18 +698,22 @@ data SessionEnv = SessionEnv type SessionM = ReaderT SessionEnv IO --- | 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. +-- | The main function which gets options for a file. +-- +-- The general approach is as follows: +-- 1. Find the 'hie.yaml' for the next file target, if there is any. +-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before +-- 3.1. If it wasn't, initialise a new session and continue with step 4. +-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified +-- 3.2.1. If we need to reload, remove the getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM () getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do - sessionLoadingOptions <- asks sessionLoadingOptions -- Get the next file to load file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp (filesMap sessionState))) + sessionLoadingOptions <- asks sessionLoadingOptions hieYaml <- liftIO $ findCradle sessionLoadingOptions file let hieLoc = cachedHieYamlLocation <|> hieYaml sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file) @@ -780,8 +749,9 @@ sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = -- Keep the same name cache liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file - -- if deps are ok, we can just remove the file from pending files - else liftIO $ atomically $ removeFromPending sessionState file + else do + -- if deps are ok, we can just remove the file from pending files + liftIO $ atomically $ removeFromPending sessionState file Nothing -> consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file @@ -835,7 +805,7 @@ session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> SessionM () session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do - let initEmptyHscEnv = emptyHscEnv libDir + let initEmptyHscEnv = emptyHscEnvM libDir (new_deps, old_deps) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) -- For each component, now make a new HscEnvEq which contains the @@ -844,7 +814,7 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l -- HscEnv but set the active component accordingly hscEnv <- initEmptyHscEnv ideOptions <- asks sessionIdeOptions - let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv + let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv all_target_details <- liftIO $ new_cache old_deps new_deps (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp @@ -867,54 +837,7 @@ packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) liftIO $ modifyVar (hscEnvs sessionState) $ - addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) - -addComponentInfo :: - MonadUnliftIO m => - Recorder (WithPriority Log) -> - (String -> [String] -> IO CacheDirs) -> - DependencyInfo -> - NonEmpty (DynFlags, [GHC.Target]) -> - (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> - Map.Map (Maybe FilePath) [RawComponentInfo] -> - m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) -addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let cacheDirOpts = componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do @@ -1062,255 +985,20 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do PreferSingleComponentLoading -> LoadFile PreferMultiComponentLoading -> LoadWithContext old_fps -emptyHscEnv :: FilePath -> SessionM HscEnv -emptyHscEnv libDir = do - nc <- asks sessionSharedNameCache - -- We call setSessionDynFlags so that the loader is initialised - -- We need to do this before we call initUnits. - env <- liftIO $ runGhc (Just libDir) $ - getSessionDynFlags >>= setSessionDynFlags >> getSession - pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) - -data TargetDetails = TargetDetails - { - targetTarget :: !Target, - targetEnv :: !(IdeResult HscEnvEq), - targetDepends :: !DependencyInfo, - targetLocations :: ![NormalizedFilePath] - } +-- ---------------------------------------------------------------------------- +-- Utilities +-- ---------------------------------------------------------------------------- -fromTargetId :: [FilePath] -- ^ import paths - -> [String] -- ^ extensions to consider - -> TargetId - -> IdeResult HscEnvEq - -> DependencyInfo - -> IO [TargetDetails] --- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule modName) env dep = do - let fps = [i moduleNameSlashes modName -<.> ext <> boot - | ext <- exts - , i <- is - , boot <- ["", "-boot"] - ] - let locs = fmap toNormalizedFilePath' fps - return [TargetDetails (TargetModule modName) env dep locs] --- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - let nf = toNormalizedFilePath' f - let other - | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) - | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") - return [TargetDetails (TargetFile nf) env deps [nf, other]] +emptyHscEnvM :: FilePath -> SessionM HscEnv +emptyHscEnvM libDir = do + nc <- asks sessionSharedNameCache + liftIO $ Ghc.emptyHscEnv nc libDir toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} = [ (l, (targetEnv, targetDepends)) | l <- targetLocations] - -setNameCache :: NameCache -> HscEnv -> HscEnv -setNameCache nc hsc = hsc { hsc_NC = nc } - -#if MIN_VERSION_ghc(9,13,0) --- Moved back to implementation in GHC. -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] -checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue -#else --- This function checks the important property that if both p and q are home units --- then any dependency of p, which transitively depends on q is also a home unit. --- GHC had an implementation of this function, but it was horribly inefficient --- We should move back to the GHC implementation on compilers where --- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) -checkHomeUnitsClosed' ue home_id_set - | OS.null bad_unit_ids = Nothing - | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) - where - bad_unit_ids = upwards_closure OS.\\ home_id_set - rootLoc = mkGeneralSrcSpan (Compat.fsLit "") - - graph :: Graph (Node UnitId UnitId) - graph = graphFromEdgedVerticesUniq graphNodes - - -- downwards closure of graph - downwards_closure - = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps) - | (uid, deps) <- Map.toList (allReachable graph node_key)] - - inverse_closure = transposeG downwards_closure - - upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set] - - all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId) - all_unit_direct_deps - = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C OS.union - (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) - rest - where - external_depends = mapUniqMap (OS.fromList . unitDepends) -#if !MIN_VERSION_ghc(9,7,0) - $ listToUniqMap $ Map.toList -#endif - - $ unitInfoMap this_units - this_units = homeUnitEnv_units this_uis - this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go OS.empty home_id_set - where - go done todo - = case OS.minView todo of - Nothing -> [] - Just (uid, todo') - | OS.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends OS.\\ done) `OS.union` todo' - in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo'' -#endif - --- | Create a mapping from FilePaths to HscEnvEqs --- This combines all the components we know about into --- an appropriate session, which is a multi component --- session on GHC 9.4+ -newComponentCache - :: Recorder (WithPriority Log) - -> [String] -- ^ File extensions to consider - -> NormalizedFilePath -- ^ Path to file that caused the creation of this component - -> HscEnv -- ^ An empty HscEnv - -> [ComponentInfo] -- ^ New components to be loaded - -> [ComponentInfo] -- ^ old, already existing components - -> IO [ [TargetDetails] ] -newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do - let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) - -- When we have multiple components with the same uid, - -- prefer the new one over the old. - -- However, we might have added some targets to the old unit - -- (see special target), so preserve those - unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } - mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) - let dfs = map componentDynFlags $ Map.elems cis - uids = Map.keys cis - logWith recorder Info $ LogMakingNewHscEnv uids - hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 - Compat.initUnits dfs hsc_env - - let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - closure_err_to_multi_err err = - ideErrorWithSource - (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp - (T.pack (Compat.printWithoutUniques (singleMessage err))) - (Just (fmap GhcDriverMessage err)) - multi_errs = map closure_err_to_multi_err closure_errs - bad_units = OS.fromList $ concat $ do - x <- map errMsgDiagnostic closure_errs - DriverHomePackagesNotClosed us <- pure x - pure us - isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units - -- Whenever we spin up a session on Linux, dynamically load libm.so.6 - -- in. We need this in case the binary is statically linked, in which - -- case the interactive session will fail when trying to load - -- ghc-prim, which happens whenever Template Haskell is being - -- evaluated or haskell-language-server's eval plugin tries to run - -- some code. If the binary is dynamically linked, then this will have - -- no effect. - -- See https://github.com/haskell/haskell-language-server/issues/221 - -- We need to do this after the call to setSessionDynFlags initialises - -- the loader - when (os == "linux") $ do - initObjLinker hscEnv' - res <- loadDLL hscEnv' "libm.so.6" - case res of - Nothing -> pure () - Just err -> logWith recorder Error $ LogDLLLoadError err - - forM (Map.elems cis) $ \ci -> do - let df = componentDynFlags ci - thisEnv <- do - -- In GHC 9.4 we have multi component support, and we have initialised all the units - -- above. - -- We just need to set the current unit here - pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' - henv <- newHscEnvEq thisEnv - let targetEnv = (if isBad ci then multi_errs else [], Just henv) - targetDepends = componentDependencyInfo ci - logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) - evaluate $ liftRnf rwhnf $ componentTargets ci - - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends - ctargets <- concatMapM mk (componentTargets ci) - - return (L.nubOrdOn targetTarget ctargets) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) - pure $ dflags - & maybe id setHiDir hiCacheDir - & maybe id setHieDir hieCacheDir - & maybe id setODir oCacheDir - -- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) @@ -1318,67 +1006,6 @@ type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResu -- It aims to be the reverse of 'FlagsMap'. type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: UnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: UnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | All targets of this components. - , componentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - safeTryIO :: IO a -> IO (Either IOException a) - safeTryIO = Safe.try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) - -- | Memoize an IO function, with the characteristics: -- -- * If multiple people ask for a result simultaneously, make sure you only compute it once. @@ -1396,118 +1023,6 @@ memoIO op = do return (Map.insert k res mp, res) Just res -> return (mp, res) -unit_flags :: [Flag (CmdLineP [String])] -unit_flags = [defFlag "unit" (SepArg addUnit)] - -addUnit :: String -> EwM (CmdLineP [String]) () -addUnit unit_str = liftEwM $ do - units <- getCmdLineState - putCmdLineState (unit_str : units) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m - => NormalizedFilePath - -> ComponentOptions - -> DynFlags - -> FilePath -- ^ root dir, see Note [Root Directory] - -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do - ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) - case NE.nonEmpty units of - Just us -> initMulti us - Nothing -> do - (df, targets) <- initOne (map unLoc theOpts') - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- - -- When we have a singleComponent that is caused to be loaded due to a - -- file, we assume the file is part of that component. This is useful - -- for bare GHC sessions, such as many of the ones used in the testsuite - -- - -- We don't do this when we have multiple components, because each - -- component better list all targets or there will be anarchy. - -- It is difficult to know which component to add our file to in - -- that case. - -- Multi unit arguments are likely to come from cabal, which - -- does list all targets. - -- - -- If we don't end up with a target for the current file in the end, then - -- we will report it as an error for that file - let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) - let special_target = Compat.mkSimpleTarget df abs_fp - pure $ (df, special_target : targets) :| [] - where - initMulti unitArgFiles = - forM unitArgFiles $ \f -> do - args <- liftIO $ expandResponse [f] - initOne args - initOne this_opts = do - (dflags', targets') <- addCmdOpts this_opts dflags - let dflags'' = - case unitIdString (homeUnitId_ dflags') of - -- cabal uses main for the unit id of all executable packages - -- This makes multi-component sessions confused about what - -- options to use for that component. - -- Solution: hash the options and use that as part of the unit id - -- This works because there won't be any dependencies on the - -- executable unit. - "main" -> - let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) - hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) - in setHomeUnitId_ hashed_uid dflags' - _ -> dflags' - - let targets = makeTargetsAbsolute root targets' - root = case workingDirectory dflags'' of - Nothing -> compRoot - Just wdir -> compRoot wdir - let dflags''' = - setWorkingDirectory root $ - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ - disableOptimisation $ - Compat.setUpTypedHoles $ - makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory - dflags'' - return (dflags''', targets) - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -setODir :: FilePath -> DynFlags -> DynFlags -setODir f d = - -- override user settings to avoid conflicts leading to recompilation - d { objectDir = Just f} - -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/ghcide/session-loader/Development/IDE/Session/Dependency.hs b/ghcide/session-loader/Development/IDE/Session/Dependency.hs new file mode 100644 index 0000000000..926e0e47b3 --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/Dependency.hs @@ -0,0 +1,35 @@ +module Development.IDE.Session.Dependency where + +import Control.Exception.Safe as Safe +import Data.Either.Extra +import qualified Data.Map.Strict as Map +import Data.Time.Clock +import System.Directory + +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + safeTryIO :: IO a -> IO (Either IOException a) + safeTryIO = Safe.try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs new file mode 100644 index 0000000000..25f377200c --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Session.Ghc where + +import Control.Monad +import Control.Monad.Extra as Extra +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.Function +import Data.List +import Data.List.Extra as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.Shake hiding (Log, knownTargets, + withHieDb) +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.CmdLine +import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, + TargetModule, Var, + Warning, getOptions) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) +import Development.IDE.GHC.Util +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) +import Development.IDE.Types.Location +import GHC.ResponseFile +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types hiding (Log) +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info), + Recorder, WithPriority, logWith, viaShow, (<+>)) +import System.Directory +import System.FilePath +import System.Info + + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Data.Set as OS +import qualified Development.IDE.GHC.Compat.Util as Compat +import Development.IDE.Session.Dependency +import GHC.Data.Graph.Directed +import Ide.PluginUtils (toAbsolute) + +import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Driver.Errors.Types +import GHC.Types.Error (errMsgDiagnostic, + singleMessage) +import GHC.Unit.State + +data Log + = LogInterfaceFilesCacheDir !FilePath + | LogMakingNewHscEnv ![UnitId] + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) + | LogDLLLoadError !String +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogMakingNewHscEnv inPlaceUnitIds -> + "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) + LogNewComponentCache componentCache -> + "New component cache HscEnvEq:" <+> viaShow componentCache + LogDLLLoadError errorString -> + "Error dynamically loading libm.so.6:" <+> pretty errorString + +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: UnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: UnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | All targets of this components. + , componentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + + +unit_flags :: [Flag (CmdLineP [String])] +unit_flags = [defFlag "unit" (SepArg addUnit)] + +addUnit :: String -> EwM (CmdLineP [String]) () +addUnit unit_str = liftEwM $ do + units <- getCmdLineState + putCmdLineState (unit_str : units) + + +-- | Create a mapping from FilePaths to HscEnvEqs +-- This combines all the components we know about into +-- an appropriate session, which is a multi component +-- session on GHC 9.4+ +newComponentCache + :: Recorder (WithPriority Log) + -> [String] -- ^ File extensions to consider + -> NormalizedFilePath -- ^ Path to file that caused the creation of this component + -> HscEnv -- ^ An empty HscEnv + -> [ComponentInfo] -- ^ New components to be loaded + -> [ComponentInfo] -- ^ old, already existing components + -> IO [ [TargetDetails] ] +newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do + let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) + -- When we have multiple components with the same uid, + -- prefer the new one over the old. + -- However, we might have added some targets to the old unit + -- (see special target), so preserve those + unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } + mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) + let dfs = map componentDynFlags $ Map.elems cis + uids = Map.keys cis + logWith recorder Info $ LogMakingNewHscEnv uids + hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits dfs hsc_env + + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + closure_err_to_multi_err err = + ideErrorWithSource + (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (T.pack (Compat.printWithoutUniques (singleMessage err))) + (Just (fmap GhcDriverMessage err)) + multi_errs = map closure_err_to_multi_err closure_errs + bad_units = OS.fromList $ concat $ do + x <- map errMsgDiagnostic closure_errs + DriverHomePackagesNotClosed us <- pure x + pure us + isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units + -- Whenever we spin up a session on Linux, dynamically load libm.so.6 + -- in. We need this in case the binary is statically linked, in which + -- case the interactive session will fail when trying to load + -- ghc-prim, which happens whenever Template Haskell is being + -- evaluated or haskell-language-server's eval plugin tries to run + -- some code. If the binary is dynamically linked, then this will have + -- no effect. + -- See https://github.com/haskell/haskell-language-server/issues/221 + -- We need to do this after the call to setSessionDynFlags initialises + -- the loader + when (os == "linux") $ do + initObjLinker hscEnv' + res <- loadDLL hscEnv' "libm.so.6" + case res of + Nothing -> pure () + Just err -> logWith recorder Error $ LogDLLLoadError err + + forM (Map.elems cis) $ \ci -> do + let df = componentDynFlags ci + thisEnv <- do + -- In GHC 9.4 we have multi component support, and we have initialised all the units + -- above. + -- We just need to set the current unit here + pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' + henv <- newHscEnvEq thisEnv + let targetEnv = (if isBad ci then multi_errs else [], Just henv) + targetDepends = componentDependencyInfo ci + logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) + evaluate $ liftRnf rwhnf $ componentTargets ci + + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (componentTargets ci) + + return (L.nubOrdOn targetTarget ctargets) + +-- | Throws if package flags are unsatisfiable +setOptions :: GhcMonad m + => NormalizedFilePath + -> ComponentOptions + -> DynFlags + -> FilePath -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do + ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) + case NE.nonEmpty units of + Just us -> initMulti us + Nothing -> do + (df, targets) <- initOne (map unLoc theOpts') + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- + -- When we have a singleComponent that is caused to be loaded due to a + -- file, we assume the file is part of that component. This is useful + -- for bare GHC sessions, such as many of the ones used in the testsuite + -- + -- We don't do this when we have multiple components, because each + -- component better list all targets or there will be anarchy. + -- It is difficult to know which component to add our file to in + -- that case. + -- Multi unit arguments are likely to come from cabal, which + -- does list all targets. + -- + -- If we don't end up with a target for the current file in the end, then + -- we will report it as an error for that file + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) + let special_target = Compat.mkSimpleTarget df abs_fp + pure $ (df, special_target : targets) :| [] + where + initMulti unitArgFiles = + forM unitArgFiles $ \f -> do + args <- liftIO $ expandResponse [f] + initOne args + initOne this_opts = do + (dflags', targets') <- addCmdOpts this_opts dflags + let dflags'' = + case unitIdString (homeUnitId_ dflags') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid dflags' + _ -> dflags' + + let targets = makeTargetsAbsolute root targets' + root = case workingDirectory dflags'' of + Nothing -> compRoot + Just wdir -> compRoot wdir + let dflags''' = + setWorkingDirectory root $ + disableWarningsAsErrors $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setBytecodeLinkerOptions $ + disableOptimisation $ + Compat.setUpTypedHoles $ + makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory + dflags'' + return (dflags''', targets) + +addComponentInfo :: + MonadUnliftIO m => + Recorder (WithPriority Log) -> + (String -> [String] -> IO CacheDirs) -> + DependencyInfo -> + NonEmpty (DynFlags, [GHC.Target]) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + Map.Map (Maybe FilePath) [RawComponentInfo] -> + m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) +addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let cacheDirOpts = componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +setODir :: FilePath -> DynFlags -> DynFlags +setODir f d = + -- override user settings to avoid conflicts leading to recompilation + d { objectDir = Just f} + +data CacheDirs = CacheDirs + { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) + pure $ dflags + & maybe id setHiDir hiCacheDir + & maybe id setHieDir hieCacheDir + & maybe id setODir oCacheDir + +getCacheDirsDefault :: String -> [String] -> IO CacheDirs +getCacheDirsDefault prefix opts = do + dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + return $ CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + +setNameCache :: NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +emptyHscEnv :: NameCache -> FilePath -> IO HscEnv +emptyHscEnv nc libDir = do + -- We call setSessionDynFlags so that the loader is initialised + -- We need to do this before we call initUnits. + env <- liftIO $ runGhc (Just libDir) $ + getSessionDynFlags >>= setSessionDynFlags >> getSession + pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) + +-- ---------------------------------------------------------------------------- +-- Target Details +-- ---------------------------------------------------------------------------- + +data TargetDetails = TargetDetails + { + targetTarget :: !Target, + targetEnv :: !(IdeResult HscEnvEq), + targetDepends :: !DependencyInfo, + targetLocations :: ![NormalizedFilePath] + } + +fromTargetId :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider + -> TargetId + -> IdeResult HscEnvEq + -> DependencyInfo + -> IO [TargetDetails] +-- For a target module we consider all the import paths +fromTargetId is exts (GHC.TargetModule modName) env dep = do + let fps = [i moduleNameSlashes modName -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] + let locs = fmap toNormalizedFilePath' fps + return [TargetDetails (TargetModule modName) env dep locs] +-- For a 'TargetFile' we consider all the possible module names +fromTargetId _ _ (GHC.TargetFile f _) env deps = do + let nf = toNormalizedFilePath' f + let other + | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) + | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") + return [TargetDetails (TargetFile nf) env deps [nf, other]] + +-- ---------------------------------------------------------------------------- +-- Backwards compatibility +-- ---------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,13,0) +-- Moved back to implementation in GHC. +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue +#else +-- This function checks the important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +-- GHC had an implementation of this function, but it was horribly inefficient +-- We should move back to the GHC implementation on compilers where +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) +checkHomeUnitsClosed' ue home_id_set + | OS.null bad_unit_ids = Nothing + | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) + where + bad_unit_ids = upwards_closure OS.\\ home_id_set + rootLoc = mkGeneralSrcSpan (Compat.fsLit "") + + graph :: Graph (Node UnitId UnitId) + graph = graphFromEdgedVerticesUniq graphNodes + + -- downwards closure of graph + downwards_closure + = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps) + | (uid, deps) <- Map.toList (allReachable graph node_key)] + + inverse_closure = transposeG downwards_closure + + upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId) + all_unit_direct_deps + = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C OS.union + (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) + rest + where + external_depends = mapUniqMap (OS.fromList . unitDepends) +#if !MIN_VERSION_ghc(9,7,0) + $ listToUniqMap $ Map.toList +#endif + + $ unitInfoMap this_units + this_units = homeUnitEnv_units this_uis + this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go OS.empty home_id_set + where + go done todo + = case OS.minView todo of + Nothing -> [] + Just (uid, todo') + | OS.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends OS.\\ done) `OS.union` todo' + in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo'' +#endif