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,
54 #if defined(COMPILING_GHC)
58 import Unique ( Unique, u2i, mkUniqueGrimily )
60 import Pretty ( SYN_IE(Pretty), PrettyRep )
61 import PprStyle ( PprStyle )
62 import SrcLoc ( SrcLoc )
64 #if ! OMIT_NATIVE_CODEGEN
67 #define IF_NCG(a) {--}
71 %************************************************************************
73 \subsection{The @UniqFM@ type, and signatures for the functions}
75 %************************************************************************
77 We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
80 emptyUFM :: UniqFM elt
81 isNullUFM :: UniqFM elt -> Bool
82 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
83 unitDirectlyUFM -- got the Unique already
84 :: Unique -> elt -> UniqFM elt
85 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
87 :: [(Unique, elt)] -> UniqFM elt
89 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
90 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
92 :: UniqFM elt -> Unique -> elt -> UniqFM elt
94 addToUFM_C :: Uniquable key => (elt -> elt -> elt)
95 -> UniqFM elt -> key -> elt -> UniqFM elt
96 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
97 -> UniqFM elt -> [(key,elt)]
100 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
101 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
102 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
104 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
106 plusUFM_C :: (elt -> elt -> elt)
107 -> UniqFM elt -> UniqFM elt -> UniqFM elt
109 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
111 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
112 intersectUFM_C :: (elt -> elt -> elt)
113 -> UniqFM elt -> UniqFM elt -> UniqFM elt
114 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
115 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
116 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
118 sizeUFM :: UniqFM elt -> Int
120 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
121 lookupUFM_Directly -- when you've got the Unique already
122 :: UniqFM elt -> Unique -> Maybe elt
124 :: Uniquable key => UniqFM elt -> elt -> key -> elt
125 lookupWithDefaultUFM_Directly
126 :: UniqFM elt -> elt -> Unique -> elt
128 eltsUFM :: UniqFM elt -> [elt]
129 ufmToList :: UniqFM elt -> [(Unique, elt)]
132 %************************************************************************
134 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
136 %************************************************************************
139 #ifdef __GLASGOW_HASKELL__
140 -- I don't think HBC was too happy about this (WDP 94/10)
143 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
144 , UniqFM elt -> [(RnName, elt)] -> UniqFM elt
147 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
148 , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt
151 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
154 listToUFM :: [(Unique, elt)] -> UniqFM elt
155 , [(RnName, elt)] -> UniqFM elt
158 lookupUFM :: UniqFM elt -> Name -> Maybe elt
159 , UniqFM elt -> RnName -> Maybe elt
160 , UniqFM elt -> Unique -> Maybe elt
163 lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt
166 #endif {- __GLASGOW_HASKELL__ -}
169 %************************************************************************
171 \subsection{Andy Gill's underlying @UniqFM@ machinery}
173 %************************************************************************
175 ``Uniq Finite maps'' are the heart and soul of the compiler's
176 lookup-tables/environments. Important stuff! It works well with
177 Dense and Sparse ranges.
178 Both @Uq@ Finite maps and @Hash@ Finite Maps
179 are built ontop of Int Finite Maps.
181 This code is explained in the paper:
183 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
184 "A Cheap balancing act that grows on a tree"
185 Glasgow FP Workshop, Sep 1994, pp??-??
188 %************************************************************************
190 \subsubsection{The @UniqFM@ type, and signatures for the functions}
192 %************************************************************************
194 @UniqFM a@ is a mapping from Unique to a.
196 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
201 | LeafUFM FAST_INT ele
202 | NodeUFM FAST_INT -- the switching
203 FAST_INT -- the delta
207 class Uniquable a where
208 uniqueOf :: a -> Unique
210 -- for debugging only :-)
212 instance Text (UniqFM a) where
213 showsPrec _ (NodeUFM a b t1 t2) =
214 showString "NodeUFM " . shows (IBOX(a))
215 . showString " " . shows (IBOX(b))
216 . showString " (" . shows t1
217 . showString ") (" . shows t2
219 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
220 showsPrec _ (EmptyUFM) = id
224 %************************************************************************
226 \subsubsection{The @UniqFM@ functions}
228 %************************************************************************
230 First the ways of building a UniqFM.
234 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
235 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
237 listToUFM key_elt_pairs
238 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
240 listToUFM_Directly uniq_elt_pairs
241 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
244 Now ways of adding things to UniqFMs.
246 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
247 but the semantics of this operation demands a linear insertion;
248 perhaps the version without the combinator function
249 could be optimised using it.
252 addToUFM fm key elt = addToUFM_C use_snd fm key elt
254 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
256 addToUFM_C combiner fm key elt
257 = insert_ele combiner fm (u2i (uniqueOf key)) elt
259 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
260 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
262 addListToUFM_C combiner fm key_elt_pairs
263 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
266 addListToUFM_directly_C combiner fm uniq_elt_pairs
267 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
271 Now ways of removing things from UniqFM.
274 delListFromUFM fm lst = foldl delFromUFM fm lst
276 delFromUFM fm key = delete fm (u2i (uniqueOf key))
277 delFromUFM_Directly fm u = delete fm (u2i u)
279 delete EmptyUFM _ = EmptyUFM
280 delete fm key = del_ele fm
282 del_ele :: UniqFM a -> UniqFM a
284 del_ele lf@(LeafUFM j _)
285 | j _EQ_ key = EmptyUFM
286 | otherwise = lf -- no delete!
288 del_ele nd@(NodeUFM j p t1 t2)
290 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
292 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
294 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
297 Now ways of adding two UniqFM's together.
300 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
302 plusUFM_C f EmptyUFM tr = tr
303 plusUFM_C f tr EmptyUFM = tr
304 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
306 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
307 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
309 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
311 (ask_about_common_ancestor
315 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
319 -- t1 t2 t1' t2' j j'
324 mix_branches (NewRoot nd False)
325 = mkLLNodeUFM nd left_t right_t
326 mix_branches (NewRoot nd True)
327 = mkLLNodeUFM nd right_t left_t
333 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
335 mix_branches (SameRoot)
336 = mkSSNodeUFM (NodeUFMData j p)
339 -- Now the 4 different other ways; all like this:
341 -- Given j >^ j' (and, say, j > j')
345 -- t1 t2 t1' t2' t1 t2 + j'
348 mix_branches (LeftRoot Leftt) -- | trace "LL" True
351 (mix_trees t1 right_t)
354 mix_branches (LeftRoot Rightt) -- | trace "LR" True
358 (mix_trees t2 right_t)
360 mix_branches (RightRoot Leftt) -- | trace "RL" True
363 (mix_trees left_t t1')
366 mix_branches (RightRoot Rightt) -- | trace "RR" True
370 (mix_trees left_t t2')
372 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
375 And ways of subtracting them. First the base cases,
376 then the full D&C approach.
379 minusUFM EmptyUFM _ = EmptyUFM
380 minusUFM t1 EmptyUFM = t1
381 minusUFM fm1 fm2 = minus_trees fm1 fm2
384 -- Notice the asymetry of subtraction
386 minus_trees lf@(LeafUFM i a) t2 =
391 minus_trees t1 (LeafUFM i _) = delete t1 i
393 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
395 (ask_about_common_ancestor
399 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
403 -- t1 t2 t1' t2' t1 t2
408 minus_branches (NewRoot nd _) = left_t
414 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
416 minus_branches (SameRoot)
417 = mkSSNodeUFM (NodeUFMData j p)
420 -- Now the 4 different other ways; all like this:
421 -- again, with asymatry
424 -- The left is above the right
426 minus_branches (LeftRoot Leftt)
429 (minus_trees t1 right_t)
431 minus_branches (LeftRoot Rightt)
435 (minus_trees t2 right_t)
438 -- The right is above the left
440 minus_branches (RightRoot Leftt)
441 = minus_trees left_t t1'
442 minus_branches (RightRoot Rightt)
443 = minus_trees left_t t2'
445 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
448 And taking the intersection of two UniqFM's.
451 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
453 intersectUFM_C f EmptyUFM _ = EmptyUFM
454 intersectUFM_C f _ EmptyUFM = EmptyUFM
455 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
457 intersect_trees (LeafUFM i a) t2 =
460 Just b -> mkLeafUFM i (f a b)
462 intersect_trees t1 (LeafUFM i a) =
465 Just b -> mkLeafUFM i (f b a)
467 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
469 (ask_about_common_ancestor
473 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
476 -- / \ + / \ ==> EmptyUFM
481 intersect_branches (NewRoot nd _) = EmptyUFM
487 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
489 intersect_branches (SameRoot)
490 = mkSSNodeUFM (NodeUFMData j p)
491 (intersect_trees t1 t1')
492 (intersect_trees t2 t2')
493 -- Now the 4 different other ways; all like this:
495 -- Given j >^ j' (and, say, j > j')
499 -- t1 t2 t1' t2' t1' t2'
501 -- This does cut down the search space quite a bit.
503 intersect_branches (LeftRoot Leftt)
504 = intersect_trees t1 right_t
505 intersect_branches (LeftRoot Rightt)
506 = intersect_trees t2 right_t
507 intersect_branches (RightRoot Leftt)
508 = intersect_trees left_t t1'
509 intersect_branches (RightRoot Rightt)
510 = intersect_trees left_t t2'
512 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
515 Now the usual set of `collection' operators, like map, fold, etc.
518 foldUFM fn a EmptyUFM = a
519 foldUFM fn a fm = fold_tree fn a fm
521 mapUFM fn EmptyUFM = EmptyUFM
522 mapUFM fn fm = map_tree fn fm
524 filterUFM fn EmptyUFM = EmptyUFM
525 filterUFM fn fm = filter_tree fn fm
528 Note, this takes a long time, O(n), but
529 because we dont want to do this very often, we put up with this.
530 O'rable, but how often do we look at the size of
535 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
536 sizeUFM (LeafUFM _ _) = 1
538 isNullUFM EmptyUFM = True
542 looking up in a hurry is the {\em whole point} of this binary tree lark.
543 Lookup up a binary tree is easy (and fast).
546 lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
547 lookupUFM_Directly fm key = lookUp fm (u2i key)
549 lookupWithDefaultUFM fm deflt key
550 = case lookUp fm (u2i (uniqueOf key)) of
554 lookupWithDefaultUFM_Directly fm deflt key
555 = case lookUp fm (u2i key) of
559 lookUp EmptyUFM _ = Nothing
560 lookUp fm i = lookup_tree fm
562 lookup_tree :: UniqFM a -> Maybe a
564 lookup_tree (LeafUFM j b)
566 | otherwise = Nothing
567 lookup_tree (NodeUFM j p t1 t2)
568 | j _GT_ i = lookup_tree t1
569 | otherwise = lookup_tree t2
571 lookup_tree EmptyUFM = panic "lookup Failed"
574 folds are *wonderful* things.
577 eltsUFM EmptyUFM = []
578 eltsUFM fm = fold_tree (:) [] fm
580 ufmToList EmptyUFM = []
582 = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
584 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
585 fold_tree f a (LeafUFM iu obj) = f iu obj a
587 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
590 %************************************************************************
592 \subsubsection{The @UniqFM@ type, and its functions}
594 %************************************************************************
596 You should always use these to build the tree.
597 There are 4 versions of mkNodeUFM, depending on
598 the strictness of the two sub-tree arguments.
599 The strictness is used *both* to prune out
600 empty trees, *and* to improve performance,
601 stoping needless thunks lying around.
602 The rule of thumb (from experence with these trees)
603 is make thunks strict, but data structures lazy.
604 If in doubt, use mkSSNodeUFM, which has the `strongest'
605 functionality, but may do a few needless evaluations.
608 mkLeafUFM :: FAST_INT -> a -> UniqFM a
609 mkLeafUFM i a = LeafUFM i a
611 -- The *ONLY* ways of building a NodeUFM.
613 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
614 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
615 mkSSNodeUFM (NodeUFMData j p) t1 t2
616 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
619 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
620 mkSLNodeUFM (NodeUFMData j p) t1 t2
621 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
624 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
625 mkLSNodeUFM (NodeUFMData j p) t1 t2
626 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
629 mkLLNodeUFM (NodeUFMData j p) t1 t2
630 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
640 correctNodeUFM j p t1 t2
641 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
643 correct low high _ (LeafUFM i _)
644 = low <= IBOX(i) && IBOX(i) <= high
645 correct low high above_p (NodeUFM j p _ _)
646 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
647 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
650 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
651 and if necessary do $\lambda$ lifting on our functions that are bound.
661 insert_ele f EmptyUFM i new = mkLeafUFM i new
663 insert_ele f (LeafUFM j old) i new
665 mkLLNodeUFM (getCommonNodeUFMData
670 | j _EQ_ i = mkLeafUFM j (f old new)
672 mkLLNodeUFM (getCommonNodeUFMData
678 insert_ele f n@(NodeUFM j p t1 t2) i a
680 = if (i _GE_ (j _SUB_ p))
681 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
682 else mkLLNodeUFM (getCommonNodeUFMData
688 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
689 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
690 else mkLLNodeUFM (getCommonNodeUFMData
697 This has got a left to right ordering.
700 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
701 fold_tree f a (LeafUFM _ obj) = f obj a
703 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
707 map_tree f (NodeUFM j p t1 t2)
708 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
709 map_tree f (LeafUFM i obj)
710 = mkLeafUFM i (f obj)
712 map_tree f _ = panic "map_tree failed"
716 filter_tree f nd@(NodeUFM j p t1 t2)
717 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
719 filter_tree f lf@(LeafUFM i obj)
721 | otherwise = EmptyUFM
724 %************************************************************************
726 \subsubsection{The @UniqFM@ type, and signatures for the functions}
728 %************************************************************************
732 This is the information that is held inside a NodeUFM, packaged up for
737 = NodeUFMData FAST_INT
741 This is the information used when computing new NodeUFMs.
744 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
746 = LeftRoot Side -- which side is the right down ?
747 | RightRoot Side -- which side is the left down ?
748 | SameRoot -- they are the same !
749 | NewRoot NodeUFMData -- here's the new, common, root
750 Bool -- do you need to swap left and right ?
753 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
756 indexToRoot :: FAST_INT -> NodeUFMData
760 l = (ILIT(1) :: FAST_INT)
762 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
764 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
766 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
767 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
768 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
769 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
771 l = (ILIT(1) :: FAST_INT)
772 j = i _QUOT_ (p `shiftL_` l)
773 j2 = i2 _QUOT_ (p2 `shiftL_` l)
775 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
777 getCommonNodeUFMData_ p j j_
779 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
781 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
783 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
785 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
786 | j _EQ_ j2 = SameRoot
788 = case getCommonNodeUFMData x y of
789 nd@(NodeUFMData j3 p3)
790 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
791 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
792 | otherwise -> NewRoot nd (j _GT_ j2)
794 decideSide :: Bool -> Side
795 decideSide True = Leftt
796 decideSide False = Rightt
799 This might be better in Util.lhs ?
802 Now the bit twiddling functions.
804 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
805 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
807 #if __GLASGOW_HASKELL__
808 {-# INLINE shiftL_ #-}
809 {-# INLINE shiftR_ #-}
810 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
811 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
813 shiftr x y = shiftRA# x y
816 shiftL_ n p = n * (2 ^ p)
817 shiftR_ n p = n `quot` (2 ^ p)
822 Andy's extras: ToDo: to Util.
825 use_fst :: a -> b -> a
828 use_snd :: a -> b -> b