ghc/compiler/utils/UniqFM.lhs

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