X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUniqFM.lhs;h=9a3d6063ab3310af98830d0f09ed6176411807c5;hb=cd24d61675e2f5c9145efcac62f64347789e583c;hp=59158f38b2be2618af4cd1a2da761997759bc0d3;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;p=ghc-hetmet.git diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 59158f3..9a3d606 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, @@ -45,7 +48,7 @@ module UniqFM ( isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - eltsUFM, keysUFM, + eltsUFM, keysUFM, splitUFM, ufmToList ) where @@ -74,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 @@ -124,6 +130,8 @@ hashUFM :: UniqFM elt -> Int 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 @@ -131,7 +139,6 @@ lookupWithDefaultUFM :: 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)] @@ -196,18 +203,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 {- @@ -243,6 +250,9 @@ listToUFM 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. @@ -349,7 +359,7 @@ plusUFM_C f fm1 fm2 = mix_trees fm1 fm2 (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 -- / \ + / \ ==> / \ @@ -599,6 +609,25 @@ lookUp fm i = lookup_tree fm | 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. @@ -634,7 +663,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. @@ -698,7 +729,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) @@ -792,8 +823,8 @@ 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 - j = i `quotFastInt` (shiftL1 p) - j2 = i2 `quotFastInt` (shiftL1 p2) + !j = i `quotFastInt` (shiftL1 p) + !j2 = i2 `quotFastInt` (shiftL1 p2) getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData @@ -839,7 +870,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. +-}