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