From 1610a6da6eee83f3c2e1daf7bf595f8c832cbfda Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 1 Mar 2024 16:44:29 +0530 Subject: [PATCH 1/4] Use a faster implementation of checkHomeUnitsClosed 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 Fixes #4046 --- .../session-loader/Development/IDE/Session.hs | 69 +++++++++++++++++-- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 7 +- 2 files changed, 69 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e6d1a6696b..5c0d90d6b4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -52,6 +52,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, Priority, knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, Var, Warning, getOptions) @@ -122,10 +123,11 @@ import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Driver.Make (checkHomeUnitsClosed) -import GHC.Types.Error (errMsgDiagnostic) +import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State #endif +import GHC.Data.Graph.Directed import GHC.ResponseFile data Log @@ -810,6 +812,65 @@ setNameCache :: IORef NameCache -> HscEnv -> HscEnv #endif setNameCache nc hsc = hsc { hsc_NC = nc } +#if MIN_VERSION_ghc(9,3,0) +-- This function checks then 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 -> [DriverMessages] +checkHomeUnitsClosed' ue home_id_set + | OS.null bad_unit_ids = [] + | otherwise = [singleMessage $ 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 @@ -838,11 +899,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do Compat.initUnits dfs hsc_env #if MIN_VERSION_ghc(9,3,0) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') pkg_deps - pkg_deps = do - home_unit_id <- uids - home_unit_env <- maybeToList $ unitEnv_lookup_maybe home_unit_id $ hsc_HUG hscEnv' - map (home_unit_id,) (map (Compat.toUnitId . fst) $ explicitUnits $ homeUnitEnv_units home_unit_env) + let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index ac14eb09a0..44e1c52adf 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -491,7 +491,12 @@ import GHC.Unit.Module hiding (ModLocation (..), UnitId, toUnitId) import qualified GHC.Unit.Module as Module import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..), emptyMessages) +import GHC.Utils.Error (Severity (..), emptyMessages +#if MIN_VERSION_ghc(9,3,0) + , mkPlainErrorMsgEnvelope) +#else + ) +#endif import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain From 341f42f48dcace5551e5832a47a853f202e6f312 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Tue, 23 Apr 2024 13:54:51 +0530 Subject: [PATCH 2/4] Update ghcide/src/Development/IDE/GHC/Compat/Core.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 44e1c52adf..4c362503a2 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -493,10 +493,9 @@ import qualified GHC.Unit.Module as Module import GHC.Unit.State (ModuleOrigin (..)) import GHC.Utils.Error (Severity (..), emptyMessages #if MIN_VERSION_ghc(9,3,0) - , mkPlainErrorMsgEnvelope) -#else - ) + , mkPlainErrorMsgEnvelope #endif + ) import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain From 7df36d080ff25c4077ad452c4ac52e0a8456606f Mon Sep 17 00:00:00 2001 From: wz1000 Date: Tue, 23 Apr 2024 13:54:57 +0530 Subject: [PATCH 3/4] Update ghcide/session-loader/Development/IDE/Session.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- 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 5c0d90d6b4..2ee4cbcedc 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -813,7 +813,7 @@ setNameCache :: IORef NameCache -> HscEnv -> HscEnv setNameCache nc hsc = hsc { hsc_NC = nc } #if MIN_VERSION_ghc(9,3,0) --- This function checks then important property that if both p and q are home units +-- 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 From eef08bc1bcec31be3646f0cf341c4015969c6aa6 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 23 Apr 2024 14:09:46 +0530 Subject: [PATCH 4/4] Follow guidelines --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 4c362503a2..467f4210e2 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -491,11 +491,7 @@ import GHC.Unit.Module hiding (ModLocation (..), UnitId, toUnitId) import qualified GHC.Unit.Module as Module import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..), emptyMessages -#if MIN_VERSION_ghc(9,3,0) - , mkPlainErrorMsgEnvelope -#endif - ) +import GHC.Utils.Error (Severity (..), emptyMessages) import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain @@ -547,6 +543,7 @@ import qualified GHC.Unit.Finder as GHC #endif #if MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Error (mkPlainErrorMsgEnvelope) import GHC.Driver.Env.KnotVars import GHC.Unit.Module.Graph import GHC.Driver.Errors.Types