X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FFiniteMap.lhs;h=9168d3656f60006255f6651f89e31aefc3cbca9f;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=3eab99e875fb4747152f5248b0dd35538fa5516a;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 3eab99e..9168d36 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -1,5 +1,5 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1996 + +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section[FiniteMap]{An implementation of finite maps} @@ -15,23 +15,9 @@ This code is derived from that in the paper: \end{display} The code is SPECIALIZEd to various highly-desirable types (e.g., Id) -near the end (only \tr{#ifdef COMPILING_GHC}). +near the end. \begin{code} -#ifdef COMPILING_GHC -#include "HsVersions.h" -#define IF_NOT_GHC(a) {--} -#else -#define ASSERT(e) {--} -#define IF_NOT_GHC(a) a -#define COMMA , -#endif - -#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */ -#define OUTPUTABLE_key , Outputable key -#else -#define OUTPUTABLE_key {--} -#endif module FiniteMap ( FiniteMap, -- abstract type @@ -42,7 +28,7 @@ module FiniteMap ( addToFM_C, addListToFM, addListToFM_C, - IF_NOT_GHC(delFromFM COMMA) + delFromFM, delListFromFM, plusFM, @@ -50,39 +36,41 @@ module FiniteMap ( minusFM, foldFM, - IF_NOT_GHC(intersectFM COMMA) - IF_NOT_GHC(intersectFM_C COMMA) - IF_NOT_GHC(mapFM COMMA filterFM COMMA) + intersectFM, + intersectFM_C, + mapFM, filterFM, sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, fmToList, keysFM, eltsFM -#ifdef COMPILING_GHC , bagToFM - , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet - , elementOf, setToList, union, minusSet -#endif + ) where +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} + +#if defined(DEBUG_FINITEMAPS)/* NB NB NB */ +#define OUTPUTABLE_key , Outputable key +#else +#define OUTPUTABLE_key {--} +#endif + import Maybes +import Bag ( Bag, foldrBag ) +import Util +import Outputable -#ifdef COMPILING_GHC -IMP_Ubiq(){-uitous-} -# ifdef DEBUG -import Pretty -# endif -import Bag ( foldBag ) -import {-hide from mkdependHS-} - Name ( RdrName, OrigName ) -- specialising only +import GLAEXTS -# if ! OMIT_NATIVE_CODEGEN +#if ! OMIT_NATIVE_CODEGEN # define IF_NCG(a) a -# else +#else # define IF_NCG(a) {--} -# endif #endif + -- SIGH: but we use unboxed "sizes"... #if __GLASGOW_HASKELL__ #define IF_GHC(a,b) a @@ -104,10 +92,8 @@ emptyFM :: FiniteMap key elt unitFM :: key -> elt -> FiniteMap key elt listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt -- In the case of duplicates, the last is taken -#ifdef COMPILING_GHC bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt -- In the case of duplicates, who knows which is taken -#endif -- ADDING AND DELETING -- Throws away any previous binding @@ -117,6 +103,7 @@ addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> Fini addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt -- Combines with previous binding + -- The combining fn goes (old -> new -> new) addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) -> FiniteMap key elt -> key -> elt -> FiniteMap key elt @@ -142,8 +129,8 @@ minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt - -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3) + -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3 -- MAPPING, FOLDING, FILTERING foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a @@ -151,6 +138,7 @@ mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool) -> FiniteMap key elt -> FiniteMap key elt + -- INTERROGATING sizeFM :: FiniteMap key elt -> Int isEmptyFM :: FiniteMap key elt -> Bool @@ -206,15 +194,13 @@ emptyFM bottom = panic "emptyFM" -} --- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _) +-- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _) unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM listToFM = addListToFM emptyFM -#ifdef COMPILING_GHC -bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM -#endif +bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM \end{code} %************************************************************************ @@ -228,21 +214,15 @@ addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt addToFM_C combiner EmptyFM key elt = unitFM key elt addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp new_key key of - _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r - _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) - _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r -#else - | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r - | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) - | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r -#endif + = case compare new_key key of + LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs addListToFM_C combiner fm key_elt_pairs - = foldl add fm key_elt_pairs -- foldl adds from the left + = foldl' add fm key_elt_pairs -- foldl adds from the left where add fmap (key,elt) = addToFM_C combiner fmap key elt \end{code} @@ -250,23 +230,12 @@ addListToFM_C combiner fm key_elt_pairs \begin{code} delFromFM EmptyFM del_key = emptyFM delFromFM (Branch key elt size fm_l fm_r) del_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp del_key key of - _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) - _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r - _EQ -> glueBal fm_l fm_r -#else - | del_key > key - = mkBalBranch key elt fm_l (delFromFM fm_r del_key) - - | del_key < key - = mkBalBranch key elt (delFromFM fm_l del_key) fm_r - - | key == del_key - = glueBal fm_l fm_r -#endif + = case compare del_key key of + GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) + LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r + EQ -> glueBal fm_l fm_r -delListFromFM fm keys = foldl delFromFM fm keys +delListFromFM fm keys = foldl' delFromFM fm keys \end{code} %************************************************************************ @@ -291,6 +260,7 @@ plusFM_C combiner fm1 (Branch split_key elt2 _ left right) -- It's worth doing plusFM specially, because we don't need -- to do the lookup in fm1. +-- FM2 over-rides FM1. plusFM EmptyFM fm2 = fm2 plusFM fm1 EmptyFM = fm1 @@ -369,16 +339,10 @@ isEmptyFM fm = sizeFM fm == 0 lookupFM EmptyFM key = Nothing lookupFM (Branch key elt _ fm_l fm_r) key_to_find -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp key_to_find key of - _LT -> lookupFM fm_l key_to_find - _GT -> lookupFM fm_r key_to_find - _EQ -> Just elt -#else - | key_to_find < key = lookupFM fm_l key_to_find - | key_to_find > key = lookupFM fm_r key_to_find - | otherwise = Just elt -#endif + = case compare key_to_find key of + LT -> lookupFM fm_l key_to_find + GT -> lookupFM fm_r key_to_find + EQ -> Just elt key `elemFM` fm = case (lookupFM fm key) of { Nothing -> False; Just elt -> True } @@ -429,12 +393,12 @@ mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only mkBranch which key elt fm_l fm_r = --ASSERT( left_ok && right_ok && balance_ok ) -#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS) +#if defined(DEBUG_FINITEMAPS) if not ( left_ok && right_ok && balance_ok ) then - pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok], - ppr PprDebug key, - ppr PprDebug fm_l, - ppr PprDebug fm_r]) + pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok], + ppr key, + ppr fm_l, + ppr fm_r]) else #endif let @@ -443,7 +407,7 @@ mkBranch which key elt fm_l fm_r -- if sizeFM result <= 8 then result -- else --- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) ( +-- pprTrace ("mkBranch:"++(show which)) (ppr result) ( -- result -- ) where @@ -623,8 +587,6 @@ glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr) | otherwise -- We now need the same two cases as in glueBal above. = glueBal fm_l fm_r where - (mid_key_l,mid_elt_l) = findMax fm_l - (mid_key_r,mid_elt_r) = findMin fm_r size_l = sizeFM fm_l size_r = sizeFM fm_r \end{code} @@ -643,29 +605,17 @@ splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Fini splitLT EmptyFM split_key = emptyFM splitLT (Branch key elt _ fm_l fm_r) split_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp split_key key of - _LT -> splitLT fm_l split_key - _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) - _EQ -> fm_l -#else - | split_key < key = splitLT fm_l split_key - | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key) - | otherwise = fm_l -#endif + = case compare split_key key of + LT -> splitLT fm_l split_key + GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) + EQ -> fm_l splitGT EmptyFM split_key = emptyFM splitGT (Branch key elt _ fm_l fm_r) split_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp split_key key of - _GT -> splitGT fm_r split_key - _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r - _EQ -> fm_r -#else - | split_key > key = splitGT fm_r split_key - | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r - | otherwise = fm_r -#endif + = case compare split_key key of + GT -> splitGT fm_r split_key + LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r + EQ -> fm_r findMin :: FiniteMap key elt -> (key,elt) findMin (Branch key elt _ EmptyFM _) = (key,elt) @@ -691,19 +641,23 @@ deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax %************************************************************************ \begin{code} -#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS) +#if defined(DEBUG_FINITEMAPS) instance (Outputable key) => Outputable (FiniteMap key elt) where - ppr sty fm = pprX sty fm + ppr fm = pprX fm -pprX sty EmptyFM = ppChar '!' -pprX sty (Branch key elt sz fm_l fm_r) - = ppBesides [ppLparen, pprX sty fm_l, ppSP, - ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP, - pprX sty fm_r, ppRparen] +pprX EmptyFM = char '!' +pprX (Branch key elt sz fm_l fm_r) + = parens (hcat [pprX fm_l, space, + ppr key, space, int (IF_GHC(I# sz, sz)), space, + pprX fm_r]) +#else +-- and when not debugging the package itself... +instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where + ppr fm = ppr (fmToList fm) #endif -#ifndef COMPILING_GHC +#if 0 instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test (fmToList fm_1 == fmToList fm_2) @@ -718,35 +672,6 @@ instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where %************************************************************************ %* * -\subsection{FiniteSets---a thin veneer} -%* * -%************************************************************************ - -\begin{code} -#ifdef COMPILING_GHC - -type FiniteSet key = FiniteMap key () -emptySet :: FiniteSet key -mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key -isEmptySet :: FiniteSet key -> Bool -elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool -minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key -setToList :: FiniteSet key -> [key] -union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key - -emptySet = emptyFM -mkSet xs = listToFM [ (x, ()) | x <- xs] -isEmptySet = isEmptyFM -elementOf = elemFM -minusSet = minusFM -setToList = keysFM -union = plusFM - -#endif -\end{code} - -%************************************************************************ -%* * \subsection{Efficiency pragmas for GHC} %* * %************************************************************************ @@ -755,73 +680,70 @@ When the FiniteMap module is used in GHC, we specialise it for \tr{Uniques}, for dastardly efficiency reasons. \begin{code} -#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3) +#if 0 + +#if __GLASGOW_HASKELL__ {-# SPECIALIZE addListToFM - :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE addListToFM_C :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt - , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt + , (elt -> elt -> elt) -> FiniteMap FastString elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE addToFM :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt - , FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt - , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt + , FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt + , FiniteMap (FastString, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE addToFM_C :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt - , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt - , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt + , (elt -> elt -> elt) -> FiniteMap FastString elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE bagToFM - :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt + :: Bag (FastString,elt) -> FiniteMap FAST_STRING elt #-} {-# SPECIALIZE delListFromFM :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt - , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt + , FiniteMap FastString elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) #-} {-# SPECIALIZE listToFM :: [([Char],elt)] -> FiniteMap [Char] elt - , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt - , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt - , [(OrigName,elt)] -> FiniteMap OrigName elt + , [(FastString,elt)] -> FiniteMap FAST_STRING elt + , [((FastString,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE lookupFM :: FiniteMap CLabel elt -> CLabel -> Maybe elt , FiniteMap [Char] elt -> [Char] -> Maybe elt - , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt - , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt - , FiniteMap OrigName elt -> OrigName -> Maybe elt - , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt + , FiniteMap FastString elt -> FAST_STRING -> Maybe elt + , FiniteMap (FastString,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt , FiniteMap RdrName elt -> RdrName -> Maybe elt , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) #-} {-# SPECIALIZE lookupWithDefaultFM - :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt + :: FiniteMap FastString elt -> elt -> FAST_STRING -> elt IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) #-} {-# SPECIALIZE plusFM :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt - , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt + , FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE plusFM_C - :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt + :: (elt -> elt -> elt) -> FiniteMap FastString elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} -#endif {- compiling for GHC -} +#endif /* compiling with ghc and have specialiser */ + +#endif /* 0 */ \end{code}