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