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
32 addListToUFM,addListToUFM_C,
34 addListToUFM_Directly,
42 IF_NOT_GHC(intersectUFM_C COMMA)
43 IF_NOT_GHC(foldUFM COMMA)
48 lookupUFM, lookupUFM_Directly,
49 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
52 #if defined(COMPILING_GHC)
59 #if defined(COMPILING_GHC)
60 # if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
61 IMPORT_DELOOPER( SpecLoop )
63 import {-# SOURCE #-} Name
67 import Unique ( Unique, u2i, mkUniqueGrimily )
70 import Outputable ( PprStyle, Outputable(..) )
71 import SrcLoc ( SrcLoc )
73 #if ! OMIT_NATIVE_CODEGEN
76 #define IF_NCG(a) {--}
80 %************************************************************************
82 \subsection{The @UniqFM@ type, and signatures for the functions}
84 %************************************************************************
86 We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
89 emptyUFM :: UniqFM elt
90 isNullUFM :: UniqFM elt -> Bool
91 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
92 unitDirectlyUFM -- got the Unique already
93 :: Unique -> elt -> UniqFM elt
94 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
96 :: [(Unique, elt)] -> UniqFM elt
98 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
99 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
101 :: UniqFM elt -> Unique -> elt -> UniqFM elt
103 addToUFM_C :: Uniquable key => (elt -> elt -> elt)
104 -> UniqFM elt -> key -> elt -> UniqFM elt
105 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
106 -> UniqFM elt -> [(key,elt)]
109 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
110 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
111 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
113 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
115 plusUFM_C :: (elt -> elt -> elt)
116 -> UniqFM elt -> UniqFM elt -> UniqFM elt
118 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
120 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
121 intersectUFM_C :: (elt -> elt -> elt)
122 -> UniqFM elt -> UniqFM elt -> UniqFM elt
123 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
124 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
125 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
127 sizeUFM :: UniqFM elt -> Int
129 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
130 lookupUFM_Directly -- when you've got the Unique already
131 :: UniqFM elt -> Unique -> Maybe elt
133 :: Uniquable key => UniqFM elt -> elt -> key -> elt
134 lookupWithDefaultUFM_Directly
135 :: UniqFM elt -> elt -> Unique -> elt
137 keysUFM :: UniqFM elt -> [Int] -- Get the keys
138 eltsUFM :: UniqFM elt -> [elt]
139 ufmToList :: UniqFM elt -> [(Unique, elt)]
142 %************************************************************************
144 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
146 %************************************************************************
149 #ifdef __GLASGOW_HASKELL__
150 -- I don't think HBC was too happy about this (WDP 94/10)
153 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
156 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
159 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
162 listToUFM :: [(Unique, elt)] -> UniqFM elt
165 lookupUFM :: UniqFM elt -> Name -> Maybe elt
166 , UniqFM elt -> Unique -> Maybe elt
169 #endif {- __GLASGOW_HASKELL__ -}
172 %************************************************************************
174 \subsection{Andy Gill's underlying @UniqFM@ machinery}
176 %************************************************************************
178 ``Uniq Finite maps'' are the heart and soul of the compiler's
179 lookup-tables/environments. Important stuff! It works well with
180 Dense and Sparse ranges.
181 Both @Uq@ Finite maps and @Hash@ Finite Maps
182 are built ontop of Int Finite Maps.
184 This code is explained in the paper:
186 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
187 "A Cheap balancing act that grows on a tree"
188 Glasgow FP Workshop, Sep 1994, pp??-??
191 %************************************************************************
193 \subsubsection{The @UniqFM@ type, and signatures for the functions}
195 %************************************************************************
197 @UniqFM a@ is a mapping from Unique to a.
199 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
204 | LeafUFM FAST_INT ele
205 | NodeUFM FAST_INT -- the switching
206 FAST_INT -- the delta
210 class Uniquable a where
211 uniqueOf :: a -> Unique
213 -- for debugging only :-)
215 instance Text (UniqFM a) where
216 showsPrec _ (NodeUFM a b t1 t2) =
217 showString "NodeUFM " . shows (IBOX(a))
218 . showString " " . shows (IBOX(b))
219 . showString " (" . shows t1
220 . showString ") (" . shows t2
222 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
223 showsPrec _ (EmptyUFM) = id
227 %************************************************************************
229 \subsubsection{The @UniqFM@ functions}
231 %************************************************************************
233 First the ways of building a UniqFM.
237 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
238 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
240 listToUFM key_elt_pairs
241 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
243 listToUFM_Directly uniq_elt_pairs
244 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
247 Now ways of adding things to UniqFMs.
249 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
250 but the semantics of this operation demands a linear insertion;
251 perhaps the version without the combinator function
252 could be optimised using it.
255 addToUFM fm key elt = addToUFM_C use_snd fm key elt
257 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
259 addToUFM_C combiner fm key elt
260 = insert_ele combiner fm (u2i (uniqueOf key)) elt
262 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
263 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
265 addListToUFM_C combiner fm key_elt_pairs
266 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
269 addListToUFM_directly_C combiner fm uniq_elt_pairs
270 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
274 Now ways of removing things from UniqFM.
277 delListFromUFM fm lst = foldl delFromUFM fm lst
279 delFromUFM fm key = delete fm (u2i (uniqueOf key))
280 delFromUFM_Directly fm u = delete fm (u2i u)
282 delete EmptyUFM _ = EmptyUFM
283 delete fm key = del_ele fm
285 del_ele :: UniqFM a -> UniqFM a
287 del_ele lf@(LeafUFM j _)
288 | j _EQ_ key = EmptyUFM
289 | otherwise = lf -- no delete!
291 del_ele nd@(NodeUFM j p t1 t2)
293 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
295 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
297 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
300 Now ways of adding two UniqFM's together.
303 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
305 plusUFM_C f EmptyUFM tr = tr
306 plusUFM_C f tr EmptyUFM = tr
307 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
309 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
310 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
312 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
314 (ask_about_common_ancestor
318 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
322 -- t1 t2 t1' t2' j j'
327 mix_branches (NewRoot nd False)
328 = mkLLNodeUFM nd left_t right_t
329 mix_branches (NewRoot nd True)
330 = mkLLNodeUFM nd right_t left_t
336 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
338 mix_branches (SameRoot)
339 = mkSSNodeUFM (NodeUFMData j p)
342 -- Now the 4 different other ways; all like this:
344 -- Given j >^ j' (and, say, j > j')
348 -- t1 t2 t1' t2' t1 t2 + j'
351 mix_branches (LeftRoot Leftt) -- | trace "LL" True
354 (mix_trees t1 right_t)
357 mix_branches (LeftRoot Rightt) -- | trace "LR" True
361 (mix_trees t2 right_t)
363 mix_branches (RightRoot Leftt) -- | trace "RL" True
366 (mix_trees left_t t1')
369 mix_branches (RightRoot Rightt) -- | trace "RR" True
373 (mix_trees left_t t2')
375 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
378 And ways of subtracting them. First the base cases,
379 then the full D&C approach.
382 minusUFM EmptyUFM _ = EmptyUFM
383 minusUFM t1 EmptyUFM = t1
384 minusUFM fm1 fm2 = minus_trees fm1 fm2
387 -- Notice the asymetry of subtraction
389 minus_trees lf@(LeafUFM i a) t2 =
394 minus_trees t1 (LeafUFM i _) = delete t1 i
396 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
398 (ask_about_common_ancestor
402 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
406 -- t1 t2 t1' t2' t1 t2
411 minus_branches (NewRoot nd _) = left_t
417 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
419 minus_branches (SameRoot)
420 = mkSSNodeUFM (NodeUFMData j p)
423 -- Now the 4 different other ways; all like this:
424 -- again, with asymatry
427 -- The left is above the right
429 minus_branches (LeftRoot Leftt)
432 (minus_trees t1 right_t)
434 minus_branches (LeftRoot Rightt)
438 (minus_trees t2 right_t)
441 -- The right is above the left
443 minus_branches (RightRoot Leftt)
444 = minus_trees left_t t1'
445 minus_branches (RightRoot Rightt)
446 = minus_trees left_t t2'
448 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
451 And taking the intersection of two UniqFM's.
454 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
456 intersectUFM_C f EmptyUFM _ = EmptyUFM
457 intersectUFM_C f _ EmptyUFM = EmptyUFM
458 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
460 intersect_trees (LeafUFM i a) t2 =
463 Just b -> mkLeafUFM i (f a b)
465 intersect_trees t1 (LeafUFM i a) =
468 Just b -> mkLeafUFM i (f b a)
470 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
472 (ask_about_common_ancestor
476 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
479 -- / \ + / \ ==> EmptyUFM
484 intersect_branches (NewRoot nd _) = EmptyUFM
490 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
492 intersect_branches (SameRoot)
493 = mkSSNodeUFM (NodeUFMData j p)
494 (intersect_trees t1 t1')
495 (intersect_trees t2 t2')
496 -- Now the 4 different other ways; all like this:
498 -- Given j >^ j' (and, say, j > j')
502 -- t1 t2 t1' t2' t1' t2'
504 -- This does cut down the search space quite a bit.
506 intersect_branches (LeftRoot Leftt)
507 = intersect_trees t1 right_t
508 intersect_branches (LeftRoot Rightt)
509 = intersect_trees t2 right_t
510 intersect_branches (RightRoot Leftt)
511 = intersect_trees left_t t1'
512 intersect_branches (RightRoot Rightt)
513 = intersect_trees left_t t2'
515 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
518 Now the usual set of `collection' operators, like map, fold, etc.
521 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
522 foldUFM f a (LeafUFM _ obj) = f obj a
523 foldUFM f a EmptyUFM = a
527 mapUFM fn EmptyUFM = EmptyUFM
528 mapUFM fn fm = map_tree fn fm
530 filterUFM fn EmptyUFM = EmptyUFM
531 filterUFM fn fm = filter_tree fn fm
534 Note, this takes a long time, O(n), but
535 because we dont want to do this very often, we put up with this.
536 O'rable, but how often do we look at the size of
541 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
542 sizeUFM (LeafUFM _ _) = 1
544 isNullUFM EmptyUFM = True
548 looking up in a hurry is the {\em whole point} of this binary tree lark.
549 Lookup up a binary tree is easy (and fast).
552 lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
553 lookupUFM_Directly fm key = lookUp fm (u2i key)
555 lookupWithDefaultUFM fm deflt key
556 = case lookUp fm (u2i (uniqueOf key)) of
560 lookupWithDefaultUFM_Directly fm deflt key
561 = case lookUp fm (u2i key) of
565 lookUp EmptyUFM _ = Nothing
566 lookUp fm i = lookup_tree fm
568 lookup_tree :: UniqFM a -> Maybe a
570 lookup_tree (LeafUFM j b)
572 | otherwise = Nothing
573 lookup_tree (NodeUFM j p t1 t2)
574 | j _GT_ i = lookup_tree t1
575 | otherwise = lookup_tree t2
577 lookup_tree EmptyUFM = panic "lookup Failed"
580 folds are *wonderful* things.
583 eltsUFM fm = foldUFM (:) [] fm
585 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
587 keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm
589 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
590 fold_tree f a (LeafUFM iu obj) = f iu obj a
591 fold_tree f a EmptyUFM = a
594 %************************************************************************
596 \subsubsection{The @UniqFM@ type, and its functions}
598 %************************************************************************
600 You should always use these to build the tree.
601 There are 4 versions of mkNodeUFM, depending on
602 the strictness of the two sub-tree arguments.
603 The strictness is used *both* to prune out
604 empty trees, *and* to improve performance,
605 stoping needless thunks lying around.
606 The rule of thumb (from experence with these trees)
607 is make thunks strict, but data structures lazy.
608 If in doubt, use mkSSNodeUFM, which has the `strongest'
609 functionality, but may do a few needless evaluations.
612 mkLeafUFM :: FAST_INT -> a -> UniqFM a
613 mkLeafUFM i a = LeafUFM i a
615 -- The *ONLY* ways of building a NodeUFM.
617 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
618 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
619 mkSSNodeUFM (NodeUFMData j p) t1 t2
620 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
623 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
624 mkSLNodeUFM (NodeUFMData j p) t1 t2
625 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
628 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
629 mkLSNodeUFM (NodeUFMData j p) t1 t2
630 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
633 mkLLNodeUFM (NodeUFMData j p) t1 t2
634 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
644 correctNodeUFM j p t1 t2
645 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
647 correct low high _ (LeafUFM i _)
648 = low <= IBOX(i) && IBOX(i) <= high
649 correct low high above_p (NodeUFM j p _ _)
650 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
651 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
654 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
655 and if necessary do $\lambda$ lifting on our functions that are bound.
665 insert_ele f EmptyUFM i new = mkLeafUFM i new
667 insert_ele f (LeafUFM j old) i new
669 mkLLNodeUFM (getCommonNodeUFMData
674 | j _EQ_ i = mkLeafUFM j (f old new)
676 mkLLNodeUFM (getCommonNodeUFMData
682 insert_ele f n@(NodeUFM j p t1 t2) i a
684 = if (i _GE_ (j _SUB_ p))
685 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
686 else mkLLNodeUFM (getCommonNodeUFMData
692 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
693 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
694 else mkLLNodeUFM (getCommonNodeUFMData
704 map_tree f (NodeUFM j p t1 t2)
705 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
706 map_tree f (LeafUFM i obj)
707 = mkLeafUFM i (f obj)
709 map_tree f _ = panic "map_tree failed"
713 filter_tree f nd@(NodeUFM j p t1 t2)
714 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
716 filter_tree f lf@(LeafUFM i obj)
718 | otherwise = EmptyUFM
719 filter_tree f _ = panic "filter_tree failed"
722 %************************************************************************
724 \subsubsection{The @UniqFM@ type, and signatures for the functions}
726 %************************************************************************
730 This is the information that is held inside a NodeUFM, packaged up for
735 = NodeUFMData FAST_INT
739 This is the information used when computing new NodeUFMs.
742 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
744 = LeftRoot Side -- which side is the right down ?
745 | RightRoot Side -- which side is the left down ?
746 | SameRoot -- they are the same !
747 | NewRoot NodeUFMData -- here's the new, common, root
748 Bool -- do you need to swap left and right ?
751 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
754 indexToRoot :: FAST_INT -> NodeUFMData
758 l = (ILIT(1) :: FAST_INT)
760 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
762 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
764 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
765 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
766 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
767 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
769 l = (ILIT(1) :: FAST_INT)
770 j = i _QUOT_ (p `shiftL_` l)
771 j2 = i2 _QUOT_ (p2 `shiftL_` l)
773 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
775 getCommonNodeUFMData_ p j j_
777 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
779 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
781 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
783 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
784 | j _EQ_ j2 = SameRoot
786 = case getCommonNodeUFMData x y of
787 nd@(NodeUFMData j3 p3)
788 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
789 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
790 | otherwise -> NewRoot nd (j _GT_ j2)
792 decideSide :: Bool -> Side
793 decideSide True = Leftt
794 decideSide False = Rightt
797 This might be better in Util.lhs ?
800 Now the bit twiddling functions.
802 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
803 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
805 #if __GLASGOW_HASKELL__
806 {-# INLINE shiftL_ #-}
807 {-# INLINE shiftR_ #-}
808 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
809 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
811 shiftr x y = shiftRA# x y
814 shiftL_ n p = n * (2 ^ p)
815 shiftR_ n p = n `quot` (2 ^ p)
821 use_snd :: a -> b -> b