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@.)
15 UniqFM, -- abstract type
23 addListToUFM,addListToUFM_C,
25 addListToUFM_Directly,
40 lookupUFM, lookupUFM_Directly,
41 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 (@uniqueOf@-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 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
115 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
116 lookupUFM_Directly -- when you've got the Unique already
117 :: UniqFM elt -> Unique -> Maybe elt
119 :: Uniquable key => UniqFM elt -> elt -> key -> elt
120 lookupWithDefaultUFM_Directly
121 :: UniqFM elt -> elt -> Unique -> elt
123 keysUFM :: UniqFM elt -> [Int] -- Get the keys
124 eltsUFM :: UniqFM elt -> [elt]
125 ufmToList :: UniqFM elt -> [(Unique, elt)]
128 %************************************************************************
130 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
132 %************************************************************************
135 -- Turn off for now, these need to be updated (SDM 4/98)
138 #ifdef __GLASGOW_HASKELL__
139 -- I don't think HBC was too happy about this (WDP 94/10)
142 addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
145 addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
148 addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
151 listToUFM :: [(Unique, elt)] -> UniqFM elt
154 lookupUFM :: UniqFM elt -> Name -> Maybe elt
155 , UniqFM elt -> Unique -> Maybe elt
158 #endif {- __GLASGOW_HASKELL__ -}
162 %************************************************************************
164 \subsection{Andy Gill's underlying @UniqFM@ machinery}
166 %************************************************************************
168 ``Uniq Finite maps'' are the heart and soul of the compiler's
169 lookup-tables/environments. Important stuff! It works well with
170 Dense and Sparse ranges.
171 Both @Uq@ Finite maps and @Hash@ Finite Maps
172 are built ontop of Int Finite Maps.
174 This code is explained in the paper:
176 A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
177 "A Cheap balancing act that grows on a tree"
178 Glasgow FP Workshop, Sep 1994, pp??-??
181 %************************************************************************
183 \subsubsection{The @UniqFM@ type, and signatures for the functions}
185 %************************************************************************
187 @UniqFM a@ is a mapping from Unique to a.
189 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
194 | LeafUFM FAST_INT ele
195 | NodeUFM FAST_INT -- the switching
196 FAST_INT -- the delta
200 -- for debugging only :-)
202 instance Text (UniqFM a) where
203 showsPrec _ (NodeUFM a b t1 t2) =
204 showString "NodeUFM " . shows (IBOX(a))
205 . showString " " . shows (IBOX(b))
206 . showString " (" . shows t1
207 . showString ") (" . shows t2
209 showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
210 showsPrec _ (EmptyUFM) = id
214 %************************************************************************
216 \subsubsection{The @UniqFM@ functions}
218 %************************************************************************
220 First the ways of building a UniqFM.
224 unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
225 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
227 listToUFM key_elt_pairs
228 = addListToUFM_C use_snd EmptyUFM key_elt_pairs
230 listToUFM_Directly uniq_elt_pairs
231 = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
234 Now ways of adding things to UniqFMs.
236 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
237 but the semantics of this operation demands a linear insertion;
238 perhaps the version without the combinator function
239 could be optimised using it.
242 addToUFM fm key elt = addToUFM_C use_snd fm key elt
244 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
246 addToUFM_C combiner fm key elt
247 = insert_ele combiner fm (u2i (uniqueOf key)) elt
249 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
250 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
252 addListToUFM_C combiner fm key_elt_pairs
253 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
256 addListToUFM_directly_C combiner fm uniq_elt_pairs
257 = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e)
261 Now ways of removing things from UniqFM.
264 delListFromUFM fm lst = foldl delFromUFM fm lst
266 delFromUFM fm key = delete fm (u2i (uniqueOf key))
267 delFromUFM_Directly fm u = delete fm (u2i u)
269 delete EmptyUFM _ = EmptyUFM
270 delete fm key = del_ele fm
272 del_ele :: UniqFM a -> UniqFM a
274 del_ele lf@(LeafUFM j _)
275 | j _EQ_ key = EmptyUFM
276 | otherwise = lf -- no delete!
278 del_ele nd@(NodeUFM j p t1 t2)
280 = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
282 = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
284 del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
287 Now ways of adding two UniqFM's together.
290 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
292 plusUFM_C f EmptyUFM tr = tr
293 plusUFM_C f tr EmptyUFM = tr
294 plusUFM_C f fm1 fm2 = mix_trees fm1 fm2
296 mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
297 mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a
299 mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
301 (ask_about_common_ancestor
305 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
309 -- t1 t2 t1' t2' j j'
314 mix_branches (NewRoot nd False)
315 = mkLLNodeUFM nd left_t right_t
316 mix_branches (NewRoot nd True)
317 = mkLLNodeUFM nd right_t left_t
323 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
325 mix_branches (SameRoot)
326 = mkSSNodeUFM (NodeUFMData j p)
329 -- Now the 4 different other ways; all like this:
331 -- Given j >^ j' (and, say, j > j')
335 -- t1 t2 t1' t2' t1 t2 + j'
338 mix_branches (LeftRoot Leftt) -- | trace "LL" True
341 (mix_trees t1 right_t)
344 mix_branches (LeftRoot Rightt) -- | trace "LR" True
348 (mix_trees t2 right_t)
350 mix_branches (RightRoot Leftt) -- | trace "RL" True
353 (mix_trees left_t t1')
356 mix_branches (RightRoot Rightt) -- | trace "RR" True
360 (mix_trees left_t t2')
362 mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
365 And ways of subtracting them. First the base cases,
366 then the full D&C approach.
369 minusUFM EmptyUFM _ = EmptyUFM
370 minusUFM t1 EmptyUFM = t1
371 minusUFM fm1 fm2 = minus_trees fm1 fm2
374 -- Notice the asymetry of subtraction
376 minus_trees lf@(LeafUFM i a) t2 =
381 minus_trees t1 (LeafUFM i _) = delete t1 i
383 minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
385 (ask_about_common_ancestor
389 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
393 -- t1 t2 t1' t2' t1 t2
398 minus_branches (NewRoot nd _) = left_t
404 -- t1 t2 t1' t2' t1 + t1' t2 + t2'
406 minus_branches (SameRoot)
407 = mkSSNodeUFM (NodeUFMData j p)
410 -- Now the 4 different other ways; all like this:
411 -- again, with asymatry
414 -- The left is above the right
416 minus_branches (LeftRoot Leftt)
419 (minus_trees t1 right_t)
421 minus_branches (LeftRoot Rightt)
425 (minus_trees t2 right_t)
428 -- The right is above the left
430 minus_branches (RightRoot Leftt)
431 = minus_trees left_t t1'
432 minus_branches (RightRoot Rightt)
433 = minus_trees left_t t2'
435 minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
438 And taking the intersection of two UniqFM's.
441 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
443 intersectUFM_C f EmptyUFM _ = EmptyUFM
444 intersectUFM_C f _ EmptyUFM = EmptyUFM
445 intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2
447 intersect_trees (LeafUFM i a) t2 =
450 Just b -> mkLeafUFM i (f a b)
452 intersect_trees t1 (LeafUFM i a) =
455 Just b -> mkLeafUFM i (f b a)
457 intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
459 (ask_about_common_ancestor
463 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
466 -- / \ + / \ ==> EmptyUFM
471 intersect_branches (NewRoot nd _) = EmptyUFM
477 -- t1 t2 t1' t2' t1 x t1' t2 x t2'
479 intersect_branches (SameRoot)
480 = mkSSNodeUFM (NodeUFMData j p)
481 (intersect_trees t1 t1')
482 (intersect_trees t2 t2')
483 -- Now the 4 different other ways; all like this:
485 -- Given j >^ j' (and, say, j > j')
489 -- t1 t2 t1' t2' t1' t2'
491 -- This does cut down the search space quite a bit.
493 intersect_branches (LeftRoot Leftt)
494 = intersect_trees t1 right_t
495 intersect_branches (LeftRoot Rightt)
496 = intersect_trees t2 right_t
497 intersect_branches (RightRoot Leftt)
498 = intersect_trees left_t t1'
499 intersect_branches (RightRoot Rightt)
500 = intersect_trees left_t t2'
502 intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
505 Now the usual set of `collection' operators, like map, fold, etc.
508 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
509 foldUFM f a (LeafUFM _ obj) = f obj a
510 foldUFM f a EmptyUFM = a
514 mapUFM fn EmptyUFM = EmptyUFM
515 mapUFM fn fm = map_tree fn fm
517 filterUFM fn EmptyUFM = EmptyUFM
518 filterUFM fn fm = filter_tree fn fm
521 Note, this takes a long time, O(n), but
522 because we dont want to do this very often, we put up with this.
523 O'rable, but how often do we look at the size of
528 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
529 sizeUFM (LeafUFM _ _) = 1
531 isNullUFM EmptyUFM = True
535 looking up in a hurry is the {\em whole point} of this binary tree lark.
536 Lookup up a binary tree is easy (and fast).
539 elemUFM key fm = case lookUp fm (u2i (uniqueOf key)) of
543 lookupUFM fm key = lookUp fm (u2i (uniqueOf key))
544 lookupUFM_Directly fm key = lookUp fm (u2i key)
546 lookupWithDefaultUFM fm deflt key
547 = case lookUp fm (u2i (uniqueOf key)) of
551 lookupWithDefaultUFM_Directly fm deflt key
552 = case lookUp fm (u2i key) of
556 lookUp EmptyUFM _ = Nothing
557 lookUp fm i = lookup_tree fm
559 lookup_tree :: UniqFM a -> Maybe a
561 lookup_tree (LeafUFM j b)
563 | otherwise = Nothing
564 lookup_tree (NodeUFM j p t1 t2)
565 | j _GT_ i = lookup_tree t1
566 | otherwise = lookup_tree t2
568 lookup_tree EmptyUFM = panic "lookup Failed"
571 folds are *wonderful* things.
574 eltsUFM fm = foldUFM (:) [] fm
576 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
578 keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm
580 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
581 fold_tree f a (LeafUFM iu obj) = f iu obj a
582 fold_tree f a EmptyUFM = a
585 %************************************************************************
587 \subsubsection{The @UniqFM@ type, and its functions}
589 %************************************************************************
591 You should always use these to build the tree.
592 There are 4 versions of mkNodeUFM, depending on
593 the strictness of the two sub-tree arguments.
594 The strictness is used *both* to prune out
595 empty trees, *and* to improve performance,
596 stoping needless thunks lying around.
597 The rule of thumb (from experence with these trees)
598 is make thunks strict, but data structures lazy.
599 If in doubt, use mkSSNodeUFM, which has the `strongest'
600 functionality, but may do a few needless evaluations.
603 mkLeafUFM :: FAST_INT -> a -> UniqFM a
604 mkLeafUFM i a = LeafUFM i a
606 -- The *ONLY* ways of building a NodeUFM.
608 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
609 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
610 mkSSNodeUFM (NodeUFMData j p) t1 t2
611 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
614 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
615 mkSLNodeUFM (NodeUFMData j p) t1 t2
616 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
619 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
620 mkLSNodeUFM (NodeUFMData j p) t1 t2
621 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
624 mkLLNodeUFM (NodeUFMData j p) t1 t2
625 = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
635 correctNodeUFM j p t1 t2
636 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
638 correct low high _ (LeafUFM i _)
639 = low <= IBOX(i) && IBOX(i) <= high
640 correct low high above_p (NodeUFM j p _ _)
641 = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
642 correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
645 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
646 and if necessary do $\lambda$ lifting on our functions that are bound.
656 insert_ele f EmptyUFM i new = mkLeafUFM i new
658 insert_ele f (LeafUFM j old) i new
660 mkLLNodeUFM (getCommonNodeUFMData
665 | j _EQ_ i = mkLeafUFM j (f old new)
667 mkLLNodeUFM (getCommonNodeUFMData
673 insert_ele f n@(NodeUFM j p t1 t2) i a
675 = if (i _GE_ (j _SUB_ p))
676 then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
677 else mkLLNodeUFM (getCommonNodeUFMData
683 = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
684 then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
685 else mkLLNodeUFM (getCommonNodeUFMData
695 map_tree f (NodeUFM j p t1 t2)
696 = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
697 map_tree f (LeafUFM i obj)
698 = mkLeafUFM i (f obj)
700 map_tree f _ = panic "map_tree failed"
704 filter_tree f nd@(NodeUFM j p t1 t2)
705 = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
707 filter_tree f lf@(LeafUFM i obj)
709 | otherwise = EmptyUFM
710 filter_tree f _ = panic "filter_tree failed"
713 %************************************************************************
715 \subsubsection{The @UniqFM@ type, and signatures for the functions}
717 %************************************************************************
721 This is the information that is held inside a NodeUFM, packaged up for
726 = NodeUFMData FAST_INT
730 This is the information used when computing new NodeUFMs.
733 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
735 = LeftRoot Side -- which side is the right down ?
736 | RightRoot Side -- which side is the left down ?
737 | SameRoot -- they are the same !
738 | NewRoot NodeUFMData -- here's the new, common, root
739 Bool -- do you need to swap left and right ?
742 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
745 indexToRoot :: FAST_INT -> NodeUFMData
749 l = (ILIT(1) :: FAST_INT)
751 NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
753 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
755 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
756 | p _EQ_ p2 = getCommonNodeUFMData_ p j j2
757 | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
758 | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
760 l = (ILIT(1) :: FAST_INT)
761 j = i _QUOT_ (p `shiftL_` l)
762 j2 = i2 _QUOT_ (p2 `shiftL_` l)
764 getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
766 getCommonNodeUFMData_ p j j_
768 = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
770 = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l)
772 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
774 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
775 | j _EQ_ j2 = SameRoot
777 = case getCommonNodeUFMData x y of
778 nd@(NodeUFMData j3 p3)
779 | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2))
780 | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
781 | otherwise -> NewRoot nd (j _GT_ j2)
783 decideSide :: Bool -> Side
784 decideSide True = Leftt
785 decideSide False = Rightt
788 This might be better in Util.lhs ?
791 Now the bit twiddling functions.
793 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
794 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
796 #if __GLASGOW_HASKELL__
797 {-# INLINE shiftL_ #-}
798 {-# INLINE shiftR_ #-}
799 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
800 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
802 shiftr x y = shiftRL# x y
805 shiftL_ n p = n * (2 ^ p)
806 shiftR_ n p = n `quot` (2 ^ p)
812 use_snd :: a -> b -> b