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,
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
107 sizeUFM :: UniqFM elt -> Int
108 hashUFM :: UniqFM elt -> Int
109 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
111 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
112 lookupUFM_Directly -- when you've got the Unique already
113 :: UniqFM elt -> Unique -> Maybe elt
115 :: Uniquable key => UniqFM elt -> elt -> key -> elt
116 lookupWithDefaultUFM_Directly
117 :: UniqFM elt -> elt -> Unique -> elt
119 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
120 eltsUFM :: UniqFM elt -> [elt]
121 ufmToList :: UniqFM elt -> [(Unique, elt)]
124 %************************************************************************
126 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
128 %************************************************************************
131 -- Turn off for now, these need to be updated (SDM 4/98)
134 #ifdef __GLASGOW_HASKELL__
135 -- I don't think HBC was too happy about this (WDP 94/10)
138 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
141 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
144 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
147 listToUFM :: [(Unique, elt)] -> UniqFM elt
150 lookupUFM :: UniqFM elt -> Name -> Maybe elt
151 , UniqFM elt -> Unique -> Maybe elt
154 #endif /* __GLASGOW_HASKELL__ */
158 %************************************************************************
160 \subsection{Andy Gill's underlying @UniqFM@ machinery}
162 %************************************************************************
164 ``Uniq Finite maps'' are the heart and soul of the compiler's
165 lookup-tables/environments. Important stuff! It works well with
166 Dense and Sparse ranges.
167 Both @Uq@ Finite maps and @Hash@ Finite Maps
168 are built ontop of Int Finite Maps.
170 This code is explained in the paper:
172 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
173 "A Cheap balancing act that grows on a tree"
174 Glasgow FP Workshop, Sep 1994, pp??-??
177 %************************************************************************
179 \subsubsection{The @UniqFM@ type, and signatures for the functions}
181 %************************************************************************
183 @UniqFM a@ is a mapping from Unique to a.
185 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
190 | LeafUFM FastInt ele
191 | NodeUFM FastInt -- the switching
197 -- for debugging only :-)
198 instance Outputable (UniqFM a) where
199 ppr(NodeUFM a b t1 t2) =
200 sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
201 nest 1 (parens (ppr t1)),
202 nest 1 (parens (ppr t2))]
203 ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
204 ppr (EmptyUFM) = empty
206 -- and when not debugging the package itself...
207 instance Outputable a => Outputable (UniqFM a) where
208 ppr ufm = ppr (ufmToList ufm)
211 %************************************************************************
213 \subsubsection{The @UniqFM@ functions}
215 %************************************************************************
217 First the ways of building a UniqFM.
221 unitUFM key elt = mkLeafUFM (getKey# (getUnique key)) elt
222 unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
224 listToUFM key_elt_pairs
225 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
227 listToUFM_Directly uniq_elt_pairs
228 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
231 Now ways of adding things to UniqFMs.
233 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
234 but the semantics of this operation demands a linear insertion;
235 perhaps the version without the combinator function
236 could be optimised using it.
239 addToUFM fm key elt = addToUFM_C use_snd fm key elt
241 addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
243 addToUFM_C combiner fm key elt
244 = insert_ele combiner fm (getKey# (getUnique key)) elt
246 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
247 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
249 addListToUFM_C combiner fm key_elt_pairs
250 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
253 addListToUFM_directly_C combiner fm uniq_elt_pairs
254 = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
258 Now ways of removing things from UniqFM.
261 delListFromUFM fm lst = foldl delFromUFM fm lst
263 delFromUFM fm key = delete fm (getKey# (getUnique key))
264 delFromUFM_Directly fm u = delete fm (getKey# u)
266 delete EmptyUFM _ = EmptyUFM
267 delete fm key = del_ele fm
269 del_ele :: UniqFM a -> UniqFM a
271 del_ele lf@(LeafUFM j _)
272 | j ==# key = EmptyUFM
273 | otherwise = lf -- no delete!
275 del_ele nd@(NodeUFM j p t1 t2)
277 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
279 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
281 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
284 Now ways of adding two UniqFM's together.
287 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
289 plusUFM_C f EmptyUFM tr = tr
290 plusUFM_C f tr EmptyUFM = tr
291 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
293 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
294 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
296 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
298 (ask_about_common_ancestor
302 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
306 -- t1 t2 t1' t2' j j'
311 mix_branches (NewRoot nd False)
312 = mkLLNodeUFM nd left_t right_t
313 mix_branches (NewRoot nd True)
314 = mkLLNodeUFM nd right_t left_t
320 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
322 mix_branches (SameRoot)
323 = mkSSNodeUFM (NodeUFMData j p)
326 -- Now the 4 different other ways; all like this:
328 -- Given j >^ j' (and, say, j > j')
332 -- t1 t2 t1' t2' t1 t2 + j'
335 mix_branches (LeftRoot Leftt) -- | trace "LL" True
338 (mix_trees t1 right_t)
341 mix_branches (LeftRoot Rightt) -- | trace "LR" True
345 (mix_trees t2 right_t)
347 mix_branches (RightRoot Leftt) -- | trace "RL" True
350 (mix_trees left_t t1')
353 mix_branches (RightRoot Rightt) -- | trace "RR" True
357 (mix_trees left_t t2')
359 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
362 And ways of subtracting them. First the base cases,
363 then the full D&C approach.
366 minusUFM EmptyUFM _ = EmptyUFM
367 minusUFM t1 EmptyUFM = t1
368 minusUFM fm1 fm2 = minus_trees fm1 fm2
371 -- Notice the asymetry of subtraction
373 minus_trees lf@(LeafUFM i a) t2 =
378 minus_trees t1 (LeafUFM i _) = delete t1 i
380 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
382 (ask_about_common_ancestor
386 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
390 -- t1 t2 t1' t2' t1 t2
395 minus_branches (NewRoot nd _) = left_t
401 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
403 minus_branches (SameRoot)
404 = mkSSNodeUFM (NodeUFMData j p)
407 -- Now the 4 different other ways; all like this:
408 -- again, with asymatry
411 -- The left is above the right
413 minus_branches (LeftRoot Leftt)
416 (minus_trees t1 right_t)
418 minus_branches (LeftRoot Rightt)
422 (minus_trees t2 right_t)
425 -- The right is above the left
427 minus_branches (RightRoot Leftt)
428 = minus_trees left_t t1'
429 minus_branches (RightRoot Rightt)
430 = minus_trees left_t t2'
432 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
435 And taking the intersection of two UniqFM's.
438 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
440 intersectUFM_C f EmptyUFM _ = EmptyUFM
441 intersectUFM_C f _ EmptyUFM = EmptyUFM
442 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
444 intersect_trees (LeafUFM i a) t2 =
447 Just b -> mkLeafUFM i (f a b)
449 intersect_trees t1 (LeafUFM i a) =
452 Just b -> mkLeafUFM i (f b a)
454 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
456 (ask_about_common_ancestor
460 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
463 -- / \ + / \ ==> EmptyUFM
468 intersect_branches (NewRoot nd _) = EmptyUFM
474 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
476 intersect_branches (SameRoot)
477 = mkSSNodeUFM (NodeUFMData j p)
478 (intersect_trees t1 t1')
479 (intersect_trees t2 t2')
480 -- Now the 4 different other ways; all like this:
482 -- Given j >^ j' (and, say, j > j')
486 -- t1 t2 t1' t2' t1' t2'
488 -- This does cut down the search space quite a bit.
490 intersect_branches (LeftRoot Leftt)
491 = intersect_trees t1 right_t
492 intersect_branches (LeftRoot Rightt)
493 = intersect_trees t2 right_t
494 intersect_branches (RightRoot Leftt)
495 = intersect_trees left_t t1'
496 intersect_branches (RightRoot Rightt)
497 = intersect_trees left_t t2'
499 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
502 Now the usual set of `collection' operators, like map, fold, etc.
505 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
506 foldUFM f a (LeafUFM _ obj) = f obj a
507 foldUFM f a EmptyUFM = a
511 mapUFM fn EmptyUFM = EmptyUFM
512 mapUFM fn fm = map_tree fn fm
514 filterUFM fn EmptyUFM = EmptyUFM
515 filterUFM fn fm = filter_tree fn fm
518 Note, this takes a long time, O(n), but
519 because we dont want to do this very often, we put up with this.
520 O'rable, but how often do we look at the size of
525 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
526 sizeUFM (LeafUFM _ _) = 1
528 isNullUFM EmptyUFM = True
531 -- hashing is used in VarSet.uniqAway, and should be fast
532 -- We use a cheap and cheerful method for now
534 hashUFM (NodeUFM n _ _ _) = iBox n
535 hashUFM (LeafUFM n _) = iBox n
538 looking up in a hurry is the {\em whole point} of this binary tree lark.
539 Lookup up a binary tree is easy (and fast).
542 elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
546 lookupUFM fm key = lookUp fm (getKey# (getUnique key))
547 lookupUFM_Directly fm key = lookUp fm (getKey# key)
549 lookupWithDefaultUFM fm deflt key
550 = case lookUp fm (getKey# (getUnique key)) of
554 lookupWithDefaultUFM_Directly fm deflt key
555 = case lookUp fm (getKey# 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 ># i = lookup_tree t1
569 | otherwise = lookup_tree t2
571 lookup_tree EmptyUFM = panic "lookup Failed"
574 folds are *wonderful* things.
577 eltsUFM fm = foldUFM (:) [] fm
579 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
581 keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
583 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
584 fold_tree f a (LeafUFM iu obj) = f iu obj a
585 fold_tree f a EmptyUFM = a
588 %************************************************************************
590 \subsubsection{The @UniqFM@ type, and its functions}
592 %************************************************************************
594 You should always use these to build the tree.
595 There are 4 versions of mkNodeUFM, depending on
596 the strictness of the two sub-tree arguments.
597 The strictness is used *both* to prune out
598 empty trees, *and* to improve performance,
599 stoping needless thunks lying around.
600 The rule of thumb (from experence with these trees)
601 is make thunks strict, but data structures lazy.
602 If in doubt, use mkSSNodeUFM, which has the `strongest'
603 functionality, but may do a few needless evaluations.
606 mkLeafUFM :: FastInt -> a -> UniqFM a
607 mkLeafUFM i a = LeafUFM i a
609 -- The *ONLY* ways of building a NodeUFM.
611 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
612 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
613 mkSSNodeUFM (NodeUFMData j p) t1 t2
614 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
617 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
618 mkSLNodeUFM (NodeUFMData j p) t1 t2
619 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
622 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
623 mkLSNodeUFM (NodeUFMData j p) t1 t2
624 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
627 mkLLNodeUFM (NodeUFMData j p) t1 t2
628 = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
638 correctNodeUFM j p t1 t2
639 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
641 correct low high _ (LeafUFM i _)
642 = low <= iBox i && iBox i <= high
643 correct low high above_p (NodeUFM j p _ _)
644 = low <= iBox j && iBox j <= high && above_p > iBox p
645 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
648 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
649 and if necessary do $\lambda$ lifting on our functions that are bound.
659 insert_ele f EmptyUFM i new = mkLeafUFM i new
661 insert_ele f (LeafUFM j old) i new
663 mkLLNodeUFM (getCommonNodeUFMData
668 | j ==# i = mkLeafUFM j (f old new)
670 mkLLNodeUFM (getCommonNodeUFMData
676 insert_ele f n@(NodeUFM j p t1 t2) i a
678 = if (i >=# (j -# p))
679 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
680 else mkLLNodeUFM (getCommonNodeUFMData
686 = if (i <=# ((j -# _ILIT(1)) +# p))
687 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
688 else mkLLNodeUFM (getCommonNodeUFMData
698 map_tree f (NodeUFM j p t1 t2)
699 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
700 map_tree f (LeafUFM i obj)
701 = mkLeafUFM i (f obj)
703 map_tree f _ = panic "map_tree failed"
707 filter_tree f nd@(NodeUFM j p t1 t2)
708 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
710 filter_tree f lf@(LeafUFM i obj)
712 | otherwise = EmptyUFM
713 filter_tree f _ = panic "filter_tree failed"
716 %************************************************************************
718 \subsubsection{The @UniqFM@ type, and signatures for the functions}
720 %************************************************************************
724 This is the information that is held inside a NodeUFM, packaged up for
729 = NodeUFMData FastInt
733 This is the information used when computing new NodeUFMs.
736 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
738 = LeftRoot Side -- which side is the right down ?
739 | RightRoot Side -- which side is the left down ?
740 | SameRoot -- they are the same !
741 | NewRoot NodeUFMData -- here's the new, common, root
742 Bool -- do you need to swap left and right ?
745 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
748 indexToRoot :: FastInt -> NodeUFMData
752 l = (_ILIT(1) :: FastInt)
754 NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
756 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
758 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
759 | p ==# p2 = getCommonNodeUFMData_ p j j2
760 | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
761 | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
763 l = (_ILIT(1) :: FastInt)
764 j = i `quotFastInt` (p `shiftL_` l)
765 j2 = i2 `quotFastInt` (p2 `shiftL_` l)
767 getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
769 getCommonNodeUFMData_ p j j_
771 = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
773 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
775 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
777 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
778 | j ==# j2 = SameRoot
780 = case getCommonNodeUFMData x y of
781 nd@(NodeUFMData j3 p3)
782 | j3 ==# j -> LeftRoot (decideSide (j ># j2))
783 | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
784 | otherwise -> NewRoot nd (j ># j2)
786 decideSide :: Bool -> Side
787 decideSide True = Leftt
788 decideSide False = Rightt
791 This might be better in Util.lhs ?
794 Now the bit twiddling functions.
796 shiftL_ :: FastInt -> FastInt -> FastInt
797 shiftR_ :: FastInt -> FastInt -> FastInt
799 #if __GLASGOW_HASKELL__
800 {-# INLINE shiftL_ #-}
801 {-# INLINE shiftR_ #-}
802 #if __GLASGOW_HASKELL__ >= 503
803 shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
805 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
807 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
809 #if __GLASGOW_HASKELL__ >= 503
810 shiftr x y = uncheckedShiftRL# x y
812 shiftr x y = shiftRL# x y
816 shiftL_ n p = n * (2 ^ p)
817 shiftR_ n p = n `quot` (2 ^ p)
823 use_snd :: a -> b -> b