-- NOTE: This only works for arcitectures with just RcInteger and RcDouble
-- (which are disjoint) ie. x86, x86_64 and ppc
--
--- BL 2007/09
--- Doing a nice fold over the UniqSet makes trivColorable use
--- 32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs.
---
-- The number of allocatable regs is hard coded here so we can do a fast
-- comparision in trivColorable.
--
-> UniqFM reg
-> FastInt
-accSqueeze count maxCount squeeze ufm
- = case ufm of
- NodeUFM _ _ left right
- -> case accSqueeze count maxCount squeeze right of
- count' -> case count' >=# maxCount of
- False -> accSqueeze count' maxCount squeeze left
- True -> count'
-
- LeafUFM _ reg -> count +# squeeze reg
- EmptyUFM -> count
-
+accSqueeze count maxCount squeeze ufm = acc count (eltsUFM ufm)
+ where acc count [] = count
+ acc count _ | count >=# maxCount = count
+ acc count (r:rs) = acc (count +# squeeze r) rs
+
+{- Note [accSqueeze]
+~~~~~~~~~~~~~~~~~~~~
+BL 2007/09
+Doing a nice fold over the UniqSet makes trivColorable use
+32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs.
+Therefore the UniqFM is made non-abstract and we use custom fold.
+
+MS 2010/04
+When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal
+representation any more. But it is imperative that the assSqueeze stops
+the folding if the count gets greater or equal to maxCount. We thus convert
+UniqFM to a (lazy) list, do the fold and stops if necessary, which was
+the most efficient variant tried. Benchmark compiling 10-times SHA1.lhs follows.
+(original = previous implementation, folding = fold of the whole UFM,
+ lazyFold = the current implementation,
+ hackFold = using internal representation of Data.IntMap)
+
+ original folding hackFold lazyFold
+ -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s
+ 100.00% 96.44% 97.72% 97.12%
+ -fregs-graph 67.938s 74.875s 62.673s 64.679s
+ 100.00% 110.21% 92.25% 95.20%
+ -fregs-iterative 89.761s 143.913s 81.075s 86.912s
+ 100.00% 160.33% 90.32% 96.83%
+ -fnew-codegen 38.225s 37.142s 37.551s 37.119s
+ 100.00% 97.17% 98.24% 97.11%
+ -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s
+ 100.00% 99.70% 95.19% 94.65%
+ -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s
+ 100.00% 166.23% 94.18% 100.95%
+-}
trivColorable
:: (RegClass -> VirtualReg -> FastInt)
% (c) The AQUA Project, Glasgow University, 1994-1998
%
-``Finite maps'' are the heart of the compiler's
-lookup-tables/environments and its implementation of sets. Important
-stuff!
+``Finite maps'' are the heart of the compiler's lookup-tables/environments
+and its implementation of sets. Important stuff!
-This code is derived from that in the paper:
-\begin{display}
-S Adams
-"Efficient sets: a balancing act"
-Journal of functional programming 3(4) Oct 1993, pp553-562
-\end{display}
+The implementation uses @Data.Map@ from the containers package, which
+is both maintained and faster than the past implementation (see commit log).
-The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
-near the end.
+The orinigal interface is being kept around. It maps directly to Data.Map,
+only ``Data.Map.union'' is left-biased and ``plusFM'' right-biased and
+``addToFM\_C'' and ``Data.Map.insertWith'' differ in the order of
+arguments of combining function.
\begin{code}
module FiniteMap (
-- * Mappings keyed from arbitrary types
- FiniteMap, -- abstract type
+ FiniteMap, -- abstract data type
-- ** Manipulating those mappings
emptyFM, unitFM, listToFM,
bagToFM
) where
-#if defined(DEBUG_FINITEMAPS)/* NB NB NB */
-#define OUTPUTABLE_key , Outputable key
-#else
-#define OUTPUTABLE_key {--}
-#endif
-
-import Maybes
import Bag ( Bag, foldrBag )
import Outputable
-#if 0
-import GHC.Exts
--- was this import only needed for I#, or does it have something
--- to do with the (not-presently-used) IF_NCG also?
-#endif
-
-import Data.List
-
-#if 0
-#if ! OMIT_NATIVE_CODEGEN
-# define IF_NCG(a) a
-#else
-# define IF_NCG(a) {--}
-#endif
-#endif
+import qualified Data.Map as M
+
\end{code}
emptyFM :: FiniteMap key elt
unitFM :: key -> elt -> FiniteMap key elt
-- | In the case of duplicates keys, the last item is taken
-listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
+listToFM :: (Ord key) => [(key,elt)] -> FiniteMap key elt
-- | In the case of duplicate keys, who knows which item is taken
-bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
+bagToFM :: (Ord key) => Bag (key,elt) -> FiniteMap key elt
-- ADDING AND DELETING
-- | Throws away any previous binding
-addToFM :: (Ord key OUTPUTABLE_key)
+addToFM :: (Ord key)
=> FiniteMap key elt -> key -> elt -> FiniteMap key elt
-- | Throws away any previous binding, items are added left-to-right
-addListToFM :: (Ord key OUTPUTABLE_key)
+addListToFM :: (Ord key)
=> FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
--- | Combines added item with previous item, if any
-addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
+-- | Combines added item with previous item, if any --
+-- if the key is present, ``addToFM_C f`` inserts
+-- ``(key, f old_value new_value)''
+addToFM_C :: (Ord key) => (elt -> elt -> elt)
-> FiniteMap key elt -> key -> elt
-> FiniteMap key elt
-- | Combines added item with previous item, if any, items are added left-to-right
-addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
+addListToFM_C :: (Ord key) => (elt -> elt -> elt)
-> FiniteMap key elt -> [(key,elt)]
-> FiniteMap key elt
-- | Deletion doesn't complain if you try to delete something which isn't there
-delFromFM :: (Ord key OUTPUTABLE_key)
+delFromFM :: (Ord key)
=> FiniteMap key elt -> key -> FiniteMap key elt
-- | Deletion doesn't complain if you try to delete something which isn't there
-delListFromFM :: (Ord key OUTPUTABLE_key)
+delListFromFM :: (Ord key)
=> FiniteMap key elt -> [key] -> FiniteMap key elt
-- COMBINING
-- | Bindings in right argument shadow those in the left
-plusFM :: (Ord key OUTPUTABLE_key)
+plusFM :: (Ord key)
=> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-- | Combines bindings for the same thing with the given function,
-- bindings in right argument shadow those in the left
-plusFM_C :: (Ord key OUTPUTABLE_key)
+plusFM_C :: (Ord key)
=> (elt -> elt -> elt)
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-- | Deletes from the left argument any bindings in the right argument
-minusFM :: (Ord key OUTPUTABLE_key)
+minusFM :: (Ord key)
=> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM :: (Ord key OUTPUTABLE_key)
+intersectFM :: (Ord key)
=> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-- | Combines bindings for the same thing in the two maps with the given function
-intersectFM_C :: (Ord key OUTPUTABLE_key)
+intersectFM_C :: (Ord key)
=> (elt1 -> elt2 -> elt3)
-> FiniteMap key elt1 -> FiniteMap key elt2
-> FiniteMap key elt3
foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
mapFM :: (key -> elt1 -> elt2)
-> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM :: (Ord key OUTPUTABLE_key)
+filterFM :: (Ord key)
=> (key -> elt -> Bool)
-> FiniteMap key elt -> FiniteMap key elt
sizeFM :: FiniteMap key elt -> Int
isEmptyFM :: FiniteMap key elt -> Bool
-elemFM :: (Ord key OUTPUTABLE_key)
+elemFM :: (Ord key)
=> key -> FiniteMap key elt -> Bool
-lookupFM :: (Ord key OUTPUTABLE_key)
+lookupFM :: (Ord key)
=> FiniteMap key elt -> key -> Maybe elt
-- | Supplies a "default" element in return for an unmapped key
-lookupWithDefaultFM :: (Ord key OUTPUTABLE_key)
+lookupWithDefaultFM :: (Ord key)
=> FiniteMap key elt -> elt -> key -> elt
-- LISTIFYING
%************************************************************************
%* *
-\subsection{The @FiniteMap@ data type, and building of same}
-%* *
-%************************************************************************
-
-Invariants about @FiniteMap@:
-\begin{enumerate}
-\item
-all keys in a FiniteMap are distinct
-\item
-all keys in left subtree are $<$ key in Branch and
-all keys in right subtree are $>$ key in Branch
-\item
-size field of a Branch gives number of Branch nodes in the tree
-\item
-size of left subtree is differs from size of right subtree by a
-factor of at most \tr{sIZE_RATIO}
-\end{enumerate}
-
-\begin{code}
--- | A finite mapping from (orderable) key types to elements
-data FiniteMap key elt
- = EmptyFM
- | Branch key elt -- Key and elt stored here
- {-# UNPACK #-} !Int -- Size >= 1
- (FiniteMap key elt) -- Children
- (FiniteMap key elt)
-\end{code}
-
-\begin{code}
-emptyFM = EmptyFM
-{-
-emptyFM
- = Branch bottom bottom 0 bottom bottom
- where
- bottom = panic "emptyFM"
--}
-
--- #define EmptyFM (Branch _ _ 0 _ _)
-
-unitFM key elt = Branch key elt 1 emptyFM emptyFM
-
-listToFM = addListToFM emptyFM
-
-bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Adding to and deleting from @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-addToFM fm key elt = addToFM_C (\ _old new -> new) fm key elt
-
-addToFM_C _ EmptyFM key elt = unitFM key elt
-addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
- = case compare new_key key of
- LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
-
-addListToFM fm key_elt_pairs
- = addListToFM_C (\ _old new -> new) fm key_elt_pairs
-
-addListToFM_C combiner fm key_elt_pairs
- = foldl' add fm key_elt_pairs -- foldl adds from the left
- where
- add fmap (key,elt) = addToFM_C combiner fmap key elt
-\end{code}
-
-\begin{code}
-delFromFM EmptyFM _ = emptyFM
-delFromFM (Branch key elt _ fm_l fm_r) del_key
- = case compare del_key key of
- GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
- LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
- EQ -> glueBal fm_l fm_r
-
-delListFromFM fm keys = foldl' delFromFM fm keys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Combining @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-plusFM_C _ EmptyFM fm2 = fm2
-plusFM_C _ fm1 EmptyFM = fm1
-plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
- = mkVBalBranch split_key new_elt
- (plusFM_C combiner lts left)
- (plusFM_C combiner gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
- new_elt = case lookupFM fm1 split_key of
- Nothing -> elt2
- Just elt1 -> combiner elt1 elt2
-
--- It's worth doing plusFM specially, because we don't need
--- to do the lookup in fm1.
--- FM2 over-rides FM1.
-
-plusFM EmptyFM fm2 = fm2
-plusFM fm1 EmptyFM = fm1
-plusFM fm1 (Branch split_key elt1 _ left right)
- = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
-
-minusFM EmptyFM _ = emptyFM
-minusFM fm1 EmptyFM = fm1
-minusFM fm1 (Branch split_key _ _ left right)
- = glueVBal (minusFM lts left) (minusFM gts right)
- -- The two can be way different, so we need glueVBal
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
-intersectFM fm1 fm2 = intersectFM_C (\ _ right -> right) fm1 fm2
-
-intersectFM_C _ _ EmptyFM = emptyFM
-intersectFM_C _ EmptyFM _ = emptyFM
-intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
-
- | maybeToBool maybe_elt1 -- split_elt *is* in intersection
- = mkVBalBranch split_key (combiner elt1 elt2)
- (intersectFM_C combiner lts left)
- (intersectFM_C combiner gts right)
-
- | otherwise -- split_elt is *not* in intersection
- = glueVBal (intersectFM_C combiner lts left)
- (intersectFM_C combiner gts right)
-
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
- maybe_elt1 = lookupFM fm1 split_key
- Just elt1 = maybe_elt1
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Mapping, folding, and filtering with @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-foldFM _ z EmptyFM = z
-foldFM k z (Branch key elt _ fm_l fm_r)
- = foldFM k (k key elt (foldFM k z fm_r)) fm_l
-
-mapFM _ EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r)
- = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
-
-filterFM _ EmptyFM = emptyFM
-filterFM p (Branch key elt _ fm_l fm_r)
- | p key elt -- Keep the item
- = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
-
- | otherwise -- Drop the item
- = glueVBal (filterFM p fm_l) (filterFM p fm_r)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Interrogating @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
---{-# INLINE sizeFM #-}
-sizeFM EmptyFM = 0
-sizeFM (Branch _ _ size _ _) = size
-
-isEmptyFM fm = sizeFM fm == 0
-
-lookupFM EmptyFM _ = Nothing
-lookupFM (Branch key elt _ fm_l fm_r) key_to_find
- = case compare key_to_find key of
- LT -> lookupFM fm_l key_to_find
- GT -> lookupFM fm_r key_to_find
- EQ -> Just elt
-
-key `elemFM` fm = isJust (lookupFM fm key)
-
-lookupWithDefaultFM fm deflt key
- = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Listifying @FiniteMaps@}
+\subsection{Implementation using ``Data.Map''}
%* *
%************************************************************************
\begin{code}
-fmToList fm = foldFM (\ key elt rest -> (key, elt) : rest) [] fm
-keysFM fm = foldFM (\ key _elt rest -> key : rest) [] fm
-eltsFM fm = foldFM (\ _key elt rest -> elt : rest) [] fm
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The implementation of balancing}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Basic construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBranch@ simply gets the size component right. This is the ONLY
-(non-trivial) place the Branch object is built, so the ASSERTion
-recursively checks consistency. (The trivial use of Branch is in
-@unitFM@.)
-
-\begin{code}
-sIZE_RATIO :: Int
-sIZE_RATIO = 5
-
-mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
- => Int
- -> key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBranch _which key elt fm_l fm_r
- = --ASSERT( left_ok && right_ok && balance_ok )
-#if defined(DEBUG_FINITEMAPS)
- if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show _which)
- (vcat [ppr [left_ok, right_ok, balance_ok],
- ppr key,
- ppr fm_l,
- ppr fm_r])
- else
-#endif
- let
- result = Branch key elt (1 + left_size + right_size) fm_l fm_r
- in
--- if sizeFM result <= 8 then
- result
--- else
--- pprTrace ("mkBranch:"++(show which)) (ppr result) (
--- result
--- )
- where
-#if defined(DEBUG_FINITEMAPS)
- left_ok = case fm_l of
- EmptyFM -> True
- Branch _ _ _ _ _ -> let
- biggest_left_key = fst (findMax fm_l)
- in
- biggest_left_key < key
- right_ok = case fm_r of
- EmptyFM -> True
- Branch _ _ _ _ _ -> let
- smallest_right_key = fst (findMin fm_r)
- in
- key < smallest_right_key
- balance_ok = True -- sigh
-#endif
-{- LATER:
- balance_ok
- = -- Both subtrees have one or no elements...
- (left_size + right_size <= 1)
--- NO || left_size == 0 -- ???
--- NO || right_size == 0 -- ???
- -- ... or the number of elements in a subtree does not exceed
- -- sIZE_RATIO times the number of elements in the other subtree
- || (left_size * sIZE_RATIO >= right_size &&
- right_size * sIZE_RATIO >= left_size)
--}
-
- left_size = sizeFM fm_l
- right_size = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{{\em Balanced} construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
-out of whack.
-
-\begin{code}
-mkBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBalBranch key elt fm_L fm_R
-
- | size_l + size_r < 2
- = mkBranch 1{-which-} key elt fm_L fm_R
-
- | size_r > sIZE_RATIO * size_l -- Right tree too big
- = case fm_R of
- Branch _ _ _ fm_rl fm_rr
- | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
- | otherwise -> double_L fm_L fm_R
- _ -> panic "mkBalBranch: impossible case 1"
-
- | size_l > sIZE_RATIO * size_r -- Left tree too big
- = case fm_L of
- Branch _ _ _ fm_ll fm_lr
- | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
- | otherwise -> double_R fm_L fm_R
- _ -> panic "mkBalBranch: impossible case 2"
- | otherwise -- No imbalance
- = mkBranch 2{-which-} key elt fm_L fm_R
-
- where
- size_l = sizeFM fm_L
- size_r = sizeFM fm_R
-
- single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
- = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
- single_L _ _ = panic "mkBalBranch: impossible case 3"
-
- double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
- = mkBranch 5{-which-} key_rl elt_rl
- (mkBranch 6{-which-} key elt fm_l fm_rll)
- (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
- double_L _ _ = panic "mkBalBranch: impossible case 4"
-
- single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
- = mkBranch 8{-which-} key_l elt_l fm_ll
- (mkBranch 9{-which-} key elt fm_lr fm_r)
- single_R _ _ = panic "mkBalBranch: impossible case 5"
-
- double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
- = mkBranch 10{-which-} key_lr elt_lr
- (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl)
- (mkBranch 12{-which-} key elt fm_lrr fm_r)
- double_R _ _ = panic "mkBalBranch: impossible case 6"
-\end{code}
-
-
-\begin{code}
-mkVBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
--- Assert: in any call to (mkVBalBranch_C comb key elt l r),
--- (a) all keys in l are < all keys in r
--- (b) all keys in l are < key
--- (c) all keys in r are > key
+newtype FiniteMap key elt = FM (M.Map key elt)
-mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
-mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
+emptyFM = FM M.empty
+unitFM k v = FM (M.singleton k v)
+listToFM l = FM (M.fromList l)
-mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
+addToFM (FM m) k v = FM (M.insert k v m)
+-- Arguments of combining function of M.insertWith and addToFM_C are flipped.
+addToFM_C f (FM m) k v = FM (M.insertWith (flip f) k v m)
+addListToFM = foldl (\m (k, v) -> addToFM m k v)
+addListToFM_C f = foldl (\m (k, v) -> addToFM_C f m k v)
+delFromFM (FM m) k = FM (M.delete k m)
+delListFromFM = foldl delFromFM
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
+-- M.union is left-biased, plusFM should be right-biased.
+plusFM (FM x) (FM y) = FM (M.union y x)
+plusFM_C f (FM x) (FM y) = FM (M.unionWith f x y)
+minusFM (FM x) (FM y) = FM (M.difference x y)
+foldFM k z (FM m) = M.foldWithKey k z m
- | otherwise
- = mkBranch 13{-which-} key elt fm_l fm_r
+intersectFM (FM x) (FM y) = FM (M.intersection x y)
+intersectFM_C f (FM x) (FM y) = FM (M.intersectionWith f x y)
+mapFM f (FM m) = FM (M.mapWithKey f m)
+filterFM p (FM m) = FM (M.filterWithKey p m)
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
+sizeFM (FM m) = M.size m
+isEmptyFM (FM m) = M.null m
+elemFM k (FM m) = M.member k m
+lookupFM (FM m) k = M.lookup k m
+lookupWithDefaultFM (FM m) v k = M.findWithDefault v k m
-%************************************************************************
-%* *
-\subsubsection{Gluing two trees together}
-%* *
-%************************************************************************
+fmToList (FM m) = M.toList m
+keysFM (FM m) = M.keys m
+eltsFM (FM m) = M.elems m
-@glueBal@ assumes its two arguments aren't too far out of whack, just
-like @mkBalBranch@. But: all keys in first arg are $<$ all keys in
-second.
+bagToFM = foldrBag (\(k,v) m -> addToFM m k v) emptyFM
-\begin{code}
-glueBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueBal EmptyFM fm2 = fm2
-glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
- -- The case analysis here (absent in Adams' program) is really to deal
- -- with the case where fm2 is a singleton. Then deleting the minimum means
- -- we pass an empty tree to mkBalBranch, which breaks its invariant.
- | sizeFM fm2 > sizeFM fm1
- = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
- | otherwise
- = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
- where
- (mid_key1, mid_elt1) = findMax fm1
- (mid_key2, mid_elt2) = findMin fm2
-\end{code}
-
-@glueVBal@ copes with arguments which can be of any size.
-But: all keys in first arg are $<$ all keys in second.
-
-\begin{code}
-glueVBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueVBal EmptyFM fm2 = fm2
-glueVBal fm1 EmptyFM = fm1
-glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
-
- | otherwise -- We now need the same two cases as in glueBal above.
- = glueBal fm_l fm_r
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utilities}
-%* *
-%************************************************************************
-
-\begin{code}
-splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-
--- splitLT fm split_key = fm restricted to keys < split_key
--- splitGT fm split_key = fm restricted to keys > split_key
-
-splitLT EmptyFM _ = emptyFM
-splitLT (Branch key elt _ fm_l fm_r) split_key
- = case compare split_key key of
- LT -> splitLT fm_l split_key
- GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- EQ -> fm_l
-
-splitGT EmptyFM _ = emptyFM
-splitGT (Branch key elt _ fm_l fm_r) split_key
- = case compare split_key key of
- GT -> splitGT fm_r split_key
- LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- EQ -> fm_r
-
-findMin :: FiniteMap key elt -> (key,elt)
-findMin (Branch key elt _ EmptyFM _) = (key, elt)
-findMin (Branch _ _ _ fm_l _) = findMin fm_l
-findMin EmptyFM = panic "findMin: Empty"
-
-deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMin (Branch _ _ _ EmptyFM fm_r) = fm_r
-deleteMin (Branch key elt _ fm_l fm_r)
- = mkBalBranch key elt (deleteMin fm_l) fm_r
-deleteMin EmptyFM = panic "deleteMin: Empty"
-
-findMax :: FiniteMap key elt -> (key, elt)
-findMax (Branch key elt _ _ EmptyFM) = (key, elt)
-findMax (Branch _ _ _ _ fm_r) = findMax fm_r
-findMax EmptyFM = panic "findMax: Empty"
-
-deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMax (Branch _ _ _ fm_l EmptyFM) = fm_l
-deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
-deleteMax EmptyFM = panic "deleteMax: Empty"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#if defined(DEBUG_FINITEMAPS)
-
-instance (Outputable key) => Outputable (FiniteMap key elt) where
- ppr fm = pprX fm
-
-pprX EmptyFM = char '!'
-pprX (Branch key elt sz fm_l fm_r)
- = parens (hcat [pprX fm_l, space,
- ppr key, space, int sz, space,
- pprX fm_r])
-#else
--- and when not debugging the package itself...
instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
ppr fm = ppr (fmToList fm)
-#endif
-
-#if 0
-instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
- fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
- (fmToList fm_1 == fmToList fm_2)
-
-{- NO: not clear what The Right Thing to do is:
-instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
- fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
- (fmToList fm_1 <= fmToList fm_2)
--}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Efficiency pragmas for GHC}
-%* *
-%************************************************************************
-
-When the FiniteMap module is used in GHC, we specialise it for
-\tr{Uniques}, for dastardly efficiency reasons.
-
-\begin{code}
-#if 0
-
-#ifdef __GLASGOW_HASKELL__
-
-{-# SPECIALIZE addListToFM
- :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt
- IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addListToFM_C
- :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt
- , (elt -> elt -> elt) -> FiniteMap FastString elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM
- :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- , FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
- , FiniteMap (FastString, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt
- , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM_C
- :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
- , (elt -> elt -> elt) -> FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE bagToFM
- :: Bag (FastString,elt) -> FiniteMap FAST_STRING elt
- #-}
-{-# SPECIALIZE delListFromFM
- :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt
- , FiniteMap FastString elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE listToFM
- :: [([Char],elt)] -> FiniteMap [Char] elt
- , [(FastString,elt)] -> FiniteMap FAST_STRING elt
- , [((FastString,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE lookupFM
- :: FiniteMap CLabel elt -> CLabel -> Maybe elt
- , FiniteMap [Char] elt -> [Char] -> Maybe elt
- , FiniteMap FastString elt -> FAST_STRING -> Maybe elt
- , FiniteMap (FastString,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
- , FiniteMap RdrName elt -> RdrName -> Maybe elt
- , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
- #-}
-{-# SPECIALIZE lookupWithDefaultFM
- :: FiniteMap FastString elt -> elt -> FAST_STRING -> elt
- IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
- #-}
-{-# SPECIALIZE plusFM
- :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
- , FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE plusFM_C
- :: (elt -> elt -> elt) -> FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-
-#endif /* compiling with ghc and have specialiser */
-
-#endif /* 0 */
\end{code}
% (c) The AQUA Project, Glasgow University, 1994-1998
%
-UniqFM: Specialised finite maps, for things with @Uniques@
-
-Based on @FiniteMaps@ (as you would expect).
+UniqFM: Specialised finite maps, for things with @Uniques@.
Basically, the things need to be in class @Uniquable@, and we use the
@getUnique@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
+The interface is based on @FiniteMap@s, but the implementation uses
+@Data.IntMap@, which is both maitained and faster than the past
+implementation (see commit log).
+
+The @UniqFM@ interface maps directly to Data.IntMap, only
+``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased
+and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
+of arguments of combining function.
+
\begin{code}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+{-# OPTIONS -Wall #-}
module UniqFM (
-- * Unique-keyed mappings
- UniqFM(..), -- abstract type
- -- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
+ UniqFM, -- abstract type
-- ** Manipulating those mappings
emptyUFM,
plusUFM,
plusUFM_C,
minusUFM,
- intersectsUFM,
intersectUFM,
intersectUFM_C,
foldUFM, foldUFM_Directly,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly,
sizeUFM,
- hashUFM,
isNullUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
ufmToList
) where
-#include "HsVersions.h"
-
-import Unique ( Uniquable(..), Unique, getKeyFastInt, mkUniqueGrimily )
-import Maybes ( maybeToBool )
-import FastTypes
+import Unique ( Uniquable(..), Unique, getKey )
import Outputable
+
+import qualified Data.IntMap as M
\end{code}
%************************************************************************
%* *
-\subsection{The @UniqFM@ type, and signatures for the functions}
+\subsection{The signature of the module}
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
-
\begin{code}
emptyUFM :: UniqFM elt
isNullUFM :: UniqFM elt -> Bool
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
+-- Bindings in right argument shadow those in the left
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C :: (elt -> elt -> elt)
intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
intersectUFM_C :: (elt1 -> elt2 -> elt3)
-> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
-intersectsUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
-hashUFM :: UniqFM elt -> Int
+--hashUFM :: UniqFM elt -> Int
elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
elemUFM_Directly:: Unique -> UniqFM elt -> Bool
keysUFM :: UniqFM elt -> [Unique] -- Get the keys
eltsUFM :: UniqFM elt -> [elt]
ufmToList :: UniqFM elt -> [(Unique, elt)]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
-%* *
-%************************************************************************
-
-\begin{code}
--- Turn off for now, these need to be updated (SDM 4/98)
-
-#if 0
-#ifdef __GLASGOW_HASKELL__
--- I don't think HBC was too happy about this (WDP 94/10)
-
-{-# SPECIALIZE
- addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
- #-}
-{-# SPECIALIZE
- listToUFM :: [(Unique, elt)] -> UniqFM elt
- #-}
-{-# SPECIALIZE
- lookupUFM :: UniqFM elt -> Name -> Maybe elt
- , UniqFM elt -> Unique -> Maybe elt
- #-}
-
-#endif /* __GLASGOW_HASKELL__ */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Andy Gill's underlying @UniqFM@ machinery}
-%* *
-%************************************************************************
-
-``Uniq Finite maps'' are the heart and soul of the compiler's
-lookup-tables/environments. Important stuff! It works well with
-Dense and Sparse ranges.
-Both @Uq@ Finite maps and @Hash@ Finite Maps
-are built ontop of Int Finite Maps.
-
-This code is explained in the paper:
-\begin{display}
- A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
- "A Cheap balancing act that grows on a tree"
- Glasgow FP Workshop, Sep 1994, pp??-??
-\end{display}
-%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ type, and signatures for the functions}
-%* *
-%************************************************************************
-
-First, the DataType itself; which is either a Node, a Leaf, or an Empty.
-
-\begin{code}
--- | @UniqFM a@ is a mapping from Unique to @a@. DO NOT use these constructors
--- directly unless you live in this module!
-data UniqFM ele
- = EmptyUFM
- | LeafUFM !FastInt ele
- | NodeUFM !FastInt -- the switching
- !FastInt -- the delta
- (UniqFM ele)
- (UniqFM ele)
--- INVARIANT: the children of a NodeUFM are never EmptyUFMs
-
-{-
--- for debugging only :-)
-instance Outputable (UniqFM a) where
- ppr(NodeUFM a b t1 t2) =
- sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
- nest 1 (parens (ppr t1)),
- nest 1 (parens (ppr t2))]
- ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
- ppr (EmptyUFM) = empty
--}
--- and when not debugging the package itself...
-instance Outputable a => Outputable (UniqFM a) where
- ppr ufm = ppr (ufmToList ufm)
\end{code}
%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ functions}
-%* *
+%* *
+\subsection{Implementation using ``Data.IntMap''}
+%* *
%************************************************************************
-First the ways of building a UniqFM.
-
\begin{code}
-emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (getKeyFastInt (getUnique key)) elt
-unitDirectlyUFM key elt = mkLeafUFM (getKeyFastInt key) elt
+newtype UniqFM ele = UFM (M.IntMap ele)
+
+emptyUFM = UFM M.empty
+isNullUFM (UFM m) = M.null m
+unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
+unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
+listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
+listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
+listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
+
+addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
+addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
+addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
+addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
+
+-- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
+addToUFM_C f (UFM m) k v =
+ UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
+addToUFM_Acc exi new (UFM m) k v =
+ UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
+addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
+
+delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
+delListFromUFM = foldl delFromUFM
+delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
+
+-- M.union is left-biased, plusUFM should be right-biased.
+plusUFM (UFM x) (UFM y) = UFM (M.union y x)
+plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
+minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
+intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
+intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
+
+foldUFM k z (UFM m) = M.fold k z m
+foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
+mapUFM f (UFM m) = UFM (M.map f m)
+filterUFM p (UFM m) = UFM (M.filter p m)
+filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
+
+sizeUFM (UFM m) = M.size m
+elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
+elemUFM_Directly u (UFM m) = M.member (getKey u) m
+
+splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
+ (less, equal, greater) -> (UFM less, equal, UFM greater)
+lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
+lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
+lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
+lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
+keysUFM (UFM m) = map getUnique $ M.keys m
+eltsUFM (UFM m) = M.elems m
+ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
-listToUFM key_elt_pairs
- = addListToUFM_C use_snd EmptyUFM key_elt_pairs
-
-listToUFM_Directly uniq_elt_pairs
- = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
-
-listToUFM_C combiner key_elt_pairs
- = addListToUFM_C combiner EmptyUFM key_elt_pairs
-\end{code}
-
-Now ways of adding things to UniqFMs.
-
-There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
-but the semantics of this operation demands a linear insertion;
-perhaps the version without the combinator function
-could be optimised using it.
-
-\begin{code}
-addToUFM fm key elt = addToUFM_C use_snd fm key elt
-
-addToUFM_Directly fm u elt = insert_ele use_snd fm (getKeyFastInt u) elt
-
-addToUFM_C combiner fm key elt
- = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt
-
-addToUFM_Acc add unit fm key item
- = insert_ele combiner fm (getKeyFastInt (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
-
-addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt (getUnique k)) e)
- fm key_elt_pairs
-
-addListToUFM_directly_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Unique,elt)] -> UniqFM elt
-addListToUFM_directly_C combiner fm uniq_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt k) e)
- fm uniq_elt_pairs
-\end{code}
-
-Now ways of removing things from UniqFM.
-
-\begin{code}
-delListFromUFM fm lst = foldl delFromUFM fm lst
-
-delFromUFM fm key = delete fm (getKeyFastInt (getUnique key))
-delFromUFM_Directly fm u = delete fm (getKeyFastInt u)
-
-delete :: UniqFM a -> FastInt -> UniqFM a
-delete EmptyUFM _ = EmptyUFM
-delete fm key = del_ele fm
- where
- del_ele :: UniqFM a -> UniqFM a
-
- del_ele lf@(LeafUFM j _)
- | j ==# key = EmptyUFM
- | otherwise = lf -- no delete!
-
- del_ele (NodeUFM j p t1 t2)
- | j ># key
- = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
- | otherwise
- = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
-
- del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
-\end{code}
-
-Now ways of adding two UniqFM's together.
-
-\begin{code}
-plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
-
-plusUFM_C _ EmptyUFM tr = tr
-plusUFM_C _ tr EmptyUFM = tr
-plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
- where
- mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
- mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
-
- mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = mix_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' (C j j')
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' j j'
- -- / \ / \
- -- t1 t2 t1' t2'
- -- Fast, Ehh !
- --
- mix_branches (NewRoot nd False)
- = mkLLNodeUFM nd left_t right_t
- mix_branches (NewRoot nd True)
- = mkLLNodeUFM nd right_t left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- mix_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (mix_trees t1 t1')
- (mix_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2 + j'
- -- / \
- -- t1' t2'
- mix_branches (LeftRoot Leftt) -- | trace "LL" True
- = mkSLNodeUFM
- (NodeUFMData j p)
- (mix_trees t1 right_t)
- t2
-
- mix_branches (LeftRoot Rightt) -- | trace "LR" True
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (mix_trees t2 right_t)
-
- mix_branches (RightRoot Leftt) -- | trace "RL" True
- = mkSLNodeUFM
- (NodeUFMData j' p')
- (mix_trees left_t t1')
- t2'
-
- mix_branches (RightRoot Rightt) -- | trace "RR" True
- = mkLSNodeUFM
- (NodeUFMData j' p')
- t1'
- (mix_trees left_t t2')
-
- mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
-\end{code}
-
-And ways of subtracting them. First the base cases,
-then the full D&C approach.
-
-\begin{code}
-minusUFM EmptyUFM _ = EmptyUFM
-minusUFM t1 EmptyUFM = t1
-minusUFM fm1 fm2 = minus_trees fm1 fm2
- where
- --
- -- Notice the asymetry of subtraction
- --
- minus_trees lf@(LeafUFM i _a) t2 =
- case lookUp t2 i of
- Nothing -> lf
- Just _ -> EmptyUFM
-
- minus_trees t1 (LeafUFM i _) = delete t1 i
-
- minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = minus_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 t2
- --
- --
- -- Fast, Ehh !
- --
- minus_branches (NewRoot _ _) = left_t
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
- minus_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (minus_trees t1 t1')
- (minus_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- -- again, with asymatry
-
- --
- -- The left is above the right
- --
- minus_branches (LeftRoot Leftt)
- = mkSLNodeUFM
- (NodeUFMData j p)
- (minus_trees t1 right_t)
- t2
- minus_branches (LeftRoot Rightt)
- = mkLSNodeUFM
- (NodeUFMData j p)
- t1
- (minus_trees t2 right_t)
-
- --
- -- The right is above the left
- --
- minus_branches (RightRoot Leftt)
- = minus_trees left_t t1'
- minus_branches (RightRoot Rightt)
- = minus_trees left_t t2'
-
- minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
-\end{code}
-
-And taking the intersection of two UniqFM's.
-
-\begin{code}
-intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
-intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
-
-intersectUFM_C _ EmptyUFM _ = EmptyUFM
-intersectUFM_C _ _ EmptyUFM = EmptyUFM
-intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
- where
- intersect_trees (LeafUFM i a) t2 =
- case lookUp t2 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f a b)
-
- intersect_trees t1 (LeafUFM i a) =
- case lookUp t1 i of
- Nothing -> EmptyUFM
- Just b -> mkLeafUFM i (f b a)
-
- intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
- = intersect_branches
- (ask_about_common_ancestor
- (NodeUFMData j p)
- (NodeUFMData j' p'))
- where
- -- Given a disjoint j,j' (p >^ p' && p' >^ p):
- --
- -- j j'
- -- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
- -- Fast, Ehh !
- --
- intersect_branches (NewRoot _nd _) = EmptyUFM
-
- -- Now, if j == j':
- --
- -- j j' j
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
- intersect_branches (SameRoot)
- = mkSSNodeUFM (NodeUFMData j p)
- (intersect_trees t1 t1')
- (intersect_trees t2 t2')
- -- Now the 4 different other ways; all like this:
- --
- -- Given j >^ j' (and, say, j > j')
- --
- -- j j' t2 + j'
- -- / \ + / \ ==> / \
- -- t1 t2 t1' t2' t1' t2'
- --
- -- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Leftt)
- = intersect_trees t1 right_t
- intersect_branches (LeftRoot Rightt)
- = intersect_trees t2 right_t
- intersect_branches (RightRoot Leftt)
- = intersect_trees left_t t1'
- intersect_branches (RightRoot Rightt)
- = intersect_trees left_t t2'
-
- intersect_trees _ _ = panic ("EmptyUFM found when intersecting trees")
-\end{code}
-
-Now the usual set of `collection' operators, like map, fold, etc.
-
-\begin{code}
-foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
-foldUFM f a (LeafUFM _ obj) = f obj a
-foldUFM _ a EmptyUFM = a
-\end{code}
-
-\begin{code}
-mapUFM _fn EmptyUFM = EmptyUFM
-mapUFM fn fm = map_tree fn fm
-
-filterUFM _fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree (\_ e -> fn e) fm
-
-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
-because we dont want to do this very often, we put up with this.
-O'rable, but how often do we look at the size of
-a finite map?
-
-\begin{code}
-sizeUFM EmptyUFM = 0
-sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
-sizeUFM (LeafUFM _ _) = 1
-
-isNullUFM EmptyUFM = True
-isNullUFM _ = False
-
--- hashing is used in VarSet.uniqAway, and should be fast
--- We use a cheap and cheerful method for now
-hashUFM EmptyUFM = 0
-hashUFM (NodeUFM n _ _ _) = iBox n
-hashUFM (LeafUFM n _) = iBox n
-\end{code}
-
-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 = maybeToBool (lookupUFM fm key)
-elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
-
-lookupUFM fm key = lookUp fm (getKeyFastInt (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKeyFastInt key)
-
-lookupWithDefaultUFM fm deflt key
- = case lookUp fm (getKeyFastInt (getUnique key)) of
- Nothing -> deflt
- Just elt -> elt
-
-lookupWithDefaultUFM_Directly fm deflt key
- = case lookUp fm (getKeyFastInt key) of
- Nothing -> deflt
- Just elt -> elt
-
-lookUp :: UniqFM a -> FastInt -> Maybe a
-lookUp EmptyUFM _ = Nothing
-lookUp fm i = lookup_tree fm
- where
- lookup_tree :: UniqFM a -> Maybe a
-
- lookup_tree (LeafUFM j b)
- | j ==# i = Just b
- | otherwise = Nothing
- lookup_tree (NodeUFM j _ t1 t2)
- | j ># i = lookup_tree t1
- | otherwise = lookup_tree t2
-
- lookup_tree EmptyUFM = panic "lookup Failed"
-
--------------------
-splitUFM fm key = split fm (getKeyFastInt (getUnique key))
-
-split :: UniqFM a -> FastInt -> (UniqFM a, Maybe a, UniqFM a)
--- Splits a UFM into things less than, equal to, and greater than the key
-split EmptyUFM _ = (EmptyUFM, Nothing, EmptyUFM)
-split fm i = go fm
- where
- go (LeafUFM j b) | i <# j = (EmptyUFM, Nothing, LeafUFM j b)
- | i ># j = (LeafUFM j b, Nothing, EmptyUFM)
- | otherwise = (EmptyUFM, Just b, EmptyUFM)
-
- go (NodeUFM j p t1 t2)
- | j ># i
- , (lt, eq, gt) <- go t1 = (lt, eq, mkSLNodeUFM (NodeUFMData j p) gt t2)
- | (lt, eq, gt) <- go t2 = (mkLSNodeUFM (NodeUFMData j p) t1 lt, eq, gt)
-
- go EmptyUFM = panic "splitUFM failed"
-\end{code}
-
-folds are *wonderful* things.
-
-\begin{code}
-eltsUFM fm = foldUFM (:) [] fm
-keysUFM fm = foldUFM_Directly (\u _ l -> u : l) [] fm
-ufmToList fm = foldUFM_Directly (\u e l -> (u, e) : l) [] fm
-foldUFM_Directly f = fold_tree (\iu e a -> f (mkUniqueGrimily (iBox iu)) e a)
-
-fold_tree :: (FastInt -> elt -> a -> a) -> a -> UniqFM elt -> a
-fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
-fold_tree f a (LeafUFM iu obj) = f iu obj a
-fold_tree _ a EmptyUFM = a
\end{code}
%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ type, and its functions}
-%* *
+%* *
+\subsection{Output-ery}
+%* *
%************************************************************************
-You should always use these to build the tree.
-There are 4 versions of mkNodeUFM, depending on
-the strictness of the two sub-tree arguments.
-The strictness is used *both* to prune out
-empty trees, *and* to improve performance,
-stoping needless thunks lying around.
-The rule of thumb (from experence with these trees)
-is make thunks strict, but data structures lazy.
-If in doubt, use mkSSNodeUFM, which has the `strongest'
-functionality, but may do a few needless evaluations.
-
\begin{code}
-mkLeafUFM :: FastInt -> a -> UniqFM a
-mkLeafUFM i a =
- ASSERT (iBox i >= 0) -- Note [Uniques must be positive]
- LeafUFM i a
-
--- The *ONLY* ways of building a NodeUFM.
-
-mkSSNodeUFM, mkSLNodeUFM, mkLSNodeUFM, mkLLNodeUFM ::
- NodeUFMData -> UniqFM a -> UniqFM a -> UniqFM a
-
-mkSSNodeUFM (NodeUFMData _ _) EmptyUFM t2 = t2
-mkSSNodeUFM (NodeUFMData _ _) t1 EmptyUFM = t1
-mkSSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkSLNodeUFM (NodeUFMData _ _) EmptyUFM t2 = t2
-mkSLNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkLSNodeUFM (NodeUFMData _ _) t1 EmptyUFM = t1
-mkLSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-mkLLNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
- NodeUFM j p t1 t2
-
-correctNodeUFM
- :: Int
- -> Int
- -> UniqFM a
- -> UniqFM a
- -> Bool
-
-correctNodeUFM j p t1 t2
- = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
- where
- correct low high _ (LeafUFM i _)
- = low <= iBox i && iBox i <= high
- correct low high above_p (NodeUFM j p _ _)
- = low <= iBox j && iBox j <= high && above_p > iBox p
- correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
-\end{code}
-
-Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
-and if necessary do $\lambda$ lifting on our functions that are bound.
-
-\begin{code}
-insert_ele
- :: (a -> a -> a) -- old -> new -> result
- -> UniqFM a
- -> FastInt
- -> a
- -> UniqFM a
-
-insert_ele _f EmptyUFM i new = mkLeafUFM i new
-
-insert_ele f (LeafUFM j old) i new
- | j ># i =
- mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- (indexToRoot j))
- (mkLeafUFM i new)
- (mkLeafUFM j old)
- | j ==# i = mkLeafUFM j $ f old new
- | otherwise =
- mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- (indexToRoot j))
- (mkLeafUFM j old)
- (mkLeafUFM i new)
-
-insert_ele f n@(NodeUFM j p t1 t2) i a
- | i <# j
- = if (i >=# (j -# p))
- then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
- else mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- ((NodeUFMData j p)))
- (mkLeafUFM i a)
- n
- | otherwise
- = if (i <=# ((j -# _ILIT(1)) +# p))
- then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
- else mkLLNodeUFM (getCommonNodeUFMData
- (indexToRoot i)
- ((NodeUFMData j p)))
- n
- (mkLeafUFM i a)
-\end{code}
-
-
-
-\begin{code}
-map_tree :: (a -> b) -> UniqFM a -> UniqFM b
-map_tree f (NodeUFM j p t1 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 _ _ = panic "map_tree failed"
-\end{code}
-
-\begin{code}
-filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
-filter_tree f (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 i obj = lf
- | otherwise = EmptyUFM
-filter_tree _ _ = panic "filter_tree failed"
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @UniqFM@ type, and signatures for the functions}
-%* *
-%************************************************************************
-
-Now some Utilities;
-
-This is the information that is held inside a NodeUFM, packaged up for
-consumer use.
-
-\begin{code}
-data NodeUFMData
- = NodeUFMData FastInt
- FastInt
-\end{code}
-
-This is the information used when computing new NodeUFMs.
-
-\begin{code}
-data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
-data CommonRoot
- = LeftRoot Side -- which side is the right down ?
- | RightRoot Side -- which side is the left down ?
- | SameRoot -- they are the same !
- | NewRoot NodeUFMData -- here's the new, common, root
- Bool -- do you need to swap left and right ?
-\end{code}
-
-This specifies the relationship between NodeUFMData and CalcNodeUFMData.
-
-\begin{code}
-indexToRoot :: FastInt -> NodeUFMData
-
-indexToRoot i
- = NodeUFMData ((shiftL1 (shiftR1 i)) +# _ILIT(1)) (_ILIT(1))
-
-getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
-
-getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
- | p ==# p2 = getCommonNodeUFMData_ p j j2
- | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
- | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
- where
- !j = i `quotFastInt` (shiftL1 p)
- !j2 = i2 `quotFastInt` (shiftL1 p2)
-
- getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
-
- getCommonNodeUFMData_ p j j_
- | j ==# j_
- = NodeUFMData (((shiftL1 j) +# _ILIT(1)) *# p) p
- | otherwise
- = getCommonNodeUFMData_ (shiftL1 p) (shiftR1 j) (shiftR1 j_)
-
-ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
-
-ask_about_common_ancestor x@(NodeUFMData j _p) y@(NodeUFMData j2 _p2)
- | j ==# j2 = SameRoot
- | otherwise
- = case getCommonNodeUFMData x y of
- nd@(NodeUFMData j3 _p3)
- | j3 ==# j -> LeftRoot (decideSide (j ># j2))
- | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
- | otherwise -> NewRoot nd (j ># j2)
- where
- decideSide :: Bool -> Side
- decideSide True = Leftt
- decideSide False = Rightt
-\end{code}
-
-This might be better in Util.lhs ?
-
-
-Now the bit twiddling functions.
-\begin{code}
-shiftL1 :: FastInt -> FastInt
-shiftR1 :: FastInt -> FastInt
-
-{-# INLINE shiftL1 #-}
-{-# INLINE shiftR1 #-}
-
-shiftL1 n = n `shiftLFastInt` _ILIT(1)
-shiftR1 n = n `shiftR_FastInt` _ILIT(1)
-\end{code}
-
-\begin{code}
-use_snd :: a -> b -> b
-use_snd _ b = b
+instance Outputable a => Outputable (UniqFM a) where
+ ppr ufm = ppr (ufmToList ufm)
\end{code}
-
-{- Note [Uniques must be positive]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The getCommonNodeUFMData function assumes that the nodes use
-positive uniques. Specifically, the inner `loop' shifts the
-low bits out of two uniques until the shifted uniques are the same.
-At the same time, it computes a new delta, by shifting
-to the left.
-
-The failure case I (JPD) encountered:
-If one of the uniques is negative, the shifting may continue
-until all 64 bits have been shifted out, resulting in a new delta
-of 0, which is wrong and can trigger later assertion failures.
-
-Where do the negative uniques come from? Both Simom M and
-I have run into this problem when hashing a data structure.
-In both cases, we have avoided the problem by ensuring that
-the hashes remain positive.
--}
\begin{code}
module UniqSet (
-- * Unique set type
- UniqSet, -- abstract type: NOT
+ UniqSet, -- type synonym for UniqFM a
-- ** Manipulating these sets
- mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
- addOneToUniqSet, addListToUniqSet, addOneToUniqSet_C,
- delOneFromUniqSet, delListFromUniqSet, delOneFromUniqSet_Directly,
- unionUniqSets, unionManyUniqSets, minusUniqSet,
- elementOfUniqSet, mapUniqSet, intersectUniqSets,
- isEmptyUniqSet, filterUniqSet, sizeUniqSet, foldUniqSet,
- elemUniqSet_Directly, lookupUniqSet, hashUniqSet
+ emptyUniqSet,
+ unitUniqSet,
+ mkUniqSet,
+ addOneToUniqSet, addOneToUniqSet_C, addListToUniqSet,
+ delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ minusUniqSet,
+ intersectUniqSets,
+ foldUniqSet,
+ mapUniqSet,
+ elementOfUniqSet,
+ elemUniqSet_Directly,
+ filterUniqSet,
+ sizeUniqSet,
+ isEmptyUniqSet,
+ lookupUniqSet,
+ uniqSetToList,
) where
-import Maybes
import UniqFM
import Unique
-#if ! OMIT_NATIVE_CODEGEN
-#define IF_NCG(a) a
-#else
-#define IF_NCG(a) {--}
-#endif
\end{code}
%************************************************************************
-%* *
-\subsection{The @UniqSet@ type}
-%* *
+%* *
+\subsection{The signature of the module}
+%* *
%************************************************************************
-We use @UniqFM@, with a (@getUnique@-able) @Unique@ as ``key''
-and the thing itself as the ``value'' (for later retrieval).
-
\begin{code}
---data UniqSet a = MkUniqSet (FiniteMap Unique a) : NOT
-
-type UniqSet a = UniqFM a
-#define MkUniqSet {--}
-
emptyUniqSet :: UniqSet a
-emptyUniqSet = MkUniqSet emptyUFM
-
unitUniqSet :: Uniquable a => a -> UniqSet a
-unitUniqSet x = MkUniqSet (unitUFM x x)
-
-uniqSetToList :: UniqSet a -> [a]
-uniqSetToList (MkUniqSet set) = eltsUFM set
-
-foldUniqSet :: (a -> b -> b) -> b -> UniqSet a -> b
-foldUniqSet k z (MkUniqSet set) = foldUFM k z set
-
mkUniqSet :: Uniquable a => [a] -> UniqSet a
-mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
-addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x)
-
-addOneToUniqSet_C :: Uniquable a
- => (a -> a -> a) -> UniqSet a -> a -> UniqSet a
-addOneToUniqSet_C f (MkUniqSet set) x = MkUniqSet (addToUFM_C f set x x)
+addOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a
+addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
-delOneFromUniqSet (MkUniqSet set) x = MkUniqSet (delFromUFM set x)
-
delOneFromUniqSet_Directly :: Uniquable a => UniqSet a -> Unique -> UniqSet a
-delOneFromUniqSet_Directly (MkUniqSet set) u
- = MkUniqSet (delFromUFM_Directly set u)
-
delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
-delListFromUniqSet (MkUniqSet set) xs = MkUniqSet (delListFromUFM set xs)
-
-addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
-addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs])
unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
-unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2)
-
unionManyUniqSets :: [UniqSet a] -> UniqSet a
--- = foldr unionUniqSets emptyUniqSet ss
-unionManyUniqSets [] = emptyUniqSet
-unionManyUniqSets [s] = s
-unionManyUniqSets (s:ss) = s `unionUniqSets` unionManyUniqSets ss
-
minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a
-minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2)
-
-filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
-filterUniqSet pred (MkUniqSet set) = MkUniqSet (filterUFM pred set)
-
intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
-intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2)
+foldUniqSet :: (a -> b -> b) -> b -> UniqSet a -> b
+mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
-elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x)
+elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
+filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+sizeUniqSet :: UniqSet a -> Int
+isEmptyUniqSet :: UniqSet a -> Bool
lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a
-lookupUniqSet (MkUniqSet set) x = lookupUFM set x
+uniqSetToList :: UniqSet a -> [a]
+\end{code}
+%************************************************************************
+%* *
+\subsection{Implementation using ``UniqFM''}
+%* *
+%************************************************************************
-elemUniqSet_Directly :: Unique -> UniqSet a -> Bool
-elemUniqSet_Directly x (MkUniqSet set) = maybeToBool (lookupUFM_Directly set x)
+\begin{code}
-sizeUniqSet :: UniqSet a -> Int
-sizeUniqSet (MkUniqSet set) = sizeUFM set
+type UniqSet a = UniqFM a
-hashUniqSet :: UniqSet a -> Int
-hashUniqSet (MkUniqSet set) = hashUFM set
+emptyUniqSet = emptyUFM
+unitUniqSet x = unitUFM x x
+mkUniqSet = foldl addOneToUniqSet emptyUniqSet
-isEmptyUniqSet :: UniqSet a -> Bool
-isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
+addOneToUniqSet set x = addToUFM set x x
+addOneToUniqSet_C f set x = addToUFM_C f set x x
+addListToUniqSet = foldl addOneToUniqSet
--- | Invariant: the mapping function doesn't change the unique
-mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b
-mapUniqSet f (MkUniqSet set) = MkUniqSet (mapUFM f set)
-\end{code}
+delOneFromUniqSet = delFromUFM
+delOneFromUniqSet_Directly = delFromUFM_Directly
+delListFromUniqSet = delListFromUFM
+
+unionUniqSets = plusUFM
+unionManyUniqSets [] = emptyUniqSet
+unionManyUniqSets sets = foldr1 unionUniqSets sets
+minusUniqSet = minusUFM
+intersectUniqSets = intersectUFM
+
+foldUniqSet = foldUFM
+mapUniqSet = mapUFM
+elementOfUniqSet = elemUFM
+elemUniqSet_Directly = elemUFM_Directly
+filterUniqSet = filterUFM
+
+sizeUniqSet = sizeUFM
+isEmptyUniqSet = isNullUFM
+lookupUniqSet = lookupUFM
+uniqSetToList = eltsUFM
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-{-# SPECIALIZE
- addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique
- #-}
-
--- These next three specialisations disabled as importing Name creates a
--- loop, and getting the Uniquable Name instance in particular is tricky.
-
-{- SPECIALIZE
- elementOfUniqSet :: Name -> UniqSet Name -> Bool
- , Unique -> UniqSet Unique -> Bool
- -}
-{- SPECIALIZE
- mkUniqSet :: [Name] -> UniqSet Name
- -}
-
-{- SPECIALIZE
- unitUniqSet :: Name -> UniqSet Name
- , Unique -> UniqSet Unique
- -}
-#endif
\end{code}
projects / ghc-hetmet.git / commitdiff