2 % (c) The AQUA Project, Glasgow University, 1994-1995
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 @getTheUnique@ method to grab their @Uniques@.
11 (A similar thing to @UniqSet@, as opposed to @Set@.)
13 @IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations
14 of this stuff for Ids and TyVars, respectively.
17 #if defined(COMPILING_GHC)
18 #include "HsVersions.h"
19 #define IF_NOT_GHC(a) {--}
21 #define ASSERT(e) {--}
22 #define IF_NOT_GHC(a) a
26 UniqFM, -- abstract type
34 IF_NOT_GHC(addListToUFM COMMA)
36 IF_NOT_GHC(addToUFM_C COMMA)
37 IF_NOT_GHC(addListToUFM_C COMMA)
44 IF_NOT_GHC(intersectUFM_C COMMA)
45 IF_NOT_GHC(foldUFM COMMA)
52 IF_NOT_GHC(lookupWithDefaultUFM COMMA)
56 -- to make the interface self-sufficient
58 IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling
61 import AbsUniType -- for specialisation to TyVars
62 import Id -- for specialisation to Ids
64 import Maybes ( maybeToBool, Maybe(..) )
67 import Unique ( u2i, mkUniqueGrimily, Unique )
69 #if ! OMIT_NATIVE_CODEGEN
70 import AsmRegAlloc ( Reg )
73 #define IF_NCG(a) {--}
77 %************************************************************************
79 \subsection{The @UniqFM@ type, and signatures for the functions}
81 %************************************************************************
83 We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''.
86 emptyUFM :: UniqFM elt
87 isNullUFM :: UniqFM elt -> Bool
88 singletonUFM :: NamedThing key => key -> elt -> UniqFM elt
89 singletonDirectlyUFM -- got the Unique already
90 :: Unique -> elt -> UniqFM elt
91 listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
93 :: [(Unique, elt)] -> UniqFM elt
95 addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt
96 addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt
98 :: UniqFM elt -> Unique -> elt -> UniqFM elt
100 addToUFM_C :: NamedThing key => (elt -> elt -> elt)
101 -> UniqFM elt -> key -> elt -> UniqFM elt
102 addListToUFM_C :: NamedThing key => (elt -> elt -> elt)
103 -> UniqFM elt -> [(key,elt)]
106 delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt
107 delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt
109 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
111 plusUFM_C :: (elt -> elt -> elt)
112 -> UniqFM elt -> UniqFM elt -> UniqFM elt
114 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
116 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
117 intersectUFM_C :: (elt -> elt -> elt)
118 -> UniqFM elt -> UniqFM elt -> UniqFM elt
119 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
120 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
121 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
123 sizeUFM :: UniqFM elt -> Int
125 lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
126 lookupDirectlyUFM -- when you've got the Unique already
127 :: UniqFM elt -> Unique -> Maybe elt
129 :: NamedThing key => UniqFM elt -> elt -> key -> elt
131 eltsUFM :: UniqFM elt -> [elt]
132 ufmToList :: UniqFM elt -> [(Unique, elt)]
135 %************************************************************************
137 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
139 %************************************************************************
142 type IdFinMap elt = UniqFM elt
143 type TyVarFinMap elt = UniqFM elt
144 type NameFinMap elt = UniqFM elt
145 type RegFinMap elt = UniqFM elt
149 #ifdef __GLASGOW_HASKELL__
150 -- I don't think HBC was too happy about this (WDP 94/10)
153 singletonUFM :: 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__ -}
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 (getTheUnique 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 (getTheUnique key)) elt
313 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
315 addListToUFM_C combiner fm key_elt_pairs
316 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getTheUnique k)) e)
319 addListToUFM_directly_C combiner fm uniq_elt_pairs
320 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
324 Now ways of removing things from UniqFM.
327 delListFromUFM fm lst = foldl delFromUFM fm lst
329 delFromUFM fm key = delete fm (u2i (getTheUnique key))
331 delete EmptyUFM _ = EmptyUFM
332 delete fm key = del_ele fm
334 del_ele :: UniqFM a -> UniqFM a
336 del_ele lf@(LeafUFM j _)
337 | j _EQ_ key = EmptyUFM
338 | otherwise = lf -- no delete!
340 del_ele nd@(NodeUFM j p t1 t2)
342 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
344 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
346 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
349 Now ways of adding two UniqFM's together.
352 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
354 plusUFM_C f EmptyUFM tr = tr
355 plusUFM_C f tr EmptyUFM = tr
356 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
358 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
359 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
361 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
363 (ask_about_common_ancestor
367 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
371 -- t1 t2 t1' t2' j j'
376 mix_branches (NewRoot nd False)
377 = mkLLNodeUFM nd left_t right_t
378 mix_branches (NewRoot nd True)
379 = mkLLNodeUFM nd right_t left_t
385 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
387 mix_branches (SameRoot)
388 = mkSSNodeUFM (NodeUFMData j p)
391 -- Now the 4 different other ways; all like this:
393 -- Given j >^ j' (and, say, j > j')
397 -- t1 t2 t1' t2' t1 t2 + j'
400 mix_branches (LeftRoot Left) -- | trace "LL" True
403 (mix_trees t1 right_t)
406 mix_branches (LeftRoot Right) -- | trace "LR" True
410 (mix_trees t2 right_t)
412 mix_branches (RightRoot Left) -- | trace "RL" True
415 (mix_trees left_t t1')
418 mix_branches (RightRoot Right) -- | trace "RR" True
422 (mix_trees left_t t2')
424 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
427 And ways of subtracting them. First the base cases,
428 then the full D&C approach.
431 minusUFM EmptyUFM _ = EmptyUFM
432 minusUFM t1 EmptyUFM = t1
433 minusUFM fm1 fm2 = minus_trees fm1 fm2
436 -- Notice the asymetry of subtraction
438 minus_trees lf@(LeafUFM i a) t2 =
443 minus_trees t1 (LeafUFM i _) = delete t1 i
445 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
447 (ask_about_common_ancestor
451 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
455 -- t1 t2 t1' t2' t1 t2
460 minus_branches (NewRoot nd _) = left_t
466 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
468 minus_branches (SameRoot)
469 = mkSSNodeUFM (NodeUFMData j p)
472 -- Now the 4 different other ways; all like this:
473 -- again, with asymatry
476 -- The left is above the right
478 minus_branches (LeftRoot Left)
481 (minus_trees t1 right_t)
483 minus_branches (LeftRoot Right)
487 (minus_trees t2 right_t)
490 -- The right is above the left
492 minus_branches (RightRoot Left)
493 = minus_trees left_t t1'
494 minus_branches (RightRoot Right)
495 = minus_trees left_t t2'
497 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
500 And taking the intersection of two UniqFM's.
503 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
505 intersectUFM_C f EmptyUFM _ = EmptyUFM
506 intersectUFM_C f _ EmptyUFM = EmptyUFM
507 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
509 intersect_trees (LeafUFM i a) t2 =
512 Just b -> mkLeafUFM i (f a b)
514 intersect_trees t1 (LeafUFM i a) =
517 Just b -> mkLeafUFM i (f b a)
519 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
521 (ask_about_common_ancestor
525 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
528 -- / \ + / \ ==> EmptyUFM
533 intersect_branches (NewRoot nd _) = EmptyUFM
539 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
541 intersect_branches (SameRoot)
542 = mkSSNodeUFM (NodeUFMData j p)
543 (intersect_trees t1 t1')
544 (intersect_trees t2 t2')
545 -- Now the 4 different other ways; all like this:
547 -- Given j >^ j' (and, say, j > j')
551 -- t1 t2 t1' t2' t1' t2'
553 -- This does cut down the search space quite a bit.
555 intersect_branches (LeftRoot Left)
556 = intersect_trees t1 right_t
557 intersect_branches (LeftRoot Right)
558 = intersect_trees t2 right_t
559 intersect_branches (RightRoot Left)
560 = intersect_trees left_t t1'
561 intersect_branches (RightRoot Right)
562 = intersect_trees left_t t2'
564 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
567 Now the usual set of `collection' operators, like map, fold, etc.
570 foldUFM fn a EmptyUFM = a
571 foldUFM fn a fm = fold_tree fn a fm
573 mapUFM fn EmptyUFM = EmptyUFM
574 mapUFM fn fm = map_tree fn fm
576 filterUFM fn EmptyUFM = EmptyUFM
577 filterUFM fn fm = filter_tree fn fm
580 Note, this takes a long time, O(n), but
581 because we dont want to do this very often, we put up with this.
582 O'rable, but how often do we look at the size of
587 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
588 sizeUFM (LeafUFM _ _) = 1
590 isNullUFM EmptyUFM = True
594 looking up in a hurry is the {\em whole point} of this binary tree lark.
595 Lookup up a binary tree is easy (and fast).
598 lookupUFM fm key = lookup fm (u2i (getTheUnique key))
599 lookupDirectlyUFM fm key = lookup fm (u2i key)
601 lookupWithDefaultUFM fm deflt key
602 = case lookup fm (u2i (getTheUnique key)) of
606 lookup EmptyUFM _ = Nothing
607 lookup fm i = lookup_tree fm
609 lookup_tree :: UniqFM a -> Maybe a
611 lookup_tree (LeafUFM j b)
613 | otherwise = Nothing
614 lookup_tree (NodeUFM j p t1 t2)
615 | j _GT_ i = lookup_tree t1
616 | otherwise = lookup_tree t2
618 lookup_tree EmptyUFM = panic "lookup Failed"
621 folds are *wonderful* things.
624 eltsUFM EmptyUFM = []
625 eltsUFM fm = fold_tree (:) [] fm
627 ufmToList EmptyUFM = []
629 = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
631 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
632 fold_tree f a (LeafUFM iu obj) = f iu obj a
634 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
637 %************************************************************************
639 \subsubsection{The @UniqFM@ type, and its functions}
641 %************************************************************************
643 You should always use these to build the tree.
644 There are 4 versions of mkNodeUFM, depending on
645 the strictness of the two sub-tree arguments.
646 The strictness is used *both* to prune out
647 empty trees, *and* to improve performance,
648 stoping needless thunks lying around.
649 The rule of thumb (from experence with these trees)
650 is make thunks strict, but data structures lazy.
651 If in doubt, use mkSSNodeUFM, which has the `strongest'
652 functionality, but may do a few needless evaluations.
655 mkLeafUFM :: FAST_INT -> a -> UniqFM a
656 mkLeafUFM i a = LeafUFM i a
658 -- The *ONLY* ways of building a NodeUFM.
660 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
661 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
662 mkSSNodeUFM (NodeUFMData j p) t1 t2
663 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
666 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
667 mkSLNodeUFM (NodeUFMData j p) t1 t2
668 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
671 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
672 mkLSNodeUFM (NodeUFMData j p) t1 t2
673 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
676 mkLLNodeUFM (NodeUFMData j p) t1 t2
677 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
687 correctNodeUFM j p t1 t2
688 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
690 correct low high _ (LeafUFM i _)
691 = low <= IBOX(i) && IBOX(i) <= high
692 correct low high above_p (NodeUFM j p _ _)
693 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
694 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
697 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
698 and if necessary do $\lambda$ lifting on our functions that are bound.
708 insert_ele f EmptyUFM i new = mkLeafUFM i new
710 insert_ele f (LeafUFM j old) i new
712 mkLLNodeUFM (getCommonNodeUFMData
717 | j _EQ_ i = mkLeafUFM j (f old new)
719 mkLLNodeUFM (getCommonNodeUFMData
725 insert_ele f n@(NodeUFM j p t1 t2) i a
727 = if (i _GE_ (j _SUB_ p))
728 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
729 else mkLLNodeUFM (getCommonNodeUFMData
735 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
736 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
737 else mkLLNodeUFM (getCommonNodeUFMData
744 This has got a left to right ordering.
747 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
748 fold_tree f a (LeafUFM _ obj) = f obj a
750 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
754 map_tree f (NodeUFM j p t1 t2)
755 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
756 map_tree f (LeafUFM i obj)
757 = mkLeafUFM i (f obj)
759 map_tree f _ = panic "map_tree failed"
763 filter_tree f nd@(NodeUFM j p t1 t2)
764 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
766 filter_tree f lf@(LeafUFM i obj)
768 | otherwise = EmptyUFM
771 %************************************************************************
773 \subsubsection{The @UniqFM@ type, and signatures for the functions}
775 %************************************************************************
779 This is the information that is held inside a NodeUFM, packaged up for
784 = NodeUFMData FAST_INT
788 This is the information used when computing new NodeUFMs.
791 data Side = Left | Right
793 = LeftRoot Side -- which side is the right down ?
794 | RightRoot Side -- which side is the left down ?
795 | SameRoot -- they are the same !
796 | NewRoot NodeUFMData -- here's the new, common, root
797 Bool -- do you need to swap left and right ?
800 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
803 indexToRoot :: FAST_INT -> NodeUFMData
807 l = (ILIT(1) :: FAST_INT)
809 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
811 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
813 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
814 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
815 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
816 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
818 l = (ILIT(1) :: FAST_INT)
819 j = i _QUOT_ (p `shiftL_` l)
820 j2 = i2 _QUOT_ (p2 `shiftL_` l)
822 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
824 getCommonNodeUFMData_ p j j_
826 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
828 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
830 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
832 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
833 | j _EQ_ j2 = SameRoot
835 = case getCommonNodeUFMData x y of
836 nd@(NodeUFMData j3 p3)
837 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
838 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
839 | otherwise -> NewRoot nd (j _GT_ j2)
841 decideSide :: Bool -> Side
842 decideSide True = Left
843 decideSide False = Right
846 This might be better in Util.lhs ?
849 Now the bit twiddling functions.
851 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
852 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
854 #if __GLASGOW_HASKELL__
855 {-# INLINE shiftL_ #-}
856 {-# INLINE shiftR_ #-}
857 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
858 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
859 # if __GLASGOW_HASKELL__ >= 23
861 shiftr x y = shiftRA# x y
863 shiftr x y = shiftR# x y
867 shiftL_ n p = n * (2 ^ p)
868 shiftR_ n p = n `quot` (2 ^ p)
873 Andy's extras: ToDo: to Util.
876 use_fst :: a -> b -> a
879 use_snd :: a -> b -> b