(A similar thing to @UniqSet@, as opposed to @Set@.)
\begin{code}
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module UniqFM (
- UniqFM, -- abstract type
+ UniqFM(..), -- abstract type
+ -- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
emptyUFM,
unitUFM,
intersectsUFM,
intersectUFM,
intersectUFM_C,
- foldUFM,
+ foldUFM, foldUFM_Directly,
mapUFM,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly,
#include "HsVersions.h"
-import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
+import Unique ( Uniquable(..), Unique, getKeyFastInt, mkUniqueGrimily )
import Maybes ( maybeToBool )
import FastTypes
import Outputable
-
-import GHC.Exts -- Lots of Int# operations
\end{code}
%************************************************************************
addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
intersectsUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
+foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
\begin{code}
data UniqFM ele
= EmptyUFM
- | LeafUFM FastInt ele
- | NodeUFM FastInt -- the switching
- FastInt -- the delta
- (UniqFM ele)
- (UniqFM ele)
+ | LeafUFM !FastInt ele
+ | NodeUFM !FastInt -- the switching
+ !FastInt -- the delta
+ (UniqFM ele)
+ (UniqFM ele)
-- INVARIANT: the children of a NodeUFM are never EmptyUFMs
{-
\begin{code}
emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (getKey# (getUnique key)) elt
-unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
+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
\begin{code}
addToUFM fm key elt = addToUFM_C use_snd fm key elt
-addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
+addToUFM_Directly fm u elt = insert_ele use_snd fm (getKeyFastInt u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (getKey# (getUnique key)) elt
+ = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt
addToUFM_Acc add unit fm key item
- = insert_ele combiner fm (getKey# (getUnique key)) (unit item)
+ = insert_ele combiner fm (getKeyFastInt (getUnique key)) (unit item)
where
combiner old _unit_item = add item old
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 (getKey# (getUnique k)) e)
+ = 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 (getKey# k) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt k) e)
fm uniq_elt_pairs
\end{code}
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (getKey# (getUnique key))
-delFromUFM_Directly fm u = delete fm (getKey# u)
+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
| j ==# key = EmptyUFM
| otherwise = lf -- no delete!
- del_ele nd@(NodeUFM j p t1 t2)
+ del_ele (NodeUFM j p t1 t2)
| j ># key
= mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
| otherwise
\begin{code}
plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
-plusUFM_C f EmptyUFM tr = tr
-plusUFM_C f tr EmptyUFM = tr
+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
--
-- Notice the asymetry of subtraction
--
- minus_trees lf@(LeafUFM i a) t2 =
+ minus_trees lf@(LeafUFM i _a) t2 =
case lookUp t2 i of
Nothing -> lf
- Just b -> EmptyUFM
+ Just _ -> EmptyUFM
minus_trees t1 (LeafUFM i _) = delete t1 i
--
-- Fast, Ehh !
--
- minus_branches (NewRoot nd _) = left_t
+ minus_branches (NewRoot _ _) = left_t
-- Now, if j == j':
--
intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
-intersectUFM_C f EmptyUFM _ = EmptyUFM
-intersectUFM_C f _ EmptyUFM = EmptyUFM
+intersectUFM_C _ EmptyUFM _ = EmptyUFM
+intersectUFM_C _ _ EmptyUFM = EmptyUFM
intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
where
intersect_trees (LeafUFM i a) t2 =
--
-- Fast, Ehh !
--
- intersect_branches (NewRoot nd _) = EmptyUFM
+ intersect_branches (NewRoot _nd _) = EmptyUFM
-- Now, if j == j':
--
intersect_branches (RightRoot Rightt)
= intersect_trees left_t t2'
- intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
+ 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 f a EmptyUFM = a
+foldUFM _ a EmptyUFM = a
\end{code}
\begin{code}
-mapUFM fn EmptyUFM = EmptyUFM
-mapUFM fn fm = map_tree fn fm
+mapUFM _fn EmptyUFM = EmptyUFM
+mapUFM fn fm = map_tree fn fm
-filterUFM fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree pred fm
- where
- pred (i::FastInt) e = fn e
+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
+filterUFM_Directly _fn EmptyUFM = EmptyUFM
+filterUFM_Directly fn fm = filter_tree pred fm
where
pred i e = fn (mkUniqueGrimily (iBox i)) e
\end{code}
elemUFM key fm = maybeToBool (lookupUFM fm key)
elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
-lookupUFM fm key = lookUp fm (getKey# (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKey# key)
+lookupUFM fm key = lookUp fm (getKeyFastInt (getUnique key))
+lookupUFM_Directly fm key = lookUp fm (getKeyFastInt key)
lookupWithDefaultUFM fm deflt key
- = case lookUp fm (getKey# (getUnique key)) of
+ = case lookUp fm (getKeyFastInt (getUnique key)) of
Nothing -> deflt
Just elt -> elt
lookupWithDefaultUFM_Directly fm deflt key
- = case lookUp fm (getKey# key) of
+ = 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 (LeafUFM j b)
| j ==# i = Just b
| otherwise = Nothing
- lookup_tree (NodeUFM j p t1 t2)
+ lookup_tree (NodeUFM j _ t1 t2)
| j ># i = lookup_tree t1
| otherwise = lookup_tree t2
folds are *wonderful* things.
\begin{code}
-eltsUFM fm = foldUFM (:) [] fm
-
-ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
-
-keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
+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 f a EmptyUFM = a
+fold_tree _ a EmptyUFM = a
\end{code}
%************************************************************************
-- The *ONLY* ways of building a NodeUFM.
-mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
-mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
+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 j p) EmptyUFM t2 = 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 j p) t1 EmptyUFM = t1
+mkLSNodeUFM (NodeUFMData _ _) t1 EmptyUFM = t1
mkLSNodeUFM (NodeUFMData j p) t1 t2
= ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
NodeUFM j p t1 t2
-> a
-> UniqFM a
-insert_ele f EmptyUFM i new = mkLeafUFM i new
+insert_ele _f EmptyUFM i new = mkLeafUFM i new
-insert_ele f (LeafUFM j old) 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)
+ | j ==# i = mkLeafUFM j $ f old new
| otherwise =
mkLLNodeUFM (getCommonNodeUFMData
(indexToRoot i)
\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 f _ = panic "map_tree failed"
+map_tree _ _ = panic "map_tree failed"
\end{code}
\begin{code}
filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
-filter_tree f nd@(NodeUFM j p t1 t2)
+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 f _ = panic "filter_tree failed"
+filter_tree _ _ = panic "filter_tree failed"
\end{code}
%************************************************************************
indexToRoot :: FastInt -> NodeUFMData
indexToRoot i
- = let
- l = (_ILIT(1) :: FastInt)
- in
- NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
+ = NodeUFMData ((shiftL1 (shiftR1 i)) +# _ILIT(1)) (_ILIT(1))
getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
| p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
| otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
where
- l = (_ILIT(1) :: FastInt)
- j = i `quotFastInt` (p `shiftL_` l)
- j2 = i2 `quotFastInt` (p2 `shiftL_` l)
+ j = i `quotFastInt` (shiftL1 p)
+ j2 = i2 `quotFastInt` (shiftL1 p2)
getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
getCommonNodeUFMData_ p j j_
| j ==# j_
- = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
+ = NodeUFMData (((shiftL1 j) +# _ILIT(1)) *# p) p
| otherwise
- = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
+ = 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)
+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)
+ nd@(NodeUFMData j3 _p3)
| j3 ==# j -> LeftRoot (decideSide (j ># j2))
| j3 ==# j2 -> RightRoot (decideSide (j <# j2))
| otherwise -> NewRoot nd (j ># j2)
Now the bit twiddling functions.
\begin{code}
-shiftL_ :: FastInt -> FastInt -> FastInt
-shiftR_ :: FastInt -> FastInt -> FastInt
-
-#if __GLASGOW_HASKELL__
-{-# INLINE shiftL_ #-}
-{-# INLINE shiftR_ #-}
-shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
-shiftR_ n p = word2Int#((int2Word# n) `uncheckedShiftRL#` p)
+shiftL1 :: FastInt -> FastInt
+shiftR1 :: FastInt -> FastInt
-#else /* not GHC */
-shiftL_ n p = n * (2 ^ p)
-shiftR_ n p = n `quot` (2 ^ p)
+{-# INLINE shiftL1 #-}
+{-# INLINE shiftR1 #-}
-#endif /* not GHC */
+shiftL1 n = n `shiftLFastInt` _ILIT(1)
+shiftR1 n = n `shiftR_FastInt` _ILIT(1)
\end{code}
\begin{code}
use_snd :: a -> b -> b
-use_snd a b = b
+use_snd _ b = b
\end{code}
+
projects / ghc-hetmet.git / blobdiff