From 5ff8ce7ff0d45ce13937ad2c24a2e37ffdd2337f Mon Sep 17 00:00:00 2001 From: Milan Straka Date: Mon, 3 May 2010 17:13:15 +0000 Subject: [PATCH] Replace FiniteMap and UniqFM with counterparts from containers. The original interfaces are kept. There is small performance improvement: - when compiling for five nofib, we get following speedups: Average ----- -2.5% Average ----- -0.6% Average ----- -0.5% Average ----- -5.5% Average ----- -10.3% - when compiling HPC ten times, we get: switches oldmaps newmaps -O -fasm 117.402s 116.081s (98.87%) -O -fasm -fregs-graph 119.993s 118.735s (98.95%) -O -fasm -fregs-iterative 120.191s 118.607s (98.68%) --- compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 51 +- compiler/utils/FiniteMap.lhs | 687 ++-------------- compiler/utils/UniqFM.lhs | 827 ++------------------ compiler/utils/UniqSet.lhs | 163 ++-- 4 files changed, 239 insertions(+), 1489 deletions(-) diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 2f10178..7c3fbd5 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -27,10 +27,6 @@ import FastTypes -- 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. -- @@ -92,17 +88,42 @@ accSqueeze -> 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) diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index e301cbc..011a00c 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -3,24 +3,21 @@ % (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, @@ -48,31 +45,11 @@ module FiniteMap ( 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} @@ -87,55 +64,57 @@ import Data.List 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 @@ -144,7 +123,7 @@ intersectFM_C :: (Ord key OUTPUTABLE_key) 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 @@ -152,12 +131,12 @@ filterFM :: (Ord key OUTPUTABLE_key) 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 @@ -168,489 +147,48 @@ eltsFM :: FiniteMap key elt -> [elt] %************************************************************************ %* * -\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} %************************************************************************ @@ -660,109 +198,6 @@ deleteMax EmptyFM = panic "deleteMax: Empty" %************************************************************************ \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} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 9a3d606..293e48e 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -3,21 +3,27 @@ % (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, @@ -36,7 +42,6 @@ module UniqFM ( plusUFM, plusUFM_C, minusUFM, - intersectsUFM, intersectUFM, intersectUFM_C, foldUFM, foldUFM_Directly, @@ -44,7 +49,6 @@ module UniqFM ( elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, sizeUFM, - hashUFM, isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, @@ -52,22 +56,18 @@ module UniqFM ( 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 @@ -107,6 +107,7 @@ delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt 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) @@ -117,7 +118,6 @@ minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 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 @@ -126,7 +126,7 @@ filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt 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 @@ -142,749 +142,78 @@ lookupWithDefaultUFM_Directly 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. --} diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index 6d39e00..443d28b 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.lhs @@ -11,140 +11,105 @@ Basically, the things need to be in class @Uniquable@. \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} -- 1.7.10.4