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