From 943d2ca2d138b03ef3e0825e378dd6f4b92c3c11 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Tue, 1 Jun 2021 16:11:37 +0100 Subject: Fix infinite looping in hptSomeModulesBelow When compiling Agda we entered into an infinite loop as the stopping condition was a bit wrong in hptSomeModulesBelow. The bad situation was something like * We would see module A (NotBoot) and follow it dependencies * Later on we would encounter A (Boot) and follow it's dependencies, because the lookup would not match A (NotBoot) and A (IsBoot) * Somewhere in A (Boot)s dependencies, A (Boot) would appear again and lead us into an infinite loop. Now the state marks whether we have been both variants (IsBoot and NotBoot) so we don't follow dependencies for A (Boot) many times. --- compiler/GHC/Driver/Env.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index fe0137c786..1948a91927 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -223,26 +223,34 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) hptModulesBelow :: HscEnv -> [ModuleNameWithIsBoot] -> Set.Set ModuleNameWithIsBoot -hptModulesBelow hsc_env mn = Set.fromList (eltsUFM $ go mn emptyUFM) +hptModulesBelow hsc_env mn = Set.fromList (map fst (eltsUFM $ go mn emptyUFM)) where hpt = hsc_HPT hsc_env go [] seen = seen go (mn:mns) seen - | Just mn' <- lookupUFM seen (gwib_mod mn) + | Just (mn', both) <- lookupUFM seen (gwib_mod mn) -- Already seen the module before - , gwib_isBoot mn' == gwib_isBoot mn = go mns seen + , gwib_isBoot mn' == gwib_isBoot mn + || both = go mns seen | otherwise = case lookupHpt hpt (gwib_mod mn) of -- Not a home module Nothing -> go mns seen Just hmi -> let - comb m@(GWIB { gwib_isBoot = NotBoot }) _ = m - comb (GWIB { gwib_isBoot = IsBoot }) x = x + -- The bool indicates if we have seen *both* the + -- NotBoot and IsBoot versions + comb :: (GenWithIsBoot ModuleName, Bool) + -> (GenWithIsBoot ModuleName, Bool) + -> (GenWithIsBoot ModuleName, Bool) + comb (o@(GWIB { gwib_isBoot = NotBoot }), b) _ = + (o, IsBoot == gwib_isBoot mn || b) + comb ((GWIB { gwib_isBoot = IsBoot }, _)) (new_gwib, _) = + (new_gwib, NotBoot == gwib_isBoot mn) in go (dep_direct_mods (mi_deps (hm_iface hmi)) ++ mns) - (addToUFM_C comb seen (gwib_mod mn) mn) + (addToUFM_C comb seen (gwib_mod mn) (mn, False)) -- | Get things from modules "below" this one (in the dependency sense) -- cgit v1.2.1