Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: 2341f9e0 by Wolfgang Jeltsch at 2026-08-21T21:51:29+03:00 Re-implement the home unit closure check Resolves #27051. - - - - - 5 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Index.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -54,7 +54,6 @@ import GHC.Runtime.Context import Language.Haskell.Syntax.ImpExp import GHC.Types.UnresolvedImport -import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.Maybe as M @@ -77,7 +76,7 @@ import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc -import GHC.Types.Unique.Map +import GHC.Types.Unique.Set import GHC.Types.PkgQual import GHC.Types.Basic @@ -91,6 +90,7 @@ import GHC.Unit.Module.Graph import GHC.Unit.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage +import GHC.Unit.External.Index import Data.Either ( partitionEithers, lefts ) import qualified Data.Map as Map @@ -260,11 +260,9 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo imps_cache <- newIORef Map.empty (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg (getRootSummary excl_mods summ_cache imps_cache) - let closure_errs = checkHomeUnitsClosed unit_env - unit_env = hsc_unit_env hsc_env - - all_errs = closure_errs ++ root_errs - + let unit_env = hsc_unit_env hsc_env + closure_errs <- checkHomeUnitsClosed unit_env + let all_errs = closure_errs ++ root_errs case all_errs of [] -> do (downsweep_errs, downsweep_nodes) <- @@ -933,52 +931,66 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do -- * Check/validate properties and error out -------------------------------------------------------------------------------- --- | 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. --- --- See Note [Multiple Home Units], section 'Closure Property'. -checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] -checkHomeUnitsClosed ue - | Set.null bad_unit_ids = [] - | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] +-- | Checks whether the given unit environment has the closure property. See +-- the section “Closure Property” in @Note [Multiple Home Units]@. +checkHomeUnitsClosed :: UnitEnv -> IO [DriverMessages] +checkHomeUnitsClosed unit_env = do + unit_infos <- globalUnits <$> readIORef (uic_index (ue_uic unit_env)) + return $ case offending_dependencies unit_infos of + [] -> [] + offenders -> [ + singleMessage $ + mkPlainErrorMsgEnvelope error_source_span $ + DriverHomePackagesNotClosed offenders + ] where - home_id_set = HUG.allUnits $ ue_home_unit_graph ue - bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") - downwards_closure :: Graph (Node UnitId UnitId) - downwards_closure = graphFromEdgedVerticesUniq graphNodes + home_unit_data :: [(UnitId, HomeUnitEnv)] + home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env) - inverse_closure = graphReachability $ transposeG downwards_closure + home_units :: UniqSet UnitId + home_units = mkUniqSet (map fst home_unit_data) - upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + referenced_external_units :: [UnitId] + referenced_external_units + = concatMap (map (toUnitId . fst) . explicitUnits . homeUnitEnv_units . snd) + home_unit_data - all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) - all_unit_direct_deps - = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C Set.union - (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) - rest - where - external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) - this_units = homeUnitEnv_units this_uis - this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go Set.empty home_id_set - where - go done todo - = case Set.minView todo of - Nothing -> [] - Just (uid, todo') - | Set.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends Set.\\ done) `Set.union` todo' - in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' + offending_dependencies :: GlobalUnitInfoMap -> [(UnitId, UnitId)] + offending_dependencies unit_infos + = collect emptyUniqSet referenced_external_units + where + + collect :: UniqSet UnitId -> [UnitId] -> [(UnitId, UnitId)] + collect _ [] = [] + collect processed (current : remaining) + | current `elementOfUniqSet` processed + = collect processed remaining + | otherwise + = let + + needed :: [UnitId] + needed | Just current_infos <- unitInfosOfUnitId current unit_infos + = concatMap unitDepends current_infos + | otherwise + = pprPanic "Unit not found during closure property check" + (ppr current) + + current_offenders :: [(UnitId, UnitId)] + current_offenders + | current `elementOfUniqSet` home_units + = [] + | otherwise + = map ((,) current) $ + nonDetEltsUniqSet $ + mkUniqSet needed `intersectUniqSets` home_units + + in + current_offenders ++ collect (addOneToUniqSet processed current) + (needed ++ remaining) + + error_source_span :: SrcSpan + error_source_span = mkGeneralSrcSpan (fsLit "<command line>") -------------------------------------------------------------------------------- -- * Enable Code Gen for Template Haskell ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -235,10 +235,17 @@ instance Diagnostic DriverMessage where "but no output will be generated.") $$ (text "There is no module named" <+> quotes (ppr mod_name) <> text ".")) - DriverHomePackagesNotClosed needed_unit_ids - -> mkSimpleDecorated $ vcat ([text "Home units are not closed." - , text "It is necessary to also load the following units:" ] - ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverHomePackagesNotClosed offending_dependencies + -> mkSimpleDecorated $ + hang (text "Some units are not loaded but depend on loaded units.") + 4 + (vcat (map pprDependency offending_dependencies)) + where + + pprDependency :: (UnitId, UnitId) -> SDoc + pprDependency (external_unit, home_unit) + = ppr external_unit <+> arrow <+> ppr home_unit + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason DriverInconsistentDynFlags msg ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -369,7 +369,7 @@ data DriverMessage where DriverRedirectedNoMain :: !ModuleName -> DriverMessage - DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage DriverInterfaceError :: !IfaceMessage -> DriverMessage ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -443,13 +443,11 @@ The flow: Closure Property ---------------- -You must perform a clean cut of the dependency graph. - -> Any dependency which is not a home unit must not (transitively) depend on a home unit. - -For example, if you have three packages p, q and r, then if p depends on q which -depends on r then it is illegal to load both p and r as home units but not q, -because q is a dependency of the home unit p which depends on another home unit r. +A unit environment must have the closure property, which means that, whenever +some units @h₁@ and @h₂@ have been loaded as home units, @h₁@ does not directly +or indirectly depend on an external unit that directly or indirectly depends +on @h₂@. 'GHC.Driver.Downsweep.checkHomeUnitsClosed' checks whether a given unit +environment indeed has this property. Offsetting Paths ---------------- ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -64,6 +64,7 @@ module GHC.Unit.External.Index ( -- * 'GlobalUnitInfoMap' GlobalUnitInfoMap, lookupGlobalUnitInfoMap, + unitInfosOfUnitId, emptyGlobalUnitInfoMap, mkGlobalUnitInfoMap, -- * 'GlobalUnitKey' @@ -287,6 +288,12 @@ lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) (GlobalUnitInfoMap globalMap Nothing -> Nothing Just sameUnitId -> Map.lookup abiHash sameUnitId +-- | Lookup all 'UnitInfo' entries of a given 'UnitId'. This can result in more +-- than one 'UnitInfo' only if the given 'UnitId' is a conflicting one. +unitInfosOfUnitId :: UnitId -> GlobalUnitInfoMap -> Maybe [UnitInfo] +unitInfosOfUnitId uid (GlobalUnitInfoMap globalMap) = + Map.elems <$> lookupUniqMap globalMap uid + mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap mkGlobalUnitInfoMap unitInfos = GlobalUnitInfoMap $ listToUniqMap_C Map.union (map mkEntry unitInfos) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2341f9e03d2a1d3f51ce582051206e08... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2341f9e03d2a1d3f51ce582051206e08... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help