2 % (c) The AQUA Project, Glasgow University, 1994-1998
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 @getUnique@ method to grab their @Uniques@.
11 (A similar thing to @UniqSet@, as opposed to @Set@.)
15 UniqFM, -- abstract type
23 addListToUFM,addListToUFM_C,
25 addListToUFM_Directly,
37 filterUFM, filterUFM_Directly,
41 lookupUFM, lookupUFM_Directly,
42 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
47 #include "HsVersions.h"
49 import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
54 import GLAEXTS -- Lots of Int# operations
57 %************************************************************************
59 \subsection{The @UniqFM@ type, and signatures for the functions}
61 %************************************************************************
63 We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
66 emptyUFM :: UniqFM elt
67 isNullUFM :: UniqFM elt -> Bool
68 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
69 unitDirectlyUFM -- got the Unique already
70 :: Unique -> elt -> UniqFM elt
71 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
73 :: [(Unique, elt)] -> UniqFM elt
75 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
76 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
78 :: UniqFM elt -> Unique -> elt -> UniqFM elt
80 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
83 -> UniqFM elt -- result
85 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
86 -> UniqFM elt -> [(key,elt)]
89 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
90 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
91 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
93 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
95 plusUFM_C :: (elt -> elt -> elt)
96 -> UniqFM elt -> UniqFM elt -> UniqFM elt
98 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
100 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
101 intersectUFM_C :: (elt1 -> elt2 -> elt3)
102 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
103 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
104 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
105 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
106 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
108 sizeUFM :: UniqFM elt -> Int
109 hashUFM :: UniqFM elt -> Int
110 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
112 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
113 lookupUFM_Directly -- when you've got the Unique already
114 :: UniqFM elt -> Unique -> Maybe elt
116 :: Uniquable key => UniqFM elt -> elt -> key -> elt
117 lookupWithDefaultUFM_Directly
118 :: UniqFM elt -> elt -> Unique -> elt
120 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
121 eltsUFM :: UniqFM elt -> [elt]
122 ufmToList :: UniqFM elt -> [(Unique, elt)]
125 %************************************************************************
127 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
129 %************************************************************************
132 -- Turn off for now, these need to be updated (SDM 4/98)
135 #ifdef __GLASGOW_HASKELL__
136 -- I don't think HBC was too happy about this (WDP 94/10)
139 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
142 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
145 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
148 listToUFM :: [(Unique, elt)] -> UniqFM elt
151 lookupUFM :: UniqFM elt -> Name -> Maybe elt
152 , UniqFM elt -> Unique -> Maybe elt
155 #endif /* __GLASGOW_HASKELL__ */
159 %************************************************************************
161 \subsection{Andy Gill's underlying @UniqFM@ machinery}
163 %************************************************************************
165 ``Uniq Finite maps'' are the heart and soul of the compiler's
166 lookup-tables/environments. Important stuff! It works well with
167 Dense and Sparse ranges.
168 Both @Uq@ Finite maps and @Hash@ Finite Maps
169 are built ontop of Int Finite Maps.
171 This code is explained in the paper:
173 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
174 "A Cheap balancing act that grows on a tree"
175 Glasgow FP Workshop, Sep 1994, pp??-??
178 %************************************************************************
180 \subsubsection{The @UniqFM@ type, and signatures for the functions}
182 %************************************************************************
184 @UniqFM a@ is a mapping from Unique to a.
186 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
191 | LeafUFM FastInt ele
192 | NodeUFM FastInt -- the switching
196 -- INVARIANT: the children of a NodeUFM are never EmptyUFMs
199 -- for debugging only :-)
200 instance Outputable (UniqFM a) where
201 ppr(NodeUFM a b t1 t2) =
202 sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
203 nest 1 (parens (ppr t1)),
204 nest 1 (parens (ppr t2))]
205 ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
206 ppr (EmptyUFM) = empty
208 -- and when not debugging the package itself...
209 instance Outputable a => Outputable (UniqFM a) where
210 ppr ufm = ppr (ufmToList ufm)
213 %************************************************************************
215 \subsubsection{The @UniqFM@ functions}
217 %************************************************************************
219 First the ways of building a UniqFM.
223 unitUFM key elt = mkLeafUFM (getKey# (getUnique key)) elt
224 unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
226 listToUFM key_elt_pairs
227 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
229 listToUFM_Directly uniq_elt_pairs
230 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
233 Now ways of adding things to UniqFMs.
235 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
236 but the semantics of this operation demands a linear insertion;
237 perhaps the version without the combinator function
238 could be optimised using it.
241 addToUFM fm key elt = addToUFM_C use_snd fm key elt
243 addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
245 addToUFM_C combiner fm key elt
246 = insert_ele combiner fm (getKey# (getUnique key)) elt
248 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
249 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
251 addListToUFM_C combiner fm key_elt_pairs
252 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
255 addListToUFM_directly_C combiner fm uniq_elt_pairs
256 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
260 Now ways of removing things from UniqFM.
263 delListFromUFM fm lst = foldl delFromUFM fm lst
265 delFromUFM fm key = delete fm (getKey# (getUnique key))
266 delFromUFM_Directly fm u = delete fm (getKey# u)
268 delete EmptyUFM _ = EmptyUFM
269 delete fm key = del_ele fm
271 del_ele :: UniqFM a -> UniqFM a
273 del_ele lf@(LeafUFM j _)
274 | j ==# key = EmptyUFM
275 | otherwise = lf -- no delete!
277 del_ele nd@(NodeUFM j p t1 t2)
279 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
281 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
283 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
286 Now ways of adding two UniqFM's together.
289 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
291 plusUFM_C f EmptyUFM tr = tr
292 plusUFM_C f tr EmptyUFM = tr
293 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
295 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
296 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
298 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
300 (ask_about_common_ancestor
304 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
308 -- t1 t2 t1' t2' j j'
313 mix_branches (NewRoot nd False)
314 = mkLLNodeUFM nd left_t right_t
315 mix_branches (NewRoot nd True)
316 = mkLLNodeUFM nd right_t left_t
322 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
324 mix_branches (SameRoot)
325 = mkSSNodeUFM (NodeUFMData j p)
328 -- Now the 4 different other ways; all like this:
330 -- Given j >^ j' (and, say, j > j')
334 -- t1 t2 t1' t2' t1 t2 + j'
337 mix_branches (LeftRoot Leftt) -- | trace "LL" True
340 (mix_trees t1 right_t)
343 mix_branches (LeftRoot Rightt) -- | trace "LR" True
347 (mix_trees t2 right_t)
349 mix_branches (RightRoot Leftt) -- | trace "RL" True
352 (mix_trees left_t t1')
355 mix_branches (RightRoot Rightt) -- | trace "RR" True
359 (mix_trees left_t t2')
361 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
364 And ways of subtracting them. First the base cases,
365 then the full D&C approach.
368 minusUFM EmptyUFM _ = EmptyUFM
369 minusUFM t1 EmptyUFM = t1
370 minusUFM fm1 fm2 = minus_trees fm1 fm2
373 -- Notice the asymetry of subtraction
375 minus_trees lf@(LeafUFM i a) t2 =
380 minus_trees t1 (LeafUFM i _) = delete t1 i
382 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
384 (ask_about_common_ancestor
388 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
392 -- t1 t2 t1' t2' t1 t2
397 minus_branches (NewRoot nd _) = left_t
403 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
405 minus_branches (SameRoot)
406 = mkSSNodeUFM (NodeUFMData j p)
409 -- Now the 4 different other ways; all like this:
410 -- again, with asymatry
413 -- The left is above the right
415 minus_branches (LeftRoot Leftt)
418 (minus_trees t1 right_t)
420 minus_branches (LeftRoot Rightt)
424 (minus_trees t2 right_t)
427 -- The right is above the left
429 minus_branches (RightRoot Leftt)
430 = minus_trees left_t t1'
431 minus_branches (RightRoot Rightt)
432 = minus_trees left_t t2'
434 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
437 And taking the intersection of two UniqFM's.
440 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
442 intersectUFM_C f EmptyUFM _ = EmptyUFM
443 intersectUFM_C f _ EmptyUFM = EmptyUFM
444 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
446 intersect_trees (LeafUFM i a) t2 =
449 Just b -> mkLeafUFM i (f a b)
451 intersect_trees t1 (LeafUFM i a) =
454 Just b -> mkLeafUFM i (f b a)
456 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
458 (ask_about_common_ancestor
462 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
465 -- / \ + / \ ==> EmptyUFM
470 intersect_branches (NewRoot nd _) = EmptyUFM
476 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
478 intersect_branches (SameRoot)
479 = mkSSNodeUFM (NodeUFMData j p)
480 (intersect_trees t1 t1')
481 (intersect_trees t2 t2')
482 -- Now the 4 different other ways; all like this:
484 -- Given j >^ j' (and, say, j > j')
488 -- t1 t2 t1' t2' t1' t2'
490 -- This does cut down the search space quite a bit.
492 intersect_branches (LeftRoot Leftt)
493 = intersect_trees t1 right_t
494 intersect_branches (LeftRoot Rightt)
495 = intersect_trees t2 right_t
496 intersect_branches (RightRoot Leftt)
497 = intersect_trees left_t t1'
498 intersect_branches (RightRoot Rightt)
499 = intersect_trees left_t t2'
501 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
504 Now the usual set of `collection' operators, like map, fold, etc.
507 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
508 foldUFM f a (LeafUFM _ obj) = f obj a
509 foldUFM f a EmptyUFM = a
513 mapUFM fn EmptyUFM = EmptyUFM
514 mapUFM fn fm = map_tree fn fm
516 filterUFM fn EmptyUFM = EmptyUFM
517 filterUFM fn fm = filter_tree pred fm
519 pred (i::FastInt) e = fn e
521 filterUFM_Directly fn EmptyUFM = EmptyUFM
522 filterUFM_Directly fn fm = filter_tree pred fm
524 pred i e = fn (mkUniqueGrimily (iBox i)) e
527 Note, this takes a long time, O(n), but
528 because we dont want to do this very often, we put up with this.
529 O'rable, but how often do we look at the size of
534 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
535 sizeUFM (LeafUFM _ _) = 1
537 isNullUFM EmptyUFM = True
540 -- hashing is used in VarSet.uniqAway, and should be fast
541 -- We use a cheap and cheerful method for now
543 hashUFM (NodeUFM n _ _ _) = iBox n
544 hashUFM (LeafUFM n _) = iBox n
547 looking up in a hurry is the {\em whole point} of this binary tree lark.
548 Lookup up a binary tree is easy (and fast).
551 elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
555 lookupUFM fm key = lookUp fm (getKey# (getUnique key))
556 lookupUFM_Directly fm key = lookUp fm (getKey# key)
558 lookupWithDefaultUFM fm deflt key
559 = case lookUp fm (getKey# (getUnique key)) of
563 lookupWithDefaultUFM_Directly fm deflt key
564 = case lookUp fm (getKey# key) of
568 lookUp EmptyUFM _ = Nothing
569 lookUp fm i = lookup_tree fm
571 lookup_tree :: UniqFM a -> Maybe a
573 lookup_tree (LeafUFM j b)
575 | otherwise = Nothing
576 lookup_tree (NodeUFM j p t1 t2)
577 | j ># i = lookup_tree t1
578 | otherwise = lookup_tree t2
580 lookup_tree EmptyUFM = panic "lookup Failed"
583 folds are *wonderful* things.
586 eltsUFM fm = foldUFM (:) [] fm
588 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
590 keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
592 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
593 fold_tree f a (LeafUFM iu obj) = f iu obj a
594 fold_tree f a EmptyUFM = a
597 %************************************************************************
599 \subsubsection{The @UniqFM@ type, and its functions}
601 %************************************************************************
603 You should always use these to build the tree.
604 There are 4 versions of mkNodeUFM, depending on
605 the strictness of the two sub-tree arguments.
606 The strictness is used *both* to prune out
607 empty trees, *and* to improve performance,
608 stoping needless thunks lying around.
609 The rule of thumb (from experence with these trees)
610 is make thunks strict, but data structures lazy.
611 If in doubt, use mkSSNodeUFM, which has the `strongest'
612 functionality, but may do a few needless evaluations.
615 mkLeafUFM :: FastInt -> a -> UniqFM a
616 mkLeafUFM i a = LeafUFM i a
618 -- The *ONLY* ways of building a NodeUFM.
620 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
621 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
622 mkSSNodeUFM (NodeUFMData j p) t1 t2
623 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
626 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
627 mkSLNodeUFM (NodeUFMData j p) t1 t2
628 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
631 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
632 mkLSNodeUFM (NodeUFMData j p) t1 t2
633 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
636 mkLLNodeUFM (NodeUFMData j p) t1 t2
637 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
647 correctNodeUFM j p t1 t2
648 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
650 correct low high _ (LeafUFM i _)
651 = low <= iBox i && iBox i <= high
652 correct low high above_p (NodeUFM j p _ _)
653 = low <= iBox j && iBox j <= high && above_p > iBox p
654 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
657 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
658 and if necessary do $\lambda$ lifting on our functions that are bound.
668 insert_ele f EmptyUFM i new = mkLeafUFM i new
670 insert_ele f (LeafUFM j old) i new
672 mkLLNodeUFM (getCommonNodeUFMData
677 | j ==# i = mkLeafUFM j (f old new)
679 mkLLNodeUFM (getCommonNodeUFMData
685 insert_ele f n@(NodeUFM j p t1 t2) i a
687 = if (i >=# (j -# p))
688 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
689 else mkLLNodeUFM (getCommonNodeUFMData
695 = if (i <=# ((j -# _ILIT(1)) +# p))
696 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
697 else mkLLNodeUFM (getCommonNodeUFMData
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 :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
717 filter_tree f nd@(NodeUFM j p t1 t2)
718 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
720 filter_tree f lf@(LeafUFM i obj)
722 | otherwise = EmptyUFM
723 filter_tree f _ = panic "filter_tree failed"
726 %************************************************************************
728 \subsubsection{The @UniqFM@ type, and signatures for the functions}
730 %************************************************************************
734 This is the information that is held inside a NodeUFM, packaged up for
739 = NodeUFMData FastInt
743 This is the information used when computing new NodeUFMs.
746 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
748 = LeftRoot Side -- which side is the right down ?
749 | RightRoot Side -- which side is the left down ?
750 | SameRoot -- they are the same !
751 | NewRoot NodeUFMData -- here's the new, common, root
752 Bool -- do you need to swap left and right ?
755 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
758 indexToRoot :: FastInt -> NodeUFMData
762 l = (_ILIT(1) :: FastInt)
764 NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
766 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
768 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
769 | p ==# p2 = getCommonNodeUFMData_ p j j2
770 | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
771 | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
773 l = (_ILIT(1) :: FastInt)
774 j = i `quotFastInt` (p `shiftL_` l)
775 j2 = i2 `quotFastInt` (p2 `shiftL_` l)
777 getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
779 getCommonNodeUFMData_ p j j_
781 = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
783 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
785 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
787 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
788 | j ==# j2 = SameRoot
790 = case getCommonNodeUFMData x y of
791 nd@(NodeUFMData j3 p3)
792 | j3 ==# j -> LeftRoot (decideSide (j ># j2))
793 | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
794 | otherwise -> NewRoot nd (j ># j2)
796 decideSide :: Bool -> Side
797 decideSide True = Leftt
798 decideSide False = Rightt
801 This might be better in Util.lhs ?
804 Now the bit twiddling functions.
806 shiftL_ :: FastInt -> FastInt -> FastInt
807 shiftR_ :: FastInt -> FastInt -> FastInt
809 #if __GLASGOW_HASKELL__
810 {-# INLINE shiftL_ #-}
811 {-# INLINE shiftR_ #-}
812 #if __GLASGOW_HASKELL__ >= 503
813 shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
815 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
817 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
819 #if __GLASGOW_HASKELL__ >= 503
820 shiftr x y = uncheckedShiftRL# x y
822 shiftr x y = shiftRL# x y
826 shiftL_ n p = n * (2 ^ p)
827 shiftR_ n p = n `quot` (2 ^ p)
833 use_snd :: a -> b -> b