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