From 5939c94de186653dfb2f02d5203b0d5a8aaa75ce Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 18 Oct 2021 13:40:23 +0100 Subject: Make fields of GlobalRdrElt strict In order to do this I thought it was prudent to change the list type to a bag type to avoid doing a lot of premature work in plusGRE because of ++. Fixes #19201 --- compiler/GHC/Data/Bag.hs | 10 ++++- compiler/GHC/Rename/Env.hs | 5 ++- compiler/GHC/Rename/Names.hs | 3 +- compiler/GHC/Rename/Unbound.hs | 7 ++-- compiler/GHC/Rename/Utils.hs | 3 +- compiler/GHC/Tc/Errors/Hole/FitTypes.hs | 7 +++- compiler/GHC/Types/Name/Reader.hs | 45 +++++++++++----------- .../tests/plugins/hole-fit-plugin/HoleFitPlugin.hs | 3 +- 8 files changed, 50 insertions(+), 33 deletions(-) diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs index e0e43d5ad1..4171d7b03e 100644 --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -17,7 +17,7 @@ module GHC.Data.Bag ( filterBag, partitionBag, partitionBagWith, concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, - listToBag, nonEmptyToBag, bagToList, mapAccumBagL, + listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, @@ -33,7 +33,7 @@ import GHC.Utils.Misc import GHC.Utils.Monad import Control.Monad import Data.Data -import Data.Maybe( mapMaybe ) +import Data.Maybe( mapMaybe, listToMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable @@ -308,6 +308,12 @@ nonEmptyToBag (x :| xs) = ListBag (x : xs) bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b +headMaybe :: Bag a -> Maybe a +headMaybe EmptyBag = Nothing +headMaybe (UnitBag v) = Just v +headMaybe (TwoBags b1 _) = headMaybe b1 +headMaybe (ListBag l) = listToMaybe l + instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index f742e60311..3e99b18e20 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -102,6 +102,7 @@ import qualified Data.List.NonEmpty as NE import Control.Arrow ( first ) import Data.Function import GHC.Types.FieldLabel +import GHC.Data.Bag {- ********************************************************* @@ -1568,7 +1569,7 @@ addUsedGREs gres warnIfDeprecated :: GlobalRdrElt -> RnM () warnIfDeprecated gre@(GRE { gre_imp = iss }) - | (imp_spec : _) <- iss + | Just imp_spec <- headMaybe iss = do { dflags <- getDynFlags ; this_mod <- getModule ; when (wopt Opt_WarnWarningsDeprecations dflags && @@ -1689,7 +1690,7 @@ lookupOneQualifiedNameGHCi fos rdr_name = do -- -fimplicit-import-qualified is used with a module that exports the same -- field name multiple times (see -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). - toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] } + toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is } is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } , is_item = ImpAll } -- If -fimplicit-import-qualified succeeded, the name must be qualified. diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 7392b76c64..c3d10a9237 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -95,6 +95,7 @@ import qualified Data.Set as S import System.FilePath (()) import System.IO +import GHC.Data.Bag {- ************************************************************************ @@ -1769,7 +1770,7 @@ mkImportMap gres RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map UnhelpfulLoc _ -> imp_map where - best_imp_spec = bestImport imp_specs + best_imp_spec = bestImport (bagToList imp_specs) add _ gres = gre : gres warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 7f62c11fce..6139ee8a8e 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -50,6 +50,7 @@ import GHC.Unit.Home.ModInfo import Data.List (sortBy, partition, nub) import Data.Function ( on ) +import GHC.Data.Bag {- ************************************************************************ @@ -263,7 +264,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) | lcl = [ Left (greDefinitionSrcSpan gre) ] | otherwise = [ Right ispec - | i <- is, let ispec = is_decl i + | i <- bagToList is, let ispec = is_decl i , not (is_qual ispec) ] @@ -272,7 +273,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) - | i <- is, let ispec = is_decl i, is_qual ispec ] + | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor @@ -422,7 +423,7 @@ qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } Nothing -> [] Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] | otherwise = [ (is_as ispec, Right ispec) - | i <- is, let ispec = is_decl i ] + | i <- bagToList is, let ispec = is_decl i ] isGreOk :: LookingFor -> GlobalRdrElt -> Bool isGreOk (LF what_look where_look) gre = what_ok && where_ok diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 9642617570..fc27dac004 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -65,6 +65,7 @@ import Data.List (find, sortBy) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Bag {- ********************************************************* @@ -566,7 +567,7 @@ addNameClashErrRn rdr_name gres pp_qual name | lcl = ppr (nameModule name) - | imp : _ <- iss -- This 'imp' is the one that + | Just imp <- headMaybe iss -- This 'imp' is the one that -- pprNameProvenance chooses , ImpDeclSpec { is_as = mod } <- is_decl imp = ppr mod diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 9c00c23cd1..70a655db45 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -42,7 +42,12 @@ instance Outputable TypedHole where data HoleFitCandidate = IdHFCand Id -- An id, like locals. | NameHFCand Name -- A name, like built-in syntax. | GreHFCand GlobalRdrElt -- A global, like imported ids. - deriving (Eq) + +instance Eq HoleFitCandidate where + IdHFCand i1 == IdHFCand i2 = i1 == i2 + NameHFCand n1 == NameHFCand n2 = n1 == n2 + GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2 + _ == _ = False instance Outputable HoleFitCandidate where ppr = pprHoleFitCand diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index f07df72f9c..864101e8a9 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -98,6 +98,7 @@ import GHC.Types.Name.Env import Data.Data import Data.List( sortBy ) +import GHC.Data.Bag {- ************************************************************************ @@ -485,11 +486,11 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt] -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt - = GRE { gre_name :: GreName -- ^ See Note [GreNames] - , gre_par :: Parent -- ^ See Note [Parents] - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports - } deriving (Data, Eq) + = GRE { gre_name :: !GreName -- ^ See Note [GreNames] + , gre_par :: !Parent -- ^ See Note [Parents] + , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally + , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports + } deriving (Data) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] @@ -671,17 +672,17 @@ gresFromAvail prov_fn avail = case prov_fn n of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = [] } + , gre_lcl = True, gre_imp = emptyBag } Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = [is] } + , gre_lcl = False, gre_imp = unitBag is } mk_fld_gre fl = case prov_fn (flSelector fl) of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = True, gre_imp = [] } + , gre_lcl = True, gre_imp = emptyBag } Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = False, gre_imp = [is] } + , gre_lcl = False, gre_imp = unitBag is } instance HasOccName GlobalRdrElt where occName = greOccName @@ -714,18 +715,18 @@ greQualModName :: GlobalRdrElt -> ModuleName -- Prerecondition: the greMangledName is always External greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | lcl, Just mod <- greDefinitionModule gre = moduleName mod - | (is:_) <- iss = is_as (is_decl is) + | Just is <- headMaybe iss = is_as (is_decl is) | otherwise = pprPanic "greQualModName" (ppr gre) greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) + = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) where occ = greOccName gre unqual = Unqual occ do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] + | is_qual decl_spec = unitBag qual + | otherwise = listToBag [unqual,qual] where qual = Qual (is_as decl_spec) occ -- the SrcSpan that pprNameProvenance prints out depends on whether @@ -736,7 +737,7 @@ greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } greSrcSpan :: GlobalRdrElt -> SrcSpan greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) | lcl = greDefinitionSrcSpan gre - | (is:_) <- iss = is_dloc (is_decl is) + | Just is <- headMaybe iss = is_dloc (is_decl is) | otherwise = pprPanic "greSrcSpan" (ppr gre) mkParent :: Name -> AvailInfo -> Parent @@ -896,7 +897,7 @@ getGRE_NameQualifier_maybes env name where qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) iss + | otherwise = Just $ map (is_as . is_decl) (bagToList iss) isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_lcl = lcl }) = lcl @@ -983,14 +984,14 @@ pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl, null iss' = Nothing | otherwise = Just (gre { gre_imp = iss' }) where - iss' = filter unQualSpecOK iss + iss' = filterBag unQualSpecOK iss pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl', null iss' = Nothing | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) where - iss' = filter (qualSpecOK mod) iss + iss' = filterBag (qualSpecOK mod) iss lcl' = lcl && name_is_from mod name_is_from :: ModuleName -> Bool @@ -1047,7 +1048,7 @@ plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt plusGRE g1 g2 = GRE { gre_name = gre_name g1 , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 ++ gre_imp g2 + , gre_imp = gre_imp g1 `unionBags` gre_imp g2 , gre_par = gre_par g1 `plusParent` gre_par g2 } transformGREs :: (GlobalRdrElt -> GlobalRdrElt) @@ -1160,9 +1161,9 @@ shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres)) -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) where - iss' = lcl_imp ++ mapMaybe set_qual iss - lcl_imp | lcl = [mk_fake_imp_spec old_gre old_mod] - | otherwise = [] + iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss + lcl_imp | lcl = listToBag [mk_fake_imp_spec old_gre old_mod] + | otherwise = emptyBag mk_fake_imp_spec old_gre old_mod -- Urgh! = ImpSpec id_spec ImpAll @@ -1338,7 +1339,7 @@ pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss }) (head pp_provs) where name = greMangledName gre - pp_provs = pp_lcl ++ map pp_is iss + pp_provs = pp_lcl ++ map pp_is (bagToList iss) pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] pp_is is = sep [ppr is, ppr_defn_site is name] diff --git a/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs index fe95cb6633..e9f504d92d 100644 --- a/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs +++ b/testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs @@ -10,6 +10,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Monad import Text.Read +import GHC.Data.Bag @@ -28,7 +29,7 @@ initPlugin _ = newTcRef $ HPS 0 Nothing fromModule :: HoleFitCandidate -> [String] fromModule (GreHFCand gre) = - map (moduleNameString . importSpecModule) $ gre_imp gre + map (moduleNameString . importSpecModule) $ (bagToList (gre_imp gre)) fromModule _ = [] toHoleFitCommand :: TypedHole -> String -> Maybe String -- cgit v1.2.1