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