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,
  32         addListToUFM,
  33         addToUFM_Directly,
  34         addListToUFM_Directly,
  35         IF_NOT_GHC(addToUFM_C COMMA)
  36         addListToUFM_C,
  37         delFromUFM,
  38         delFromUFM_Directly,
  39         delListFromUFM,
  40         plusUFM,
  41         plusUFM_C,
  42         minusUFM,
  43         intersectUFM,
  44         IF_NOT_GHC(intersectUFM_C COMMA)
  45         IF_NOT_GHC(foldUFM COMMA)
  46         mapUFM,
  47         filterUFM,
  48         sizeUFM,
  49         isNullUFM,
  50         lookupUFM, lookupUFM_Directly,
  51         lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
  52         eltsUFM,
  53         ufmToList
  54     ) where
  55
  56 #if defined(COMPILING_GHC)
  57 IMP_Ubiq(){-uitous-}
  58 #endif
  59
  60 import Unique           ( Unique, u2i, mkUniqueGrimily )
  61 import Util
  62 import Pretty           ( SYN_IE(Pretty), PrettyRep )
  63 import PprStyle         ( PprStyle )
  64 import SrcLoc           ( SrcLoc )
  65
  66 #if ! OMIT_NATIVE_CODEGEN
  67 #define IF_NCG(a) a
  68 #else
  69 #define IF_NCG(a) {--}
  70 #endif
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{The @UniqFM@ type, and signatures for the functions}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
  80
  81 \begin{code}
  82 emptyUFM        :: UniqFM elt
  83 isNullUFM       :: UniqFM elt -> Bool
  84 unitUFM         :: Uniquable key => key -> elt -> UniqFM elt
  85 unitDirectlyUFM -- got the Unique already
  86                 :: Unique -> elt -> UniqFM elt
  87 listToUFM       :: Uniquable key => [(key,elt)] -> UniqFM elt
  88 listToUFM_Directly
  89                 :: [(Unique, elt)] -> UniqFM elt
  90
  91 addToUFM        :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
  92 addListToUFM    :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
  93 addToUFM_Directly
  94                 :: UniqFM elt -> Unique -> elt -> UniqFM elt
  95
  96 addToUFM_C      :: Uniquable key => (elt -> elt -> elt)
  97                            -> UniqFM elt -> key -> elt -> UniqFM elt
  98 addListToUFM_C  :: Uniquable key => (elt -> elt -> elt)
  99                            -> UniqFM elt -> [(key,elt)]
 100                            -> UniqFM elt
 101
 102 delFromUFM      :: Uniquable key => UniqFM elt -> key    -> UniqFM elt
 103 delListFromUFM  :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
 104 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
 105
 106 plusUFM         :: UniqFM elt -> UniqFM elt -> UniqFM elt
 107
 108 plusUFM_C       :: (elt -> elt -> elt)
 109                 -> UniqFM elt -> UniqFM elt -> UniqFM elt
 110
 111 minusUFM        :: UniqFM elt -> UniqFM elt -> UniqFM elt
 112
 113 intersectUFM    :: UniqFM elt -> UniqFM elt -> UniqFM elt
 114 intersectUFM_C  :: (elt -> elt -> elt)
 115                 -> UniqFM elt -> UniqFM elt -> UniqFM elt
 116 foldUFM         :: (elt -> a -> a) -> a -> UniqFM elt -> a
 117 mapUFM          :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
 118 filterUFM       :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
 119
 120 sizeUFM         :: UniqFM elt -> Int
 121
 122 lookupUFM       :: Uniquable key => UniqFM elt -> key -> Maybe elt
 123 lookupUFM_Directly  -- when you've got the Unique already
 124                 :: UniqFM elt -> Unique -> Maybe elt
 125 lookupWithDefaultUFM
 126                 :: Uniquable key => UniqFM elt -> elt -> key -> elt
 127 lookupWithDefaultUFM_Directly
 128                 :: UniqFM elt -> elt -> Unique -> elt
 129
 130 eltsUFM         :: UniqFM elt -> [elt]
 131 ufmToList       :: UniqFM elt -> [(Unique, elt)]
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 \begin{code}
 141 #ifdef __GLASGOW_HASKELL__
 142 -- I don't think HBC was too happy about this (WDP 94/10)
 143
 144 {-# SPECIALIZE
 145     addListToUFM :: UniqFM elt -> [(Name,   elt)] -> UniqFM elt
 146                   , UniqFM elt -> [(RnName, elt)] -> UniqFM elt
 147   #-}
 148 {-# SPECIALIZE
 149     addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name,  elt)] -> UniqFM elt
 150                     , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt
 151   #-}
 152 {-# SPECIALIZE
 153     addToUFM    :: UniqFM elt -> Unique -> elt  -> UniqFM elt
 154   #-}
 155 {-# SPECIALIZE
 156     listToUFM   :: [(Unique, elt)]     -> UniqFM elt
 157                  , [(RnName, elt)]     -> UniqFM elt
 158   #-}
 159 {-# SPECIALIZE
 160     lookupUFM   :: UniqFM elt -> Name   -> Maybe elt
 161                  , UniqFM elt -> RnName -> Maybe elt
 162                  , UniqFM elt -> Unique -> Maybe elt
 163   #-}
 164 {-# SPECIALIZE
 165     lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt
 166   #-}
 167
 168 #endif {- __GLASGOW_HASKELL__ -}
 169 \end{code}
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{Andy Gill's underlying @UniqFM@ machinery}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 ``Uniq Finite maps'' are the heart and soul of the compiler's
 178 lookup-tables/environments.  Important stuff!  It works well with
 179 Dense and Sparse ranges.
 180 Both @Uq@ Finite maps and @Hash@ Finite Maps
 181 are built ontop of Int Finite Maps.
 182
 183 This code is explained in the paper:
 184 \begin{display}
 185         A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends
 186         "A Cheap balancing act that grows on a tree"
 187         Glasgow FP Workshop, Sep 1994, pp??-??
 188 \end{display}
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsubsection{The @UniqFM@ type, and signatures for the functions}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 @UniqFM a@ is a mapping from Unique to a.
 197
 198 First, the DataType itself; which is either a Node, a Leaf, or an Empty.
 199
 200 \begin{code}
 201 data UniqFM ele
 202   = EmptyUFM
 203   | LeafUFM FAST_INT ele
 204   | NodeUFM FAST_INT        -- the switching
 205             FAST_INT        -- the delta
 206             (UniqFM ele)
 207             (UniqFM ele)
 208
 209 class Uniquable a where
 210     uniqueOf :: a -> Unique
 211
 212 -- for debugging only :-)
 213 {-
 214 instance Text (UniqFM a) where
 215         showsPrec _ (NodeUFM a b t1 t2) =
 216                   showString "NodeUFM " . shows (IBOX(a))
 217                 . showString " " . shows (IBOX(b))
 218                 . showString " (" . shows t1
 219                 . showString ") (" . shows t2
 220                 . showString ")"
 221         showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
 222         showsPrec _ (EmptyUFM) = id
 223 -}
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsubsection{The @UniqFM@ functions}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 First the ways of building a UniqFM.
 233
 234 \begin{code}
 235 emptyUFM                     = EmptyUFM
 236 unitUFM      key elt = mkLeafUFM (u2i (uniqueOf key)) elt
 237 unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
 238
 239 listToUFM key_elt_pairs
 240   = addListToUFM_C use_snd EmptyUFM key_elt_pairs
 241
 242 listToUFM_Directly uniq_elt_pairs
 243   = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs
 244 \end{code}
 245
 246 Now ways of adding things to UniqFMs.
 247
 248 There is an alternative version of @addListToUFM_C@, that uses @plusUFM@,
 249 but the semantics of this operation demands a linear insertion;
 250 perhaps the version without the combinator function
 251 could be optimised using it.
 252
 253 \begin{code}
 254 addToUFM fm key elt = addToUFM_C use_snd fm key elt
 255
 256 addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
 257
 258 addToUFM_C combiner fm key elt
 259   = insert_ele combiner fm (u2i (uniqueOf key)) elt
 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 (u2i (uniqueOf 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 (u2i 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 (u2i (uniqueOf key))
 279 delFromUFM_Directly fm u   = delete fm (u2i 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 _EQ_ key      = EmptyUFM
 288       | otherwise       = lf    -- no delete!
 289
 290     del_ele nd@(NodeUFM j p t1 t2)
 291       | j _GT_ 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 fn a EmptyUFM = a
 521 foldUFM fn a fm       = fold_tree fn a fm
 522
 523 mapUFM fn EmptyUFM    = EmptyUFM
 524 mapUFM fn fm          = map_tree fn fm
 525
 526 filterUFM fn EmptyUFM = EmptyUFM
 527 filterUFM fn fm       = filter_tree fn fm
 528 \end{code}
 529
 530 Note, this takes a long time, O(n), but
 531 because we dont want to do this very often, we put up with this.
 532 O'rable, but how often do we look at the size of
 533 a finite map?
 534
 535 \begin{code}
 536 sizeUFM EmptyUFM            = 0
 537 sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2
 538 sizeUFM (LeafUFM _ _)       = 1
 539
 540 isNullUFM EmptyUFM = True
 541 isNullUFM _        = False
 542 \end{code}
 543
 544 looking up in a hurry is the {\em whole point} of this binary tree lark.
 545 Lookup up a binary tree is easy (and fast).
 546
 547 \begin{code}
 548 lookupUFM          fm key = lookUp fm (u2i (uniqueOf key))
 549 lookupUFM_Directly fm key = lookUp fm (u2i key)
 550
 551 lookupWithDefaultUFM fm deflt key
 552   = case lookUp fm (u2i (uniqueOf key)) of
 553       Nothing  -> deflt
 554       Just elt -> elt
 555
 556 lookupWithDefaultUFM_Directly fm deflt key
 557   = case lookUp fm (u2i key) of
 558       Nothing  -> deflt
 559       Just elt -> elt
 560
 561 lookUp EmptyUFM _   = Nothing
 562 lookUp fm i         = lookup_tree fm
 563   where
 564         lookup_tree :: UniqFM a -> Maybe a
 565
 566         lookup_tree (LeafUFM j b)
 567           | j _EQ_ i    = Just b
 568           | otherwise   = Nothing
 569         lookup_tree (NodeUFM j p t1 t2)
 570           | j _GT_ i    = lookup_tree t1
 571           | otherwise   = lookup_tree t2
 572
 573         lookup_tree EmptyUFM = panic "lookup Failed"
 574 \end{code}
 575
 576 folds are *wonderful* things.
 577
 578 \begin{code}
 579 eltsUFM EmptyUFM = []
 580 eltsUFM fm       = fold_tree (:) [] fm
 581
 582 ufmToList EmptyUFM = []
 583 ufmToList fm
 584   = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
 585   where
 586     fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
 587     fold_tree f a (LeafUFM iu obj)    = f iu obj a
 588
 589     fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
 590 \end{code}
 591
 592 %************************************************************************
 593 %*                                                                      *
 594 \subsubsection{The @UniqFM@ type, and its functions}
 595 %*                                                                      *
 596 %************************************************************************
 597
 598 You should always use these to build the tree.
 599 There are 4 versions of mkNodeUFM, depending on
 600 the strictness of the two sub-tree arguments.
 601 The strictness is used *both* to prune out
 602 empty trees, *and* to improve performance,
 603 stoping needless thunks lying around.
 604 The rule of thumb (from experence with these trees)
 605 is make thunks strict, but data structures lazy.
 606 If in doubt, use mkSSNodeUFM, which has the `strongest'
 607 functionality, but may do a few needless evaluations.
 608
 609 \begin{code}
 610 mkLeafUFM :: FAST_INT -> a -> UniqFM a
 611 mkLeafUFM i a     = LeafUFM i a
 612
 613 -- The *ONLY* ways of building a NodeUFM.
 614
 615 mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
 616 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
 617 mkSSNodeUFM (NodeUFMData j p) t1 t2
 618   = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
 619     NodeUFM j p t1 t2
 620
 621 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2
 622 mkSLNodeUFM (NodeUFMData j p) t1 t2
 623   = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
 624     NodeUFM j p t1 t2
 625
 626 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1
 627 mkLSNodeUFM (NodeUFMData j p) t1 t2
 628   = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
 629     NodeUFM j p t1 t2
 630
 631 mkLLNodeUFM (NodeUFMData j p) t1 t2
 632   = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2)
 633     NodeUFM j p t1 t2
 634
 635 correctNodeUFM
 636         :: Int
 637         -> Int
 638         -> UniqFM a
 639         -> UniqFM a
 640         -> Bool
 641
 642 correctNodeUFM j p t1 t2
 643   = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2
 644   where
 645     correct low high _ (LeafUFM i _)
 646       = low <= IBOX(i) && IBOX(i) <= high
 647     correct low high above_p (NodeUFM j p _ _)
 648       = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p)
 649     correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree"
 650 \end{code}
 651
 652 Note: doing SAT on this by hand seems to make it worse. Todo: Investigate,
 653 and if necessary do $\lambda$ lifting on our functions that are bound.
 654
 655 \begin{code}
 656 insert_ele
 657         :: (a -> a -> a)
 658         -> UniqFM a
 659         -> FAST_INT
 660         -> a
 661         -> UniqFM a
 662
 663 insert_ele f EmptyUFM i new = mkLeafUFM i new
 664
 665 insert_ele f (LeafUFM j old) i new
 666   | j _GT_ i =
 667           mkLLNodeUFM (getCommonNodeUFMData
 668                           (indexToRoot i)
 669                           (indexToRoot j))
 670                  (mkLeafUFM i new)
 671                  (mkLeafUFM j old)
 672   | j _EQ_ i  = mkLeafUFM j (f old new)
 673   | otherwise =
 674           mkLLNodeUFM (getCommonNodeUFMData
 675                           (indexToRoot i)
 676                           (indexToRoot j))
 677                  (mkLeafUFM j old)
 678                  (mkLeafUFM i new)
 679
 680 insert_ele f n@(NodeUFM j p t1 t2) i a
 681   | i _LT_ j
 682     = if (i _GE_ (j _SUB_ p))
 683       then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2
 684       else mkLLNodeUFM (getCommonNodeUFMData
 685                           (indexToRoot i)
 686                           ((NodeUFMData j p)))
 687                   (mkLeafUFM i a)
 688                   n
 689   | otherwise
 690     = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p))
 691       then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a)
 692       else mkLLNodeUFM (getCommonNodeUFMData
 693                           (indexToRoot i)
 694                           ((NodeUFMData j p)))
 695                   n
 696                   (mkLeafUFM i a)
 697 \end{code}
 698
 699 This has got a left to right ordering.
 700
 701 \begin{code}
 702 fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
 703 fold_tree f a (LeafUFM _ obj)     = f obj a
 704
 705 fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM"
 706 \end{code}
 707
 708 \begin{code}
 709 map_tree f (NodeUFM j p t1 t2)
 710   = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2)
 711 map_tree f (LeafUFM i obj)
 712   = mkLeafUFM i (f obj)
 713
 714 map_tree f _ = panic "map_tree failed"
 715 \end{code}
 716
 717 \begin{code}
 718 filter_tree f nd@(NodeUFM j p t1 t2)
 719   = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
 720
 721 filter_tree f lf@(LeafUFM i obj)
 722   | f obj = lf
 723   | otherwise = EmptyUFM
 724 \end{code}
 725
 726 %************************************************************************
 727 %*                                                                      *
 728 \subsubsection{The @UniqFM@ type, and signatures for the functions}
 729 %*                                                                      *
 730 %************************************************************************
 731
 732 Now some Utilities;
 733
 734 This is the information that is held inside a NodeUFM, packaged up for
 735 consumer use.
 736
 737 \begin{code}
 738 data NodeUFMData
 739   = NodeUFMData FAST_INT
 740                 FAST_INT
 741 \end{code}
 742
 743 This is the information used when computing new NodeUFMs.
 744
 745 \begin{code}
 746 data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
 747 data CommonRoot
 748   = LeftRoot  Side      -- which side is the right down ?
 749   | RightRoot Side      -- which side is the left down ?
 750   | SameRoot            -- they are the same !
 751   | NewRoot NodeUFMData -- here's the new, common, root
 752             Bool        -- do you need to swap left and right ?
 753 \end{code}
 754
 755 This specifies the relationship between NodeUFMData and CalcNodeUFMData.
 756
 757 \begin{code}
 758 indexToRoot :: FAST_INT -> NodeUFMData
 759
 760 indexToRoot i
 761   = let
 762         l = (ILIT(1) :: FAST_INT)
 763     in
 764     NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l
 765
 766 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
 767
 768 getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
 769   | p _EQ_ p2   = getCommonNodeUFMData_ p j j2
 770   | p _LT_ p2   = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2
 771   | otherwise   = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2))
 772   where
 773     l  = (ILIT(1) :: FAST_INT)
 774     j  = i  _QUOT_ (p  `shiftL_` l)
 775     j2 = i2 _QUOT_ (p2 `shiftL_` l)
 776
 777     getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData
 778
 779     getCommonNodeUFMData_ p j j_
 780       | j _EQ_ j_
 781       = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p
 782       | otherwise
 783       = getCommonNodeUFMData_ (p `shiftL_`  l) (j `shiftR_` l) (j_ `shiftR_` l)
 784
 785 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
 786
 787 ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2)
 788   | j _EQ_ j2 = SameRoot
 789   | otherwise
 790   = case getCommonNodeUFMData x y of
 791       nd@(NodeUFMData j3 p3)
 792         | j3 _EQ_ j  -> LeftRoot (decideSide (j _GT_ j2))
 793         | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2))
 794         | otherwise   -> NewRoot nd (j _GT_ j2)
 795     where
 796         decideSide :: Bool -> Side
 797         decideSide True  = Leftt
 798         decideSide False = Rightt
 799 \end{code}
 800
 801 This might be better in Util.lhs ?
 802
 803
 804 Now the bit twiddling functions.
 805 \begin{code}
 806 shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT
 807 shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT
 808
 809 #if __GLASGOW_HASKELL__
 810 {-# INLINE shiftL_ #-}
 811 {-# INLINE shiftR_ #-}
 812 shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
 813 shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
 814   where
 815     shiftr x y = shiftRA# x y
 816
 817 #else {- not GHC -}
 818 shiftL_ n p = n * (2 ^ p)
 819 shiftR_ n p = n `quot` (2 ^ p)
 820
 821 #endif {- not GHC -}
 822 \end{code}
 823
 824 Andy's extras: ToDo: to Util.
 825
 826 \begin{code}
 827 use_fst :: a -> b -> a
 828 use_fst a b = a
 829
 830 use_snd :: a -> b -> b
 831 use_snd a b = b
 832 \end{code}