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