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