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