\begin{code}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module UniqFM (
+ -- * Unique-keyed mappings
UniqFM(..), -- abstract type
-- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
+ -- ** Manipulating those mappings
emptyUFM,
unitUFM,
unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
+ listToUFM_C,
addToUFM,addToUFM_C,addToUFM_Acc,
addListToUFM,addListToUFM_C,
addToUFM_Directly,
isNullUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
- eltsUFM, keysUFM,
+ eltsUFM, keysUFM, splitUFM,
ufmToList
) where
#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}
%************************************************************************
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
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)]
%* *
%************************************************************************
-@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}
+-- | @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)
+ | 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
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.
\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 -> Int# -> UniqFM a
+delete :: UniqFM a -> FastInt -> UniqFM a
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
where
(mix_trees t2 t2')
-- Now the 4 different other ways; all like this:
--
- -- Given j >^ j' (and, say, j > j')
+ -- Given j >^ j' (and, say, j > j')
--
-- j j' j
-- / \ + / \ ==> / \
mapUFM fn fm = map_tree fn fm
filterUFM _fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree pred fm
- where
- pred (_::FastInt) e = fn e
+filterUFM fn fm = filter_tree (\_ e -> fn e) fm
filterUFM_Directly _fn EmptyUFM = EmptyUFM
filterUFM_Directly fn fm = filter_tree pred fm
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 -> Int# -> Maybe a
+lookUp :: UniqFM a -> FastInt -> Maybe a
lookUp EmptyUFM _ = Nothing
lookUp fm i = lookup_tree fm
where
| 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}
mkLeafUFM :: FastInt -> a -> UniqFM a
-mkLeafUFM i a = LeafUFM i a
+mkLeafUFM i a =
+ ASSERT (iBox i >= 0) -- Note [Uniques must be positive]
+ LeafUFM i a
-- The *ONLY* ways of building a NodeUFM.
(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)
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
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 _ b = b
\end{code}
-\begin{code}
-_unused :: FS.FastString
-_unused = undefined
-\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.
+-}