X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUniqFM.lhs;h=cc2d066ab761896f15e54e176b4b2259fdb46cd8;hp=3abf698fb888d65d69ec04fb5499f4fc2163de1e;hb=831a35dd00faff195cf938659c2dd736192b865f;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 3abf698..cc2d066 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -13,21 +13,19 @@ Basically, the things need to be in class @Uniquable@, and we use the (A similar thing to @UniqSet@, as opposed to @Set@.) \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module UniqFM ( - UniqFM, -- abstract type + -- * 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, @@ -41,7 +39,7 @@ module UniqFM ( intersectsUFM, intersectUFM, intersectUFM_C, - foldUFM, + foldUFM, foldUFM_Directly, mapUFM, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, @@ -56,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} %************************************************************************ @@ -81,9 +77,13 @@ 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 +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt @@ -120,6 +120,7 @@ intersectUFM_C :: (elt1 -> elt2 -> 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 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt @@ -201,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 {- @@ -240,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. @@ -260,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 @@ -274,11 +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} @@ -287,9 +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 -> FastInt -> UniqFM a delete EmptyUFM _ = EmptyUFM delete fm key = del_ele fm where @@ -299,7 +305,7 @@ delete fm key = del_ele fm | 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 @@ -313,8 +319,8 @@ Now ways of adding two UniqFM's together. \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 @@ -397,10 +403,10 @@ minusUFM fm1 fm2 = minus_trees fm1 fm2 -- -- 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 @@ -419,7 +425,7 @@ minusUFM fm1 fm2 = minus_trees fm1 fm2 -- -- Fast, Ehh ! -- - minus_branches (NewRoot nd _) = left_t + minus_branches (NewRoot _ _) = left_t -- Now, if j == j': -- @@ -465,8 +471,8 @@ And taking the intersection of two UniqFM's. 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 = @@ -493,7 +499,7 @@ intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2 -- -- Fast, Ehh ! -- - intersect_branches (NewRoot nd _) = EmptyUFM + intersect_branches (NewRoot _nd _) = EmptyUFM -- Now, if j == j': -- @@ -524,7 +530,7 @@ intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2 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. @@ -532,20 +538,18 @@ 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} @@ -577,19 +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 -> FastInt -> Maybe a lookUp EmptyUFM _ = Nothing lookUp fm i = lookup_tree fm where @@ -598,7 +603,7 @@ lookUp fm i = lookup_tree fm 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 @@ -608,15 +613,15 @@ lookUp fm i = lookup_tree fm 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} %************************************************************************ @@ -638,22 +643,27 @@ 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. -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 @@ -690,16 +700,16 @@ insert_ele -> 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) @@ -729,23 +739,24 @@ insert_ele f n@(NodeUFM j p t1 t2) i a \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} %************************************************************************ @@ -783,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 @@ -795,25 +803,24 @@ 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 -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) @@ -828,23 +835,36 @@ This might be better in Util.lhs ? 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} + +{- 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. +-}