[project @ 2005-07-19 16:44:50 by simonpj]

[ghc-hetmet.git] / ghc / compiler / utils / UniqFM.lhs

diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index aa357b8..d2676bf 100644 (file)
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -19,7 +19,7 @@ module UniqFM (
        unitDirectlyUFM,
        listToUFM,
        listToUFM_Directly,
-       addToUFM,addToUFM_C,
+       addToUFM,addToUFM_C,addToUFM_Acc,
        addListToUFM,addListToUFM_C,
        addToUFM_Directly,
        addListToUFM_Directly,
@@ -82,6 +82,13 @@ addToUFM_C   :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
                           -> key -> elt                -- new
                           -> UniqFM elt                -- result
 
+addToUFM_Acc   :: Uniquable key =>
+                             (elt -> elts -> elts)     -- Add to existing
+                          -> (elt -> elts)             -- New element
+                          -> UniqFM elts               -- old
+                          -> key -> elt                -- new
+                          -> UniqFM elts               -- result
+
 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
                           -> UniqFM elt -> [(key,elt)]
                           -> UniqFM elt
@@ -245,6 +252,11 @@ addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
 addToUFM_C combiner fm key elt
   = insert_ele combiner fm (getKey# (getUnique key)) elt
 
+addToUFM_Acc add unit fm key item
+  = insert_ele combiner fm (getKey# (getUnique key)) (unit item)
+  where
+    combiner old _unit_item = add item old
+
 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
 
@@ -334,25 +346,25 @@ plusUFM_C f fm1 fm2       = mix_trees fm1 fm2
                --     t1   t2      t1'   t2'                 t1   t2 + j'
                --                                                     / \
                --                                                   t1'  t2'
-         mix_branches (LeftRoot Leftt) -- | trace "LL" True
+         mix_branches (LeftRoot Leftt) --  | trace "LL" True
            = mkSLNodeUFM
                (NodeUFMData j p)
                (mix_trees t1 right_t)
                t2
 
-         mix_branches (LeftRoot Rightt) -- | trace "LR" True
+         mix_branches (LeftRoot Rightt) --  | trace "LR" True
            = mkLSNodeUFM
                (NodeUFMData j p)
                t1
                (mix_trees t2 right_t)
 
-         mix_branches (RightRoot Leftt) -- | trace "RL" True
+         mix_branches (RightRoot Leftt) --  | trace "RL" True
            = mkSLNodeUFM
                (NodeUFMData j' p')
                (mix_trees left_t t1')
                t2'
 
-         mix_branches (RightRoot Rightt) -- | trace "RR" True
+         mix_branches (RightRoot Rightt) --  | trace "RR" True
            = mkLSNodeUFM
                (NodeUFMData j' p')
                t1'
@@ -659,7 +671,7 @@ and if necessary do $\lambda$ lifting on our functions that are bound.
 
 \begin{code}
 insert_ele
-       :: (a -> a -> a)
+       :: (a -> a -> a)        -- old -> new -> result
        -> UniqFM a
        -> FastInt
        -> a