X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUniqFM.lhs;h=cc2d066ab761896f15e54e176b4b2259fdb46cd8;hb=9aad47f1162666431deee99884c523b1ff69cf98;hp=2184f52db61549d1093244b6ee485c3680690748;hpb=bbd67a5f4f3515ea5c37711815b2f6ad58cbd655;p=ghc-hetmet.git diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 2184f52..cc2d066 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -15,14 +15,17 @@ Basically, the things need to be in class @Uniquable@, and we use the \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, @@ -51,12 +54,10 @@ module UniqFM ( #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} %************************************************************************ @@ -76,6 +77,9 @@ unitDirectlyUFM -- got the Unique already 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 @@ -198,18 +202,18 @@ This code is explained in the paper: %* * %************************************************************************ -@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 {- @@ -237,14 +241,17 @@ First the ways of building a UniqFM. \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. @@ -257,13 +264,13 @@ 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 (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 @@ -271,12 +278,12 @@ 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 (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} @@ -285,10 +292,10 @@ Now ways of removing things from UniqFM. \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 @@ -539,9 +546,7 @@ mapUFM _fn EmptyUFM = EmptyUFM 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 @@ -576,20 +581,20 @@ Lookup up a binary tree is easy (and fast). 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 @@ -638,7 +643,9 @@ functionality, but may do a few needless evaluations. \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. @@ -702,7 +709,7 @@ insert_ele f (LeafUFM j old) i new (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) @@ -787,10 +794,7 @@ This specifies the relationship between NodeUFMData and CalcNodeUFMData. 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 @@ -799,17 +803,16 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) | 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 @@ -832,20 +835,14 @@ This might be better in Util.lhs ? Now the bit twiddling functions. \begin{code} -shiftL_ :: FastInt -> FastInt -> FastInt -shiftR_ :: FastInt -> FastInt -> FastInt +shiftL1 :: FastInt -> FastInt +shiftR1 :: 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) +{-# INLINE shiftL1 #-} +{-# INLINE shiftR1 #-} -#else /* not GHC */ -shiftL_ n p = n * (2 ^ p) -shiftR_ n p = n `quot` (2 ^ p) - -#endif /* not GHC */ +shiftL1 n = n `shiftLFastInt` _ILIT(1) +shiftR1 n = n `shiftR_FastInt` _ILIT(1) \end{code} \begin{code} @@ -853,7 +850,21 @@ use_snd :: a -> b -> b 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. +-}