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 {-# SOURCE #-} Name ( Name )
51 import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
53 import GlaExts -- Lots of Int# operations
55 #if ! OMIT_NATIVE_CODEGEN
58 #define IF_NCG(a) {--}
62 %************************************************************************
64 \subsection{The @UniqFM@ type, and signatures for the functions}
66 %************************************************************************
68 We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
71 emptyUFM :: UniqFM elt
72 isNullUFM :: UniqFM elt -> Bool
73 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
74 unitDirectlyUFM -- got the Unique already
75 :: Unique -> elt -> UniqFM elt
76 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
78 :: [(Unique, elt)] -> UniqFM elt
80 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
81 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
83 :: UniqFM elt -> Unique -> elt -> UniqFM elt
85 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
88 -> UniqFM elt -- result
90 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
91 -> UniqFM elt -> [(key,elt)]
94 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
95 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
96 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
98 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
100 plusUFM_C :: (elt -> elt -> elt)
101 -> UniqFM elt -> UniqFM elt -> UniqFM elt
103 minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
105 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
106 intersectUFM_C :: (elt -> elt -> elt)
107 -> UniqFM elt -> UniqFM elt -> UniqFM elt
108 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
109 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
110 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
112 sizeUFM :: UniqFM elt -> Int
113 hashUFM :: UniqFM elt -> Int
114 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
116 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
117 lookupUFM_Directly -- when you've got the Unique already
118 :: UniqFM elt -> Unique -> Maybe elt
120 :: Uniquable key => UniqFM elt -> elt -> key -> elt
121 lookupWithDefaultUFM_Directly
122 :: UniqFM elt -> elt -> Unique -> elt
124 keysUFM :: UniqFM elt -> [Int] -- Get the keys
125 eltsUFM :: UniqFM elt -> [elt]
126 ufmToList :: UniqFM elt -> [(Unique, elt)]
129 %************************************************************************
131 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
133 %************************************************************************
136 -- Turn off for now, these need to be updated (SDM 4/98)
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
146 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
149 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
152 listToUFM :: [(Unique, elt)] -> UniqFM elt
155 lookupUFM :: UniqFM elt -> Name -> Maybe elt
156 , UniqFM elt -> Unique -> Maybe elt
159 #endif {- __GLASGOW_HASKELL__ -}
163 %************************************************************************
165 \subsection{Andy Gill's underlying @UniqFM@ machinery}
167 %************************************************************************
169 ``Uniq Finite maps'' are the heart and soul of the compiler's
170 lookup-tables/environments. Important stuff! It works well with
171 Dense and Sparse ranges.
172 Both @Uq@ Finite maps and @Hash@ Finite Maps
173 are built ontop of Int Finite Maps.
175 This code is explained in the paper:
177 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
178 "A Cheap balancing act that grows on a tree"
179 Glasgow FP Workshop, Sep 1994, pp??-??
182 %************************************************************************
184 \subsubsection{The @UniqFM@ type, and signatures for the functions}
186 %************************************************************************
188 @UniqFM a@ is a mapping from Unique to a.
190 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
195 | LeafUFM FAST_INT ele
196 | NodeUFM FAST_INT -- the switching
197 FAST_INT -- the delta
201 -- for debugging only :-)
203 instance Text (UniqFM a) where
204 showsPrec _ (NodeUFM a b t1 t2) =
205 showString "NodeUFM " . shows (IBOX(a))
206 . showString " " . shows (IBOX(b))
207 . showString " (" . shows t1
208 . showString ") (" . shows t2
210 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
211 showsPrec _ (EmptyUFM) = id
215 %************************************************************************
217 \subsubsection{The @UniqFM@ functions}
219 %************************************************************************
221 First the ways of building a UniqFM.
225 unitUFM key elt = mkLeafUFM (u2i (getUnique key)) elt
226 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
228 listToUFM key_elt_pairs
229 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
231 listToUFM_Directly uniq_elt_pairs
232 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
235 Now ways of adding things to UniqFMs.
237 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
238 but the semantics of this operation demands a linear insertion;
239 perhaps the version without the combinator function
240 could be optimised using it.
243 addToUFM fm key elt = addToUFM_C use_snd fm key elt
245 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
247 addToUFM_C combiner fm key elt
248 = insert_ele combiner fm (u2i (getUnique key)) elt
250 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
251 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
253 addListToUFM_C combiner fm key_elt_pairs
254 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getUnique k)) e)
257 addListToUFM_directly_C combiner fm uniq_elt_pairs
258 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
262 Now ways of removing things from UniqFM.
265 delListFromUFM fm lst = foldl delFromUFM fm lst
267 delFromUFM fm key = delete fm (u2i (getUnique key))
268 delFromUFM_Directly fm u = delete fm (u2i u)
270 delete EmptyUFM _ = EmptyUFM
271 delete fm key = del_ele fm
273 del_ele :: UniqFM a -> UniqFM a
275 del_ele lf@(LeafUFM j _)
276 | j _EQ_ key = EmptyUFM
277 | otherwise = lf -- no delete!
279 del_ele nd@(NodeUFM j p t1 t2)
281 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
283 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
285 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
288 Now ways of adding two UniqFM's together.
291 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
293 plusUFM_C f EmptyUFM tr = tr
294 plusUFM_C f tr EmptyUFM = tr
295 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
297 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
298 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
300 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
302 (ask_about_common_ancestor
306 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
310 -- t1 t2 t1' t2' j j'
315 mix_branches (NewRoot nd False)
316 = mkLLNodeUFM nd left_t right_t
317 mix_branches (NewRoot nd True)
318 = mkLLNodeUFM nd right_t left_t
324 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
326 mix_branches (SameRoot)
327 = mkSSNodeUFM (NodeUFMData j p)
330 -- Now the 4 different other ways; all like this:
332 -- Given j >^ j' (and, say, j > j')
336 -- t1 t2 t1' t2' t1 t2 + j'
339 mix_branches (LeftRoot Leftt) -- | trace "LL" True
342 (mix_trees t1 right_t)
345 mix_branches (LeftRoot Rightt) -- | trace "LR" True
349 (mix_trees t2 right_t)
351 mix_branches (RightRoot Leftt) -- | trace "RL" True
354 (mix_trees left_t t1')
357 mix_branches (RightRoot Rightt) -- | trace "RR" True
361 (mix_trees left_t t2')
363 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
366 And ways of subtracting them. First the base cases,
367 then the full D&C approach.
370 minusUFM EmptyUFM _ = EmptyUFM
371 minusUFM t1 EmptyUFM = t1
372 minusUFM fm1 fm2 = minus_trees fm1 fm2
375 -- Notice the asymetry of subtraction
377 minus_trees lf@(LeafUFM i a) t2 =
382 minus_trees t1 (LeafUFM i _) = delete t1 i
384 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
386 (ask_about_common_ancestor
390 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
394 -- t1 t2 t1' t2' t1 t2
399 minus_branches (NewRoot nd _) = left_t
405 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
407 minus_branches (SameRoot)
408 = mkSSNodeUFM (NodeUFMData j p)
411 -- Now the 4 different other ways; all like this:
412 -- again, with asymatry
415 -- The left is above the right
417 minus_branches (LeftRoot Leftt)
420 (minus_trees t1 right_t)
422 minus_branches (LeftRoot Rightt)
426 (minus_trees t2 right_t)
429 -- The right is above the left
431 minus_branches (RightRoot Leftt)
432 = minus_trees left_t t1'
433 minus_branches (RightRoot Rightt)
434 = minus_trees left_t t2'
436 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
439 And taking the intersection of two UniqFM's.
442 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
444 intersectUFM_C f EmptyUFM _ = EmptyUFM
445 intersectUFM_C f _ EmptyUFM = EmptyUFM
446 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
448 intersect_trees (LeafUFM i a) t2 =
451 Just b -> mkLeafUFM i (f a b)
453 intersect_trees t1 (LeafUFM i a) =
456 Just b -> mkLeafUFM i (f b a)
458 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
460 (ask_about_common_ancestor
464 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
467 -- / \ + / \ ==> EmptyUFM
472 intersect_branches (NewRoot nd _) = EmptyUFM
478 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
480 intersect_branches (SameRoot)
481 = mkSSNodeUFM (NodeUFMData j p)
482 (intersect_trees t1 t1')
483 (intersect_trees t2 t2')
484 -- Now the 4 different other ways; all like this:
486 -- Given j >^ j' (and, say, j > j')
490 -- t1 t2 t1' t2' t1' t2'
492 -- This does cut down the search space quite a bit.
494 intersect_branches (LeftRoot Leftt)
495 = intersect_trees t1 right_t
496 intersect_branches (LeftRoot Rightt)
497 = intersect_trees t2 right_t
498 intersect_branches (RightRoot Leftt)
499 = intersect_trees left_t t1'
500 intersect_branches (RightRoot Rightt)
501 = intersect_trees left_t t2'
503 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
506 Now the usual set of `collection' operators, like map, fold, etc.
509 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
510 foldUFM f a (LeafUFM _ obj) = f obj a
511 foldUFM f a EmptyUFM = a
515 mapUFM fn EmptyUFM = EmptyUFM
516 mapUFM fn fm = map_tree fn fm
518 filterUFM fn EmptyUFM = EmptyUFM
519 filterUFM fn fm = filter_tree fn fm
522 Note, this takes a long time, O(n), but
523 because we dont want to do this very often, we put up with this.
524 O'rable, but how often do we look at the size of
529 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
530 sizeUFM (LeafUFM _ _) = 1
532 isNullUFM EmptyUFM = True
535 -- hashing is used in VarSet.uniqAway, and should be fast
536 -- We use a cheap and cheerful method for now
538 hashUFM (NodeUFM n _ _ _) = IBOX(n)
539 hashUFM (LeafUFM n _) = IBOX(n)
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 elemUFM key fm = case lookUp fm (u2i (getUnique key)) of
550 lookupUFM fm key = lookUp fm (u2i (getUnique key))
551 lookupUFM_Directly fm key = lookUp fm (u2i key)
553 lookupWithDefaultUFM fm deflt key
554 = case lookUp fm (u2i (getUnique key)) of
558 lookupWithDefaultUFM_Directly fm deflt key
559 = case lookUp fm (u2i key) of
563 lookUp EmptyUFM _ = Nothing
564 lookUp fm i = lookup_tree fm
566 lookup_tree :: UniqFM a -> Maybe a
568 lookup_tree (LeafUFM j b)
570 | otherwise = Nothing
571 lookup_tree (NodeUFM j p t1 t2)
572 | j _GT_ i = lookup_tree t1
573 | otherwise = lookup_tree t2
575 lookup_tree EmptyUFM = panic "lookup Failed"
578 folds are *wonderful* things.
581 eltsUFM fm = foldUFM (:) [] fm
583 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
585 keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm
587 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
588 fold_tree f a (LeafUFM iu obj) = f iu obj a
589 fold_tree f a EmptyUFM = a
592 %************************************************************************
594 \subsubsection{The @UniqFM@ type, and its functions}
596 %************************************************************************
598 You should always use these to build the tree.
599 There are 4 versions of mkNodeUFM, depending on
600 the strictness of the two sub-tree arguments.
601 The strictness is used *both* to prune out
602 empty trees, *and* to improve performance,
603 stoping needless thunks lying around.
604 The rule of thumb (from experence with these trees)
605 is make thunks strict, but data structures lazy.
606 If in doubt, use mkSSNodeUFM, which has the `strongest'
607 functionality, but may do a few needless evaluations.
610 mkLeafUFM :: FAST_INT -> a -> UniqFM a
611 mkLeafUFM i a = LeafUFM i a
613 -- The *ONLY* ways of building a NodeUFM.
615 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
616 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
617 mkSSNodeUFM (NodeUFMData j p) t1 t2
618 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
621 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
622 mkSLNodeUFM (NodeUFMData j p) t1 t2
623 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
626 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
627 mkLSNodeUFM (NodeUFMData j p) t1 t2
628 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
631 mkLLNodeUFM (NodeUFMData j p) t1 t2
632 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
642 correctNodeUFM j p t1 t2
643 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
645 correct low high _ (LeafUFM i _)
646 = low <= IBOX(i) && IBOX(i) <= high
647 correct low high above_p (NodeUFM j p _ _)
648 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
649 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
652 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
653 and if necessary do $\lambda$ lifting on our functions that are bound.
663 insert_ele f EmptyUFM i new = mkLeafUFM i new
665 insert_ele f (LeafUFM j old) i new
667 mkLLNodeUFM (getCommonNodeUFMData
672 | j _EQ_ i = mkLeafUFM j (f old new)
674 mkLLNodeUFM (getCommonNodeUFMData
680 insert_ele f n@(NodeUFM j p t1 t2) i a
682 = if (i _GE_ (j _SUB_ p))
683 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
684 else mkLLNodeUFM (getCommonNodeUFMData
690 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
691 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
692 else mkLLNodeUFM (getCommonNodeUFMData
702 map_tree f (NodeUFM j p t1 t2)
703 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
704 map_tree f (LeafUFM i obj)
705 = mkLeafUFM i (f obj)
707 map_tree f _ = panic "map_tree failed"
711 filter_tree f nd@(NodeUFM j p t1 t2)
712 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
714 filter_tree f lf@(LeafUFM i obj)
716 | otherwise = EmptyUFM
717 filter_tree f _ = panic "filter_tree failed"
720 %************************************************************************
722 \subsubsection{The @UniqFM@ type, and signatures for the functions}
724 %************************************************************************
728 This is the information that is held inside a NodeUFM, packaged up for
733 = NodeUFMData FAST_INT
737 This is the information used when computing new NodeUFMs.
740 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
742 = LeftRoot Side -- which side is the right down ?
743 | RightRoot Side -- which side is the left down ?
744 | SameRoot -- they are the same !
745 | NewRoot NodeUFMData -- here's the new, common, root
746 Bool -- do you need to swap left and right ?
749 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
752 indexToRoot :: FAST_INT -> NodeUFMData
756 l = (ILIT(1) :: FAST_INT)
758 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
760 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
762 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
763 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
764 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
765 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
767 l = (ILIT(1) :: FAST_INT)
768 j = i _QUOT_ (p `shiftL_` l)
769 j2 = i2 _QUOT_ (p2 `shiftL_` l)
771 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
773 getCommonNodeUFMData_ p j j_
775 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
777 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
779 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
781 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
782 | j _EQ_ j2 = SameRoot
784 = case getCommonNodeUFMData x y of
785 nd@(NodeUFMData j3 p3)
786 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
787 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
788 | otherwise -> NewRoot nd (j _GT_ j2)
790 decideSide :: Bool -> Side
791 decideSide True = Leftt
792 decideSide False = Rightt
795 This might be better in Util.lhs ?
798 Now the bit twiddling functions.
800 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
801 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
803 #if __GLASGOW_HASKELL__
804 {-# INLINE shiftL_ #-}
805 {-# INLINE shiftR_ #-}
806 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
807 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
809 shiftr x y = shiftRL# x y
812 shiftL_ n p = n * (2 ^ p)
813 shiftR_ n p = n `quot` (2 ^ p)
819 use_snd :: a -> b -> b