summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-10-18 13:40:23 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-10-20 14:07:49 -0400
commit05b8a21884fb3b283acb7d148afc875a95f7752c (patch)
treed41b6dcdb9ef529593ab45d3c1e8d82c5db847d0
parentef92d88928651fa21b3b23d054f8a97d7b6104cd (diff)
downloadhaskell-05b8a21884fb3b283acb7d148afc875a95f7752c.tar.gz
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
-rw-r--r--compiler/GHC/Data/Bag.hs10
-rw-r--r--compiler/GHC/Rename/Env.hs5
-rw-r--r--compiler/GHC/Rename/Names.hs3
-rw-r--r--compiler/GHC/Rename/Unbound.hs7
-rw-r--r--compiler/GHC/Rename/Utils.hs3
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs7
-rw-r--r--compiler/GHC/Types/Name/Reader.hs45
-rw-r--r--testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs3
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