summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-06-01 16:11:37 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-06-02 16:24:27 -0400
commitb66cf8ad218264593efc8bceddc86c53ce89bbeb (patch)
tree3ef17dec7854d6b7b7b6890293113c16f57d2a7b
parent852a12c82830f25b2d7db5a4ab9d098c71203905 (diff)
downloadhaskell-b66cf8ad218264593efc8bceddc86c53ce89bbeb.tar.gz
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.
-rw-r--r--compiler/GHC/Driver/Env.hs20
1 files 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)