ghc/compiler/utils/UniqFM.lhs

   1 %ilter
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[UniqFM]{Specialised finite maps, for things with @Uniques@}
   5
   6 Based on @FiniteMaps@ (as you would expect).
   7
   8 Basically, the things need to be in class @Uniquable@, and we use the
   9 @getUnique@ method to grab their @Uniques@.
  10
  11 (A similar thing to @UniqSet@, as opposed to @Set@.)
  12
  13 \begin{code}
  14 module UniqFM (
  15         UniqFM,   -- abstract type
  16
  17         emptyUFM,
  18         unitUFM,
  19         unitDirectlyUFM,
  20         listToUFM,
  21         listToUFM_Directly,
  22         addToUFM,addToUFM_C,addToUFM_Acc,
  23         addListToUFM,addListToUFM_C,
  24         addToUFM_Directly,
  25         addListToUFM_Directly,
  26         delFromUFM,
  27         delFromUFM_Directly,
  28         delListFromUFM,
  29         plusUFM,
  30         plusUFM_C,
  31         minusUFM,
  32         intersectUFM,
  33         intersectUFM_C,
  34         foldUFM,
  35         mapUFM,
  36         elemUFM, elemUFM_Directly,
  37         filterUFM, filterUFM_Directly,
  38         sizeUFM,
  39         hashUFM,
  40         isNullUFM,
  41         lookupUFM, lookupUFM_Directly,
  42         lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
  43         eltsUFM, keysUFM,
  44         ufmToList
  45     ) where
  46
  47 #include "HsVersions.h"
  48
  49 import Unique           ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
  50 import Maybes           ( maybeToBool )
  51 import FastTypes
  52 import Outputable
  53
  54 import GLAEXTS          -- Lots of Int# operations
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{The @UniqFM@ type, and signatures for the functions}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 We use @FiniteMaps@, with a (@getUnique@-able) @Unique@ as ``key''.
  64
  65 \begin{code}
  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
  72 listToUFM_Directly
  73                 :: [(Unique, elt)] -> UniqFM elt
  74
  75 addToUFM        :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
  76 addListToUFM    :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
  77 addToUFM_Directly
  78                 :: UniqFM elt -> Unique -> elt -> UniqFM elt
  79
  80 addToUFM_C      :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
  81                            -> UniqFM elt                -- old
  82                            -> key -> elt                -- new
  83                            -> UniqFM elt                -- result
  84
  85 addToUFM_Acc    :: Uniquable key =>
  86                               (elt -> elts -> elts)     -- Add to existing
  87                            -> (elt -> elts)             -- New element
  88                            -> UniqFM elts               -- old
  89                            -> key -> elt                -- new
  90                            -> UniqFM elts               -- result
  91
  92 addListToUFM_C  :: Uniquable key => (elt -> elt -> elt)
  93                            -> UniqFM elt -> [(key,elt)]
  94                            -> UniqFM elt
  95
  96 delFromUFM      :: Uniquable key => UniqFM elt -> key    -> UniqFM elt
  97 delListFromUFM  :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
  98 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
  99
 100 plusUFM         :: UniqFM elt -> UniqFM elt -> UniqFM elt
 101
 102 plusUFM_C       :: (elt -> elt -> elt)
 103                 -> UniqFM elt -> UniqFM elt -> UniqFM elt
 104
 105 minusUFM        :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
 106
 107 intersectUFM    :: UniqFM elt -> UniqFM elt -> UniqFM elt
 108 intersectUFM_C  :: (elt1 -> elt2 -> elt3)
 109                 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
 110 foldUFM         :: (elt -> a -> a) -> a -> UniqFM elt -> a
 111 mapUFM          :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
 112 filterUFM       :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
 113 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
 114
 115 sizeUFM         :: UniqFM elt -> Int
 116 hashUFM         :: UniqFM elt -> Int
 117 elemUFM         :: Uniquable key => key -> UniqFM elt -> Bool
 118 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
 119
 120 lookupUFM       :: Uniquable key => UniqFM elt -> key -> Maybe elt
 121 lookupUFM_Directly  -- when you've got the Unique already
 122                 :: UniqFM elt -> Unique -> Maybe elt
 123 lookupWithDefaultUFM
 124                 :: Uniquable key => UniqFM elt -> elt -> key -> elt
 125 lookupWithDefaultUFM_Directly
 126                 :: UniqFM elt -> elt -> Unique -> elt
 127
 128 keysUFM         :: UniqFM elt -> [Unique]       -- Get the keys
 129 eltsUFM         :: UniqFM elt -> [elt]
 130 ufmToList       :: UniqFM elt -> [(Unique, elt)]
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 \begin{code}
 140 -- Turn off for now, these need to be updated (SDM 4/98)
 141
 142 #if 0
 143 #ifdef __GLASGOW_HASKELL__
 144 -- I don't think HBC was too happy about this (WDP 94/10)
 145
 146 {-# SPECIALIZE
 147     addListToUFM :: UniqFM elt -> [(Name,   elt)] -> UniqFM elt
 148   #-}
 149 {-# SPECIALIZE
 150     addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name,  elt)] -> UniqFM elt
 151   #-}
 152 {-# SPECIALIZE
 153     addToUFM    :: UniqFM elt -> Unique -> elt  -> UniqFM elt
 154   #-}
 155 {-# SPECIALIZE
 156     listToUFM   :: [(Unique, elt)]     -> UniqFM elt
 157   #-}
 158 {-# SPECIALIZE
 159     lookupUFM   :: UniqFM elt -> Name   -> Maybe elt
 160                  , UniqFM elt -> Unique -> Maybe elt
 161   #-}
 162
 163 #endif /* __GLASGOW_HASKELL__ */
 164 #endif
 165 \end{code}
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection{Andy Gill's underlying @UniqFM@ machinery}
 170 %*                                                                      *
 171 %************************************************************************
 172
 173 ``Uniq Finite maps'' are the heart and soul of the compiler's
 174 lookup-tables/environments.  Important stuff!  It works well with
 175 Dense and Sparse ranges.
 176 Both @Uq@ Finite maps and @Hash@ Finite Maps
 177 are built ontop of Int Finite Maps.
 178
 179 This code is explained in the paper:
 180 \begin{display}
 181         A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
 182         "A Cheap balancing act that grows on a tree"
 183         Glasgow FP Workshop, Sep 1994, pp??-??
 184 \end{display}
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsubsection{The @UniqFM@ type, and signatures for the functions}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 @UniqFM a@ is a mapping from Unique to a.
 193
 194 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
 195
 196 \begin{code}
 197 data UniqFM ele
 198   = EmptyUFM
 199   | LeafUFM FastInt ele
 200   | NodeUFM FastInt         -- the switching
 201             FastInt         -- the delta
 202             (UniqFM ele)
 203             (UniqFM ele)
 204 -- INVARIANT: the children of a NodeUFM are never EmptyUFMs
 205
 206 {-
 207 -- for debugging only :-)
 208 instance Outputable (UniqFM a) where
 209         ppr(NodeUFM a b t1 t2) =
 210                 sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
 211                      nest 1 (parens (ppr t1)),
 212                      nest 1 (parens (ppr t2))]
 213         ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
 214         ppr (EmptyUFM)    = empty
 215 -}
 216 -- and when not debugging the package itself...
 217 instance Outputable a => Outputable (UniqFM a) where
 218     ppr ufm = ppr (ufmToList ufm)
 219 \end{code}
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsubsection{The @UniqFM@ functions}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 First the ways of building a UniqFM.
 228
 229 \begin{code}
 230 emptyUFM                     = EmptyUFM
 231 unitUFM      key elt = mkLeafUFM (getKey# (getUnique key)) elt
 232 unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
 233
 234 listToUFM key_elt_pairs
 235   = addListToUFM_C use_snd EmptyUFM key_elt_pairs
 236
 237 listToUFM_Directly uniq_elt_pairs
 238   = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
 239 \end{code}
 240
 241 Now ways of adding things to UniqFMs.
 242
 243 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
 244 but the semantics of this operation demands a linear insertion;
 245 perhaps the version without the combinator function
 246 could be optimised using it.
 247
 248 \begin{code}
 249 addToUFM fm key elt = addToUFM_C use_snd fm key elt
 250
 251 addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
 252
 253 addToUFM_C combiner fm key elt
 254   = insert_ele combiner fm (getKey# (getUnique key)) elt
 255
 256 addToUFM_Acc add unit fm key item
 257   = insert_ele combiner fm (getKey# (getUnique key)) (unit item)
 258   where
 259     combiner old _unit_item = add item old
 260
 261 addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
 262 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
 263
 264 addListToUFM_C combiner fm key_elt_pairs
 265  = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
 266          fm key_elt_pairs
 267
 268 addListToUFM_directly_C combiner fm uniq_elt_pairs
 269  = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
 270          fm uniq_elt_pairs
 271 \end{code}
 272
 273 Now ways of removing things from UniqFM.
 274
 275 \begin{code}
 276 delListFromUFM fm lst = foldl delFromUFM fm lst
 277
 278 delFromUFM          fm key = delete fm (getKey# (getUnique key))
 279 delFromUFM_Directly fm u   = delete fm (getKey# u)
 280
 281 delete EmptyUFM _   = EmptyUFM
 282 delete fm       key = del_ele fm
 283   where
 284     del_ele :: UniqFM a -> UniqFM a
 285
 286     del_ele lf@(LeafUFM j _)
 287       | j ==# key       = EmptyUFM
 288       | otherwise       = lf    -- no delete!
 289
 290     del_ele nd@(NodeUFM j p t1 t2)
 291       | j ># key
 292       = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
 293       | otherwise
 294       = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
 295
 296     del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
 297 \end{code}
 298
 299 Now ways of adding two UniqFM's together.
 300
 301 \begin{code}
 302 plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2
 303
 304 plusUFM_C f EmptyUFM tr = tr
 305 plusUFM_C f tr EmptyUFM = tr
 306 plusUFM_C f fm1 fm2     = mix_trees fm1 fm2
 307     where
 308         mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a
 309         mix_trees t1 (LeafUFM i a) = insert_ele f        t1 i a
 310
 311         mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
 312           = mix_branches
 313                 (ask_about_common_ancestor
 314                         (NodeUFMData j p)
 315                         (NodeUFMData j' p'))
 316           where
 317                 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
 318                 --
 319                 --        j             j'                      (C j j')
 320                 --       / \    +      / \      ==>             /       \
 321                 --     t1   t2      t1'   t2'                  j         j'
 322                 --                                            / \       / \
 323                 --                                           t1  t2   t1'  t2'
 324                 -- Fast, Ehh !
 325                 --
 326           mix_branches (NewRoot nd False)
 327                 = mkLLNodeUFM nd left_t right_t
 328           mix_branches (NewRoot nd True)
 329                 = mkLLNodeUFM nd right_t left_t
 330
 331                 -- Now, if j == j':
 332                 --
 333                 --        j             j'                       j
 334                 --       / \    +      / \      ==>             / \
 335                 --     t1   t2      t1'   t2'           t1 + t1'   t2 + t2'
 336                 --
 337           mix_branches (SameRoot)
 338                 = mkSSNodeUFM (NodeUFMData j p)
 339                         (mix_trees t1 t1')
 340                         (mix_trees t2 t2')
 341                 -- Now the 4 different other ways; all like this:
 342                 --
 343                 -- Given j >^ j' (and, say,  j > j')
 344                 --
 345                 --        j             j'                       j
 346                 --       / \    +      / \      ==>             / \
 347                 --     t1   t2      t1'   t2'                 t1   t2 + j'
 348                 --                                                     / \
 349                 --                                                   t1'  t2'
 350           mix_branches (LeftRoot Leftt) --  | trace "LL" True
 351             = mkSLNodeUFM
 352                 (NodeUFMData j p)
 353                 (mix_trees t1 right_t)
 354                 t2
 355
 356           mix_branches (LeftRoot Rightt) --  | trace "LR" True
 357             = mkLSNodeUFM
 358                 (NodeUFMData j p)
 359                 t1
 360                 (mix_trees t2 right_t)
 361
 362           mix_branches (RightRoot Leftt) --  | trace "RL" True
 363             = mkSLNodeUFM
 364                 (NodeUFMData j' p')
 365                 (mix_trees left_t t1')
 366                 t2'
 367
 368           mix_branches (RightRoot Rightt) --  | trace "RR" True
 369             = mkLSNodeUFM
 370                 (NodeUFMData j' p')
 371                 t1'
 372                 (mix_trees left_t t2')
 373
 374         mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
 375 \end{code}
 376
 377 And ways of subtracting them. First the base cases,
 378 then the full D&C approach.
 379
 380 \begin{code}
 381 minusUFM EmptyUFM _  = EmptyUFM
 382 minusUFM t1 EmptyUFM = t1
 383 minusUFM fm1 fm2     = minus_trees fm1 fm2
 384     where
 385         --
 386         -- Notice the asymetry of subtraction
 387         --
 388         minus_trees lf@(LeafUFM i a) t2 =
 389                 case lookUp t2 i of
 390                   Nothing -> lf
 391                   Just b -> EmptyUFM
 392
 393         minus_trees t1 (LeafUFM i _) = delete t1 i
 394
 395         minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
 396           = minus_branches
 397                 (ask_about_common_ancestor
 398                         (NodeUFMData j p)
 399                         (NodeUFMData j' p'))
 400           where
 401                 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
 402                 --
 403                 --        j             j'                 j
 404                 --       / \    +      / \      ==>       / \
 405                 --     t1   t2      t1'   t2'            t1  t2
 406                 --
 407                 --
 408                 -- Fast, Ehh !
 409                 --
 410           minus_branches (NewRoot nd _) = left_t
 411
 412                 -- Now, if j == j':
 413                 --
 414                 --        j             j'                       j
 415                 --       / \    +      / \      ==>             / \
 416                 --     t1   t2      t1'   t2'           t1 + t1'   t2 + t2'
 417                 --
 418           minus_branches (SameRoot)
 419                 = mkSSNodeUFM (NodeUFMData j p)
 420                         (minus_trees t1 t1')
 421                         (minus_trees t2 t2')
 422                 -- Now the 4 different other ways; all like this:
 423                 -- again, with asymatry
 424
 425                 --
 426                 -- The left is above the right
 427                 --
 428           minus_branches (LeftRoot Leftt)
 429             = mkSLNodeUFM
 430                 (NodeUFMData j p)
 431                 (minus_trees t1 right_t)
 432                 t2
 433           minus_branches (LeftRoot Rightt)
 434             = mkLSNodeUFM
 435                 (NodeUFMData j p)
 436                 t1
 437                 (minus_trees t2 right_t)
 438
 439                 --
 440                 -- The right is above the left
 441                 --
 442           minus_branches (RightRoot Leftt)
 443             = minus_trees left_t t1'
 444           minus_branches (RightRoot Rightt)
 445             = minus_trees left_t t2'
 446
 447         minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
 448 \end{code}
 449
 450 And taking the intersection of two UniqFM's.
 451
 452 \begin{code}
 453 intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2
 454
 455 intersectUFM_C f EmptyUFM _ = EmptyUFM
 456 intersectUFM_C f _ EmptyUFM = EmptyUFM
 457 intersectUFM_C f fm1 fm2    = intersect_trees fm1 fm2
 458     where
 459         intersect_trees (LeafUFM i a) t2 =
 460                 case lookUp t2 i of
 461                   Nothing -> EmptyUFM
 462                   Just b -> mkLeafUFM i (f a b)
 463
 464         intersect_trees t1 (LeafUFM i a) =
 465                 case lookUp t1 i of
 466                   Nothing -> EmptyUFM
 467                   Just b -> mkLeafUFM i (f b a)
 468
 469         intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2')
 470           = intersect_branches
 471                 (ask_about_common_ancestor
 472                         (NodeUFMData j p)
 473                         (NodeUFMData j' p'))
 474           where
 475                 -- Given a disjoint j,j' (p >^ p' && p' >^ p):
 476                 --
 477                 --        j             j'
 478                 --       / \    +      / \      ==>             EmptyUFM
 479                 --     t1   t2      t1'   t2'
 480                 --
 481                 -- Fast, Ehh !
 482                 --
 483           intersect_branches (NewRoot nd _) = EmptyUFM
 484
 485                 -- Now, if j == j':
 486                 --
 487                 --        j             j'                       j
 488                 --       / \    +      / \      ==>             / \
 489                 --     t1   t2      t1'   t2'           t1 x t1'   t2 x t2'
 490                 --
 491           intersect_branches (SameRoot)
 492                 = mkSSNodeUFM (NodeUFMData j p)
 493                         (intersect_trees t1 t1')
 494                         (intersect_trees t2 t2')
 495                 -- Now the 4 different other ways; all like this:
 496                 --
 497                 -- Given j >^ j' (and, say,  j > j')
 498                 --
 499                 --        j             j'                     t2 + j'
 500                 --       / \    +      / \      ==>                / \
 501                 --     t1   t2      t1'   t2'                    t1'  t2'
 502                 --
 503                 -- This does cut down the search space quite a bit.
 504
 505           intersect_branches (LeftRoot Leftt)
 506             = intersect_trees t1 right_t
 507           intersect_branches (LeftRoot Rightt)
 508             = intersect_trees t2 right_t
 509           intersect_branches (RightRoot Leftt)
 510             = intersect_trees left_t t1'
 511           intersect_branches (RightRoot Rightt)
 512             = intersect_trees left_t t2'
 513
 514         intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
 515 \end{code}
 516
 517 Now the usual set of `collection' operators, like map, fold, etc.
 518
 519 \begin{code}
 520 foldUFM f a (NodeUFM _ _ t1 t2) = foldUFM f (foldUFM f a t2) t1
 521 foldUFM f a (LeafUFM _ obj)     = f obj a
 522 foldUFM f a EmptyUFM            = a
 523 \end{code}
 524
 525 \begin{code}
 526 mapUFM fn EmptyUFM    = EmptyUFM
 527 mapUFM fn fm          = map_tree fn fm
 528
 529 filterUFM fn EmptyUFM = EmptyUFM
 530 filterUFM fn fm       = filter_tree pred fm
 531         where
 532           pred (i::FastInt) e = fn e
 533
 534 filterUFM_Directly fn EmptyUFM = EmptyUFM
 535 filterUFM_Directly fn fm       = filter_tree pred fm
 536         where
 537           pred i e = fn (mkUniqueGrimily (iBox i)) e
 538 \end{code}
 539
 540 Note, this takes a long time, O(n), but
 541 because we dont want to do this very often, we put up with this.
 542 O'rable, but how often do we look at the size of
 543 a finite map?
 544
 545 \begin{code}
 546 sizeUFM EmptyUFM            = 0
 547 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
 548 sizeUFM (LeafUFM _ _)       = 1
 549
 550 isNullUFM EmptyUFM = True
 551 isNullUFM _        = False
 552
 553 -- hashing is used in VarSet.uniqAway, and should be fast
 554 -- We use a cheap and cheerful method for now
 555 hashUFM EmptyUFM          = 0
 556 hashUFM (NodeUFM n _ _ _) = iBox n
 557 hashUFM (LeafUFM n _)     = iBox n
 558 \end{code}
 559
 560 looking up in a hurry is the {\em whole point} of this binary tree lark.
 561 Lookup up a binary tree is easy (and fast).
 562
 563 \begin{code}
 564 elemUFM          key fm = maybeToBool (lookupUFM fm key)
 565 elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
 566
 567 lookupUFM          fm key = lookUp fm (getKey# (getUnique key))
 568 lookupUFM_Directly fm key = lookUp fm (getKey# key)
 569
 570 lookupWithDefaultUFM fm deflt key
 571   = case lookUp fm (getKey# (getUnique key)) of
 572       Nothing  -> deflt
 573       Just elt -> elt
 574
 575 lookupWithDefaultUFM_Directly fm deflt key
 576   = case lookUp fm (getKey# key) of
 577       Nothing  -> deflt
 578       Just elt -> elt
 579
 580 lookUp EmptyUFM _   = Nothing
 581 lookUp fm i         = lookup_tree fm
 582   where
 583         lookup_tree :: UniqFM a -> Maybe a
 584
 585         lookup_tree (LeafUFM j b)
 586           | j ==# i     = Just b
 587           | otherwise   = Nothing
 588         lookup_tree (NodeUFM j p t1 t2)
 589           | j ># i      = lookup_tree t1
 590           | otherwise   = lookup_tree t2
 591
 592         lookup_tree EmptyUFM = panic "lookup Failed"
 593 \end{code}
 594
 595 folds are *wonderful* things.
 596
 597 \begin{code}
 598 eltsUFM fm = foldUFM (:) [] fm
 599
 600 ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
 601
 602 keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
 603
 604 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
 605 fold_tree f a (LeafUFM iu obj)    = f iu obj a
 606 fold_tree f a EmptyUFM            = a
 607 \end{code}
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsubsection{The @UniqFM@ type, and its functions}
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 You should always use these to build the tree.
 616 There are 4 versions of mkNodeUFM, depending on
 617 the strictness of the two sub-tree arguments.
 618 The strictness is used *both* to prune out
 619 empty trees, *and* to improve performance,
 620 stoping needless thunks lying around.
 621 The rule of thumb (from experence with these trees)
 622 is make thunks strict, but data structures lazy.
 623 If in doubt, use mkSSNodeUFM, which has the `strongest'
 624 functionality, but may do a few needless evaluations.
 625
 626 \begin{code}
 627 mkLeafUFM :: FastInt -> a -> UniqFM a
 628 mkLeafUFM i a     = LeafUFM i a
 629
 630 -- The *ONLY* ways of building a NodeUFM.
 631
 632 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
 633 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
 634 mkSSNodeUFM (NodeUFMData j p) t1 t2
 635   = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
 636     NodeUFM j p t1 t2
 637
 638 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
 639 mkSLNodeUFM (NodeUFMData j p) t1 t2
 640   = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
 641     NodeUFM j p t1 t2
 642
 643 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
 644 mkLSNodeUFM (NodeUFMData j p) t1 t2
 645   = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
 646     NodeUFM j p t1 t2
 647
 648 mkLLNodeUFM (NodeUFMData j p) t1 t2
 649   = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2)
 650     NodeUFM j p t1 t2
 651
 652 correctNodeUFM
 653         :: Int
 654         -> Int
 655         -> UniqFM a
 656         -> UniqFM a
 657         -> Bool
 658
 659 correctNodeUFM j p t1 t2
 660   = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
 661   where
 662     correct low high _ (LeafUFM i _)
 663       = low <= iBox i && iBox i <= high
 664     correct low high above_p (NodeUFM j p _ _)
 665       = low <= iBox j && iBox j <= high && above_p > iBox p
 666     correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
 667 \end{code}
 668
 669 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
 670 and if necessary do $\lambda$ lifting on our functions that are bound.
 671
 672 \begin{code}
 673 insert_ele
 674         :: (a -> a -> a)        -- old -> new -> result
 675         -> UniqFM a
 676         -> FastInt
 677         -> a
 678         -> UniqFM a
 679
 680 insert_ele f EmptyUFM i new = mkLeafUFM i new
 681
 682 insert_ele f (LeafUFM j old) i new
 683   | j ># i =
 684           mkLLNodeUFM (getCommonNodeUFMData
 685                           (indexToRoot i)
 686                           (indexToRoot j))
 687                  (mkLeafUFM i new)
 688                  (mkLeafUFM j old)
 689   | j ==# i  = mkLeafUFM j (f old new)
 690   | otherwise =
 691           mkLLNodeUFM (getCommonNodeUFMData
 692                           (indexToRoot i)
 693                           (indexToRoot j))
 694                  (mkLeafUFM j old)
 695                  (mkLeafUFM i new)
 696
 697 insert_ele f n@(NodeUFM j p t1 t2) i a
 698   | i <# j
 699     = if (i >=# (j -# p))
 700       then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
 701       else mkLLNodeUFM (getCommonNodeUFMData
 702                           (indexToRoot i)
 703                           ((NodeUFMData j p)))
 704                   (mkLeafUFM i a)
 705                   n
 706   | otherwise
 707     = if (i <=# ((j -# _ILIT(1)) +# p))
 708       then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
 709       else mkLLNodeUFM (getCommonNodeUFMData
 710                           (indexToRoot i)
 711                           ((NodeUFMData j p)))
 712                   n
 713                   (mkLeafUFM i a)
 714 \end{code}
 715
 716
 717
 718 \begin{code}
 719 map_tree f (NodeUFM j p t1 t2)
 720   = mkLLNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
 721         -- NB. lazy! we know the tree is well-formed.
 722 map_tree f (LeafUFM i obj)
 723   = mkLeafUFM i (f obj)
 724 map_tree f _ = panic "map_tree failed"
 725 \end{code}
 726
 727 \begin{code}
 728 filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
 729 filter_tree f nd@(NodeUFM j p t1 t2)
 730   = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
 731
 732 filter_tree f lf@(LeafUFM i obj)
 733   | f i obj = lf
 734   | otherwise = EmptyUFM
 735 filter_tree f _ = panic "filter_tree failed"
 736 \end{code}
 737
 738 %************************************************************************
 739 %*                                                                      *
 740 \subsubsection{The @UniqFM@ type, and signatures for the functions}
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 Now some Utilities;
 745
 746 This is the information that is held inside a NodeUFM, packaged up for
 747 consumer use.
 748
 749 \begin{code}
 750 data NodeUFMData
 751   = NodeUFMData FastInt
 752                 FastInt
 753 \end{code}
 754
 755 This is the information used when computing new NodeUFMs.
 756
 757 \begin{code}
 758 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
 759 data CommonRoot
 760   = LeftRoot  Side      -- which side is the right down ?
 761   | RightRoot Side      -- which side is the left down ?
 762   | SameRoot            -- they are the same !
 763   | NewRoot NodeUFMData -- here's the new, common, root
 764             Bool        -- do you need to swap left and right ?
 765 \end{code}
 766
 767 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
 768
 769 \begin{code}
 770 indexToRoot :: FastInt -> NodeUFMData
 771
 772 indexToRoot i
 773   = let
 774         l = (_ILIT(1) :: FastInt)
 775     in
 776     NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
 777
 778 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
 779
 780 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
 781   | p ==# p2    = getCommonNodeUFMData_ p j j2
 782   | p <# p2     = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
 783   | otherwise   = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
 784   where
 785     l  = (_ILIT(1) :: FastInt)
 786     j  = i  `quotFastInt` (p  `shiftL_` l)
 787     j2 = i2 `quotFastInt` (p2 `shiftL_` l)
 788
 789     getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
 790
 791     getCommonNodeUFMData_ p j j_
 792       | j ==# j_
 793       = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
 794       | otherwise
 795       = getCommonNodeUFMData_ (p `shiftL_`  l) (j `shiftR_` l) (j_ `shiftR_` l)
 796
 797 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
 798
 799 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
 800   | j ==# j2 = SameRoot
 801   | otherwise
 802   = case getCommonNodeUFMData x y of
 803       nd@(NodeUFMData j3 p3)
 804         | j3 ==# j  -> LeftRoot (decideSide (j ># j2))
 805         | j3 ==# j2 -> RightRoot (decideSide (j <# j2))
 806         | otherwise   -> NewRoot nd (j ># j2)
 807     where
 808         decideSide :: Bool -> Side
 809         decideSide True  = Leftt
 810         decideSide False = Rightt
 811 \end{code}
 812
 813 This might be better in Util.lhs ?
 814
 815
 816 Now the bit twiddling functions.
 817 \begin{code}
 818 shiftL_ :: FastInt -> FastInt -> FastInt
 819 shiftR_ :: FastInt -> FastInt -> FastInt
 820
 821 #if __GLASGOW_HASKELL__
 822 {-# INLINE shiftL_ #-}
 823 {-# INLINE shiftR_ #-}
 824 #if __GLASGOW_HASKELL__ >= 503
 825 shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
 826 #else
 827 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
 828 #endif
 829 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
 830   where
 831 #if __GLASGOW_HASKELL__ >= 503
 832     shiftr x y = uncheckedShiftRL# x y
 833 #else
 834     shiftr x y = shiftRL# x y
 835 #endif
 836
 837 #else /* not GHC */
 838 shiftL_ n p = n * (2 ^ p)
 839 shiftR_ n p = n `quot` (2 ^ p)
 840
 841 #endif /* not GHC */
 842 \end{code}
 843
 844 \begin{code}
 845 use_snd :: a -> b -> b
 846 use_snd a b = b
 847 \end{code}