Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -54,8 +54,8 @@ import GHC.Runtime.Context
    54 54 
     import Language.Haskell.Syntax.ImpExp
    55 55 
     import GHC.Types.UnresolvedImport
    56 56
    57 
    -import GHC.Data.Graph.Directed
    58 57 
     import GHC.Data.FastString
    58 
    +import GHC.Data.ShortText (ShortText)
    59 59 
     import GHC.Data.Maybe      ( expectJust )
    60 60 
     import qualified GHC.Data.Maybe as M
    61 61 
     import GHC.Data.OsPath     ( OsPath, unsafeEncodeUtf )
    ... ... @@ -71,12 +71,14 @@ import GHC.Utils.Logger
    71 71 
     import GHC.Utils.Fingerprint
    72 72 
     import GHC.Utils.TmpFs
    73 73 
     import GHC.Utils.Constants
    74 
    +import GHC.Utils.Monad.State.Strict
    74 75
    75 76 
     import GHC.Types.Error
    76 77 
     import GHC.Types.Target
    77 78 
     import GHC.Types.SourceFile
    78 79 
     import GHC.Types.SourceError
    79 80 
     import GHC.Types.SrcLoc
    81 
    +import GHC.Types.Unique.Set
    80 82 
     import GHC.Types.Unique.Map
    81 83 
     import GHC.Types.PkgQual
    82 84 
     import GHC.Types.Basic
    ... ... @@ -93,7 +95,9 @@ import qualified GHC.Unit.Home.Graph as HUG
    93 95 
     import GHC.Unit.Module.Stage
    94 96
    95 97 
     import Data.Either ( partitionEithers, lefts )
    98 
    +import Data.Map (Map)
    96 99 
     import qualified Data.Map as Map
    100 
    +import Data.Set (Set)
    97 101 
     import qualified Data.Set as Set
    98 102
    99 103 
     import Control.Concurrent.MVar
    ... ... @@ -101,7 +105,7 @@ import Control.Monad
    101 105 
     import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
    102 106 
     import qualified Control.Monad.Catch as MC
    103 107 
     import Data.Maybe
    104 
    -import Data.List (partition)
    108 
    +import Data.List (sort, partition)
    105 109 
     import Data.Time
    106 110 
     import Data.List (unfoldr)
    107 111 
     import Data.Bifunctor (first, bimap)
    ... ... @@ -933,52 +937,85 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
    933 937 
     -- * Check/validate properties and error out
    934 938 
     --------------------------------------------------------------------------------
    935 939
    936 
    --- | This function checks then important property that if both p and q are home units
    937 
    --- then any dependency of p, which transitively depends on q is also a home unit.
    938 
    ---
    939 
    --- See Note [Multiple Home Units], section 'Closure Property'.
    940 
    -checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]
    941 
    -checkHomeUnitsClosed ue
    942 
    -    | Set.null bad_unit_ids = []
    943 
    -    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
    940 
    +-- | Checks whether the given unit environment has the closure property. See
    941 
    +--   the section “Closure Property” in @Note [Multiple Home Units]@.
    942 
    +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
    943 
    +checkHomeUnitsClosed unit_env
    944 
    +  | null offenders = []
    945 
    +  | otherwise      = [
    946 
    +                        singleMessage                                $
    947 
    +                        mkPlainErrorMsgEnvelope error_source_span    $
    948 
    +                        DriverHomePackagesNotClosed (sort offenders)
    949 
    +                     ]
    944 950 
       where
    945 
    -    home_id_set = HUG.allUnits $ ue_home_unit_graph ue
    946 
    -    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
    947 
    -    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
    948 951
    949 
    -    downwards_closure :: Graph (Node UnitId UnitId)
    950 
    -    downwards_closure = graphFromEdgedVerticesUniq graphNodes
    952 
    +  home_unit_data :: [(UnitId, HomeUnitEnv)]
    953 
    +  home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
    951 954
    952 
    -    inverse_closure = graphReachability $ transposeG downwards_closure
    955 
    +  home_units :: UniqSet UnitId
    956 
    +  home_units = mkUniqSet (map fst home_unit_data)
    953 957
    954 
    -    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
    958 
    +  offenders :: [(UnitId, UnitId)]
    959 
    +  offenders
    960 
    +    = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) $
    961 
    +      Set.empty
    962 
    +    where
    955 963
    956 
    -    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
    957 
    -    all_unit_direct_deps
    958 
    -      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
    964 
    +    collect :: [UnitState] -> State (Set ShortText) [(UnitId, UnitId)]
    965 
    +    collect []
    966 
    +      = pure []
    967 
    +    collect (current_unit_state : remaining_unit_states)
    968 
    +      = (++) <$> collect_for_home_unit
    969 
    +                   (unitInfoMap current_unit_state)
    970 
    +                   (map (toUnitId . fst) $ explicitUnits $ current_unit_state)
    971 
    +             <*> collect remaining_unit_states
    959 972 
           where
    960 
    -        go rest this this_uis =
    961 
    -           plusUniqMap_C Set.union
    962 
    -             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
    963 
    -             rest
    964 
    -           where
    965 
    -             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
    966 
    -             this_units = homeUnitEnv_units this_uis
    967 
    -             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
    968 
    -
    969 
    -    graphNodes :: [Node UnitId UnitId]
    970 
    -    graphNodes = go Set.empty home_id_set
    971 
    -      where
    972 
    -        go done todo
    973 
    -          = case Set.minView todo of
    974 
    -              Nothing -> []
    975 
    -              Just (uid, todo')
    976 
    -                | Set.member uid done -> go done todo'
    977 
    -                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
    978 
    -                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
    979 
    -                    Just depends ->
    980 
    -                      let todo'' = (depends Set.\\ done) `Set.union` todo'
    981 
    -                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
    973 
    +
    974 
    +      collect_for_home_unit :: UnitInfoMap
    975 
    +                            -> [UnitId]
    976 
    +                            -> State (Set ShortText) [(UnitId, UnitId)]
    977 
    +      collect_for_home_unit _ []
    978 
    +        = return []
    979 
    +      collect_for_home_unit unit_info_map (current_unit : remaining_units) = do
    980 
    +        let
    981 
    +
    982 
    +          unit_info :: UnitInfo
    983 
    +          unit_info
    984 
    +            = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $
    985 
    +              lookupUniqMap unit_info_map current_unit
    986 
    +            where
    987 
    +
    988 
    +            unit_not_found_msg :: String
    989 
    +            unit_not_found_msg = "Unit not found during closure property check"
    990 
    +
    991 
    +          abi_hash :: ShortText
    992 
    +          abi_hash = unitAbiHash unit_info
    993 
    +
    994 
    +        has_been_processed <- gets (Set.member abi_hash)
    995 
    +        if has_been_processed
    996 
    +          then collect_for_home_unit unit_info_map remaining_units
    997 
    +          else do
    998 
    +            modify (Set.insert abi_hash)
    999 
    +            let
    1000 
    +
    1001 
    +              needed_units :: [UnitId]
    1002 
    +              needed_units = unitDepends unit_info
    1003 
    +
    1004 
    +              current_offenders :: [(UnitId, UnitId)]
    1005 
    +              current_offenders
    1006 
    +                | current_unit `elementOfUniqSet` home_units
    1007 
    +                  = []
    1008 
    +                | otherwise
    1009 
    +                  = map ((,) current_unit) $
    1010 
    +                    nonDetEltsUniqSet $
    1011 
    +                    mkUniqSet needed_units `intersectUniqSets` home_units
    1012 
    +
    1013 
    +            remaining_offenders <- collect_for_home_unit unit_info_map $
    1014 
    +                                   needed_units ++ remaining_units
    1015 
    +            return $ current_offenders ++ remaining_offenders
    1016 
    +
    1017 
    +  error_source_span :: SrcSpan
    1018 
    +  error_source_span = mkGeneralSrcSpan (fsLit "<command line>")
    982 1019
    983 1020 
     --------------------------------------------------------------------------------
    984 1021 
     -- * Enable Code Gen for Template Haskell
    ... ... @@ -1763,7 +1800,7 @@ data NodeRes v
    1763 1800 
     --
    1764 1801 
     -- See also Note [Downsweep Control Flow and Caching]
    1765 1802 
     dfsBuild :: (Ord k, Monad m)
    1766 
    -         => Maybe (Map.Map k (NodeRes v))
    1803 
    +         => Maybe (Map k (NodeRes v))
    1767 1804 
              -- ^ Base map, existing results. We won't re-expand any of the nodes
    1768 1805 
              -- already present in this map.
    1769 1806 
              -> [n]
    ... ... @@ -1773,7 +1810,7 @@ dfsBuild :: (Ord k, Monad m)
    1773 1810 
              -> (n -> m (NodeRes (v,[n])))
    1774 1811 
              -- ^ Expand this node into its payload result and into the list of
    1775 1812 
              -- children nodes to visit next.
    1776 
    -         -> m (Map.Map k (NodeRes v))
    1813 
    +         -> m (Map k (NodeRes v))
    1777 1814 
              -- ^ The result accumulates the payload of expanding the root nodes
    1778 1815 
              -- and all nodes transitively reachable from those roots.
    1779 1816 
     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
    235 235 
                            "but no output will be generated.") $$
    236 236 
                            (text "There is no module named" <+>
    237 237 
                            quotes (ppr mod_name) <> text "."))
    238 
    -    DriverHomePackagesNotClosed needed_unit_ids
    239 
    -      -> mkSimpleDecorated $ vcat ([text "Home units are not closed."
    240 
    -                                  , text "It is necessary to also load the following units:" ]
    241 
    -                                  ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
    238 
    +    DriverHomePackagesNotClosed offending_dependencies
    239 
    +      -> mkSimpleDecorated $
    240 
    +         hang (text "Some units are not loaded but depend on loaded units.")
    241 
    +              4
    242 
    +              (vcat (map pprDependency offending_dependencies))
    243 
    +      where
    244 
    +
    245 
    +        pprDependency :: (UnitId, UnitId) -> SDoc
    246 
    +        pprDependency (external_unit, home_unit)
    247 
    +          = ppr external_unit <+> arrow <+> ppr home_unit
    248 
    +
    242 249 
         DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason
    243 250
    244 251 
         DriverInconsistentDynFlags msg

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -369,7 +369,7 @@ data DriverMessage where
    369 369
    370 370 
       DriverRedirectedNoMain :: !ModuleName -> DriverMessage
    371 371
    372 
    -  DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
    372 
    +  DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage
    373 373
    374 374 
       DriverInterfaceError :: !IfaceMessage -> DriverMessage
    375 375

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -443,13 +443,11 @@ The flow:
    443 443 
     Closure Property
    444 444 
     ----------------
    445 445
    446 
    -You must perform a clean cut of the dependency graph.
    447 
    -
    448 
    -> Any dependency which is not a home unit must not (transitively) depend on a home unit.
    449 
    -
    450 
    -For example, if you have three packages p, q and r, then if p depends on q which
    451 
    -depends on r then it is illegal to load both p and r as home units but not q,
    452 
    -because q is a dependency of the home unit p which depends on another home unit r.
    446 
    +A unit environment must have the closure property, which means that, whenever
    447 
    +some units @h₁@ and @h₂@ have been loaded as home units, @h₁@ does not directly
    448 
    +or indirectly depend on an external unit that directly or indirectly depends
    449 
    +on @h₂@. 'GHC.Driver.Downsweep.checkHomeUnitsClosed' checks whether a given unit
    450 
    +environment indeed has this property.
    453 451
    454 452 
     Offsetting Paths
    455 453 
     ----------------

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/755cf854150d85be469d6ad0d14cc6b47355619f at 1787741948