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

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index a48922a..8248b5f 100644 (file)
--- 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,
        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, 
 
        -- * 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
 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
 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
 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
 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 (file)
--- 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
                                        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)
   where
     occ = nameOccName (gre_name gre)

-    add gres _ = gre:gres

 
 lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
 lookupGRE_RdrName rdr_name env
 
 lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
 lookupGRE_RdrName rdr_name env

@@ -515,9 +514,9 @@ mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv
 mkGlobalRdrEnv gres
   = foldr add emptyGlobalRdrEnv gres
   where
 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
 
 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 (file)
--- 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,
        -- ** 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,
        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
 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
                  
 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
 elemVarEnvByKey  = elemUFM_Directly
 extendVarEnv    = addToUFM
 extendVarEnv_C  = addToUFM_C

+extendVarEnv_Acc = addToUFM_Acc

 extendVarEnvList = addListToUFM
 plusVarEnv_C    = plusUFM_C
 delVarEnvList   = delListFromUFM
 extendVarEnvList = addListToUFM
 plusVarEnv_C    = plusUFM_C
 delVarEnvList   = delListFromUFM

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 8037449..55fcea2 100644 (file)
--- 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
 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]
        add _                                            env = env
 
 findChildren :: NameEnv [Name] -> Name -> [Name]

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 2199ab1..d33a68e 100644 (file)
--- 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]
   | 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
     fvs2 = fvs1 `unionVarSet`  freeVarsCoI co
                `extendVarSet` case_bndr
                `extendVarSet` scrut1