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)
57 #if defined(COMPILING_GHC)
58 IMPORT_DELOOPER( SpecLoop )
62 import Unique ( Unique, u2i, mkUniqueGrimily )
65 import Outputable ( Outputable(..) )
66 import PprStyle ( PprStyle )
67 import SrcLoc ( SrcLoc )
69 #if ! OMIT_NATIVE_CODEGEN
72 #define IF_NCG(a) {--}
76 %************************************************************************
78 \subsection{The @UniqFM@ type, and signatures for the functions}
80 %************************************************************************
82 We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
85 emptyUFM :: UniqFM elt
86 isNullUFM :: UniqFM elt -> Bool
87 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
88 unitDirectlyUFM -- got the Unique already
89 :: Unique -> elt -> UniqFM elt
90 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
92 :: [(Unique, elt)] -> UniqFM elt
94 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
95 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
97 :: UniqFM elt -> Unique -> elt -> UniqFM elt
99 addToUFM_C :: Uniquable key => (elt -> elt -> elt)
100 -> UniqFM elt -> key -> elt -> UniqFM elt
101 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
102 -> UniqFM elt -> [(key,elt)]
105 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
106 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
107 delFromUFM_Directly :: UniqFM elt -> Unique -> 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 :: Uniquable key => UniqFM elt -> key -> Maybe elt
126 lookupUFM_Directly -- when you've got the Unique already
127 :: UniqFM elt -> Unique -> Maybe elt
129 :: Uniquable key => UniqFM elt -> elt -> key -> elt
130 lookupWithDefaultUFM_Directly
131 :: UniqFM elt -> elt -> Unique -> elt
133 keysUFM :: UniqFM elt -> [Int] -- Get the keys
134 eltsUFM :: UniqFM elt -> [elt]
135 ufmToList :: UniqFM elt -> [(Unique, elt)]
138 %************************************************************************
140 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
142 %************************************************************************
145 #ifdef __GLASGOW_HASKELL__
146 -- I don't think HBC was too happy about this (WDP 94/10)
149 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
152 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
155 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
158 listToUFM :: [(Unique, elt)] -> UniqFM elt
161 lookupUFM :: UniqFM elt -> Name -> Maybe elt
162 , UniqFM elt -> Unique -> Maybe elt
165 #endif {- __GLASGOW_HASKELL__ -}
168 %************************************************************************
170 \subsection{Andy Gill's underlying @UniqFM@ machinery}
172 %************************************************************************
174 ``Uniq Finite maps'' are the heart and soul of the compiler's
175 lookup-tables/environments. Important stuff! It works well with
176 Dense and Sparse ranges.
177 Both @Uq@ Finite maps and @Hash@ Finite Maps
178 are built ontop of Int Finite Maps.
180 This code is explained in the paper:
182 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
183 "A Cheap balancing act that grows on a tree"
184 Glasgow FP Workshop, Sep 1994, pp??-??
187 %************************************************************************
189 \subsubsection{The @UniqFM@ type, and signatures for the functions}
191 %************************************************************************
193 @UniqFM a@ is a mapping from Unique to a.
195 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
200 | LeafUFM FAST_INT ele
201 | NodeUFM FAST_INT -- the switching
202 FAST_INT -- the delta
206 class Uniquable a where
207 uniqueOf :: a -> Unique
209 -- for debugging only :-)
211 instance Text (UniqFM a) where
212 showsPrec _ (NodeUFM a b t1 t2) =
213 showString "NodeUFM " . shows (IBOX(a))
214 . showString " " . shows (IBOX(b))
215 . showString " (" . shows t1
216 . showString ") (" . shows t2
218 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
219 showsPrec _ (EmptyUFM) = id
223 %************************************************************************
225 \subsubsection{The @UniqFM@ functions}
227 %************************************************************************
229 First the ways of building a UniqFM.
233 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
234 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
236 listToUFM key_elt_pairs
237 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
239 listToUFM_Directly uniq_elt_pairs
240 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
243 Now ways of adding things to UniqFMs.
245 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
246 but the semantics of this operation demands a linear insertion;
247 perhaps the version without the combinator function
248 could be optimised using it.
251 addToUFM fm key elt = addToUFM_C use_snd fm key elt
253 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
255 addToUFM_C combiner fm key elt
256 = insert_ele combiner fm (u2i (uniqueOf key)) elt
258 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
259 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
261 addListToUFM_C combiner fm key_elt_pairs
262 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
265 addListToUFM_directly_C combiner fm uniq_elt_pairs
266 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
270 Now ways of removing things from UniqFM.
273 delListFromUFM fm lst = foldl delFromUFM fm lst
275 delFromUFM fm key = delete fm (u2i (uniqueOf key))
276 delFromUFM_Directly fm u = delete fm (u2i u)
278 delete EmptyUFM _ = EmptyUFM
279 delete fm key = del_ele fm
281 del_ele :: UniqFM a -> UniqFM a
283 del_ele lf@(LeafUFM j _)
284 | j _EQ_ key = EmptyUFM
285 | otherwise = lf -- no delete!
287 del_ele nd@(NodeUFM j p t1 t2)
289 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
291 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
293 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
296 Now ways of adding two UniqFM's together.
299 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
301 plusUFM_C f EmptyUFM tr = tr
302 plusUFM_C f tr EmptyUFM = tr
303 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
305 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
306 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
308 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
310 (ask_about_common_ancestor
314 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
318 -- t1 t2 t1' t2' j j'
323 mix_branches (NewRoot nd False)
324 = mkLLNodeUFM nd left_t right_t
325 mix_branches (NewRoot nd True)
326 = mkLLNodeUFM nd right_t left_t
332 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
334 mix_branches (SameRoot)
335 = mkSSNodeUFM (NodeUFMData j p)
338 -- Now the 4 different other ways; all like this:
340 -- Given j >^ j' (and, say, j > j')
344 -- t1 t2 t1' t2' t1 t2 + j'
347 mix_branches (LeftRoot Leftt) -- | trace "LL" True
350 (mix_trees t1 right_t)
353 mix_branches (LeftRoot Rightt) -- | trace "LR" True
357 (mix_trees t2 right_t)
359 mix_branches (RightRoot Leftt) -- | trace "RL" True
362 (mix_trees left_t t1')
365 mix_branches (RightRoot Rightt) -- | trace "RR" True
369 (mix_trees left_t t2')
371 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
374 And ways of subtracting them. First the base cases,
375 then the full D&C approach.
378 minusUFM EmptyUFM _ = EmptyUFM
379 minusUFM t1 EmptyUFM = t1
380 minusUFM fm1 fm2 = minus_trees fm1 fm2
383 -- Notice the asymetry of subtraction
385 minus_trees lf@(LeafUFM i a) t2 =
390 minus_trees t1 (LeafUFM i _) = delete t1 i
392 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
394 (ask_about_common_ancestor
398 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
402 -- t1 t2 t1' t2' t1 t2
407 minus_branches (NewRoot nd _) = left_t
413 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
415 minus_branches (SameRoot)
416 = mkSSNodeUFM (NodeUFMData j p)
419 -- Now the 4 different other ways; all like this:
420 -- again, with asymatry
423 -- The left is above the right
425 minus_branches (LeftRoot Leftt)
428 (minus_trees t1 right_t)
430 minus_branches (LeftRoot Rightt)
434 (minus_trees t2 right_t)
437 -- The right is above the left
439 minus_branches (RightRoot Leftt)
440 = minus_trees left_t t1'
441 minus_branches (RightRoot Rightt)
442 = minus_trees left_t t2'
444 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
447 And taking the intersection of two UniqFM's.
450 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
452 intersectUFM_C f EmptyUFM _ = EmptyUFM
453 intersectUFM_C f _ EmptyUFM = EmptyUFM
454 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
456 intersect_trees (LeafUFM i a) t2 =
459 Just b -> mkLeafUFM i (f a b)
461 intersect_trees t1 (LeafUFM i a) =
464 Just b -> mkLeafUFM i (f b a)
466 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
468 (ask_about_common_ancestor
472 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
475 -- / \ + / \ ==> EmptyUFM
480 intersect_branches (NewRoot nd _) = EmptyUFM
486 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
488 intersect_branches (SameRoot)
489 = mkSSNodeUFM (NodeUFMData j p)
490 (intersect_trees t1 t1')
491 (intersect_trees t2 t2')
492 -- Now the 4 different other ways; all like this:
494 -- Given j >^ j' (and, say, j > j')
498 -- t1 t2 t1' t2' t1' t2'
500 -- This does cut down the search space quite a bit.
502 intersect_branches (LeftRoot Leftt)
503 = intersect_trees t1 right_t
504 intersect_branches (LeftRoot Rightt)
505 = intersect_trees t2 right_t
506 intersect_branches (RightRoot Leftt)
507 = intersect_trees left_t t1'
508 intersect_branches (RightRoot Rightt)
509 = intersect_trees left_t t2'
511 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
514 Now the usual set of `collection' operators, like map, fold, etc.
517 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
518 foldUFM f a (LeafUFM _ obj) = f obj a
519 foldUFM f a EmptyUFM = a
523 mapUFM fn EmptyUFM = EmptyUFM
524 mapUFM fn fm = map_tree fn fm
526 filterUFM fn EmptyUFM = EmptyUFM
527 filterUFM fn fm = filter_tree fn fm
530 Note, this takes a long time, O(n), but
531 because we dont want to do this very often, we put up with this.
532 O'rable, but how often do we look at the size of
537 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
538 sizeUFM (LeafUFM _ _) = 1
540 isNullUFM EmptyUFM = True
544 looking up in a hurry is the {\em whole point} of this binary tree lark.
545 Lookup up a binary tree is easy (and fast).
548 lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
549 lookupUFM_Directly fm key = lookUp fm (u2i key)
551 lookupWithDefaultUFM fm deflt key
552 = case lookUp fm (u2i (uniqueOf key)) of
556 lookupWithDefaultUFM_Directly fm deflt key
557 = case lookUp fm (u2i key) of
561 lookUp EmptyUFM _ = Nothing
562 lookUp fm i = lookup_tree fm
564 lookup_tree :: UniqFM a -> Maybe a
566 lookup_tree (LeafUFM j b)
568 | otherwise = Nothing
569 lookup_tree (NodeUFM j p t1 t2)
570 | j _GT_ i = lookup_tree t1
571 | otherwise = lookup_tree t2
573 lookup_tree EmptyUFM = panic "lookup Failed"
576 folds are *wonderful* things.
579 eltsUFM fm = foldUFM (:) [] fm
581 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
583 keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm
585 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
586 fold_tree f a (LeafUFM iu obj) = f iu obj a
587 fold_tree f a EmptyUFM = a
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
700 map_tree f (NodeUFM j p t1 t2)
701 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
702 map_tree f (LeafUFM i obj)
703 = mkLeafUFM i (f obj)
705 map_tree f _ = panic "map_tree failed"
709 filter_tree f nd@(NodeUFM j p t1 t2)
710 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
712 filter_tree f lf@(LeafUFM i obj)
714 | otherwise = EmptyUFM
715 filter_tree f _ = panic "filter_tree failed"
718 %************************************************************************
720 \subsubsection{The @UniqFM@ type, and signatures for the functions}
722 %************************************************************************
726 This is the information that is held inside a NodeUFM, packaged up for
731 = NodeUFMData FAST_INT
735 This is the information used when computing new NodeUFMs.
738 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
740 = LeftRoot Side -- which side is the right down ?
741 | RightRoot Side -- which side is the left down ?
742 | SameRoot -- they are the same !
743 | NewRoot NodeUFMData -- here's the new, common, root
744 Bool -- do you need to swap left and right ?
747 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
750 indexToRoot :: FAST_INT -> NodeUFMData
754 l = (ILIT(1) :: FAST_INT)
756 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
758 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
760 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
761 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
762 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
763 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
765 l = (ILIT(1) :: FAST_INT)
766 j = i _QUOT_ (p `shiftL_` l)
767 j2 = i2 _QUOT_ (p2 `shiftL_` l)
769 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
771 getCommonNodeUFMData_ p j j_
773 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
775 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
777 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
779 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
780 | j _EQ_ j2 = SameRoot
782 = case getCommonNodeUFMData x y of
783 nd@(NodeUFMData j3 p3)
784 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
785 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
786 | otherwise -> NewRoot nd (j _GT_ j2)
788 decideSide :: Bool -> Side
789 decideSide True = Leftt
790 decideSide False = Rightt
793 This might be better in Util.lhs ?
796 Now the bit twiddling functions.
798 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
799 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
801 #if __GLASGOW_HASKELL__
802 {-# INLINE shiftL_ #-}
803 {-# INLINE shiftR_ #-}
804 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
805 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
807 shiftr x y = shiftRA# x y
810 shiftL_ n p = n * (2 ^ p)
811 shiftR_ n p = n `quot` (2 ^ p)
817 use_snd :: a -> b -> b