% (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 (
- UniqFM(..), -- abstract type
- -- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
+ -- * Unique-keyed mappings
+ UniqFM, -- abstract type
+ -- ** Manipulating those mappings
emptyUFM,
unitUFM,
unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
+ listToUFM_C,
addToUFM,addToUFM_C,addToUFM_Acc,
addListToUFM,addListToUFM_C,
addToUFM_Directly,
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,
- eltsUFM, keysUFM,
+ eltsUFM, keysUFM, splitUFM,
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
listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
listToUFM_Directly
:: [(Unique, elt)] -> UniqFM elt
+listToUFM_C :: Uniquable key => (elt -> elt -> elt)
+ -> [(key, elt)]
+ -> UniqFM elt
addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> 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)
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
+splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
+ -- Splits a UFM into things less than, equal to, and greater than the key
lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
:: Uniquable key => UniqFM elt -> elt -> key -> elt
lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
-
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}
-%* *
-%************************************************************************
-
-@UniqFM a@ is a mapping from Unique to a.
-
-First, the DataType itself; which is either a Node, a Leaf, or an Empty.
-
-\begin{code}
-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}
-%* *
-%************************************************************************
-
-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
-
-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
-\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"
-\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{Implementation using ``Data.IntMap''}
+%* *
%************************************************************************
-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 = 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.
+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
-\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}
-%* *
+%* *
+\subsection{Output-ery}
+%* *
%************************************************************************
-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
-\end{code}
-
-\begin{code}
-_unused :: FS.FastString
-_unused = undefined
+instance Outputable a => Outputable (UniqFM a) where
+ ppr ufm = ppr (ufmToList ufm)
\end{code}
projects / ghc-hetmet.git / blobdiff