diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-06-01 16:11:37 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-02 16:24:27 -0400 |
commit | b66cf8ad218264593efc8bceddc86c53ce89bbeb (patch) | |
tree | 3ef17dec7854d6b7b7b6890293113c16f57d2a7b | |
parent | 852a12c82830f25b2d7db5a4ab9d098c71203905 (diff) | |
download | haskell-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.hs | 20 |
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) |