%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
Based on @FiniteMaps@ (as you would expect).
-Basically, the things need to be in class @NamedThing@, and we use the
-@getTheUnique@ method to grab their @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@.)
-@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations
-of this stuff for Ids and TyVars, respectively.
-
\begin{code}
-#if defined(COMPILING_GHC)
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-#else
-#define ASSERT(e) {--}
-#define IF_NOT_GHC(a) a
-#endif
-
module UniqFM (
UniqFM, -- abstract type
emptyUFM,
- singletonUFM,
- singletonDirectlyUFM,
+ unitUFM,
+ unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
- addToUFM,
- IF_NOT_GHC(addListToUFM COMMA)
+ addToUFM,addToUFM_C,
+ addListToUFM,addListToUFM_C,
addToUFM_Directly,
- IF_NOT_GHC(addToUFM_C COMMA)
- IF_NOT_GHC(addListToUFM_C COMMA)
+ addListToUFM_Directly,
delFromUFM,
+ delFromUFM_Directly,
delListFromUFM,
plusUFM,
plusUFM_C,
minusUFM,
intersectUFM,
- IF_NOT_GHC(intersectUFM_C COMMA)
- IF_NOT_GHC(foldUFM COMMA)
+ intersectUFM_C,
+ foldUFM,
mapUFM,
+ elemUFM,
filterUFM,
sizeUFM,
+ hashUFM,
isNullUFM,
- lookupUFM,
- lookupDirectlyUFM,
- IF_NOT_GHC(lookupWithDefaultUFM COMMA)
- eltsUFM,
- ufmToList,
-
- -- to make the interface self-sufficient
- Id, TyVar, Unique
- IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling
+ lookupUFM, lookupUFM_Directly,
+ lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
+ eltsUFM, keysUFM,
+ ufmToList
) where
-import AbsUniType -- for specialisation to TyVars
-import Id -- for specialisation to Ids
-import IdInfo -- sigh
-import Maybes ( maybeToBool, Maybe(..) )
-import Name
+#include "HsVersions.h"
+
+import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
+import Panic
+import FastTypes
import Outputable
-import Unique ( u2i, mkUniqueGrimily, Unique )
-import Util
-#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
-#define IF_NCG(a) a
-#else
-#define IF_NCG(a) {--}
-#endif
+
+import GLAEXTS -- Lots of Int# operations
\end{code}
%************************************************************************
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
isNullUFM :: UniqFM elt -> Bool
-singletonUFM :: NamedThing key => key -> elt -> UniqFM elt
-singletonDirectlyUFM -- got the Unique already
+unitUFM :: Uniquable key => key -> elt -> UniqFM elt
+unitDirectlyUFM -- got the Unique already
:: Unique -> elt -> UniqFM elt
-listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
+listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
listToUFM_Directly
:: [(Unique, elt)] -> UniqFM elt
-addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
+addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
-addToUFM_C :: NamedThing key => (elt -> elt -> elt)
- -> UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM_C :: NamedThing key => (elt -> elt -> elt)
+addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
+ -> UniqFM elt -- old
+ -> key -> elt -- new
+ -> UniqFM elt -- result
+
+addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
-delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt
-delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
+delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C :: (elt -> elt -> elt)
-> UniqFM elt -> UniqFM elt -> UniqFM elt
-minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
+minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
-intersectUFM_C :: (elt -> elt -> elt)
- -> UniqFM elt -> UniqFM elt -> UniqFM elt
+intersectUFM_C :: (elt1 -> elt2 -> elt3)
+ -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
+hashUFM :: UniqFM elt -> Int
+elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
-lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
-lookupDirectlyUFM -- when you've got the Unique already
+lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
+lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
lookupWithDefaultUFM
- :: NamedThing key => UniqFM elt -> elt -> key -> 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}
%************************************************************************
\begin{code}
-type IdFinMap elt = UniqFM elt
-type TyVarFinMap elt = UniqFM elt
-type NameFinMap elt = UniqFM elt
-type RegFinMap elt = UniqFM elt
-\end{code}
+-- Turn off for now, these need to be updated (SDM 4/98)
-\begin{code}
+#if 0
#ifdef __GLASGOW_HASKELL__
-- I don't think HBC was too happy about this (WDP 94/10)
{-# SPECIALIZE
- singletonUFM :: Id -> elt -> IdFinMap elt,
- TyVar -> elt -> TyVarFinMap elt,
- Name -> elt -> NameFinMap elt
- IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
+ addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
- listToUFM :: [(Id, elt)] -> IdFinMap elt,
- [(TyVar,elt)] -> TyVarFinMap elt,
- [(Name, elt)] -> NameFinMap elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt)
+ addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
- addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt,
- TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
- NameFinMap elt -> Name -> elt -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt)
+ addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
#-}
{-# SPECIALIZE
- addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt,
- TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
- NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
+ listToUFM :: [(Unique, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
- addToUFM_C :: (elt -> elt -> elt)
- -> IdFinMap elt -> Id -> elt -> IdFinMap elt,
- (elt -> elt -> elt)
- -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
- (elt -> elt -> elt)
- -> NameFinMap elt -> Name -> elt -> NameFinMap elt
- IF_NCG(COMMA (elt -> elt -> elt)
- -> RegFinMap elt -> Reg -> elt -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- addListToUFM_C :: (elt -> elt -> elt)
- -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt,
- (elt -> elt -> elt)
- -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
- (elt -> elt -> elt)
- -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
- IF_NCG(COMMA (elt -> elt -> elt)
- -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt,
- TyVarFinMap elt -> TyVar -> TyVarFinMap elt,
- NameFinMap elt -> Name -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt)
- #-}
-{-# SPECIALIZE
- delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt,
- TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt,
- NameFinMap elt -> [Name] -> NameFinMap elt
- IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt)
- #-}
-
-{-# SPECIALIZE
- lookupUFM :: IdFinMap elt -> Id -> Maybe elt,
- TyVarFinMap elt -> TyVar -> Maybe elt,
- NameFinMap elt -> Name -> Maybe elt
- IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt)
- #-}
-{-# SPECIALIZE
- lookupWithDefaultUFM
- :: IdFinMap elt -> elt -> Id -> elt,
- TyVarFinMap elt -> elt -> TyVar -> elt,
- NameFinMap elt -> elt -> Name -> elt
- IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt)
+ lookupUFM :: UniqFM elt -> Name -> Maybe elt
+ , UniqFM elt -> Unique -> Maybe elt
#-}
-#endif {- __GLASGOW_HASKELL__ -}
+#endif /* __GLASGOW_HASKELL__ */
+#endif
\end{code}
%************************************************************************
\begin{code}
data UniqFM ele
= EmptyUFM
- | LeafUFM FAST_INT ele
- | NodeUFM FAST_INT -- the switching
- FAST_INT -- the delta
+ | LeafUFM FastInt ele
+ | NodeUFM FastInt -- the switching
+ FastInt -- the delta
(UniqFM ele)
(UniqFM ele)
--- for debugging only :-)
{-
-instance Text (UniqFM a) where
- showsPrec _ (NodeUFM a b t1 t2) =
- showString "NodeUFM " . shows (IBOX(a))
- . showString " " . shows (IBOX(b))
- . showString " (" . shows t1
- . showString ") (" . shows t2
- . showString ")"
- showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
- showsPrec _ (EmptyUFM) = id
+-- 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}
%************************************************************************
\begin{code}
emptyUFM = EmptyUFM
-singletonUFM key elt = mkLeafUFM (u2i (getTheUnique key)) elt
-singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
+unitUFM key elt = mkLeafUFM (getKey# (getUnique key)) elt
+unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
listToUFM key_elt_pairs
= addListToUFM_C use_snd EmptyUFM key_elt_pairs
\begin{code}
addToUFM fm key elt = addToUFM_C use_snd fm key elt
-addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
+addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (u2i (getTheUnique key)) elt
+ = insert_ele combiner fm (getKey# (getUnique key)) elt
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 (u2i (getTheUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
fm uniq_elt_pairs
\end{code}
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (getTheUnique key))
+delFromUFM fm key = delete fm (getKey# (getUnique key))
+delFromUFM_Directly fm u = delete fm (getKey# u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
del_ele :: UniqFM a -> UniqFM a
del_ele lf@(LeafUFM j _)
- | j _EQ_ key = EmptyUFM
+ | j ==# key = EmptyUFM
| otherwise = lf -- no delete!
del_ele nd@(NodeUFM j p t1 t2)
- | j _GT_ key
+ | j ># key
= mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
- | otherwise
+ | otherwise
= mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
mix_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(mix_trees t1 t1')
-- t1 t2 t1' t2' t1 t2 + j'
-- / \
-- t1' t2'
- mix_branches (LeftRoot Left) -- | trace "LL" True
+ mix_branches (LeftRoot Leftt) -- | trace "LL" True
= mkSLNodeUFM
(NodeUFMData j p)
- (mix_trees t1 right_t)
+ (mix_trees t1 right_t)
t2
- mix_branches (LeftRoot Right) -- | trace "LR" True
+ mix_branches (LeftRoot Rightt) -- | trace "LR" True
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (mix_trees t2 right_t)
+ (mix_trees t2 right_t)
- mix_branches (RightRoot Left) -- | trace "RL" True
+ mix_branches (RightRoot Leftt) -- | trace "RL" True
= mkSLNodeUFM
(NodeUFMData j' p')
- (mix_trees left_t t1')
+ (mix_trees left_t t1')
t2'
- mix_branches (RightRoot Right) -- | trace "RR" True
+ mix_branches (RightRoot Rightt) -- | trace "RR" True
= mkLSNodeUFM
(NodeUFMData j' p')
t1'
- (mix_trees left_t t2')
+ (mix_trees left_t t2')
mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
\end{code}
--
-- Notice the asymetry of subtraction
--
- minus_trees lf@(LeafUFM i a) t2 =
- case lookup t2 i of
+ minus_trees lf@(LeafUFM i a) t2 =
+ case lookUp t2 i of
Nothing -> lf
Just b -> EmptyUFM
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 t2
- --
- --
+ --
+ --
-- Fast, Ehh !
--
minus_branches (NewRoot nd _) = left_t
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
minus_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(minus_trees t1 t1')
--
-- The left is above the right
--
- minus_branches (LeftRoot Left)
+ minus_branches (LeftRoot Leftt)
= mkSLNodeUFM
(NodeUFMData j p)
- (minus_trees t1 right_t)
+ (minus_trees t1 right_t)
t2
- minus_branches (LeftRoot Right)
+ minus_branches (LeftRoot Rightt)
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (minus_trees t2 right_t)
+ (minus_trees t2 right_t)
--
-- The right is above the left
--
- minus_branches (RightRoot Left)
+ minus_branches (RightRoot Leftt)
= minus_trees left_t t1'
- minus_branches (RightRoot Right)
+ minus_branches (RightRoot Rightt)
= minus_trees left_t t2'
minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
where
intersect_trees (LeafUFM i a) t2 =
- case lookup t2 i of
+ 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
+ case lookUp t1 i of
Nothing -> EmptyUFM
Just b -> mkLeafUFM i (f b a)
where
-- Given a disjoint j,j' (p >^ p' && p' >^ p):
--
- -- j j'
+ -- j j'
-- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
+ -- t1 t2 t1' t2'
+ --
-- Fast, Ehh !
--
intersect_branches (NewRoot nd _) = EmptyUFM
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
+ --
intersect_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(intersect_trees t1 t1')
-- j j' t2 + j'
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1' t2'
- --
+ --
-- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Left)
+
+ intersect_branches (LeftRoot Leftt)
= intersect_trees t1 right_t
- intersect_branches (LeftRoot Right)
+ intersect_branches (LeftRoot Rightt)
= intersect_trees t2 right_t
- intersect_branches (RightRoot Left)
+ intersect_branches (RightRoot Leftt)
= intersect_trees left_t t1'
- intersect_branches (RightRoot Right)
+ intersect_branches (RightRoot Rightt)
= intersect_trees left_t t2'
intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
Now the usual set of `collection' operators, like map, fold, etc.
\begin{code}
-foldUFM fn a EmptyUFM = a
-foldUFM fn a fm = fold_tree fn a fm
+foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
+foldUFM f a (LeafUFM _ obj) = f obj a
+foldUFM f a EmptyUFM = a
+\end{code}
+\begin{code}
mapUFM fn EmptyUFM = EmptyUFM
mapUFM fn fm = map_tree fn fm
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}
-lookupUFM fm key = lookup fm (u2i (getTheUnique key))
-lookupDirectlyUFM fm key = lookup fm (u2i key)
+elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
+ Nothing -> False
+ Just _ -> True
+
+lookupUFM fm key = lookUp fm (getKey# (getUnique key))
+lookupUFM_Directly fm key = lookUp fm (getKey# key)
lookupWithDefaultUFM fm deflt key
- = case lookup fm (u2i (getTheUnique key)) of
+ = case lookUp fm (getKey# (getUnique key)) of
+ Nothing -> deflt
+ Just elt -> elt
+
+lookupWithDefaultUFM_Directly fm deflt key
+ = case lookUp fm (getKey# key) of
Nothing -> deflt
Just elt -> elt
-lookup EmptyUFM _ = Nothing
-lookup fm i = lookup_tree fm
+lookUp EmptyUFM _ = Nothing
+lookUp fm i = lookup_tree fm
where
lookup_tree :: UniqFM a -> Maybe a
lookup_tree (LeafUFM j b)
- | j _EQ_ i = Just b
+ | j ==# i = Just b
| otherwise = Nothing
lookup_tree (NodeUFM j p t1 t2)
- | j _GT_ i = lookup_tree t1
+ | j ># i = lookup_tree t1
| otherwise = lookup_tree t2
lookup_tree EmptyUFM = panic "lookup Failed"
folds are *wonderful* things.
\begin{code}
-eltsUFM EmptyUFM = []
-eltsUFM fm = fold_tree (:) [] fm
+eltsUFM fm = foldUFM (:) [] fm
-ufmToList EmptyUFM = []
-ufmToList fm
- = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
- where
- 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
+ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
- fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
+keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
+
+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 f a EmptyUFM = a
\end{code}
%************************************************************************
functionality, but may do a few needless evaluations.
\begin{code}
-mkLeafUFM :: FAST_INT -> a -> UniqFM a
+mkLeafUFM :: FastInt -> a -> UniqFM a
mkLeafUFM i a = LeafUFM i a
-- The *ONLY* ways of building a NodeUFM.
mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
mkSSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
+ = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
NodeUFM j p t1 t2
mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
mkSLNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
+ = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
NodeUFM j p t1 t2
mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
mkLSNodeUFM (NodeUFMData j p) t1 t2
- = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(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)
+ = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
NodeUFM j p t1 t2
correctNodeUFM
= 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
+ = low <= iBox i && iBox i <= high
correct low high above_p (NodeUFM j p _ _)
- = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
+ = low <= iBox j && iBox j <= high && above_p > iBox p
correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
\end{code}
insert_ele
:: (a -> a -> a)
-> UniqFM a
- -> FAST_INT
+ -> FastInt
-> a
-> UniqFM a
insert_ele f EmptyUFM i new = mkLeafUFM i new
insert_ele f (LeafUFM j old) i new
- | j _GT_ i =
+ | j ># i =
mkLLNodeUFM (getCommonNodeUFMData
(indexToRoot i)
(indexToRoot j))
(mkLeafUFM i new)
(mkLeafUFM j old)
- | j _EQ_ i = mkLeafUFM j (f old new)
+ | j ==# i = mkLeafUFM j (f old new)
| otherwise =
mkLLNodeUFM (getCommonNodeUFMData
(indexToRoot i)
(mkLeafUFM i new)
insert_ele f n@(NodeUFM j p t1 t2) i a
- | i _LT_ j
- = if (i _GE_ (j _SUB_ p))
+ | i <# j
+ = if (i >=# (j -# p))
then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
else mkLLNodeUFM (getCommonNodeUFMData
(indexToRoot i)
(mkLeafUFM i a)
n
| otherwise
- = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
+ = if (i <=# ((j -# _ILIT(1)) +# p))
then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
else mkLLNodeUFM (getCommonNodeUFMData
(indexToRoot i)
(mkLeafUFM i a)
\end{code}
-This has got a left to right ordering.
-
-\begin{code}
-fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
-fold_tree f a (LeafUFM _ obj) = f obj a
-fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
-\end{code}
\begin{code}
map_tree f (NodeUFM j p t1 t2)
filter_tree f nd@(NodeUFM j p t1 t2)
= mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
-filter_tree f lf@(LeafUFM i obj)
+filter_tree f lf@(LeafUFM i obj)
| f obj = lf
| otherwise = EmptyUFM
+filter_tree f _ = panic "filter_tree failed"
\end{code}
%************************************************************************
\begin{code}
data NodeUFMData
- = NodeUFMData FAST_INT
- FAST_INT
+ = NodeUFMData FastInt
+ FastInt
\end{code}
This is the information used when computing new NodeUFMs.
\begin{code}
-data Side = Left | Right
+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 ?
This specifies the relationship between NodeUFMData and CalcNodeUFMData.
\begin{code}
-indexToRoot :: FAST_INT -> NodeUFMData
+indexToRoot :: FastInt -> NodeUFMData
indexToRoot i
= let
- l = (ILIT(1) :: FAST_INT)
+ l = (_ILIT(1) :: FastInt)
in
- NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
+ NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
- | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
- | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
- | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ 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
- l = (ILIT(1) :: FAST_INT)
- j = i _QUOT_ (p `shiftL_` l)
- j2 = i2 _QUOT_ (p2 `shiftL_` l)
+ l = (_ILIT(1) :: FastInt)
+ j = i `quotFastInt` (p `shiftL_` l)
+ j2 = i2 `quotFastInt` (p2 `shiftL_` l)
- getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
+ getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
getCommonNodeUFMData_ p j j_
- | j _EQ_ j_
- = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
+ | j ==# j_
+ = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
| otherwise
= getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
- | j _EQ_ j2 = SameRoot
+ | j ==# j2 = SameRoot
| otherwise
= case getCommonNodeUFMData x y of
nd@(NodeUFMData j3 p3)
- | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
- | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
- | otherwise -> NewRoot nd (j _GT_ j2)
+ | j3 ==# j -> LeftRoot (decideSide (j ># j2))
+ | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
+ | otherwise -> NewRoot nd (j ># j2)
where
decideSide :: Bool -> Side
- decideSide True = Left
- decideSide False = Right
+ decideSide True = Leftt
+ decideSide False = Rightt
\end{code}
This might be better in Util.lhs ?
Now the bit twiddling functions.
\begin{code}
-shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
-shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
+shiftL_ :: FastInt -> FastInt -> FastInt
+shiftR_ :: FastInt -> FastInt -> FastInt
#if __GLASGOW_HASKELL__
{-# INLINE shiftL_ #-}
{-# INLINE shiftR_ #-}
+#if __GLASGOW_HASKELL__ >= 503
+shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
+#else
shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
+#endif
shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
-# if __GLASGOW_HASKELL__ >= 23
where
- shiftr x y = shiftRA# x y
-# else
- shiftr x y = shiftR# x y
-# endif
+#if __GLASGOW_HASKELL__ >= 503
+ shiftr x y = uncheckedShiftRL# x y
+#else
+ shiftr x y = shiftRL# x y
+#endif
-#else {- not GHC -}
+#else /* not GHC */
shiftL_ n p = n * (2 ^ p)
shiftR_ n p = n `quot` (2 ^ p)
-#endif {- not GHC -}
+#endif /* not GHC */
\end{code}
-Andy's extras: ToDo: to Util.
-
\begin{code}
-use_fst :: a -> b -> a
-use_fst a b = a
-
use_snd :: a -> b -> b
use_snd a b = b
\end{code}
projects / ghc-hetmet.git / blobdiff