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 @NamedThing@, and we use the
9 @getItsUnique@ 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
33 addListToUFM_Directly,
34 IF_NOT_GHC(addToUFM_C COMMA)
35 IF_NOT_GHC(addListToUFM_C COMMA)
42 IF_NOT_GHC(intersectUFM_C COMMA)
43 IF_NOT_GHC(foldUFM COMMA)
48 lookupUFM, lookupUFM_Directly,
49 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
53 -- to make the interface self-sufficient
56 #if defined(COMPILING_GHC)
57 CHK_Ubiq() -- debugging consistency check
60 import Unique ( Unique, u2i, mkUniqueGrimily )
62 import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
63 import Pretty ( Pretty(..), PrettyRep )
64 import PprStyle ( PprStyle )
65 import SrcLoc ( SrcLoc )
67 #if ! OMIT_NATIVE_CODEGEN
70 #define IF_NCG(a) {--}
74 %************************************************************************
76 \subsection{The @UniqFM@ type, and signatures for the functions}
78 %************************************************************************
80 We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''.
83 emptyUFM :: UniqFM elt
84 isNullUFM :: UniqFM elt -> Bool
85 singletonUFM :: NamedThing key => key -> elt -> UniqFM elt
86 singletonDirectlyUFM -- got the Unique already
87 :: Unique -> elt -> UniqFM elt
88 listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
90 :: [(Unique, elt)] -> UniqFM elt
92 addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt
93 addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt
95 :: UniqFM elt -> Unique -> elt -> UniqFM elt
97 addToUFM_C :: NamedThing key => (elt -> elt -> elt)
98 -> UniqFM elt -> key -> elt -> UniqFM elt
99 addListToUFM_C :: NamedThing key => (elt -> elt -> elt)
100 -> UniqFM elt -> [(key,elt)]
103 delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt
104 delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt
106 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
108 plusUFM_C :: (elt -> elt -> elt)
109 -> UniqFM elt -> UniqFM elt -> UniqFM elt
111 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
113 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
114 intersectUFM_C :: (elt -> elt -> elt)
115 -> UniqFM elt -> UniqFM elt -> UniqFM elt
116 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
117 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
118 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
120 sizeUFM :: UniqFM elt -> Int
122 lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
123 lookupUFM_Directly -- when you've got the Unique already
124 :: UniqFM elt -> Unique -> Maybe elt
126 :: NamedThing key => UniqFM elt -> elt -> key -> elt
127 lookupWithDefaultUFM_Directly
128 :: UniqFM elt -> elt -> Unique -> elt
130 eltsUFM :: UniqFM elt -> [elt]
131 ufmToList :: UniqFM elt -> [(Unique, elt)]
134 %************************************************************************
136 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
138 %************************************************************************
143 type IdFinMap elt = UniqFM elt
144 type TyVarFinMap elt = UniqFM elt
145 type NameFinMap elt = UniqFM elt
146 type RegFinMap elt = UniqFM elt
148 #ifdef __GLASGOW_HASKELL__
149 -- I don't think HBC was too happy about this (WDP 94/10)
152 singletonUFM :: Id -> elt -> IdFinMap elt,
153 TyVar -> elt -> TyVarFinMap elt,
154 Name -> elt -> NameFinMap elt
155 IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
158 listToUFM :: [(Id, elt)] -> IdFinMap elt,
159 [(TyVar,elt)] -> TyVarFinMap elt,
160 [(Name, elt)] -> NameFinMap elt
161 IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt)
164 addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt,
165 TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
166 NameFinMap elt -> Name -> elt -> NameFinMap elt
167 IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt)
170 addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt,
171 TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
172 NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
173 IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
176 addToUFM_C :: (elt -> elt -> elt)
177 -> IdFinMap elt -> Id -> elt -> IdFinMap elt,
179 -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
181 -> NameFinMap elt -> Name -> elt -> NameFinMap elt
182 IF_NCG(COMMA (elt -> elt -> elt)
183 -> RegFinMap elt -> Reg -> elt -> RegFinMap elt)
186 addListToUFM_C :: (elt -> elt -> elt)
187 -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt,
189 -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
191 -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
192 IF_NCG(COMMA (elt -> elt -> elt)
193 -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
196 delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt,
197 TyVarFinMap elt -> TyVar -> TyVarFinMap elt,
198 NameFinMap elt -> Name -> NameFinMap elt
199 IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt)
202 delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt,
203 TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt,
204 NameFinMap elt -> [Name] -> NameFinMap elt
205 IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt)
209 lookupUFM :: IdFinMap elt -> Id -> Maybe elt,
210 TyVarFinMap elt -> TyVar -> Maybe elt,
211 NameFinMap elt -> Name -> Maybe elt
212 IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt)
216 :: IdFinMap elt -> elt -> Id -> elt,
217 TyVarFinMap elt -> elt -> TyVar -> elt,
218 NameFinMap elt -> elt -> Name -> elt
219 IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt)
222 #endif {- __GLASGOW_HASKELL__ -}
226 %************************************************************************
228 \subsection{Andy Gill's underlying @UniqFM@ machinery}
230 %************************************************************************
232 ``Uniq Finite maps'' are the heart and soul of the compiler's
233 lookup-tables/environments. Important stuff! It works well with
234 Dense and Sparse ranges.
235 Both @Uq@ Finite maps and @Hash@ Finite Maps
236 are built ontop of Int Finite Maps.
238 This code is explained in the paper:
240 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
241 "A Cheap balancing act that grows on a tree"
242 Glasgow FP Workshop, Sep 1994, pp??-??
245 %************************************************************************
247 \subsubsection{The @UniqFM@ type, and signatures for the functions}
249 %************************************************************************
251 @UniqFM a@ is a mapping from Unique to a.
253 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
258 | LeafUFM FAST_INT ele
259 | NodeUFM FAST_INT -- the switching
260 FAST_INT -- the delta
264 -- for debugging only :-)
266 instance Text (UniqFM a) where
267 showsPrec _ (NodeUFM a b t1 t2) =
268 showString "NodeUFM " . shows (IBOX(a))
269 . showString " " . shows (IBOX(b))
270 . showString " (" . shows t1
271 . showString ") (" . shows t2
273 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
274 showsPrec _ (EmptyUFM) = id
278 %************************************************************************
280 \subsubsection{The @UniqFM@ functions}
282 %************************************************************************
284 First the ways of building a UniqFM.
288 singletonUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt
289 singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
291 listToUFM key_elt_pairs
292 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
294 listToUFM_Directly uniq_elt_pairs
295 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
298 Now ways of adding things to UniqFMs.
300 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
301 but the semantics of this operation demands a linear insertion;
302 perhaps the version without the combinator function
303 could be optimised using it.
306 addToUFM fm key elt = addToUFM_C use_snd fm key elt
308 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
310 addToUFM_C combiner fm key elt
311 = insert_ele combiner fm (u2i (getItsUnique key)) elt
313 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
314 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
316 addListToUFM_C combiner fm key_elt_pairs
317 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getItsUnique k)) e)
320 addListToUFM_directly_C combiner fm uniq_elt_pairs
321 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
325 Now ways of removing things from UniqFM.
328 delListFromUFM fm lst = foldl delFromUFM fm lst
330 delFromUFM fm key = delete fm (u2i (getItsUnique key))
332 delete EmptyUFM _ = EmptyUFM
333 delete fm key = del_ele fm
335 del_ele :: UniqFM a -> UniqFM a
337 del_ele lf@(LeafUFM j _)
338 | j _EQ_ key = EmptyUFM
339 | otherwise = lf -- no delete!
341 del_ele nd@(NodeUFM j p t1 t2)
343 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
345 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
347 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
350 Now ways of adding two UniqFM's together.
353 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
355 plusUFM_C f EmptyUFM tr = tr
356 plusUFM_C f tr EmptyUFM = tr
357 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
359 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
360 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
362 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
364 (ask_about_common_ancestor
368 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
372 -- t1 t2 t1' t2' j j'
377 mix_branches (NewRoot nd False)
378 = mkLLNodeUFM nd left_t right_t
379 mix_branches (NewRoot nd True)
380 = mkLLNodeUFM nd right_t left_t
386 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
388 mix_branches (SameRoot)
389 = mkSSNodeUFM (NodeUFMData j p)
392 -- Now the 4 different other ways; all like this:
394 -- Given j >^ j' (and, say, j > j')
398 -- t1 t2 t1' t2' t1 t2 + j'
401 mix_branches (LeftRoot Leftt) -- | trace "LL" True
404 (mix_trees t1 right_t)
407 mix_branches (LeftRoot Rightt) -- | trace "LR" True
411 (mix_trees t2 right_t)
413 mix_branches (RightRoot Leftt) -- | trace "RL" True
416 (mix_trees left_t t1')
419 mix_branches (RightRoot Rightt) -- | trace "RR" True
423 (mix_trees left_t t2')
425 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
428 And ways of subtracting them. First the base cases,
429 then the full D&C approach.
432 minusUFM EmptyUFM _ = EmptyUFM
433 minusUFM t1 EmptyUFM = t1
434 minusUFM fm1 fm2 = minus_trees fm1 fm2
437 -- Notice the asymetry of subtraction
439 minus_trees lf@(LeafUFM i a) t2 =
444 minus_trees t1 (LeafUFM i _) = delete t1 i
446 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
448 (ask_about_common_ancestor
452 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
456 -- t1 t2 t1' t2' t1 t2
461 minus_branches (NewRoot nd _) = left_t
467 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
469 minus_branches (SameRoot)
470 = mkSSNodeUFM (NodeUFMData j p)
473 -- Now the 4 different other ways; all like this:
474 -- again, with asymatry
477 -- The left is above the right
479 minus_branches (LeftRoot Leftt)
482 (minus_trees t1 right_t)
484 minus_branches (LeftRoot Rightt)
488 (minus_trees t2 right_t)
491 -- The right is above the left
493 minus_branches (RightRoot Leftt)
494 = minus_trees left_t t1'
495 minus_branches (RightRoot Rightt)
496 = minus_trees left_t t2'
498 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
501 And taking the intersection of two UniqFM's.
504 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
506 intersectUFM_C f EmptyUFM _ = EmptyUFM
507 intersectUFM_C f _ EmptyUFM = EmptyUFM
508 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
510 intersect_trees (LeafUFM i a) t2 =
513 Just b -> mkLeafUFM i (f a b)
515 intersect_trees t1 (LeafUFM i a) =
518 Just b -> mkLeafUFM i (f b a)
520 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
522 (ask_about_common_ancestor
526 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
529 -- / \ + / \ ==> EmptyUFM
534 intersect_branches (NewRoot nd _) = EmptyUFM
540 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
542 intersect_branches (SameRoot)
543 = mkSSNodeUFM (NodeUFMData j p)
544 (intersect_trees t1 t1')
545 (intersect_trees t2 t2')
546 -- Now the 4 different other ways; all like this:
548 -- Given j >^ j' (and, say, j > j')
552 -- t1 t2 t1' t2' t1' t2'
554 -- This does cut down the search space quite a bit.
556 intersect_branches (LeftRoot Leftt)
557 = intersect_trees t1 right_t
558 intersect_branches (LeftRoot Rightt)
559 = intersect_trees t2 right_t
560 intersect_branches (RightRoot Leftt)
561 = intersect_trees left_t t1'
562 intersect_branches (RightRoot Rightt)
563 = intersect_trees left_t t2'
565 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
568 Now the usual set of `collection' operators, like map, fold, etc.
571 foldUFM fn a EmptyUFM = a
572 foldUFM fn a fm = fold_tree fn a fm
574 mapUFM fn EmptyUFM = EmptyUFM
575 mapUFM fn fm = map_tree fn fm
577 filterUFM fn EmptyUFM = EmptyUFM
578 filterUFM fn fm = filter_tree fn fm
581 Note, this takes a long time, O(n), but
582 because we dont want to do this very often, we put up with this.
583 O'rable, but how often do we look at the size of
588 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
589 sizeUFM (LeafUFM _ _) = 1
591 isNullUFM EmptyUFM = True
595 looking up in a hurry is the {\em whole point} of this binary tree lark.
596 Lookup up a binary tree is easy (and fast).
599 lookupUFM fm key = lookup fm (u2i (getItsUnique key))
600 lookupUFM_Directly fm key = lookup fm (u2i key)
602 lookupWithDefaultUFM fm deflt key
603 = case lookup fm (u2i (getItsUnique key)) of
607 lookupWithDefaultUFM_Directly fm deflt key
608 = case lookup fm (u2i key) of
612 lookup EmptyUFM _ = Nothing
613 lookup fm i = lookup_tree fm
615 lookup_tree :: UniqFM a -> Maybe a
617 lookup_tree (LeafUFM j b)
619 | otherwise = Nothing
620 lookup_tree (NodeUFM j p t1 t2)
621 | j _GT_ i = lookup_tree t1
622 | otherwise = lookup_tree t2
624 lookup_tree EmptyUFM = panic "lookup Failed"
627 folds are *wonderful* things.
630 eltsUFM EmptyUFM = []
631 eltsUFM fm = fold_tree (:) [] fm
633 ufmToList EmptyUFM = []
635 = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
637 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
638 fold_tree f a (LeafUFM iu obj) = f iu obj a
640 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
643 %************************************************************************
645 \subsubsection{The @UniqFM@ type, and its functions}
647 %************************************************************************
649 You should always use these to build the tree.
650 There are 4 versions of mkNodeUFM, depending on
651 the strictness of the two sub-tree arguments.
652 The strictness is used *both* to prune out
653 empty trees, *and* to improve performance,
654 stoping needless thunks lying around.
655 The rule of thumb (from experence with these trees)
656 is make thunks strict, but data structures lazy.
657 If in doubt, use mkSSNodeUFM, which has the `strongest'
658 functionality, but may do a few needless evaluations.
661 mkLeafUFM :: FAST_INT -> a -> UniqFM a
662 mkLeafUFM i a = LeafUFM i a
664 -- The *ONLY* ways of building a NodeUFM.
666 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
667 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
668 mkSSNodeUFM (NodeUFMData j p) t1 t2
669 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
672 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
673 mkSLNodeUFM (NodeUFMData j p) t1 t2
674 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
677 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
678 mkLSNodeUFM (NodeUFMData j p) t1 t2
679 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
682 mkLLNodeUFM (NodeUFMData j p) t1 t2
683 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
693 correctNodeUFM j p t1 t2
694 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
696 correct low high _ (LeafUFM i _)
697 = low <= IBOX(i) && IBOX(i) <= high
698 correct low high above_p (NodeUFM j p _ _)
699 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
700 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
703 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
704 and if necessary do $\lambda$ lifting on our functions that are bound.
714 insert_ele f EmptyUFM i new = mkLeafUFM i new
716 insert_ele f (LeafUFM j old) i new
718 mkLLNodeUFM (getCommonNodeUFMData
723 | j _EQ_ i = mkLeafUFM j (f old new)
725 mkLLNodeUFM (getCommonNodeUFMData
731 insert_ele f n@(NodeUFM j p t1 t2) i a
733 = if (i _GE_ (j _SUB_ p))
734 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
735 else mkLLNodeUFM (getCommonNodeUFMData
741 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
742 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
743 else mkLLNodeUFM (getCommonNodeUFMData
750 This has got a left to right ordering.
753 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
754 fold_tree f a (LeafUFM _ obj) = f obj a
756 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
760 map_tree f (NodeUFM j p t1 t2)
761 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
762 map_tree f (LeafUFM i obj)
763 = mkLeafUFM i (f obj)
765 map_tree f _ = panic "map_tree failed"
769 filter_tree f nd@(NodeUFM j p t1 t2)
770 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
772 filter_tree f lf@(LeafUFM i obj)
774 | otherwise = EmptyUFM
777 %************************************************************************
779 \subsubsection{The @UniqFM@ type, and signatures for the functions}
781 %************************************************************************
785 This is the information that is held inside a NodeUFM, packaged up for
790 = NodeUFMData FAST_INT
794 This is the information used when computing new NodeUFMs.
797 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
799 = LeftRoot Side -- which side is the right down ?
800 | RightRoot Side -- which side is the left down ?
801 | SameRoot -- they are the same !
802 | NewRoot NodeUFMData -- here's the new, common, root
803 Bool -- do you need to swap left and right ?
806 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
809 indexToRoot :: FAST_INT -> NodeUFMData
813 l = (ILIT(1) :: FAST_INT)
815 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
817 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
819 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
820 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
821 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
822 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
824 l = (ILIT(1) :: FAST_INT)
825 j = i _QUOT_ (p `shiftL_` l)
826 j2 = i2 _QUOT_ (p2 `shiftL_` l)
828 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
830 getCommonNodeUFMData_ p j j_
832 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
834 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
836 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
838 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
839 | j _EQ_ j2 = SameRoot
841 = case getCommonNodeUFMData x y of
842 nd@(NodeUFMData j3 p3)
843 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
844 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
845 | otherwise -> NewRoot nd (j _GT_ j2)
847 decideSide :: Bool -> Side
848 decideSide True = Leftt
849 decideSide False = Rightt
852 This might be better in Util.lhs ?
855 Now the bit twiddling functions.
857 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
858 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
860 #if __GLASGOW_HASKELL__
861 {-# INLINE shiftL_ #-}
862 {-# INLINE shiftR_ #-}
863 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
864 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
866 shiftr x y = shiftRA# x y
869 shiftL_ n p = n * (2 ^ p)
870 shiftR_ n p = n `quot` (2 ^ p)
875 Andy's extras: ToDo: to Util.
878 use_fst :: a -> b -> a
881 use_snd :: a -> b -> b