ghc/compiler/utils/FiniteMap.lhs

   1
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[FiniteMap]{An implementation of finite maps}
   5
   6 ``Finite maps'' are the heart of the compiler's
   7 lookup-tables/environments and its implementation of sets.  Important
   8 stuff!
   9
  10 This code is derived from that in the paper:
  11 \begin{display}
  12         S Adams
  13         "Efficient sets: a balancing act"
  14         Journal of functional programming 3(4) Oct 1993, pp553-562
  15 \end{display}
  16
  17 The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
  18 near the end.
  19
  20 \begin{code}
  21
  22 module FiniteMap (
  23         FiniteMap,              -- abstract type
  24
  25         emptyFM, unitFM, listToFM,
  26
  27         addToFM,
  28         addToFM_C,
  29         addListToFM,
  30         addListToFM_C,
  31         delFromFM,
  32         delListFromFM,
  33
  34         plusFM,
  35         plusFM_C,
  36         minusFM,
  37         foldFM,
  38
  39         intersectFM,
  40         intersectFM_C,
  41         mapFM, filterFM,
  42
  43         sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
  44
  45         fmToList, keysFM, eltsFM
  46
  47         , bagToFM
  48
  49     ) where
  50
  51 #include "HsVersions.h"
  52 #define IF_NOT_GHC(a) {--}
  53
  54 #if defined(DEBUG_FINITEMAPS)/* NB NB NB */
  55 #define OUTPUTABLE_key , Outputable key
  56 #else
  57 #define OUTPUTABLE_key {--}
  58 #endif
  59
  60 import GlaExts
  61 import Maybes
  62 import Bag        ( Bag, foldrBag )
  63 import Util
  64 import Outputable
  65
  66 #if ! OMIT_NATIVE_CODEGEN
  67 #  define IF_NCG(a) a
  68 #else
  69 #  define IF_NCG(a) {--}
  70 #endif
  71
  72
  73 -- SIGH: but we use unboxed "sizes"...
  74 #if __GLASGOW_HASKELL__
  75 #define IF_GHC(a,b) a
  76 #else /* not GHC */
  77 #define IF_GHC(a,b) b
  78 #endif /* not GHC */
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{The signature of the module}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 --      BUILDING
  90 emptyFM         :: FiniteMap key elt
  91 unitFM          :: key -> elt -> FiniteMap key elt
  92 listToFM        :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
  93                         -- In the case of duplicates, the last is taken
  94 bagToFM         :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
  95                         -- In the case of duplicates, who knows which is taken
  96
  97 --      ADDING AND DELETING
  98                    -- Throws away any previous binding
  99                    -- In the list case, the items are added starting with the
 100                    -- first one in the list
 101 addToFM         :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt  -> FiniteMap key elt
 102 addListToFM     :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
 103
 104                    -- Combines with previous binding
 105                    -- The combining fn goes (old -> new -> new)
 106 addToFM_C       :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
 107                            -> FiniteMap key elt -> key -> elt
 108                            -> FiniteMap key elt
 109 addListToFM_C   :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
 110                            -> FiniteMap key elt -> [(key,elt)]
 111                            -> FiniteMap key elt
 112
 113                    -- Deletion doesn't complain if you try to delete something
 114                    -- which isn't there
 115 delFromFM       :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key   -> FiniteMap key elt
 116 delListFromFM   :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt
 117
 118 --      COMBINING
 119                    -- Bindings in right argument shadow those in the left
 120 plusFM          :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
 121                            -> FiniteMap key elt
 122
 123                    -- Combines bindings for the same thing with the given function
 124 plusFM_C        :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
 125                            -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
 126
 127 minusFM         :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
 128                    -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
 129
 130 intersectFM     :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
 131 intersectFM_C   :: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)
 132                            -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3
 133
 134 --      MAPPING, FOLDING, FILTERING
 135 foldFM          :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
 136 mapFM           :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
 137 filterFM        :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
 138                            -> FiniteMap key elt -> FiniteMap key elt
 139
 140
 141 --      INTERROGATING
 142 sizeFM          :: FiniteMap key elt -> Int
 143 isEmptyFM       :: FiniteMap key elt -> Bool
 144
 145 elemFM          :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool
 146 lookupFM        :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt
 147 lookupWithDefaultFM
 148                 :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt
 149                 -- lookupWithDefaultFM supplies a "default" elt
 150                 -- to return for an unmapped key
 151
 152 --      LISTIFYING
 153 fmToList        :: FiniteMap key elt -> [(key,elt)]
 154 keysFM          :: FiniteMap key elt -> [key]
 155 eltsFM          :: FiniteMap key elt -> [elt]
 156 \end{code}
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection{The @FiniteMap@ data type, and building of same}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 Invariants about @FiniteMap@:
 165 \begin{enumerate}
 166 \item
 167 all keys in a FiniteMap are distinct
 168 \item
 169 all keys in left  subtree are $<$ key in Branch and
 170 all keys in right subtree are $>$ key in Branch
 171 \item
 172 size field of a Branch gives number of Branch nodes in the tree
 173 \item
 174 size of left subtree is differs from size of right subtree by a
 175 factor of at most \tr{sIZE_RATIO}
 176 \end{enumerate}
 177
 178 \begin{code}
 179 data FiniteMap key elt
 180   = EmptyFM
 181   | Branch key elt              -- Key and elt stored here
 182     IF_GHC(Int#,Int{-STRICT-})  -- Size >= 1
 183     (FiniteMap key elt)         -- Children
 184     (FiniteMap key elt)
 185 \end{code}
 186
 187 \begin{code}
 188 emptyFM = EmptyFM
 189 {-
 190 emptyFM
 191   = Branch bottom bottom IF_GHC(0#,0) bottom bottom
 192   where
 193     bottom = panic "emptyFM"
 194 -}
 195
 196 -- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
 197
 198 unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
 199
 200 listToFM = addListToFM emptyFM
 201
 202 bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM
 203 \end{code}
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsection{Adding to and deleting from @FiniteMaps@}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 \begin{code}
 212 addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
 213
 214 addToFM_C combiner EmptyFM key elt = unitFM key elt
 215 addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
 216   = case compare new_key key of
 217         LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
 218         GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
 219         EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
 220
 221 addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
 222
 223 addListToFM_C combiner fm key_elt_pairs
 224   = foldl' add fm key_elt_pairs -- foldl adds from the left
 225   where
 226     add fmap (key,elt) = addToFM_C combiner fmap key elt
 227 \end{code}
 228
 229 \begin{code}
 230 delFromFM EmptyFM del_key = emptyFM
 231 delFromFM (Branch key elt size fm_l fm_r) del_key
 232   = case compare del_key key of
 233         GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
 234         LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
 235         EQ -> glueBal fm_l fm_r
 236
 237 delListFromFM fm keys = foldl' delFromFM fm keys
 238 \end{code}
 239
 240 %************************************************************************
 241 %*                                                                      *
 242 \subsection{Combining @FiniteMaps@}
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 \begin{code}
 247 plusFM_C combiner EmptyFM fm2 = fm2
 248 plusFM_C combiner fm1 EmptyFM = fm1
 249 plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
 250   = mkVBalBranch split_key new_elt
 251                  (plusFM_C combiner lts left)
 252                  (plusFM_C combiner gts right)
 253   where
 254     lts     = splitLT fm1 split_key
 255     gts     = splitGT fm1 split_key
 256     new_elt = case lookupFM fm1 split_key of
 257                 Nothing   -> elt2
 258                 Just elt1 -> combiner elt1 elt2
 259
 260 -- It's worth doing plusFM specially, because we don't need
 261 -- to do the lookup in fm1.
 262 -- FM2 over-rides FM1.
 263
 264 plusFM EmptyFM fm2 = fm2
 265 plusFM fm1 EmptyFM = fm1
 266 plusFM fm1 (Branch split_key elt1 _ left right)
 267   = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
 268   where
 269     lts     = splitLT fm1 split_key
 270     gts     = splitGT fm1 split_key
 271
 272 minusFM EmptyFM fm2 = emptyFM
 273 minusFM fm1 EmptyFM = fm1
 274 minusFM fm1 (Branch split_key elt _ left right)
 275   = glueVBal (minusFM lts left) (minusFM gts right)
 276         -- The two can be way different, so we need glueVBal
 277   where
 278     lts = splitLT fm1 split_key         -- NB gt and lt, so the equal ones
 279     gts = splitGT fm1 split_key         -- are not in either.
 280
 281 intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2
 282
 283 intersectFM_C combiner fm1 EmptyFM = emptyFM
 284 intersectFM_C combiner EmptyFM fm2 = emptyFM
 285 intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
 286
 287   | maybeToBool maybe_elt1      -- split_elt *is* in intersection
 288   = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
 289                                                 (intersectFM_C combiner gts right)
 290
 291   | otherwise                   -- split_elt is *not* in intersection
 292   = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
 293
 294   where
 295     lts = splitLT fm1 split_key         -- NB gt and lt, so the equal ones
 296     gts = splitGT fm1 split_key         -- are not in either.
 297
 298     maybe_elt1 = lookupFM fm1 split_key
 299     Just elt1  = maybe_elt1
 300 \end{code}
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection{Mapping, folding, and filtering with @FiniteMaps@}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 \begin{code}
 309 foldFM k z EmptyFM = z
 310 foldFM k z (Branch key elt _ fm_l fm_r)
 311   = foldFM k (k key elt (foldFM k z fm_r)) fm_l
 312
 313 mapFM f EmptyFM = emptyFM
 314 mapFM f (Branch key elt size fm_l fm_r)
 315   = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
 316
 317 filterFM p EmptyFM = emptyFM
 318 filterFM p (Branch key elt _ fm_l fm_r)
 319   | p key elt           -- Keep the item
 320   = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
 321
 322   | otherwise           -- Drop the item
 323   = glueVBal (filterFM p fm_l) (filterFM p fm_r)
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection{Interrogating @FiniteMaps@}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 --{-# INLINE sizeFM #-}
 334 sizeFM EmptyFM               = 0
 335 sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)
 336
 337 isEmptyFM fm = sizeFM fm == 0
 338
 339 lookupFM EmptyFM key = Nothing
 340 lookupFM (Branch key elt _ fm_l fm_r) key_to_find
 341   = case compare key_to_find key of
 342         LT -> lookupFM fm_l key_to_find
 343         GT -> lookupFM fm_r key_to_find
 344         EQ -> Just elt
 345
 346 key `elemFM` fm
 347   = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
 348
 349 lookupWithDefaultFM fm deflt key
 350   = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
 351 \end{code}
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection{Listifying @FiniteMaps@}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 \begin{code}
 360 fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
 361 keysFM fm   = foldFM (\ key elt rest -> key : rest)       [] fm
 362 eltsFM fm   = foldFM (\ key elt rest -> elt : rest)       [] fm
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{The implementation of balancing}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsubsection{Basic construction of a @FiniteMap@}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 @mkBranch@ simply gets the size component right.  This is the ONLY
 379 (non-trivial) place the Branch object is built, so the ASSERTion
 380 recursively checks consistency.  (The trivial use of Branch is in
 381 @unitFM@.)
 382
 383 \begin{code}
 384 sIZE_RATIO :: Int
 385 sIZE_RATIO = 5
 386
 387 mkBranch :: (Ord key OUTPUTABLE_key)            -- Used for the assertion checking only
 388          => Int
 389          -> key -> elt
 390          -> FiniteMap key elt -> FiniteMap key elt
 391          -> FiniteMap key elt
 392
 393 mkBranch which key elt fm_l fm_r
 394   = --ASSERT( left_ok && right_ok && balance_ok )
 395 #if defined(DEBUG_FINITEMAPS)
 396     if not ( left_ok && right_ok && balance_ok ) then
 397         pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok],
 398                                        ppr key,
 399                                        ppr fm_l,
 400                                        ppr fm_r])
 401     else
 402 #endif
 403     let
 404         result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
 405     in
 406 --    if sizeFM result <= 8 then
 407         result
 408 --    else
 409 --      pprTrace ("mkBranch:"++(show which)) (ppr result) (
 410 --      result
 411 --      )
 412   where
 413     left_ok  = case fm_l of
 414                 EmptyFM                  -> True
 415                 Branch left_key _ _ _ _  -> let
 416                                                 biggest_left_key = fst (findMax fm_l)
 417                                             in
 418                                             biggest_left_key < key
 419     right_ok = case fm_r of
 420                 EmptyFM                  -> True
 421                 Branch right_key _ _ _ _ -> let
 422                                                 smallest_right_key = fst (findMin fm_r)
 423                                             in
 424                                             key < smallest_right_key
 425     balance_ok = True -- sigh
 426 {- LATER:
 427     balance_ok
 428       = -- Both subtrees have one or no elements...
 429         (left_size + right_size <= 1)
 430 -- NO         || left_size == 0  -- ???
 431 -- NO         || right_size == 0 -- ???
 432         -- ... or the number of elements in a subtree does not exceed
 433         -- sIZE_RATIO times the number of elements in the other subtree
 434       || (left_size  * sIZE_RATIO >= right_size &&
 435           right_size * sIZE_RATIO >= left_size)
 436 -}
 437
 438     left_size  = sizeFM fm_l
 439     right_size = sizeFM fm_r
 440
 441 #ifdef __GLASGOW_HASKELL__
 442     unbox :: Int -> Int#
 443     unbox (I# size) = size
 444 #else
 445     unbox :: Int -> Int
 446     unbox x = x
 447 #endif
 448 \end{code}
 449
 450 %************************************************************************
 451 %*                                                                      *
 452 \subsubsection{{\em Balanced} construction of a @FiniteMap@}
 453 %*                                                                      *
 454 %************************************************************************
 455
 456 @mkBalBranch@ rebalances, assuming that the subtrees aren't too far
 457 out of whack.
 458
 459 \begin{code}
 460 mkBalBranch :: (Ord key OUTPUTABLE_key)
 461             => key -> elt
 462             -> FiniteMap key elt -> FiniteMap key elt
 463             -> FiniteMap key elt
 464
 465 mkBalBranch key elt fm_L fm_R
 466
 467   | size_l + size_r < 2
 468   = mkBranch 1{-which-} key elt fm_L fm_R
 469
 470   | size_r > sIZE_RATIO * size_l        -- Right tree too big
 471   = case fm_R of
 472         Branch _ _ _ fm_rl fm_rr
 473                 | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
 474                 | otherwise                       -> double_L fm_L fm_R
 475         -- Other case impossible
 476
 477   | size_l > sIZE_RATIO * size_r        -- Left tree too big
 478   = case fm_L of
 479         Branch _ _ _ fm_ll fm_lr
 480                 | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
 481                 | otherwise                       -> double_R fm_L fm_R
 482         -- Other case impossible
 483
 484   | otherwise                           -- No imbalance
 485   = mkBranch 2{-which-} key elt fm_L fm_R
 486
 487   where
 488     size_l   = sizeFM fm_L
 489     size_r   = sizeFM fm_R
 490
 491     single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
 492         = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
 493
 494     double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
 495         = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)
 496                                  (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
 497
 498     single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
 499         = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
 500
 501     double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
 502         = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll  fm_lrl)
 503                                  (mkBranch 12{-which-} key   elt   fm_lrr fm_r)
 504 \end{code}
 505
 506
 507 \begin{code}
 508 mkVBalBranch :: (Ord key OUTPUTABLE_key)
 509              => key -> elt
 510              -> FiniteMap key elt -> FiniteMap key elt
 511              -> FiniteMap key elt
 512
 513 -- Assert: in any call to (mkVBalBranch_C comb key elt l r),
 514 --         (a) all keys in l are < all keys in r
 515 --         (b) all keys in l are < key
 516 --         (c) all keys in r are > key
 517
 518 mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
 519 mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
 520
 521 mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
 522                      fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
 523   | sIZE_RATIO * size_l < size_r
 524   = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
 525
 526   | sIZE_RATIO * size_r < size_l
 527   = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
 528
 529   | otherwise
 530   = mkBranch 13{-which-} key elt fm_l fm_r
 531
 532   where
 533     size_l = sizeFM fm_l
 534     size_r = sizeFM fm_r
 535 \end{code}
 536
 537 %************************************************************************
 538 %*                                                                      *
 539 \subsubsection{Gluing two trees together}
 540 %*                                                                      *
 541 %************************************************************************
 542
 543 @glueBal@ assumes its two arguments aren't too far out of whack, just
 544 like @mkBalBranch@.  But: all keys in first arg are $<$ all keys in
 545 second.
 546
 547 \begin{code}
 548 glueBal :: (Ord key OUTPUTABLE_key)
 549         => FiniteMap key elt -> FiniteMap key elt
 550         -> FiniteMap key elt
 551
 552 glueBal EmptyFM fm2 = fm2
 553 glueBal fm1 EmptyFM = fm1
 554 glueBal fm1 fm2
 555         -- The case analysis here (absent in Adams' program) is really to deal
 556         -- with the case where fm2 is a singleton. Then deleting the minimum means
 557         -- we pass an empty tree to mkBalBranch, which breaks its invariant.
 558   | sizeFM fm2 > sizeFM fm1
 559   = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
 560
 561   | otherwise
 562   = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
 563   where
 564     (mid_key1, mid_elt1) = findMax fm1
 565     (mid_key2, mid_elt2) = findMin fm2
 566 \end{code}
 567
 568 @glueVBal@ copes with arguments which can be of any size.
 569 But: all keys in first arg are $<$ all keys in second.
 570
 571 \begin{code}
 572 glueVBal :: (Ord key OUTPUTABLE_key)
 573          => FiniteMap key elt -> FiniteMap key elt
 574          -> FiniteMap key elt
 575
 576 glueVBal EmptyFM fm2 = fm2
 577 glueVBal fm1 EmptyFM = fm1
 578 glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
 579          fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
 580   | sIZE_RATIO * size_l < size_r
 581   = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
 582
 583   | sIZE_RATIO * size_r < size_l
 584   = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
 585
 586   | otherwise           -- We now need the same two cases as in glueBal above.
 587   = glueBal fm_l fm_r
 588   where
 589     size_l = sizeFM fm_l
 590     size_r = sizeFM fm_r
 591 \end{code}
 592
 593 %************************************************************************
 594 %*                                                                      *
 595 \subsection{Local utilities}
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
 601
 602 -- splitLT fm split_key  =  fm restricted to keys <  split_key
 603 -- splitGT fm split_key  =  fm restricted to keys >  split_key
 604
 605 splitLT EmptyFM split_key = emptyFM
 606 splitLT (Branch key elt _ fm_l fm_r) split_key
 607   = case compare split_key key of
 608         LT -> splitLT fm_l split_key
 609         GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
 610         EQ -> fm_l
 611
 612 splitGT EmptyFM split_key = emptyFM
 613 splitGT (Branch key elt _ fm_l fm_r) split_key
 614   = case compare split_key key of
 615         GT -> splitGT fm_r split_key
 616         LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
 617         EQ -> fm_r
 618
 619 findMin :: FiniteMap key elt -> (key,elt)
 620 findMin (Branch key elt _ EmptyFM _) = (key,elt)
 621 findMin (Branch key elt _ fm_l    _) = findMin fm_l
 622
 623 deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
 624 deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
 625 deleteMin (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
 626
 627 findMax :: FiniteMap key elt -> (key,elt)
 628 findMax (Branch key elt _ _ EmptyFM) = (key,elt)
 629 findMax (Branch key elt _ _    fm_r) = findMax fm_r
 630
 631 deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
 632 deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
 633 deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
 634 \end{code}
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection{Output-ery}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642 \begin{code}
 643 #if defined(DEBUG_FINITEMAPS)
 644
 645 instance (Outputable key) => Outputable (FiniteMap key elt) where
 646     ppr fm = pprX fm
 647
 648 pprX EmptyFM = char '!'
 649 pprX (Branch key elt sz fm_l fm_r)
 650  = parens (hcat [pprX fm_l, space,
 651                       ppr key, space, int (IF_GHC(I# sz, sz)), space,
 652                       pprX fm_r])
 653 #else
 654 -- and when not debugging the package itself...
 655 instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
 656     ppr fm = ppr (fmToList fm)
 657 #endif
 658
 659 #if 0
 660 instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
 661   fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test
 662                  (fmToList fm_1 == fmToList fm_2)
 663
 664 {- NO: not clear what The Right Thing to do is:
 665 instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
 666   fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test
 667                  (fmToList fm_1 <= fmToList fm_2)
 668 -}
 669 #endif
 670 \end{code}
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{Efficiency pragmas for GHC}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 When the FiniteMap module is used in GHC, we specialise it for
 679 \tr{Uniques}, for dastardly efficiency reasons.
 680
 681 \begin{code}
 682 #if 0
 683
 684 #if __GLASGOW_HASKELL__
 685
 686 {-# SPECIALIZE addListToFM
 687                 :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
 688                  , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt
 689     IF_NCG(COMMA   FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
 690     #-}
 691 {-# SPECIALIZE addListToFM_C
 692                 :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt
 693                  , (elt -> elt -> elt) -> FiniteMap FastString elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
 694     IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
 695     #-}
 696 {-# SPECIALIZE addToFM
 697                 :: FiniteMap CLabel elt -> CLabel -> elt  -> FiniteMap CLabel elt
 698                  , FiniteMap FastString elt -> FAST_STRING -> elt  -> FiniteMap FAST_STRING elt
 699                  , FiniteMap (FastString, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt  -> FiniteMap (FAST_STRING, FAST_STRING) elt
 700                  , FiniteMap RdrName elt -> RdrName -> elt  -> FiniteMap RdrName elt
 701     IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> elt  -> FiniteMap Reg elt)
 702     #-}
 703 {-# SPECIALIZE addToFM_C
 704                 :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt
 705                  , (elt -> elt -> elt) -> FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
 706     IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
 707     #-}
 708 {-# SPECIALIZE bagToFM
 709                 :: Bag (FastString,elt) -> FiniteMap FAST_STRING elt
 710     #-}
 711 {-# SPECIALIZE delListFromFM
 712                 :: FiniteMap RdrName elt -> [RdrName]   -> FiniteMap RdrName elt
 713                  , FiniteMap FastString elt -> [FAST_STRING]   -> FiniteMap FAST_STRING elt
 714     IF_NCG(COMMA   FiniteMap Reg elt -> [Reg]   -> FiniteMap Reg elt)
 715     #-}
 716 {-# SPECIALIZE listToFM
 717                 :: [([Char],elt)] -> FiniteMap [Char] elt
 718                  , [(FastString,elt)] -> FiniteMap FAST_STRING elt
 719                  , [((FastString,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
 720     IF_NCG(COMMA   [(Reg COMMA elt)] -> FiniteMap Reg elt)
 721     #-}
 722 {-# SPECIALIZE lookupFM
 723                 :: FiniteMap CLabel elt -> CLabel -> Maybe elt
 724                  , FiniteMap [Char] elt -> [Char] -> Maybe elt
 725                  , FiniteMap FastString elt -> FAST_STRING -> Maybe elt
 726                  , FiniteMap (FastString,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
 727                  , FiniteMap RdrName elt -> RdrName -> Maybe elt
 728                  , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
 729     IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> Maybe elt)
 730     #-}
 731 {-# SPECIALIZE lookupWithDefaultFM
 732                 :: FiniteMap FastString elt -> elt -> FAST_STRING -> elt
 733     IF_NCG(COMMA   FiniteMap Reg elt -> elt -> Reg -> elt)
 734     #-}
 735 {-# SPECIALIZE plusFM
 736                 :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt
 737                  , FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
 738     IF_NCG(COMMA   FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
 739     #-}
 740 {-# SPECIALIZE plusFM_C
 741                 :: (elt -> elt -> elt) -> FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
 742     IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
 743     #-}
 744
 745 #endif {- compiling with ghc and have specialiser -}
 746
 747 #endif {- 0 -}
 748 \end{code}