Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check.global-unit-info-map at Glasgow Haskell Compiler / GHC Commits: 555b4614 by fendor at 2026-08-26T15:41:59+02:00 Reuse the UnitIndexCache after initialising multiple home units - - - - - da4f57bf by Wolfgang Jeltsch at 2026-08-26T21:15:55+03:00 Improve the `mhu-closure` makefile - - - - - a8a12bfe by Wolfgang Jeltsch at 2026-08-26T21:18:14+03:00 Re-implement the home unit closure check Resolves #27051. - - - - - 4b2c3aed by Wolfgang Jeltsch at 2026-08-26T21:56:27+03:00 Adapt `mhu-closure` to the inclusion of implicitly used units - - - - - 9 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Index.hs - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout 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/Driver/Session/Units.hs ===================================== @@ -145,8 +145,15 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkUnitCycles initial_dflags home_unit_graph let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph - unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + newUnitEnv <- do + env <- liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) + -- We need to reuse the 'UnitIndexCache' as we used it above in 'initUnits'. + -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] why this must be shared. + pure $ assertUnitEnvInvariant $ env + { ue_uic = hscUIC hsc_env + } + + let final_hsc_env = hsc_env { hsc_unit_env = newUnitEnv } GHC.setSession final_hsc_env ===================================== 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) ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile ===================================== @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk SETUP=../Setup -v0 +CONFIGURE=configure \ + $(CABAL_MINIMAL_BUILD) \ + --with-ghc='$(TEST_HC)' \ + --with-hc-pkg='$(GHC_PKG)' \ + --ghc-options='$(TEST_HC_OPTS)' \ + --package-db=../tmp.d +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp +ONLY_BASE=-hide-all-packages -package base -mhu-closure: clean - $(MAKE) -s --no-print-directory clean +mhu-closure: clean pkg-database + ! $(TEST_BUILD) -unit @unitP + ! $(TEST_BUILD) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) -unit @unitP -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitR1 + $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1 + +.PHONY: pkg-database +pkg-database: '$(GHC_PKG)' init tmp.d '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup - cd p && $(SETUP) clean - cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0 cd p && $(SETUP) build cd p && $(SETUP) register --inplace - cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=q-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0 cd q && $(SETUP) build cd q && $(SETUP) register --inplace - cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=r-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0 cd r && $(SETUP) build cd r && $(SETUP) register --inplace - # This should work - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR - # This should error with a closure message - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR - # This should work, even though r1 is not in the package db - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1 - # This should fail, even though r1 is not in the package db - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1 +.PHONY: clean +clean: + $(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o ifeq "$(CLEANUP)" "1" $(MAKE) -s --no-print-directory clean endif - -clean : - $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) - ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr ===================================== @@ -1,10 +1,28 @@ <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout ===================================== @@ -1,3 +1,6 @@ +[1 of 3] Compiling P[p-0.1.0.0] +[2 of 3] Compiling Q[q-0.1.0.0] +[3 of 3] Compiling R[r-0.1.0.0] [1 of 1] Compiling P [1 of 2] Compiling P[p-0.1.0.0] [2 of 2] Compiling Q[q-0.1.0.0] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/44ebfb87150d73288987bb944a6ed11... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/44ebfb87150d73288987bb944a6ed11... 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