X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUniqFM.lhs;h=84294aae0d6ffc15a31601af98ad18eb2822e05b;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=18efa0e4c53f782a27eec8210fc2b81ae1a21080;hpb=1f5e55804b97d2b9a77207d568d602ba88d8855d;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 18efa0e..84294aa 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -1,4 +1,4 @@
-%
+%ilter
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
 \section[UniqFM]{Specialised finite maps, for things with @Uniques@}
@@ -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,
@@ -33,8 +33,8 @@ module UniqFM (
 	intersectUFM_C,
 	foldUFM,
 	mapUFM,
-	elemUFM,
-	filterUFM,
+	elemUFM, elemUFM_Directly,
+	filterUFM, filterUFM_Directly,
 	sizeUFM,
 	hashUFM,
 	isNullUFM,
@@ -46,10 +46,8 @@ module UniqFM (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Name	( Name )
-
 import Unique		( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
-import Panic
+import Maybes		( maybeToBool )
 import FastTypes
 import Outputable
 
@@ -84,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
@@ -105,10 +110,12 @@ intersectUFM_C	:: (elt1 -> elt2 -> elt3)
 foldUFM		:: (elt -> a -> a) -> a -> UniqFM elt -> a
 mapUFM		:: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
 filterUFM	:: (elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
 
 sizeUFM		:: UniqFM elt -> Int
 hashUFM		:: UniqFM elt -> Int
 elemUFM		:: Uniquable key => key -> UniqFM elt -> Bool
+elemUFM_Directly:: Unique -> UniqFM elt -> Bool
 
 lookupUFM	:: Uniquable key => UniqFM elt -> key -> Maybe elt
 lookupUFM_Directly  -- when you've got the Unique already
@@ -194,6 +201,7 @@ data UniqFM ele
 	    FastInt	    -- the delta
 	    (UniqFM ele)
 	    (UniqFM ele)
+-- INVARIANT: the children of a NodeUFM are never EmptyUFMs
 
 {-
 -- for debugging only :-)
@@ -245,6 +253,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 +347,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'
@@ -514,7 +527,14 @@ mapUFM fn EmptyUFM    = EmptyUFM
 mapUFM fn fm	      = map_tree fn fm
 
 filterUFM fn EmptyUFM = EmptyUFM
-filterUFM fn fm	      = filter_tree fn fm
+filterUFM fn fm	      = filter_tree pred fm
+	where
+	  pred (i::FastInt) e = fn e
+
+filterUFM_Directly fn EmptyUFM = EmptyUFM
+filterUFM_Directly fn fm       = filter_tree pred fm
+	where
+	  pred i e = fn (mkUniqueGrimily (iBox i)) e
 \end{code}
 
 Note, this takes a long time, O(n), but
@@ -541,9 +561,8 @@ looking up in a hurry is the {\em whole point} of this binary tree lark.
 Lookup up a binary tree is easy (and fast).
 
 \begin{code}
-elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
-			Nothing -> False
-			Just _  -> True
+elemUFM          key fm = maybeToBool (lookupUFM fm key)
+elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
 
 lookupUFM	   fm key = lookUp fm (getKey# (getUnique key))
 lookupUFM_Directly fm key = lookUp fm (getKey# key)
@@ -652,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
@@ -698,19 +717,20 @@ insert_ele f n@(NodeUFM j p t1 t2) i a
 
 \begin{code}
 map_tree f (NodeUFM j p t1 t2)
-  = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
+  = mkLLNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
+	-- NB. lazy! we know the tree is well-formed.
 map_tree f (LeafUFM i obj)
   = mkLeafUFM i (f obj)
-
 map_tree f _ = panic "map_tree failed"
 \end{code}
 
 \begin{code}
+filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
 filter_tree f nd@(NodeUFM j p t1 t2)
   = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
 
 filter_tree f lf@(LeafUFM i obj)
-  | f obj = lf
+  | f i obj = lf
   | otherwise = EmptyUFM
 filter_tree f _ = panic "filter_tree failed"
 \end{code}