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

Commits:

9 changed files:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -54,7 +54,6 @@ 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
    59 58 
     import GHC.Data.Maybe      ( expectJust )
    60 59 
     import qualified GHC.Data.Maybe as M
    ... ... @@ -71,12 +70,14 @@ import GHC.Utils.Logger
    71 70 
     import GHC.Utils.Fingerprint
    72 71 
     import GHC.Utils.TmpFs
    73 72 
     import GHC.Utils.Constants
    73 
    +import GHC.Utils.Monad.State.Strict
    74 74
    75 75 
     import GHC.Types.Error
    76 76 
     import GHC.Types.Target
    77 77 
     import GHC.Types.SourceFile
    78 78 
     import GHC.Types.SourceError
    79 79 
     import GHC.Types.SrcLoc
    80 
    +import GHC.Types.Unique.Set
    80 81 
     import GHC.Types.Unique.Map
    81 82 
     import GHC.Types.PkgQual
    82 83 
     import GHC.Types.Basic
    ... ... @@ -91,9 +92,12 @@ import GHC.Unit.Module.Graph
    91 92 
     import GHC.Unit.Module.Deps
    92 93 
     import qualified GHC.Unit.Home.Graph as HUG
    93 94 
     import GHC.Unit.Module.Stage
    95 
    +import GHC.Unit.External.Index (GlobalUnitKey, mkGlobalUnitKey)
    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 GlobalUnitKey) [(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 GlobalUnitKey) [(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 
    +          global_unit_key :: GlobalUnitKey
    992 
    +          global_unit_key = mkGlobalUnitKey current_unit (unitAbiHash unit_info)
    993 
    +
    994 
    +        has_been_processed <- gets (Set.member global_unit_key)
    995 
    +        if has_been_processed
    996 
    +          then collect_for_home_unit unit_info_map remaining_units
    997 
    +          else do
    998 
    +            modify (Set.insert global_unit_key)
    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/Driver/Session/Units.hs
    ... ... @@ -145,8 +145,15 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
    145 145 
       checkUnitCycles initial_dflags home_unit_graph
    146 146
    147 147 
       let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph
    148 
    -  unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
    149 
    -  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
    148 
    +  newUnitEnv <-  do
    149 
    +    env <- liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
    150 
    +    -- We need to reuse the 'UnitIndexCache' as we used it above in 'initUnits'.
    151 
    +    -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] why this must be shared.
    152 
    +    pure $ assertUnitEnvInvariant $ env
    153 
    +      { ue_uic = hscUIC hsc_env
    154 
    +      }
    155 
    +
    156 
    +  let final_hsc_env = hsc_env { hsc_unit_env = newUnitEnv }
    150 157
    151 158 
       GHC.setSession final_hsc_env
    152 159

  • 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 
     ----------------

  • compiler/GHC/Unit/External/Index.hs
    ... ... @@ -308,6 +308,7 @@ data GlobalUnitKey =
    308 308 
       GlobalUnitKey
    309 309 
         !UnitId -- ^ Unit Id of the 'UnitInfo'
    310 310 
         !UnitAbiHash -- ^ ABI hash of the 'UnitInfo'
    311 
    +  deriving (Eq, Ord)
    311 312
    312 313 
     globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey
    313 314 
     globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui)

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile
    ... ... @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 5 
     SETUP=../Setup -v0
    6 
    +CONFIGURE=configure \
    7 
    +	  $(CABAL_MINIMAL_BUILD) \
    8 
    +	  --with-ghc='$(TEST_HC)' \
    9 
    +	  --with-hc-pkg='$(GHC_PKG)' \
    10 
    +	  --ghc-options='$(TEST_HC_OPTS)' \
    11 
    +	  --package-db=../tmp.d
    12 
    +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp
    13 
    +ONLY_BASE=-hide-all-packages -package base
    6 14
    7 
    -mhu-closure: clean
    8 
    -	$(MAKE) -s --no-print-directory clean
    15 
    +mhu-closure: clean pkg-database
    16 
    +	! $(TEST_BUILD) -unit @unitP
    17 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ
    18 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR
    19 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR1
    20 
    +	$(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR
    21 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1
    22 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP
    23 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ
    24 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR
    25 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1
    26 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR
    27 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1
    28 
    +
    29 
    +.PHONY: pkg-database
    30 
    +pkg-database:
    9 31 
     	'$(GHC_PKG)' init tmp.d
    10 32 
     	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
    11 
    -	cd p && $(SETUP) clean
    12 
    -	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
    33 
    +	cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0
    13 34 
     	cd p && $(SETUP) build
    14 35 
     	cd p && $(SETUP) register --inplace
    15 
    -	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
    36 
    +	cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0
    16 37 
     	cd q && $(SETUP) build
    17 38 
     	cd q && $(SETUP) register --inplace
    18 
    -	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
    39 
    +	cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0
    19 40 
     	cd r && $(SETUP) build
    20 41 
     	cd r && $(SETUP) register --inplace
    21 
    -	# This should work
    22 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP
    23 
    -	# So should this
    24 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ
    25 
    -	# So should this
    26 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR
    27 
    -	# This should error with a closure message
    28 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR
    29 
    -	# This should work, even though r1 is not in the package db
    30 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1
    31 
    -	# This should fail, even though r1 is not in the package db
    32 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1
    33 42
    43 
    +.PHONY: clean
    44 
    +clean:
    45 
    +	$(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o
    34 46
    35 47 
     ifeq "$(CLEANUP)" "1"
    36 48 
     	$(MAKE) -s --no-print-directory clean
    37 49 
     endif
    38 
    -
    39 
    -clean :
    40 
    -	 $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
    41 
    -

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr
    1 1
    2 2 
     <command line>: error: [GHC-03271]
    3 
    -    Home units are not closed.
    4 
    -    It is necessary to also load the following units:
    5 
    -    - q-0.1.0.0
    3 
    +    Some units are not loaded but depend on loaded units.
    4 
    +        q-0.1.0.0 -> p-0.1.0.0
    6 5
    7 6 
     <command line>: error: [GHC-03271]
    8 
    -    Home units are not closed.
    9 
    -    It is necessary to also load the following units:
    10 
    -    - q-0.1.0.0
    7 
    +    Some units are not loaded but depend on loaded units.
    8 
    +        r-0.1.0.0 -> q-0.1.0.0
    9 
    +
    10 
    +<command line>: error: [GHC-03271]
    11 
    +    Some units are not loaded but depend on loaded units.
    12 
    +        q-0.1.0.0 -> p-0.1.0.0
    13 
    +
    14 
    +<command line>: error: [GHC-03271]
    15 
    +    Some units are not loaded but depend on loaded units.
    16 
    +        q-0.1.0.0 -> p-0.1.0.0
    17 
    +
    18 
    +<command line>: error: [GHC-03271]
    19 
    +    Some units are not loaded but depend on loaded units.
    20 
    +        r-0.1.0.0 -> q-0.1.0.0
    21 
    +
    22 
    +<command line>: error: [GHC-03271]
    23 
    +    Some units are not loaded but depend on loaded units.
    24 
    +        q-0.1.0.0 -> p-0.1.0.0
    25 
    +
    26 
    +<command line>: error: [GHC-03271]
    27 
    +    Some units are not loaded but depend on loaded units.
    28 
    +        q-0.1.0.0 -> p-0.1.0.0

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout
    1 
    +[1 of 3] Compiling P[p-0.1.0.0]
    2 
    +[2 of 3] Compiling Q[q-0.1.0.0]
    3 
    +[3 of 3] Compiling R[r-0.1.0.0]
    1 4 
     [1 of 1] Compiling P
    2 5 
     [1 of 2] Compiling P[p-0.1.0.0]
    3 6 
     [2 of 2] Compiling Q[q-0.1.0.0]

    • —
    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/-/compare/ebd3f23d37929fe81704bafb51069ddef5f599c6...ad88ceb0d01859de0ad4fcf5e5cd1e5f148de9ff at 1787770697