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