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