ghc/compiler/utils/UniqFM.lhs

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