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)
44 IF_NOT_GHC(intersectUFM_C COMMA)
45 IF_NOT_GHC(foldUFM COMMA)
50 lookupUFM, lookupUFM_Directly,
51 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
56 #if defined(COMPILING_GHC)
60 import Unique ( Unique, u2i, mkUniqueGrimily )
62 --import Outputable ( Outputable(..), 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 (@uniqueOf@-able) @Unique@ as ``key''.
83 emptyUFM :: UniqFM elt
84 isNullUFM :: UniqFM elt -> Bool
85 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
86 unitDirectlyUFM -- got the Unique already
87 :: Unique -> elt -> UniqFM elt
88 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
90 :: [(Unique, elt)] -> UniqFM elt
92 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
93 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
95 :: UniqFM elt -> Unique -> elt -> UniqFM elt
97 addToUFM_C :: Uniquable key => (elt -> elt -> elt)
98 -> UniqFM elt -> key -> elt -> UniqFM elt
99 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
100 -> UniqFM elt -> [(key,elt)]
103 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
104 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
105 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
107 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
109 plusUFM_C :: (elt -> elt -> elt)
110 -> UniqFM elt -> UniqFM elt -> UniqFM elt
112 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
114 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
115 intersectUFM_C :: (elt -> elt -> elt)
116 -> UniqFM elt -> UniqFM elt -> UniqFM elt
117 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
118 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
119 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
121 sizeUFM :: UniqFM elt -> Int
123 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
124 lookupUFM_Directly -- when you've got the Unique already
125 :: UniqFM elt -> Unique -> Maybe elt
127 :: Uniquable key => UniqFM elt -> elt -> key -> elt
128 lookupWithDefaultUFM_Directly
129 :: UniqFM elt -> elt -> Unique -> elt
131 eltsUFM :: UniqFM elt -> [elt]
132 ufmToList :: UniqFM elt -> [(Unique, elt)]
135 %************************************************************************
137 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
139 %************************************************************************
144 type IdFinMap elt = UniqFM elt
145 type TyVarFinMap elt = UniqFM elt
146 type NameFinMap elt = UniqFM elt
147 type RegFinMap elt = UniqFM elt
149 #ifdef __GLASGOW_HASKELL__
150 -- I don't think HBC was too happy about this (WDP 94/10)
153 unitUFM :: Id -> elt -> IdFinMap elt,
154 TyVar -> elt -> TyVarFinMap elt,
155 Name -> elt -> NameFinMap elt
156 IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
159 listToUFM :: [(Id, elt)] -> IdFinMap elt,
160 [(TyVar,elt)] -> TyVarFinMap elt,
161 [(Name, elt)] -> NameFinMap elt
162 IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt)
165 addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt,
166 TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
167 NameFinMap elt -> Name -> elt -> NameFinMap elt
168 IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt)
171 addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt,
172 TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
173 NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
174 IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
177 addToUFM_C :: (elt -> elt -> elt)
178 -> IdFinMap elt -> Id -> elt -> IdFinMap elt,
180 -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt,
182 -> NameFinMap elt -> Name -> elt -> NameFinMap elt
183 IF_NCG(COMMA (elt -> elt -> elt)
184 -> RegFinMap elt -> Reg -> elt -> RegFinMap elt)
187 addListToUFM_C :: (elt -> elt -> elt)
188 -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt,
190 -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt,
192 -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt
193 IF_NCG(COMMA (elt -> elt -> elt)
194 -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt)
197 delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt,
198 TyVarFinMap elt -> TyVar -> TyVarFinMap elt,
199 NameFinMap elt -> Name -> NameFinMap elt
200 IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt)
203 delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt,
204 TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt,
205 NameFinMap elt -> [Name] -> NameFinMap elt
206 IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt)
210 lookupUFM :: IdFinMap elt -> Id -> Maybe elt,
211 TyVarFinMap elt -> TyVar -> Maybe elt,
212 NameFinMap elt -> Name -> Maybe elt
213 IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt)
217 :: IdFinMap elt -> elt -> Id -> elt,
218 TyVarFinMap elt -> elt -> TyVar -> elt,
219 NameFinMap elt -> elt -> Name -> elt
220 IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt)
223 #endif {- __GLASGOW_HASKELL__ -}
227 %************************************************************************
229 \subsection{Andy Gill's underlying @UniqFM@ machinery}
231 %************************************************************************
233 ``Uniq Finite maps'' are the heart and soul of the compiler's
234 lookup-tables/environments. Important stuff! It works well with
235 Dense and Sparse ranges.
236 Both @Uq@ Finite maps and @Hash@ Finite Maps
237 are built ontop of Int Finite Maps.
239 This code is explained in the paper:
241 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
242 "A Cheap balancing act that grows on a tree"
243 Glasgow FP Workshop, Sep 1994, pp??-??
246 %************************************************************************
248 \subsubsection{The @UniqFM@ type, and signatures for the functions}
250 %************************************************************************
252 @UniqFM a@ is a mapping from Unique to a.
254 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
259 | LeafUFM FAST_INT ele
260 | NodeUFM FAST_INT -- the switching
261 FAST_INT -- the delta
265 class Uniquable a where
266 uniqueOf :: a -> Unique
268 -- for debugging only :-)
270 instance Text (UniqFM a) where
271 showsPrec _ (NodeUFM a b t1 t2) =
272 showString "NodeUFM " . shows (IBOX(a))
273 . showString " " . shows (IBOX(b))
274 . showString " (" . shows t1
275 . showString ") (" . shows t2
277 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
278 showsPrec _ (EmptyUFM) = id
282 %************************************************************************
284 \subsubsection{The @UniqFM@ functions}
286 %************************************************************************
288 First the ways of building a UniqFM.
292 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
293 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
295 listToUFM key_elt_pairs
296 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
298 listToUFM_Directly uniq_elt_pairs
299 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
302 Now ways of adding things to UniqFMs.
304 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
305 but the semantics of this operation demands a linear insertion;
306 perhaps the version without the combinator function
307 could be optimised using it.
310 addToUFM fm key elt = addToUFM_C use_snd fm key elt
312 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
314 addToUFM_C combiner fm key elt
315 = insert_ele combiner fm (u2i (uniqueOf key)) elt
317 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
318 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
320 addListToUFM_C combiner fm key_elt_pairs
321 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
324 addListToUFM_directly_C combiner fm uniq_elt_pairs
325 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
329 Now ways of removing things from UniqFM.
332 delListFromUFM fm lst = foldl delFromUFM fm lst
334 delFromUFM fm key = delete fm (u2i (uniqueOf key))
335 delFromUFM_Directly fm u = delete fm (u2i u)
337 delete EmptyUFM _ = EmptyUFM
338 delete fm key = del_ele fm
340 del_ele :: UniqFM a -> UniqFM a
342 del_ele lf@(LeafUFM j _)
343 | j _EQ_ key = EmptyUFM
344 | otherwise = lf -- no delete!
346 del_ele nd@(NodeUFM j p t1 t2)
348 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
350 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
352 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
355 Now ways of adding two UniqFM's together.
358 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
360 plusUFM_C f EmptyUFM tr = tr
361 plusUFM_C f tr EmptyUFM = tr
362 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
364 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
365 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
367 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
369 (ask_about_common_ancestor
373 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
377 -- t1 t2 t1' t2' j j'
382 mix_branches (NewRoot nd False)
383 = mkLLNodeUFM nd left_t right_t
384 mix_branches (NewRoot nd True)
385 = mkLLNodeUFM nd right_t left_t
391 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
393 mix_branches (SameRoot)
394 = mkSSNodeUFM (NodeUFMData j p)
397 -- Now the 4 different other ways; all like this:
399 -- Given j >^ j' (and, say, j > j')
403 -- t1 t2 t1' t2' t1 t2 + j'
406 mix_branches (LeftRoot Leftt) -- | trace "LL" True
409 (mix_trees t1 right_t)
412 mix_branches (LeftRoot Rightt) -- | trace "LR" True
416 (mix_trees t2 right_t)
418 mix_branches (RightRoot Leftt) -- | trace "RL" True
421 (mix_trees left_t t1')
424 mix_branches (RightRoot Rightt) -- | trace "RR" True
428 (mix_trees left_t t2')
430 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
433 And ways of subtracting them. First the base cases,
434 then the full D&C approach.
437 minusUFM EmptyUFM _ = EmptyUFM
438 minusUFM t1 EmptyUFM = t1
439 minusUFM fm1 fm2 = minus_trees fm1 fm2
442 -- Notice the asymetry of subtraction
444 minus_trees lf@(LeafUFM i a) t2 =
449 minus_trees t1 (LeafUFM i _) = delete t1 i
451 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
453 (ask_about_common_ancestor
457 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
461 -- t1 t2 t1' t2' t1 t2
466 minus_branches (NewRoot nd _) = left_t
472 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
474 minus_branches (SameRoot)
475 = mkSSNodeUFM (NodeUFMData j p)
478 -- Now the 4 different other ways; all like this:
479 -- again, with asymatry
482 -- The left is above the right
484 minus_branches (LeftRoot Leftt)
487 (minus_trees t1 right_t)
489 minus_branches (LeftRoot Rightt)
493 (minus_trees t2 right_t)
496 -- The right is above the left
498 minus_branches (RightRoot Leftt)
499 = minus_trees left_t t1'
500 minus_branches (RightRoot Rightt)
501 = minus_trees left_t t2'
503 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
506 And taking the intersection of two UniqFM's.
509 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
511 intersectUFM_C f EmptyUFM _ = EmptyUFM
512 intersectUFM_C f _ EmptyUFM = EmptyUFM
513 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
515 intersect_trees (LeafUFM i a) t2 =
518 Just b -> mkLeafUFM i (f a b)
520 intersect_trees t1 (LeafUFM i a) =
523 Just b -> mkLeafUFM i (f b a)
525 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
527 (ask_about_common_ancestor
531 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
534 -- / \ + / \ ==> EmptyUFM
539 intersect_branches (NewRoot nd _) = EmptyUFM
545 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
547 intersect_branches (SameRoot)
548 = mkSSNodeUFM (NodeUFMData j p)
549 (intersect_trees t1 t1')
550 (intersect_trees t2 t2')
551 -- Now the 4 different other ways; all like this:
553 -- Given j >^ j' (and, say, j > j')
557 -- t1 t2 t1' t2' t1' t2'
559 -- This does cut down the search space quite a bit.
561 intersect_branches (LeftRoot Leftt)
562 = intersect_trees t1 right_t
563 intersect_branches (LeftRoot Rightt)
564 = intersect_trees t2 right_t
565 intersect_branches (RightRoot Leftt)
566 = intersect_trees left_t t1'
567 intersect_branches (RightRoot Rightt)
568 = intersect_trees left_t t2'
570 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
573 Now the usual set of `collection' operators, like map, fold, etc.
576 foldUFM fn a EmptyUFM = a
577 foldUFM fn a fm = fold_tree fn a fm
579 mapUFM fn EmptyUFM = EmptyUFM
580 mapUFM fn fm = map_tree fn fm
582 filterUFM fn EmptyUFM = EmptyUFM
583 filterUFM fn fm = filter_tree fn fm
586 Note, this takes a long time, O(n), but
587 because we dont want to do this very often, we put up with this.
588 O'rable, but how often do we look at the size of
593 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
594 sizeUFM (LeafUFM _ _) = 1
596 isNullUFM EmptyUFM = True
600 looking up in a hurry is the {\em whole point} of this binary tree lark.
601 Lookup up a binary tree is easy (and fast).
604 lookupUFM fm key = lookup fm (u2i (uniqueOf key))
605 lookupUFM_Directly fm key = lookup fm (u2i key)
607 lookupWithDefaultUFM fm deflt key
608 = case lookup fm (u2i (uniqueOf key)) of
612 lookupWithDefaultUFM_Directly fm deflt key
613 = case lookup fm (u2i key) of
617 lookup EmptyUFM _ = Nothing
618 lookup fm i = lookup_tree fm
620 lookup_tree :: UniqFM a -> Maybe a
622 lookup_tree (LeafUFM j b)
624 | otherwise = Nothing
625 lookup_tree (NodeUFM j p t1 t2)
626 | j _GT_ i = lookup_tree t1
627 | otherwise = lookup_tree t2
629 lookup_tree EmptyUFM = panic "lookup Failed"
632 folds are *wonderful* things.
635 eltsUFM EmptyUFM = []
636 eltsUFM fm = fold_tree (:) [] fm
638 ufmToList EmptyUFM = []
640 = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
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
645 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
648 %************************************************************************
650 \subsubsection{The @UniqFM@ type, and its functions}
652 %************************************************************************
654 You should always use these to build the tree.
655 There are 4 versions of mkNodeUFM, depending on
656 the strictness of the two sub-tree arguments.
657 The strictness is used *both* to prune out
658 empty trees, *and* to improve performance,
659 stoping needless thunks lying around.
660 The rule of thumb (from experence with these trees)
661 is make thunks strict, but data structures lazy.
662 If in doubt, use mkSSNodeUFM, which has the `strongest'
663 functionality, but may do a few needless evaluations.
666 mkLeafUFM :: FAST_INT -> a -> UniqFM a
667 mkLeafUFM i a = LeafUFM i a
669 -- The *ONLY* ways of building a NodeUFM.
671 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
672 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
673 mkSSNodeUFM (NodeUFMData j p) t1 t2
674 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
677 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
678 mkSLNodeUFM (NodeUFMData j p) t1 t2
679 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
682 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
683 mkLSNodeUFM (NodeUFMData j p) t1 t2
684 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
687 mkLLNodeUFM (NodeUFMData j p) t1 t2
688 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
698 correctNodeUFM j p t1 t2
699 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
701 correct low high _ (LeafUFM i _)
702 = low <= IBOX(i) && IBOX(i) <= high
703 correct low high above_p (NodeUFM j p _ _)
704 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
705 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
708 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
709 and if necessary do $\lambda$ lifting on our functions that are bound.
719 insert_ele f EmptyUFM i new = mkLeafUFM i new
721 insert_ele f (LeafUFM j old) i new
723 mkLLNodeUFM (getCommonNodeUFMData
728 | j _EQ_ i = mkLeafUFM j (f old new)
730 mkLLNodeUFM (getCommonNodeUFMData
736 insert_ele f n@(NodeUFM j p t1 t2) i a
738 = if (i _GE_ (j _SUB_ p))
739 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
740 else mkLLNodeUFM (getCommonNodeUFMData
746 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
747 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
748 else mkLLNodeUFM (getCommonNodeUFMData
755 This has got a left to right ordering.
758 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
759 fold_tree f a (LeafUFM _ obj) = f obj a
761 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
765 map_tree f (NodeUFM j p t1 t2)
766 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
767 map_tree f (LeafUFM i obj)
768 = mkLeafUFM i (f obj)
770 map_tree f _ = panic "map_tree failed"
774 filter_tree f nd@(NodeUFM j p t1 t2)
775 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
777 filter_tree f lf@(LeafUFM i obj)
779 | otherwise = EmptyUFM
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 FAST_INT
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 :: FAST_INT -> NodeUFMData
818 l = (ILIT(1) :: FAST_INT)
820 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
822 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
824 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
825 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
826 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
827 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
829 l = (ILIT(1) :: FAST_INT)
830 j = i _QUOT_ (p `shiftL_` l)
831 j2 = i2 _QUOT_ (p2 `shiftL_` l)
833 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
835 getCommonNodeUFMData_ p j j_
837 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
839 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
841 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
843 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
844 | j _EQ_ j2 = SameRoot
846 = case getCommonNodeUFMData x y of
847 nd@(NodeUFMData j3 p3)
848 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
849 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
850 | otherwise -> NewRoot nd (j _GT_ j2)
852 decideSide :: Bool -> Side
853 decideSide True = Leftt
854 decideSide False = Rightt
857 This might be better in Util.lhs ?
860 Now the bit twiddling functions.
862 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
863 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
865 #if __GLASGOW_HASKELL__
866 {-# INLINE shiftL_ #-}
867 {-# INLINE shiftR_ #-}
868 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
869 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
871 shiftr x y = shiftRA# x y
874 shiftL_ n p = n * (2 ^ p)
875 shiftR_ n p = n `quot` (2 ^ p)
880 Andy's extras: ToDo: to Util.
883 use_fst :: a -> b -> a
886 use_snd :: a -> b -> b