2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[UniqFM]{Specialised finite maps, for things with @Uniques@}
6 Based on @FiniteMaps@ (as you would expect).
8 Basically, the things need to be in class @Uniquable@, and we use the
9 @uniqueOf@ method to grab their @Uniques@.
11 (A similar thing to @UniqSet@, as opposed to @Set@.)
14 #if defined(COMPILING_GHC)
15 #include "HsVersions.h"
16 #define IF_NOT_GHC(a) {--}
18 #define ASSERT(e) {--}
19 #define IF_NOT_GHC(a) a
23 UniqFM, -- abstract type
24 Uniquable(..), -- class to go with it
34 addListToUFM_Directly,
35 IF_NOT_GHC(addToUFM_C COMMA)
43 IF_NOT_GHC(intersectUFM_C COMMA)
44 IF_NOT_GHC(foldUFM COMMA)
49 lookupUFM, lookupUFM_Directly,
50 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
55 #if defined(COMPILING_GHC)
59 import Unique ( Unique, u2i, mkUniqueGrimily )
61 --import Outputable ( Outputable(..), ExportFlag )
62 import Pretty ( Pretty(..), PrettyRep )
63 import PprStyle ( PprStyle )
64 import SrcLoc ( SrcLoc )
66 #if ! OMIT_NATIVE_CODEGEN
69 #define IF_NCG(a) {--}
73 %************************************************************************
75 \subsection{The @UniqFM@ type, and signatures for the functions}
77 %************************************************************************
79 We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
82 emptyUFM :: UniqFM elt
83 isNullUFM :: UniqFM elt -> Bool
84 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
85 unitDirectlyUFM -- got the Unique already
86 :: Unique -> elt -> UniqFM elt
87 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
89 :: [(Unique, elt)] -> UniqFM elt
91 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
92 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
94 :: UniqFM elt -> Unique -> elt -> UniqFM elt
96 addToUFM_C :: Uniquable key => (elt -> elt -> elt)
97 -> UniqFM elt -> key -> elt -> UniqFM elt
98 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
99 -> UniqFM elt -> [(key,elt)]
102 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
103 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
105 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
107 plusUFM_C :: (elt -> elt -> elt)
108 -> UniqFM elt -> UniqFM elt -> UniqFM elt
110 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
112 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
113 intersectUFM_C :: (elt -> elt -> elt)
114 -> UniqFM elt -> UniqFM elt -> UniqFM elt
115 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
116 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
117 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
119 sizeUFM :: UniqFM elt -> Int
121 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
122 lookupUFM_Directly -- when you've got the Unique already
123 :: UniqFM elt -> Unique -> Maybe elt
125 :: Uniquable key => UniqFM elt -> elt -> key -> elt
126 lookupWithDefaultUFM_Directly
127 :: UniqFM elt -> elt -> Unique -> elt
129 eltsUFM :: UniqFM elt -> [elt]
130 ufmToList :: UniqFM elt -> [(Unique, elt)]
133 %************************************************************************
135 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
137 %************************************************************************
142 type IdFinMap elt = UniqFM elt
143 type TyVarFinMap elt = UniqFM elt
144 type NameFinMap elt = UniqFM elt
145 type RegFinMap elt = UniqFM elt
147 #ifdef __GLASGOW_HASKELL__
148 -- I don't think HBC was too happy about this (WDP 94/10)
151 unitUFM :: Id -> elt -> IdFinMap elt,
152 TyVar -> elt -> TyVarFinMap elt,
153 Name -> elt -> NameFinMap elt
154 IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
157 listToUFM :: [(Id, elt)] -> IdFinMap elt,
158 [(TyVar,elt)] -> TyVarFinMap elt,
159 [(Name, elt)] -> NameFinMap elt
160 IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt)
163 addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt,
164 TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
165 NameFinMap elt -> Name -> elt -> NameFinMap elt
166 IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt)
169 addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt,
170 TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
171 NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
172 IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
175 addToUFM_C :: (elt -> elt -> elt)
176 -> IdFinMap elt -> Id -> elt -> IdFinMap elt,
178 -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
180 -> NameFinMap elt -> Name -> elt -> NameFinMap elt
181 IF_NCG(COMMA (elt -> elt -> elt)
182 -> RegFinMap elt -> Reg -> elt -> RegFinMap elt)
185 addListToUFM_C :: (elt -> elt -> elt)
186 -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt,
188 -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
190 -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
191 IF_NCG(COMMA (elt -> elt -> elt)
192 -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
195 delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt,
196 TyVarFinMap elt -> TyVar -> TyVarFinMap elt,
197 NameFinMap elt -> Name -> NameFinMap elt
198 IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt)
201 delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt,
202 TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt,
203 NameFinMap elt -> [Name] -> NameFinMap elt
204 IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt)
208 lookupUFM :: IdFinMap elt -> Id -> Maybe elt,
209 TyVarFinMap elt -> TyVar -> Maybe elt,
210 NameFinMap elt -> Name -> Maybe elt
211 IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt)
215 :: IdFinMap elt -> elt -> Id -> elt,
216 TyVarFinMap elt -> elt -> TyVar -> elt,
217 NameFinMap elt -> elt -> Name -> elt
218 IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt)
221 #endif {- __GLASGOW_HASKELL__ -}
225 %************************************************************************
227 \subsection{Andy Gill's underlying @UniqFM@ machinery}
229 %************************************************************************
231 ``Uniq Finite maps'' are the heart and soul of the compiler's
232 lookup-tables/environments. Important stuff! It works well with
233 Dense and Sparse ranges.
234 Both @Uq@ Finite maps and @Hash@ Finite Maps
235 are built ontop of Int Finite Maps.
237 This code is explained in the paper:
239 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
240 "A Cheap balancing act that grows on a tree"
241 Glasgow FP Workshop, Sep 1994, pp??-??
244 %************************************************************************
246 \subsubsection{The @UniqFM@ type, and signatures for the functions}
248 %************************************************************************
250 @UniqFM a@ is a mapping from Unique to a.
252 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
257 | LeafUFM FAST_INT ele
258 | NodeUFM FAST_INT -- the switching
259 FAST_INT -- the delta
263 class Uniquable a where
264 uniqueOf :: a -> Unique
266 -- for debugging only :-)
268 instance Text (UniqFM a) where
269 showsPrec _ (NodeUFM a b t1 t2) =
270 showString "NodeUFM " . shows (IBOX(a))
271 . showString " " . shows (IBOX(b))
272 . showString " (" . shows t1
273 . showString ") (" . shows t2
275 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
276 showsPrec _ (EmptyUFM) = id
280 %************************************************************************
282 \subsubsection{The @UniqFM@ functions}
284 %************************************************************************
286 First the ways of building a UniqFM.
290 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
291 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
293 listToUFM key_elt_pairs
294 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
296 listToUFM_Directly uniq_elt_pairs
297 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
300 Now ways of adding things to UniqFMs.
302 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
303 but the semantics of this operation demands a linear insertion;
304 perhaps the version without the combinator function
305 could be optimised using it.
308 addToUFM fm key elt = addToUFM_C use_snd fm key elt
310 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
312 addToUFM_C combiner fm key elt
313 = insert_ele combiner fm (u2i (uniqueOf key)) elt
315 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
316 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
318 addListToUFM_C combiner fm key_elt_pairs
319 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
322 addListToUFM_directly_C combiner fm uniq_elt_pairs
323 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
327 Now ways of removing things from UniqFM.
330 delListFromUFM fm lst = foldl delFromUFM fm lst
332 delFromUFM fm key = delete fm (u2i (uniqueOf key))
334 delete EmptyUFM _ = EmptyUFM
335 delete fm key = del_ele fm
337 del_ele :: UniqFM a -> UniqFM a
339 del_ele lf@(LeafUFM j _)
340 | j _EQ_ key = EmptyUFM
341 | otherwise = lf -- no delete!
343 del_ele nd@(NodeUFM j p t1 t2)
345 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
347 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
349 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
352 Now ways of adding two UniqFM's together.
355 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
357 plusUFM_C f EmptyUFM tr = tr
358 plusUFM_C f tr EmptyUFM = tr
359 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
361 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
362 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
364 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
366 (ask_about_common_ancestor
370 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
374 -- t1 t2 t1' t2' j j'
379 mix_branches (NewRoot nd False)
380 = mkLLNodeUFM nd left_t right_t
381 mix_branches (NewRoot nd True)
382 = mkLLNodeUFM nd right_t left_t
388 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
390 mix_branches (SameRoot)
391 = mkSSNodeUFM (NodeUFMData j p)
394 -- Now the 4 different other ways; all like this:
396 -- Given j >^ j' (and, say, j > j')
400 -- t1 t2 t1' t2' t1 t2 + j'
403 mix_branches (LeftRoot Leftt) -- | trace "LL" True
406 (mix_trees t1 right_t)
409 mix_branches (LeftRoot Rightt) -- | trace "LR" True
413 (mix_trees t2 right_t)
415 mix_branches (RightRoot Leftt) -- | trace "RL" True
418 (mix_trees left_t t1')
421 mix_branches (RightRoot Rightt) -- | trace "RR" True
425 (mix_trees left_t t2')
427 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
430 And ways of subtracting them. First the base cases,
431 then the full D&C approach.
434 minusUFM EmptyUFM _ = EmptyUFM
435 minusUFM t1 EmptyUFM = t1
436 minusUFM fm1 fm2 = minus_trees fm1 fm2
439 -- Notice the asymetry of subtraction
441 minus_trees lf@(LeafUFM i a) t2 =
446 minus_trees t1 (LeafUFM i _) = delete t1 i
448 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
450 (ask_about_common_ancestor
454 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
458 -- t1 t2 t1' t2' t1 t2
463 minus_branches (NewRoot nd _) = left_t
469 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
471 minus_branches (SameRoot)
472 = mkSSNodeUFM (NodeUFMData j p)
475 -- Now the 4 different other ways; all like this:
476 -- again, with asymatry
479 -- The left is above the right
481 minus_branches (LeftRoot Leftt)
484 (minus_trees t1 right_t)
486 minus_branches (LeftRoot Rightt)
490 (minus_trees t2 right_t)
493 -- The right is above the left
495 minus_branches (RightRoot Leftt)
496 = minus_trees left_t t1'
497 minus_branches (RightRoot Rightt)
498 = minus_trees left_t t2'
500 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
503 And taking the intersection of two UniqFM's.
506 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
508 intersectUFM_C f EmptyUFM _ = EmptyUFM
509 intersectUFM_C f _ EmptyUFM = EmptyUFM
510 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
512 intersect_trees (LeafUFM i a) t2 =
515 Just b -> mkLeafUFM i (f a b)
517 intersect_trees t1 (LeafUFM i a) =
520 Just b -> mkLeafUFM i (f b a)
522 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
524 (ask_about_common_ancestor
528 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
531 -- / \ + / \ ==> EmptyUFM
536 intersect_branches (NewRoot nd _) = EmptyUFM
542 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
544 intersect_branches (SameRoot)
545 = mkSSNodeUFM (NodeUFMData j p)
546 (intersect_trees t1 t1')
547 (intersect_trees t2 t2')
548 -- Now the 4 different other ways; all like this:
550 -- Given j >^ j' (and, say, j > j')
554 -- t1 t2 t1' t2' t1' t2'
556 -- This does cut down the search space quite a bit.
558 intersect_branches (LeftRoot Leftt)
559 = intersect_trees t1 right_t
560 intersect_branches (LeftRoot Rightt)
561 = intersect_trees t2 right_t
562 intersect_branches (RightRoot Leftt)
563 = intersect_trees left_t t1'
564 intersect_branches (RightRoot Rightt)
565 = intersect_trees left_t t2'
567 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
570 Now the usual set of `collection' operators, like map, fold, etc.
573 foldUFM fn a EmptyUFM = a
574 foldUFM fn a fm = fold_tree fn a fm
576 mapUFM fn EmptyUFM = EmptyUFM
577 mapUFM fn fm = map_tree fn fm
579 filterUFM fn EmptyUFM = EmptyUFM
580 filterUFM fn fm = filter_tree fn fm
583 Note, this takes a long time, O(n), but
584 because we dont want to do this very often, we put up with this.
585 O'rable, but how often do we look at the size of
590 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
591 sizeUFM (LeafUFM _ _) = 1
593 isNullUFM EmptyUFM = True
597 looking up in a hurry is the {\em whole point} of this binary tree lark.
598 Lookup up a binary tree is easy (and fast).
601 lookupUFM fm key = lookup fm (u2i (uniqueOf key))
602 lookupUFM_Directly fm key = lookup fm (u2i key)
604 lookupWithDefaultUFM fm deflt key
605 = case lookup fm (u2i (uniqueOf key)) of
609 lookupWithDefaultUFM_Directly fm deflt key
610 = case lookup fm (u2i key) of
614 lookup EmptyUFM _ = Nothing
615 lookup fm i = lookup_tree fm
617 lookup_tree :: UniqFM a -> Maybe a
619 lookup_tree (LeafUFM j b)
621 | otherwise = Nothing
622 lookup_tree (NodeUFM j p t1 t2)
623 | j _GT_ i = lookup_tree t1
624 | otherwise = lookup_tree t2
626 lookup_tree EmptyUFM = panic "lookup Failed"
629 folds are *wonderful* things.
632 eltsUFM EmptyUFM = []
633 eltsUFM fm = fold_tree (:) [] fm
635 ufmToList EmptyUFM = []
637 = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
639 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
640 fold_tree f a (LeafUFM iu obj) = f iu obj a
642 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
645 %************************************************************************
647 \subsubsection{The @UniqFM@ type, and its functions}
649 %************************************************************************
651 You should always use these to build the tree.
652 There are 4 versions of mkNodeUFM, depending on
653 the strictness of the two sub-tree arguments.
654 The strictness is used *both* to prune out
655 empty trees, *and* to improve performance,
656 stoping needless thunks lying around.
657 The rule of thumb (from experence with these trees)
658 is make thunks strict, but data structures lazy.
659 If in doubt, use mkSSNodeUFM, which has the `strongest'
660 functionality, but may do a few needless evaluations.
663 mkLeafUFM :: FAST_INT -> a -> UniqFM a
664 mkLeafUFM i a = LeafUFM i a
666 -- The *ONLY* ways of building a NodeUFM.
668 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
669 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
670 mkSSNodeUFM (NodeUFMData j p) t1 t2
671 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
674 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
675 mkSLNodeUFM (NodeUFMData j p) t1 t2
676 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
679 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
680 mkLSNodeUFM (NodeUFMData j p) t1 t2
681 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
684 mkLLNodeUFM (NodeUFMData j p) t1 t2
685 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
695 correctNodeUFM j p t1 t2
696 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
698 correct low high _ (LeafUFM i _)
699 = low <= IBOX(i) && IBOX(i) <= high
700 correct low high above_p (NodeUFM j p _ _)
701 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
702 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
705 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
706 and if necessary do $\lambda$ lifting on our functions that are bound.
716 insert_ele f EmptyUFM i new = mkLeafUFM i new
718 insert_ele f (LeafUFM j old) i new
720 mkLLNodeUFM (getCommonNodeUFMData
725 | j _EQ_ i = mkLeafUFM j (f old new)
727 mkLLNodeUFM (getCommonNodeUFMData
733 insert_ele f n@(NodeUFM j p t1 t2) i a
735 = if (i _GE_ (j _SUB_ p))
736 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
737 else mkLLNodeUFM (getCommonNodeUFMData
743 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
744 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
745 else mkLLNodeUFM (getCommonNodeUFMData
752 This has got a left to right ordering.
755 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
756 fold_tree f a (LeafUFM _ obj) = f obj a
758 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
762 map_tree f (NodeUFM j p t1 t2)
763 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
764 map_tree f (LeafUFM i obj)
765 = mkLeafUFM i (f obj)
767 map_tree f _ = panic "map_tree failed"
771 filter_tree f nd@(NodeUFM j p t1 t2)
772 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
774 filter_tree f lf@(LeafUFM i obj)
776 | otherwise = EmptyUFM
779 %************************************************************************
781 \subsubsection{The @UniqFM@ type, and signatures for the functions}
783 %************************************************************************
787 This is the information that is held inside a NodeUFM, packaged up for
792 = NodeUFMData FAST_INT
796 This is the information used when computing new NodeUFMs.
799 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
801 = LeftRoot Side -- which side is the right down ?
802 | RightRoot Side -- which side is the left down ?
803 | SameRoot -- they are the same !
804 | NewRoot NodeUFMData -- here's the new, common, root
805 Bool -- do you need to swap left and right ?
808 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
811 indexToRoot :: FAST_INT -> NodeUFMData
815 l = (ILIT(1) :: FAST_INT)
817 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
819 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
821 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
822 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
823 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
824 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
826 l = (ILIT(1) :: FAST_INT)
827 j = i _QUOT_ (p `shiftL_` l)
828 j2 = i2 _QUOT_ (p2 `shiftL_` l)
830 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
832 getCommonNodeUFMData_ p j j_
834 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
836 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
838 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
840 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
841 | j _EQ_ j2 = SameRoot
843 = case getCommonNodeUFMData x y of
844 nd@(NodeUFMData j3 p3)
845 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
846 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
847 | otherwise -> NewRoot nd (j _GT_ j2)
849 decideSide :: Bool -> Side
850 decideSide True = Leftt
851 decideSide False = Rightt
854 This might be better in Util.lhs ?
857 Now the bit twiddling functions.
859 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
860 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
862 #if __GLASGOW_HASKELL__
863 {-# INLINE shiftL_ #-}
864 {-# INLINE shiftR_ #-}
865 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
866 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
868 shiftr x y = shiftRA# x y
871 shiftL_ n p = n * (2 ^ p)
872 shiftR_ n p = n `quot` (2 ^ p)
877 Andy's extras: ToDo: to Util.
880 use_fst :: a -> b -> a
883 use_snd :: a -> b -> b