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