diff options
| -rw-r--r-- | compiler/GHC/Driver/Env.hs | 38 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/Graph.hs | 30 |
2 files changed, 33 insertions, 35 deletions
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 492adc82cc..13898f85f4 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} module GHC.Driver.Env ( Hsc(..) @@ -84,10 +83,7 @@ import GHC.Utils.Logger import Data.IORef import qualified Data.Set as Set -import Data.Set (Set) import GHC.Unit.Module.Graph -import Data.List (sort) -import qualified Data.Map as Map runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do @@ -267,35 +263,6 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd) (hugElts (hsc_HUG hsc_env)) --- | This function returns all the modules belonging to the home-unit that can --- be reached by following the given dependencies. Additionally, if both the --- boot module and the non-boot module can be reached, it only returns the --- non-boot one. -hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid -hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below] - where - td_map = mgTransDeps (hsc_mod_graph hsc_env) - - modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map - - filtered_mods = Set.fromDistinctAscList . filter_mods . sort - - -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list - -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a - -- linear sweep with a window of size 2 to remove boot modules for which we - -- have the corresponding non-boot. - filter_mods = \case - (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) - | m1 == m2 && uid1 == uid2 -> - let !r' = case b1 of - NotBoot -> r1 - IsBoot -> r2 - in r' : filter_mods rs - | otherwise -> r1 : filter_mods (r2:rs) - rs -> rs - - - -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a] @@ -304,11 +271,12 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn | otherwise = let hug = hsc_HUG hsc_env + mg = hsc_mod_graph hsc_env in [ thing | -- Find each non-hi-boot module below me - (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn) + (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn) , include_hi_boot || (is_boot == NotBoot) -- unsavoury: when compiling the base package with --make, we @@ -324,7 +292,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty msg = vcat [text "missing module" <+> ppr mod, text "When starting from" <+> ppr mn, - text "below:" <+> ppr (hptModulesBelow hsc_env uid mn), + text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn), text "Probable cause: out-of-date interface files"] -- This really shouldn't happen, but see #962 , thing <- things diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index 3de0bd2aee..1c273e4d32 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -22,6 +22,7 @@ module GHC.Unit.Module.Graph , showModMsg , moduleGraphNodeModule , moduleGraphNodeModSum + , moduleGraphModulesBelow , moduleGraphNodes , SummaryNode @@ -62,12 +63,14 @@ import System.FilePath import qualified Data.Map as Map import GHC.Types.Unique.DSet import qualified Data.Set as Set +import Data.Set (Set) import GHC.Unit.Module import GHC.Linker.Static.Utils import Data.Bifunctor import Data.Either import Data.Function +import Data.List (sort) import GHC.Data.List.SetOps -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. @@ -385,3 +388,30 @@ msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) type ModNodeKey = ModuleNameWithIsBoot + +-- | This function returns all the modules belonging to the home-unit that can +-- be reached by following the given dependencies. Additionally, if both the +-- boot module and the non-boot module can be reached, it only returns the +-- non-boot one. +moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid +moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below] + where + td_map = mgTransDeps mg + + modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map + + filtered_mods = Set.fromDistinctAscList . filter_mods . sort + + -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list + -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a + -- linear sweep with a window of size 2 to remove boot modules for which we + -- have the corresponding non-boot. + filter_mods = \case + (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) + | m1 == m2 && uid1 == uid2 -> + let !r' = case b1 of + NotBoot -> r1 + IsBoot -> r2 + in r' : filter_mods rs + | otherwise -> r1 : filter_mods (r2:rs) + rs -> rs |