2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1994-1998
6 UniqFM: Specialised finite maps, for things with @Uniques@
8 Based on @FiniteMaps@ (as you would expect).
10 Basically, the things need to be in class @Uniquable@, and we use the
11 @getUnique@ method to grab their @Uniques@.
13 (A similar thing to @UniqSet@, as opposed to @Set@.)
16 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
18 -- * Unique-keyed mappings
19 UniqFM(..), -- abstract type
20 -- (de-abstracted for MachRegs.trivColorable optimisation BL 2007/09)
22 -- ** Manipulating those mappings
29 addToUFM,addToUFM_C,addToUFM_Acc,
30 addListToUFM,addListToUFM_C,
32 addListToUFM_Directly,
42 foldUFM, foldUFM_Directly,
44 elemUFM, elemUFM_Directly,
45 filterUFM, filterUFM_Directly,
49 lookupUFM, lookupUFM_Directly,
50 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
51 eltsUFM, keysUFM, splitUFM,
55 #include "HsVersions.h"
57 import Unique ( Uniquable(..), Unique, getKeyFastInt, mkUniqueGrimily )
58 import Maybes ( maybeToBool )
63 %************************************************************************
65 \subsection{The @UniqFM@ type, and signatures for the functions}
67 %************************************************************************
69 We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
72 emptyUFM :: UniqFM elt
73 isNullUFM :: UniqFM elt -> Bool
74 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
75 unitDirectlyUFM -- got the Unique already
76 :: Unique -> elt -> UniqFM elt
77 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
79 :: [(Unique, elt)] -> UniqFM elt
80 listToUFM_C :: Uniquable key => (elt -> elt -> elt)
84 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
85 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
86 addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
88 :: UniqFM elt -> Unique -> elt -> UniqFM elt
90 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
93 -> UniqFM elt -- result
95 addToUFM_Acc :: Uniquable key =>
96 (elt -> elts -> elts) -- Add to existing
97 -> (elt -> elts) -- New element
100 -> UniqFM elts -- result
102 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
103 -> UniqFM elt -> [(key,elt)]
106 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
107 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
108 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
110 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
112 plusUFM_C :: (elt -> elt -> elt)
113 -> UniqFM elt -> UniqFM elt -> UniqFM elt
115 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
117 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
118 intersectUFM_C :: (elt1 -> elt2 -> elt3)
119 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
120 intersectsUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool
122 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
123 foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
124 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
125 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
126 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
128 sizeUFM :: UniqFM elt -> Int
129 hashUFM :: UniqFM elt -> Int
130 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
131 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
133 splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
134 -- Splits a UFM into things less than, equal to, and greater than the key
135 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
136 lookupUFM_Directly -- when you've got the Unique already
137 :: UniqFM elt -> Unique -> Maybe elt
139 :: Uniquable key => UniqFM elt -> elt -> key -> elt
140 lookupWithDefaultUFM_Directly
141 :: UniqFM elt -> elt -> Unique -> elt
142 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
143 eltsUFM :: UniqFM elt -> [elt]
144 ufmToList :: UniqFM elt -> [(Unique, elt)]
147 %************************************************************************
149 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
151 %************************************************************************
154 -- Turn off for now, these need to be updated (SDM 4/98)
157 #ifdef __GLASGOW_HASKELL__
158 -- I don't think HBC was too happy about this (WDP 94/10)
161 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
164 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
167 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
170 listToUFM :: [(Unique, elt)] -> UniqFM elt
173 lookupUFM :: UniqFM elt -> Name -> Maybe elt
174 , UniqFM elt -> Unique -> Maybe elt
177 #endif /* __GLASGOW_HASKELL__ */
181 %************************************************************************
183 \subsection{Andy Gill's underlying @UniqFM@ machinery}
185 %************************************************************************
187 ``Uniq Finite maps'' are the heart and soul of the compiler's
188 lookup-tables/environments. Important stuff! It works well with
189 Dense and Sparse ranges.
190 Both @Uq@ Finite maps and @Hash@ Finite Maps
191 are built ontop of Int Finite Maps.
193 This code is explained in the paper:
195 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
196 "A Cheap balancing act that grows on a tree"
197 Glasgow FP Workshop, Sep 1994, pp??-??
200 %************************************************************************
202 \subsubsection{The @UniqFM@ type, and signatures for the functions}
204 %************************************************************************
206 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
209 -- | @UniqFM a@ is a mapping from Unique to @a@. DO NOT use these constructors
210 -- directly unless you live in this module!
213 | LeafUFM !FastInt ele
214 | NodeUFM !FastInt -- the switching
215 !FastInt -- the delta
218 -- INVARIANT: the children of a NodeUFM are never EmptyUFMs
221 -- for debugging only :-)
222 instance Outputable (UniqFM a) where
223 ppr(NodeUFM a b t1 t2) =
224 sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
225 nest 1 (parens (ppr t1)),
226 nest 1 (parens (ppr t2))]
227 ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
228 ppr (EmptyUFM) = empty
230 -- and when not debugging the package itself...
231 instance Outputable a => Outputable (UniqFM a) where
232 ppr ufm = ppr (ufmToList ufm)
235 %************************************************************************
237 \subsubsection{The @UniqFM@ functions}
239 %************************************************************************
241 First the ways of building a UniqFM.
245 unitUFM key elt = mkLeafUFM (getKeyFastInt (getUnique key)) elt
246 unitDirectlyUFM key elt = mkLeafUFM (getKeyFastInt key) elt
248 listToUFM key_elt_pairs
249 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
251 listToUFM_Directly uniq_elt_pairs
252 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
254 listToUFM_C combiner key_elt_pairs
255 = addListToUFM_C combiner EmptyUFM key_elt_pairs
258 Now ways of adding things to UniqFMs.
260 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
261 but the semantics of this operation demands a linear insertion;
262 perhaps the version without the combinator function
263 could be optimised using it.
266 addToUFM fm key elt = addToUFM_C use_snd fm key elt
268 addToUFM_Directly fm u elt = insert_ele use_snd fm (getKeyFastInt u) elt
270 addToUFM_C combiner fm key elt
271 = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt
273 addToUFM_Acc add unit fm key item
274 = insert_ele combiner fm (getKeyFastInt (getUnique key)) (unit item)
276 combiner old _unit_item = add item old
278 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
279 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
281 addListToUFM_C combiner fm key_elt_pairs
282 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt (getUnique k)) e)
285 addListToUFM_directly_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Unique,elt)] -> UniqFM elt
286 addListToUFM_directly_C combiner fm uniq_elt_pairs
287 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt k) e)
291 Now ways of removing things from UniqFM.
294 delListFromUFM fm lst = foldl delFromUFM fm lst
296 delFromUFM fm key = delete fm (getKeyFastInt (getUnique key))
297 delFromUFM_Directly fm u = delete fm (getKeyFastInt u)
299 delete :: UniqFM a -> FastInt -> UniqFM a
300 delete EmptyUFM _ = EmptyUFM
301 delete fm key = del_ele fm
303 del_ele :: UniqFM a -> UniqFM a
305 del_ele lf@(LeafUFM j _)
306 | j ==# key = EmptyUFM
307 | otherwise = lf -- no delete!
309 del_ele (NodeUFM j p t1 t2)
311 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
313 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
315 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
318 Now ways of adding two UniqFM's together.
321 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
323 plusUFM_C _ EmptyUFM tr = tr
324 plusUFM_C _ tr EmptyUFM = tr
325 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
327 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
328 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
330 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
332 (ask_about_common_ancestor
336 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
340 -- t1 t2 t1' t2' j j'
345 mix_branches (NewRoot nd False)
346 = mkLLNodeUFM nd left_t right_t
347 mix_branches (NewRoot nd True)
348 = mkLLNodeUFM nd right_t left_t
354 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
356 mix_branches (SameRoot)
357 = mkSSNodeUFM (NodeUFMData j p)
360 -- Now the 4 different other ways; all like this:
362 -- Given j >^ j' (and, say, j > j')
366 -- t1 t2 t1' t2' t1 t2 + j'
369 mix_branches (LeftRoot Leftt) -- | trace "LL" True
372 (mix_trees t1 right_t)
375 mix_branches (LeftRoot Rightt) -- | trace "LR" True
379 (mix_trees t2 right_t)
381 mix_branches (RightRoot Leftt) -- | trace "RL" True
384 (mix_trees left_t t1')
387 mix_branches (RightRoot Rightt) -- | trace "RR" True
391 (mix_trees left_t t2')
393 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
396 And ways of subtracting them. First the base cases,
397 then the full D&C approach.
400 minusUFM EmptyUFM _ = EmptyUFM
401 minusUFM t1 EmptyUFM = t1
402 minusUFM fm1 fm2 = minus_trees fm1 fm2
405 -- Notice the asymetry of subtraction
407 minus_trees lf@(LeafUFM i _a) t2 =
412 minus_trees t1 (LeafUFM i _) = delete t1 i
414 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
416 (ask_about_common_ancestor
420 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
424 -- t1 t2 t1' t2' t1 t2
429 minus_branches (NewRoot _ _) = left_t
435 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
437 minus_branches (SameRoot)
438 = mkSSNodeUFM (NodeUFMData j p)
441 -- Now the 4 different other ways; all like this:
442 -- again, with asymatry
445 -- The left is above the right
447 minus_branches (LeftRoot Leftt)
450 (minus_trees t1 right_t)
452 minus_branches (LeftRoot Rightt)
456 (minus_trees t2 right_t)
459 -- The right is above the left
461 minus_branches (RightRoot Leftt)
462 = minus_trees left_t t1'
463 minus_branches (RightRoot Rightt)
464 = minus_trees left_t t2'
466 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
469 And taking the intersection of two UniqFM's.
472 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
473 intersectsUFM t1 t2 = isNullUFM (intersectUFM_C (\ _ _ -> error "urk") t1 t2)
475 intersectUFM_C _ EmptyUFM _ = EmptyUFM
476 intersectUFM_C _ _ EmptyUFM = EmptyUFM
477 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
479 intersect_trees (LeafUFM i a) t2 =
482 Just b -> mkLeafUFM i (f a b)
484 intersect_trees t1 (LeafUFM i a) =
487 Just b -> mkLeafUFM i (f b a)
489 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
491 (ask_about_common_ancestor
495 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
498 -- / \ + / \ ==> EmptyUFM
503 intersect_branches (NewRoot _nd _) = EmptyUFM
509 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
511 intersect_branches (SameRoot)
512 = mkSSNodeUFM (NodeUFMData j p)
513 (intersect_trees t1 t1')
514 (intersect_trees t2 t2')
515 -- Now the 4 different other ways; all like this:
517 -- Given j >^ j' (and, say, j > j')
521 -- t1 t2 t1' t2' t1' t2'
523 -- This does cut down the search space quite a bit.
525 intersect_branches (LeftRoot Leftt)
526 = intersect_trees t1 right_t
527 intersect_branches (LeftRoot Rightt)
528 = intersect_trees t2 right_t
529 intersect_branches (RightRoot Leftt)
530 = intersect_trees left_t t1'
531 intersect_branches (RightRoot Rightt)
532 = intersect_trees left_t t2'
534 intersect_trees _ _ = panic ("EmptyUFM found when intersecting trees")
537 Now the usual set of `collection' operators, like map, fold, etc.
540 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
541 foldUFM f a (LeafUFM _ obj) = f obj a
542 foldUFM _ a EmptyUFM = a
546 mapUFM _fn EmptyUFM = EmptyUFM
547 mapUFM fn fm = map_tree fn fm
549 filterUFM _fn EmptyUFM = EmptyUFM
550 filterUFM fn fm = filter_tree (\_ e -> fn e) fm
552 filterUFM_Directly _fn EmptyUFM = EmptyUFM
553 filterUFM_Directly fn fm = filter_tree pred fm
555 pred i e = fn (mkUniqueGrimily (iBox i)) e
558 Note, this takes a long time, O(n), but
559 because we dont want to do this very often, we put up with this.
560 O'rable, but how often do we look at the size of
565 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
566 sizeUFM (LeafUFM _ _) = 1
568 isNullUFM EmptyUFM = True
571 -- hashing is used in VarSet.uniqAway, and should be fast
572 -- We use a cheap and cheerful method for now
574 hashUFM (NodeUFM n _ _ _) = iBox n
575 hashUFM (LeafUFM n _) = iBox n
578 looking up in a hurry is the {\em whole point} of this binary tree lark.
579 Lookup up a binary tree is easy (and fast).
582 elemUFM key fm = maybeToBool (lookupUFM fm key)
583 elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
585 lookupUFM fm key = lookUp fm (getKeyFastInt (getUnique key))
586 lookupUFM_Directly fm key = lookUp fm (getKeyFastInt key)
588 lookupWithDefaultUFM fm deflt key
589 = case lookUp fm (getKeyFastInt (getUnique key)) of
593 lookupWithDefaultUFM_Directly fm deflt key
594 = case lookUp fm (getKeyFastInt key) of
598 lookUp :: UniqFM a -> FastInt -> Maybe a
599 lookUp EmptyUFM _ = Nothing
600 lookUp fm i = lookup_tree fm
602 lookup_tree :: UniqFM a -> Maybe a
604 lookup_tree (LeafUFM j b)
606 | otherwise = Nothing
607 lookup_tree (NodeUFM j _ t1 t2)
608 | j ># i = lookup_tree t1
609 | otherwise = lookup_tree t2
611 lookup_tree EmptyUFM = panic "lookup Failed"
614 splitUFM fm key = split fm (getKeyFastInt (getUnique key))
616 split :: UniqFM a -> FastInt -> (UniqFM a, Maybe a, UniqFM a)
617 -- Splits a UFM into things less than, equal to, and greater than the key
618 split EmptyUFM _ = (EmptyUFM, Nothing, EmptyUFM)
621 go (LeafUFM j b) | i <# j = (EmptyUFM, Nothing, LeafUFM j b)
622 | i ># j = (LeafUFM j b, Nothing, EmptyUFM)
623 | otherwise = (EmptyUFM, Just b, EmptyUFM)
625 go (NodeUFM j p t1 t2)
627 , (lt, eq, gt) <- go t1 = (lt, eq, mkSLNodeUFM (NodeUFMData j p) gt t2)
628 | (lt, eq, gt) <- go t2 = (mkLSNodeUFM (NodeUFMData j p) t1 lt, eq, gt)
630 go EmptyUFM = panic "splitUFM failed"
633 folds are *wonderful* things.
636 eltsUFM fm = foldUFM (:) [] fm
637 keysUFM fm = foldUFM_Directly (\u _ l -> u : l) [] fm
638 ufmToList fm = foldUFM_Directly (\u e l -> (u, e) : l) [] fm
639 foldUFM_Directly f = fold_tree (\iu e a -> f (mkUniqueGrimily (iBox iu)) e a)
641 fold_tree :: (FastInt -> elt -> a -> a) -> a -> UniqFM elt -> a
642 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
643 fold_tree f a (LeafUFM iu obj) = f iu obj a
644 fold_tree _ a EmptyUFM = a
647 %************************************************************************
649 \subsubsection{The @UniqFM@ type, and its functions}
651 %************************************************************************
653 You should always use these to build the tree.
654 There are 4 versions of mkNodeUFM, depending on
655 the strictness of the two sub-tree arguments.
656 The strictness is used *both* to prune out
657 empty trees, *and* to improve performance,
658 stoping needless thunks lying around.
659 The rule of thumb (from experence with these trees)
660 is make thunks strict, but data structures lazy.
661 If in doubt, use mkSSNodeUFM, which has the `strongest'
662 functionality, but may do a few needless evaluations.
665 mkLeafUFM :: FastInt -> a -> UniqFM a
667 ASSERT (iBox i >= 0) -- Note [Uniques must be positive]
670 -- The *ONLY* ways of building a NodeUFM.
672 mkSSNodeUFM, mkSLNodeUFM, mkLSNodeUFM, mkLLNodeUFM ::
673 NodeUFMData -> UniqFM a -> UniqFM a -> UniqFM a
675 mkSSNodeUFM (NodeUFMData _ _) EmptyUFM t2 = t2
676 mkSSNodeUFM (NodeUFMData _ _) t1 EmptyUFM = t1
677 mkSSNodeUFM (NodeUFMData j p) t1 t2
678 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
681 mkSLNodeUFM (NodeUFMData _ _) EmptyUFM t2 = t2
682 mkSLNodeUFM (NodeUFMData j p) t1 t2
683 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
686 mkLSNodeUFM (NodeUFMData _ _) t1 EmptyUFM = t1
687 mkLSNodeUFM (NodeUFMData j p) t1 t2
688 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
691 mkLLNodeUFM (NodeUFMData j p) t1 t2
692 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
702 correctNodeUFM j p t1 t2
703 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
705 correct low high _ (LeafUFM i _)
706 = low <= iBox i && iBox i <= high
707 correct low high above_p (NodeUFM j p _ _)
708 = low <= iBox j && iBox j <= high && above_p > iBox p
709 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
712 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
713 and if necessary do $\lambda$ lifting on our functions that are bound.
717 :: (a -> a -> a) -- old -> new -> result
723 insert_ele _f EmptyUFM i new = mkLeafUFM i new
725 insert_ele f (LeafUFM j old) i new
727 mkLLNodeUFM (getCommonNodeUFMData
732 | j ==# i = mkLeafUFM j $ f old new
734 mkLLNodeUFM (getCommonNodeUFMData
740 insert_ele f n@(NodeUFM j p t1 t2) i a
742 = if (i >=# (j -# p))
743 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
744 else mkLLNodeUFM (getCommonNodeUFMData
750 = if (i <=# ((j -# _ILIT(1)) +# p))
751 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
752 else mkLLNodeUFM (getCommonNodeUFMData
762 map_tree :: (a -> b) -> UniqFM a -> UniqFM b
763 map_tree f (NodeUFM j p t1 t2)
764 = mkLLNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
765 -- NB. lazy! we know the tree is well-formed.
766 map_tree f (LeafUFM i obj)
767 = mkLeafUFM i (f obj)
768 map_tree _ _ = panic "map_tree failed"
772 filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
773 filter_tree f (NodeUFM j p t1 t2)
774 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
776 filter_tree f lf@(LeafUFM i obj)
778 | otherwise = EmptyUFM
779 filter_tree _ _ = panic "filter_tree failed"
782 %************************************************************************
784 \subsubsection{The @UniqFM@ type, and signatures for the functions}
786 %************************************************************************
790 This is the information that is held inside a NodeUFM, packaged up for
795 = NodeUFMData FastInt
799 This is the information used when computing new NodeUFMs.
802 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
804 = LeftRoot Side -- which side is the right down ?
805 | RightRoot Side -- which side is the left down ?
806 | SameRoot -- they are the same !
807 | NewRoot NodeUFMData -- here's the new, common, root
808 Bool -- do you need to swap left and right ?
811 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
814 indexToRoot :: FastInt -> NodeUFMData
817 = NodeUFMData ((shiftL1 (shiftR1 i)) +# _ILIT(1)) (_ILIT(1))
819 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
821 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
822 | p ==# p2 = getCommonNodeUFMData_ p j j2
823 | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
824 | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
826 !j = i `quotFastInt` (shiftL1 p)
827 !j2 = i2 `quotFastInt` (shiftL1 p2)
829 getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
831 getCommonNodeUFMData_ p j j_
833 = NodeUFMData (((shiftL1 j) +# _ILIT(1)) *# p) p
835 = getCommonNodeUFMData_ (shiftL1 p) (shiftR1 j) (shiftR1 j_)
837 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
839 ask_about_common_ancestor x@(NodeUFMData j _p) y@(NodeUFMData j2 _p2)
840 | j ==# j2 = SameRoot
842 = case getCommonNodeUFMData x y of
843 nd@(NodeUFMData j3 _p3)
844 | j3 ==# j -> LeftRoot (decideSide (j ># j2))
845 | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
846 | otherwise -> NewRoot nd (j ># j2)
848 decideSide :: Bool -> Side
849 decideSide True = Leftt
850 decideSide False = Rightt
853 This might be better in Util.lhs ?
856 Now the bit twiddling functions.
858 shiftL1 :: FastInt -> FastInt
859 shiftR1 :: FastInt -> FastInt
861 {-# INLINE shiftL1 #-}
862 {-# INLINE shiftR1 #-}
864 shiftL1 n = n `shiftLFastInt` _ILIT(1)
865 shiftR1 n = n `shiftR_FastInt` _ILIT(1)
869 use_snd :: a -> b -> b
873 {- Note [Uniques must be positive]
874 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
875 The getCommonNodeUFMData function assumes that the nodes use
876 positive uniques. Specifically, the inner `loop' shifts the
877 low bits out of two uniques until the shifted uniques are the same.
878 At the same time, it computes a new delta, by shifting
881 The failure case I (JPD) encountered:
882 If one of the uniques is negative, the shifting may continue
883 until all 64 bits have been shifted out, resulting in a new delta
884 of 0, which is wrong and can trigger later assertion failures.
886 Where do the negative uniques come from? Both Simom M and
887 I have run into this problem when hashing a data structure.
888 In both cases, we have avoided the problem by ensuring that
889 the hashes remain positive.