Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: 64799b05 by Wolfgang Jeltsch at 2026-09-24T12:28:41+03:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - dabbc669 by Wolfgang Jeltsch at 2026-09-24T12:29:26+03:00 Remove erroneous GHC flag in `hadrian-multi` The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its purpose was to permit incomplete record selectors, but because of the illegal combination of `-Werror=` and `-Wno-error` it was ignored, without any negative consequences. - - - - - 7 changed files: - .gitlab-ci.yml - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.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: ===================================== .gitlab-ci.yml ===================================== @@ -497,12 +497,7 @@ hadrian-multi: # workaround for docker permissions - sudo chown ghc:ghc -R . variables: - GHC_FLAGS: "-Werror=-Wno-error=incomplete-record-selectors -Wwarn=deprecations -Wwarn=unused-imports" - # -Wno-error=incomplete-record-selectors is present because -Wall now - # includes -Wincomplete-record-selectors, and hadrian-multi has many, many - # warnings about incomplete record selectors. A better fix would be to - # remove the use of incomplete record selectors, since each of them represents - # a potential crash. + GHC_FLAGS: "-Wwarn=deprecations -Wwarn=unused-imports" CONFIGURE_ARGS: --enable-bootstrap-with-devel-snapshot tags: - x86_64-linux ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -6,6 +6,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-invalid-haddock #-} + -- | See Note [The ModuleGraph] module GHC.Driver.Downsweep ( downsweep @@ -54,8 +56,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 import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf ) @@ -71,12 +71,15 @@ import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants +import GHC.Utils.Monad (concatMapM) +import GHC.Utils.Monad.State.Strict import GHC.Types.Error import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc +import GHC.Types.Unique.Set import GHC.Types.Unique.Map import GHC.Types.PkgQual import GHC.Types.Basic @@ -91,9 +94,12 @@ 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 (UnitAbiHash) import Data.Either ( partitionEithers, lefts ) +import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent.MVar @@ -101,7 +107,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe -import Data.List (partition) +import Data.List (sort, partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first, bimap) @@ -864,7 +870,7 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do - let root_imp = (generatedImport FromTarget (L rootLoc modl)) + let root_imp = (generatedImport FromTarget (L noSrcSpan modl)) { ui_pkg_qual = ThisPkg (homeUnitId home_unit) } maybe_summary <- summariseModule hsc_env home_unit summ_cache imports_cache root_imp maybe_buf excl_mods @@ -875,7 +881,6 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target where Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) -- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline @@ -933,52 +938,171 @@ 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. +-- | Checks whether the given 'UnitEnv' has the closure property. -- --- 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)] +-- See the section “Closure Property” in @Note [Multiple Home Units]@ for the +-- definition of the closure property and +-- @Note [Home unit closure property check]@ below for a discussion of the +-- algorithm used for this check, its justification, and a potential +-- alternative. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed unit_env + | null offenders = [] + | otherwise = [ + singleMessage $ + mkPlainErrorMsgEnvelope noSrcSpan $ + DriverHomePackagesNotClosed (sort 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 + -- | The 'UnitId' and 'HomeUnitEnv' of each home unit. + home_unit_data :: [(UnitId, HomeUnitEnv)] + home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env) + + -- | The 'UnitId's of all home units. + home_units :: UniqSet UnitId + home_units = mkUniqSet (map fst home_unit_data) + + -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is + -- offending exactly if /u/ is an external unit reachable from a home unit + -- and /v/ is a home unit. Each such dependency is represented in this list + -- by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/. + offenders :: [(UnitId, UnitId)] + offenders + = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) + emptyUniqMap + where - inverse_closure = graphReachability $ transposeG downwards_closure + -- | Collects offending dependencies. + collect :: [UnitState] + -- ^ The 'UnitState's of the home units from which to traverse + -- the dependency graph. + -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)] + -- ^ A stateful computation that collects offending dependencies + -- that have not yet been found. It uses its state, which is an + -- efficent representation of a set of 'GlobalUnitKey's, to + -- keep track of which units have already been considered as + -- sources of offending dependencies. + collect = concatMapM $ \ unit_state -> + collect_for_home_unit + (unitInfoMap unit_state) + (map (toUnitId . fst) $ explicitUnits $ unit_state) + where - upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + -- | Collects offending dependencies that are reachable from a particular + -- home unit. + collect_for_home_unit + :: UnitInfoMap + -- ^ The 'UnitInfoMap' of the home unit. + -> [UnitId] + -- ^ The 'UnitId's of the units from which to traverse the dependency + -- graph. + -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)] + -- ^ A stateful computation that collects offending dependencies that + -- have not yet been found. It uses its state, which is an efficent + -- representation of a set of 'GlobalUnitKey's, to keep track of + -- which units have already been considered as sources of offending + -- dependencies. + collect_for_home_unit _ [] + = return [] + collect_for_home_unit unit_info_map (current_unit : remaining_units) = do + let + + -- | The 'UnitInfo' of the current unit. + unit_info :: UnitInfo + unit_info + = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $ + lookupUniqMap unit_info_map current_unit + where + + -- | The message that says that a unit was not found. + unit_not_found_msg :: String + unit_not_found_msg = "Unit not found during closure property check" + + -- | The ABI hash of the current unit. + unit_abi_hash :: UnitAbiHash + unit_abi_hash = unitAbiHash unit_info + + has_been_processed <- gets $ maybe False (Set.member unit_abi_hash) . + (`lookupUniqMap` current_unit) + if has_been_processed + then collect_for_home_unit unit_info_map remaining_units + else do + modify $ \ processed -> addToUniqMap_C Set.union + processed + current_unit + (Set.singleton unit_abi_hash) + let + + -- | The 'UnitId's of the units that the current unit depends on. + needed_units :: [UnitId] + needed_units = unitDepends unit_info + + -- | The offending dependencies of the current unit. + current_offenders :: [(UnitId, UnitId)] + current_offenders + | current_unit `elementOfUniqSet` home_units + = [] + | otherwise + = map ((,) current_unit) $ + nonDetEltsUniqSet $ + mkUniqSet needed_units `intersectUniqSets` home_units + + remaining_offenders <- collect_for_home_unit unit_info_map $ + needed_units ++ remaining_units + return $ current_offenders ++ remaining_offenders - 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'' +{- + +Note [Home unit closure property check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Per the definition in Note [Multiple Home Units], a unit environment has the +closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the +dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external +unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for +so-called offending dependencies, which are dependencies /e/ → /h/₂ that are +part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a +viable approach, consider the following: + + * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂. + + * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′, + where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be + constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂ + and as /e/′ the, necessarily external, unit preceding it. + +Concretely, the algorithm picks one home unit after the other, determines what +units it directly depends on, and, starting from them, follows unit dependencies +to search for offending dependencies. It does not follow dependencies that have +been followed before, possibly when processing another home unit. To achieve +this, the algorithm tracks, across home units, from which units it has already +followed dependencies. For this tracking, it identifies each unit by a 'UnitId' +and an ABI hash. Using only a 'UnitId' would not work, because 'UnitId's are not +always globally unique. Also using only an ABI hash is not an option, because an +ABI hash is not necessarily an ABI hash: it can also be the string @"inline"@. + +The correctness of this algorithm rests on the, likely correct, assumption that, +among the units mentioned in the 'UnitState' of a particular home unit, any unit +can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only +occur across the 'UnitState's of different home units. + +An alternative approach to finding offending dependencies would be to follow +dependencies starting from all units that /any/ home unit directly depends on +instead of considering the different home units separately. A corresponding +algorithm could in principle find the dependencies of a particular unit +independently of any home unit by fetching the 'UnitInfo' of that unit from the +'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not +only the 'UnitId' but also the ABI hash of the unit in question. Therefore, +whenever following a dependency of a unit /u/ on a unit /v/, it would have to +determine the ABI hash of /v/, so that it could later look up /v/’s +dependencies. The ABI hashes of all units that /u/ depends on should be +available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the +time of writing, 'unitAbiDepends' never contained anything other than the empty +list during GHC test runs, which indicated that this alternative solution was +impossible to realize. + +-} -------------------------------------------------------------------------------- -- * Enable Code Gen for Template Haskell @@ -1763,7 +1887,7 @@ data NodeRes v -- -- See also Note [Downsweep Control Flow and Caching] dfsBuild :: (Ord k, Monad m) - => Maybe (Map.Map k (NodeRes v)) + => Maybe (Map k (NodeRes v)) -- ^ Base map, existing results. We won't re-expand any of the nodes -- already present in this map. -> [n] @@ -1773,7 +1897,7 @@ dfsBuild :: (Ord k, Monad m) -> (n -> m (NodeRes (v,[n]))) -- ^ Expand this node into its payload result and into the list of -- children nodes to visit next. - -> m (Map.Map k (NodeRes v)) + -> m (Map k (NodeRes v)) -- ^ The result accumulates the payload of expanding the root nodes -- and all nodes transitively reachable from those roots. dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) ===================================== 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 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile ===================================== @@ -10,14 +10,21 @@ CONFIGURE=configure \ --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 pkg-database - $(TEST_BUILD) -unit @unitP - $(TEST_BUILD) -unit @unitP -unit @unitQ + ! $(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) -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: ===================================== 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 - -<command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<no location info>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<no location info>: 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/c3a50a05a34de16cea00905643b7517... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3a50a05a34de16cea00905643b7517... 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