ghc/compiler/utils/UniqFM.lhs

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