From 65277a1c9ff86c28c656849d6f6cbb392f1eb3e7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 4 Dec 2009 15:50:36 +0000 Subject: [PATCH] Use addToUFM_Acc where appropriate This way of extending a UniqFM has existed for some time, but we weren't really using it. addToUFM_Acc :: Uniquable key => (elt -> elts -> elts) -- Add to existing -> (elt -> elts) -- New element -> UniqFM elts -- old -> key -> elt -- new -> UniqFM elts -- result --- compiler/basicTypes/OccName.lhs | 4 +++- compiler/basicTypes/RdrName.lhs | 9 ++++----- compiler/basicTypes/VarEnv.lhs | 4 +++- compiler/rename/RnNames.lhs | 2 +- compiler/simplCore/OccurAnal.lhs | 5 +++-- 5 files changed, 14 insertions(+), 10 deletions(-) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index a48922a..8248b5f 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -75,7 +75,7 @@ module OccName ( OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - filterOccEnv, delListFromOccEnv, delFromOccEnv, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, @@ -335,6 +335,7 @@ elemOccEnv :: OccName -> OccEnv a -> Bool foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b occEnvElts :: OccEnv a -> [a] extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b @@ -354,6 +355,7 @@ occEnvElts (A x) = eltsUFM x plusOccEnv (A x) (A y) = A $ plusUFM x y plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z mapOccEnv f (A x) = A $ mapUFM f x mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l delFromOccEnv (A x) y = A $ delFromUFM x y diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index ed6bd43..a33c243 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -428,10 +428,9 @@ lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of Just gres -> gres extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre = extendOccEnv_C add env occ [gre] +extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre where occ = nameOccName (gre_name gre) - add gres _ = gre:gres lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env @@ -515,9 +514,9 @@ mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv mkGlobalRdrEnv gres = foldr add emptyGlobalRdrEnv gres where - add gre env = extendOccEnv_C (foldr insertGRE) env - (nameOccName (gre_name gre)) - [gre] + add gre env = extendOccEnv_Acc insertGRE singleton env + (nameOccName (gre_name gre)) + gre findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]]) -- ^ For each 'OccName', see if there are multiple local definitions diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index 2699748..2ee5ea5 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -11,7 +11,7 @@ module VarEnv ( -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, elemVarEnv, varEnvElts, varEnvKeys, - extendVarEnv, extendVarEnv_C, extendVarEnvList, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, @@ -316,6 +316,7 @@ zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a @@ -344,6 +345,7 @@ elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C delVarEnvList = delListFromUFM diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 8037449..55fcea2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -722,7 +722,7 @@ gresFromIE decl_spec (L loc ie, avail) mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name] mkChildEnv gres = foldr add emptyNameEnv gres where - add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_C (++) env p [n] + add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n add _ env = env findChildren :: NameEnv [Name] -> Name -> [Name] diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 2199ab1..d33a68e 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -1370,8 +1370,9 @@ extendProxyEnv pe scrut co case_bndr | otherwise = PE env2 fvs2 -- don't extend where PE env1 fvs1 = trimProxyEnv pe [case_bndr] - env2 = extendVarEnv_C add env1 scrut1 (scrut1, [(case_bndr,co)]) - add (x, cb_cos) _ = (x, (case_bndr,co):cb_cos) + env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co) + single cb_co = (scrut1, [cb_co]) + add cb_co (x, cb_cos) = (x, cb_co:cb_cos) fvs2 = fvs1 `unionVarSet` freeVarsCoI co `extendVarSet` case_bndr `extendVarSet` scrut1 -- 1.7.10.4