ghc/compiler/utils/UniqFM.lhs

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