diff options
| author | Ian Lynagh <igloo@earth.li> | 2010-09-14 20:17:03 +0000 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2010-09-14 20:17:03 +0000 |
| commit | e95ee1f718c6915c478005aad8af81705357d6ab (patch) | |
| tree | 0b19fdfd9d02b195b371e0f6ef8d413936113519 /compiler | |
| parent | 83a8fc9f6e04436784693a2188a58eac9c3e9664 (diff) | |
| download | haskell-e95ee1f718c6915c478005aad8af81705357d6ab.tar.gz | |
Remove (most of) the FiniteMap wrapper
We still have
insertList, insertListWith, deleteList
which aren't in Data.Map, and
foldRightWithKey
which works around the fold(r)WithKey addition and deprecation.
Diffstat (limited to 'compiler')
28 files changed, 338 insertions, 470 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index ef93a4739e..072d011166 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -5,7 +5,7 @@ Module ~~~~~~~~~~ Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build FiniteMaps with Modules as +These are Uniquable, hence we can build Maps with Modules as the keys. \begin{code} @@ -60,7 +60,7 @@ module Module lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, moduleEnvKeys, moduleEnvElts, moduleEnvToList, unitModuleEnv, isEmptyModuleEnv, - foldModuleEnv, extendModuleEnv_C, filterModuleEnv, + foldModuleEnv, extendModuleEnvWith, filterModuleEnv, -- * ModuleName mappings ModuleNameEnv, @@ -76,13 +76,15 @@ import Config import Outputable import qualified Pretty import Unique -import FiniteMap import UniqFM import FastString import Binary import Util import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map import System.FilePath \end{code} @@ -370,76 +372,76 @@ mainPackageId = fsToPackageId (fsLit "main") \begin{code} -- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (FiniteMap Module elt) +newtype ModuleEnv elt = ModuleEnv (Map Module elt) filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = ModuleEnv (filterFM f e) +filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e) elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = elemFM m e +elemModuleEnv m (ModuleEnv e) = Map.member m e extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (addToFM e m x) +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e) -extendModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv_C f (ModuleEnv e) m x = ModuleEnv (addToFM_C f e m x) +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e) extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (addListToFM e xs) +extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e) extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (addListToFM_C f e xs) +extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e) plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM_C f e1 e2) +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2) delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = ModuleEnv (delListFromFM e ms) +delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e) delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (delFromFM e m) +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e) plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM e1 e2) +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = lookupFM e m +lookupModuleEnv (ModuleEnv e) m = Map.lookup m e lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = lookupWithDefaultFM e x m +lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (mapFM (\_ v -> f v) e) +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (listToFM xs) +mkModuleEnv xs = ModuleEnv (Map.fromList xs) emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv emptyFM +emptyModuleEnv = ModuleEnv Map.empty moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = keysFM e +moduleEnvKeys (ModuleEnv e) = Map.keys e moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts (ModuleEnv e) = eltsFM e +moduleEnvElts (ModuleEnv e) = Map.elems e moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = fmToList e +moduleEnvToList (ModuleEnv e) = Map.toList e unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (unitFM m x) +unitModuleEnv m x = ModuleEnv (Map.singleton m x) isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = isEmptyFM e +isEmptyModuleEnv (ModuleEnv e) = Map.null e foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b -foldModuleEnv f x (ModuleEnv e) = foldFM (\_ v -> f v) x e +foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e \end{code} \begin{code} -- | A set of 'Module's -type ModuleSet = FiniteMap Module () +type ModuleSet = Map Module () mkModuleSet :: [Module] -> ModuleSet extendModuleSet :: ModuleSet -> Module -> ModuleSet @@ -447,11 +449,11 @@ emptyModuleSet :: ModuleSet moduleSetElts :: ModuleSet -> [Module] elemModuleSet :: Module -> ModuleSet -> Bool -emptyModuleSet = emptyFM -mkModuleSet ms = listToFM [(m,()) | m <- ms ] -extendModuleSet s m = addToFM s m () -moduleSetElts = keysFM -elemModuleSet = elemFM +emptyModuleSet = Map.empty +mkModuleSet ms = Map.fromList [(m,()) | m <- ms ] +extendModuleSet s m = Map.insert m () s +moduleSetElts = Map.keys +elemModuleSet = Map.member \end{code} A ModuleName has a Unique, so we can build mappings of these using diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 0ba8cc0c51..0e87c6cd84 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -33,7 +33,6 @@ import CmmTx import DFMonad import Module import FastString -import FiniteMap import ForeignCall import IdInfo import Data.List @@ -54,6 +53,10 @@ import qualified ZipCfg as G import ZipCfgCmmRep import ZipDataflow +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + ---------------------------------------------------------------- -- Building InfoTables @@ -133,12 +136,12 @@ live_ptrs oldByte slotEnv areaMap bid = liveSlots :: [RegSlotInfo] liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off) - (foldFM (\_ -> flip $ foldl add_slot) [] slots) + (Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots) add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo] add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = if off == w && widthInBytes (typeWidth ty) == w then - (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst + (expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst else panic "live_ptrs: only part of a variable live at a proc point" add_slot rst (CallArea Old, _, _) = rst -- the update frame (or return infotable) should be live @@ -155,7 +158,7 @@ live_ptrs oldByte slotEnv areaMap bid = slots :: SubAreaSet -- The SubAreaSet for 'bid' slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid - youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid)) + youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap -- Construct the stack maps for the given procedure. setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables @@ -187,14 +190,16 @@ setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" ----------------------------------------------------------------------- -- Finding the CAFs used by a procedure -type CAFSet = FiniteMap CLabel () +type CAFSet = Map CLabel () type CAFEnv = BlockEnv CAFSet -- First, an analysis to find live CAFs. cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice "live cafs" emptyFM add False - where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new' - where new' = new `plusFM` old +cafLattice = DataflowLattice "live cafs" Map.empty add False + where add new old = if Map.size new' > Map.size old + then aTx new' + else noTx new' + where new' = new `Map.union` old cafTransfers :: BackwardTransfers Middle Last CAFSet cafTransfers = BackwardTransfers first middle last @@ -206,7 +211,7 @@ cafTransfers = BackwardTransfers first middle last CmmLit (CmmLabelOff c _) -> add c set CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set _ -> set - add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () else s + add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a) cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv @@ -222,7 +227,7 @@ cafAnal g = liftM zdfFpFacts (res :: CafFix ()) data TopSRT = TopSRT { lbl :: CLabel , next_elt :: Int -- the next entry in the table , rev_elts :: [CLabel] - , elt_map :: FiniteMap CLabel Int } + , elt_map :: Map CLabel Int } -- map: CLabel -> its last entry in the table instance Outputable TopSRT where ppr (TopSRT lbl next elts eltmap) = @@ -231,19 +236,19 @@ instance Outputable TopSRT where emptySRT :: MonadUnique m => m TopSRT emptySRT = do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs - return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = emptyFM } + return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } cafMember :: TopSRT -> CLabel -> Bool -cafMember srt lbl = elemFM lbl (elt_map srt) +cafMember srt lbl = Map.member lbl (elt_map srt) cafOffset :: TopSRT -> CLabel -> Maybe Int -cafOffset srt lbl = lookupFM (elt_map srt) lbl +cafOffset srt lbl = Map.lookup lbl (elt_map srt) addCAF :: CLabel -> TopSRT -> TopSRT addCAF caf srt = srt { next_elt = last + 1 , rev_elts = caf : rev_elts srt - , elt_map = addToFM (elt_map srt) caf last } + , elt_map = Map.insert caf last (elt_map srt) } where last = next_elt srt srtToData :: TopSRT -> CmmZ @@ -258,16 +263,16 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, -- we make sure they're all close enough to the bottom of the table that the -- bitmap will be able to cover all of them. -buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet -> +buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet -> FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT) buildSRTs topSRT topCAFMap cafs = do let liftCAF lbl () z = -- get CAFs for functions without static closures - case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs - Nothing -> addToFM z lbl () + case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs + Nothing -> Map.insert lbl () z -- For each label referring to a function f without a static closure, -- replace it with the CAFs that are reachable from f. sub_srt topSRT localCafs = - let cafs = keysFM (foldFM liftCAF emptyFM localCafs) + let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty localCafs) mkSRT topSRT = do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs return (topSRT, localSRTs) @@ -283,7 +288,7 @@ buildSRTs topSRT topCAFMap cafs = add_if_too_far srt@(TopSRT {elt_map = m}) cafs = add srt (sortBy farthestFst cafs) where - farthestFst x y = case (lookupFM m x, lookupFM m y) of + farthestFst x y = case (Map.lookup x m, Map.lookup y m) of (Nothing, Nothing) -> EQ (Nothing, Just _) -> LT (Just _, Nothing) -> GT @@ -301,7 +306,7 @@ buildSRTs topSRT topCAFMap cafs = -- Construct an SRT bitmap. -- Adapted from simpleStg/SRT.lhs, which expects Id's. -procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] -> +procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] -> FuelMonad (Maybe CmmTopZ, C_SRT) procpointSRT _ _ [] = return (Nothing, NoC_SRT) @@ -309,7 +314,7 @@ procpointSRT top_srt top_table entries = do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap return (top, srt) where - ints = map (expectJust "constructSRT" . lookupFM top_table) entries + ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries sorted_ints = sortLe (<=) ints offset = head sorted_ints bitmap_entries = map (subtract offset) sorted_ints @@ -361,21 +366,21 @@ localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) -- the environment with every reference to f replaced by its set of CAFs. -- To do this replacement efficiently, we gather strongly connected -- components, then we sort the components in topological order. -mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet -mkTopCAFInfo localCAFs = foldl addToTop emptyFM g +mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet +mkTopCAFInfo localCAFs = foldl addToTop Map.empty g where addToTop env (AcyclicSCC (l, cafset)) = - addToFM env l (flatten env cafset) + Map.insert l (flatten env cafset) env addToTop env (CyclicSCC nodes) = let (lbls, cafsets) = unzip nodes - cafset = foldl plusFM emptyFM cafsets `delListFromFM` lbls - in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls - flatten env cafset = foldFM (lookup env) emptyFM cafset + cafset = lbls `Map.deleteList` foldl Map.union Map.empty cafsets + in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls + flatten env cafset = Map.foldRightWithKey (lookup env) Map.empty cafset lookup env caf () cafset' = - case lookupFM env caf of Just cafs -> foldFM add cafset' cafs - Nothing -> add caf () cafset' - add caf () cafset' = addToFM cafset' caf () + case Map.lookup caf env of Just cafs -> Map.foldRightWithKey add cafset' cafs + Nothing -> add caf () cafset' + add caf () cafset' = Map.insert caf () cafset' g = stronglyConnCompFromEdgedVertices - (map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs) + (map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs) type StackLayout = [Maybe LocalReg] @@ -388,10 +393,10 @@ bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) = -- until we stop splitting the graphs at procpoints in the native path bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) = (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t) -bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t) +bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t) -- Construct the SRTs for the given procedure. -setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) -> +setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) -> FuelMonad (TopSRT, [CmmTopForInfoTables]) setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) = case blockSetToList procpoints of @@ -402,7 +407,7 @@ setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) = setSRT cafs topCAFMap topSRT t setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t]) -setSRT :: CAFSet -> FiniteMap CLabel CAFSet -> TopSRT -> +setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT -> CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables]) setSRT cafs topCAFMap topSRT t = do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index fa568afdc9..d74da69d06 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -24,10 +24,11 @@ import ZipCfgCmmRep import DynFlags import ErrUtils -import FiniteMap import HscTypes import Data.Maybe import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map import Outputable import StaticFlags @@ -73,7 +74,7 @@ global to one compiler session. cpsTop :: HscEnv -> CmmTopZ -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTopForInfoTables)]) -cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)]) +cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)]) cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = do dump Opt_D_dump_cmmz "Pre Proc Points Added" g @@ -172,7 +173,7 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = -- This probably belongs in CmmBuildInfoTables? -- We're just finishing the job here: once we know what CAFs are defined -- in non-static closures, we can build the SRTs. -toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) +toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]]) toTops hsc_env topCAFEnv (topSRT, tops) gs = diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 39099f1e05..8a5bab1f6c 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -49,13 +49,13 @@ import BlockId import CLabel import Constants import FastString -import FiniteMap import Outputable import Unique import UniqSet import Data.Word import Data.Int +import Data.Map (Map) ----------------------------------------------------------------------------- -- CmmExpr @@ -117,9 +117,9 @@ necessarily at the young end of the Old area. End of note -} type SubArea = (Area, Int, Int) -- area, offset, width -type SubAreaSet = FiniteMap Area [SubArea] +type SubAreaSet = Map Area [SubArea] -type AreaMap = FiniteMap Area Int +type AreaMap = Map Area Int -- Byte offset of the oldest byte of the Area, -- relative to the oldest byte of the Old Area diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 13f6421d08..c972ad59ab 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -15,7 +15,6 @@ import CmmInfo import CmmLiveZ import CmmTx import DFMonad -import FiniteMap import Data.List (sortBy) import Maybes import MkZipCfg @@ -28,6 +27,8 @@ import ZipCfg import ZipCfgCmmRep import ZipDataflow +import qualified Data.Map as Map + -- Compute a minimal set of proc points for a control-flow graph. -- Determine a protocol for each proc point (which live variables will @@ -399,9 +400,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g -- Build a map from proc point BlockId to labels for their new procedures -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = return $ addToFM map pp lbl + let add_label map pp = return $ Map.insert pp lbl map where lbl = if pp == entry then entry_label else blockLbl pp - procLabels <- foldM add_label emptyFM + procLabels <- foldM add_label Map.empty (filter (elemBlockEnv blocks) (blockSetToList procPoints)) -- For each procpoint, we need to know the SP offset on entry. -- If the procpoint is: @@ -434,7 +435,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap add_if_pp ti (add_if_pp fi rst) LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl) _ -> rst - add_if_pp id rst = case lookupFM procLabels id of + add_if_pp id rst = case Map.lookup id procLabels of Just x -> (id, x) : rst Nothing -> rst (jumpEnv, jumpBlocks) <- @@ -456,14 +457,14 @@ splitAtProcPoints entry_label callPPs procPoints procMap CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g) else CmmProc emptyContInfoTable lbl [] (replacePPIds g) - where lbl = expectJust "pp label" $ lookupFM procLabels bid + where lbl = expectJust "pp label" $ Map.lookup bid procLabels to_proc (bid, g) = CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g) - where lbl = expectJust "pp label" $ lookupFM procLabels bid + where lbl = expectJust "pp label" $ Map.lookup bid procLabels -- References to procpoint IDs can now be replaced with the infotable's label replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g) where repl e@(CmmLit (CmmBlock bid)) = - case lookupFM procLabels bid of + case Map.lookup bid procLabels of Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l)) Nothing -> e repl e = e diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index dedb6b0a1b..06204ef9c3 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -18,7 +18,6 @@ import CmmExpr import CmmProcPointZ import CmmTx import DFMonad -import FiniteMap import Maybes import MkZipCfg import MkZipCfgCmm hiding (CmmBlock, CmmGraph) @@ -30,6 +29,10 @@ import ZipCfg as Z import ZipCfgCmmRep import ZipDataflow +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + ------------------------------------------------------------------------ -- Stack Layout -- ------------------------------------------------------------------------ @@ -63,14 +66,14 @@ import ZipDataflow -- a single slot, on insertion. slotLattice :: DataflowLattice SubAreaSet -slotLattice = DataflowLattice "live slots" emptyFM add False - where add new old = case foldFM addArea (False, old) new of +slotLattice = DataflowLattice "live slots" Map.empty add False + where add new old = case Map.foldRightWithKey addArea (False, old) new of (True, x) -> aTx x (False, x) -> noTx x addArea a newSlots z = foldr (addSlot a) z newSlots addSlot a slot (changed, map) = - let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a - in (c || changed, addToFM map a live) + let (c, live) = liveGen slot $ Map.findWithDefault [] a map + in (c || changed, Map.insert a live map) type SlotEnv = BlockEnv SubAreaSet -- The sub-areas live on entry to the block @@ -122,17 +125,17 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $ liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet liveSlotTransfers = BackwardTransfers first liveInSlots liveLastIn - where first id live = delFromFM live (CallArea (Young id)) + where first id live = Map.delete (CallArea (Young id)) live -- Slot sets: adding slots, removing slots, and checking for membership. liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet elemSlot :: SubAreaSet -> SubArea -> Bool -liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a) +liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map addSlot live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live removeSlot live (a, i, w) = liftToArea a (liveKill (a, i, w)) live elemSlot live (a, i, w) = - not $ fst $ liveGen (a, i, w) (lookupWithDefaultFM live [] a) + not $ fst $ liveGen (a, i, w) (Map.findWithDefault [] a live) removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet removeLiveSlotDefs = foldSlotsDefd removeSlot @@ -163,7 +166,7 @@ liveLastOut env l = where out = joinOuts slotLattice env l add_area _ n live | n == 0 = live add_area a n live = - addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a + Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live -- The liveness analysis must be precise: otherwise, we won't know if a definition -- should really kill a live-out stack slot. @@ -174,7 +177,7 @@ liveLastOut env l = -- every time, I provide a function to fold over the nodes, which should be a -- reasonably efficient approach for the implementations we envision. -- Of course, it will probably be much easier to program if we just return a list... -type Set x = FiniteMap x () +type Set x = Map x () data IGraphBuilder n = Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int] @@ -184,8 +187,8 @@ areaBuilder :: IGraphBuilder Area areaBuilder = Builder fold words where fold (a, _, _) f z = f a z words areaSize areaMap a = - case lookupFM areaMap a of - Just addr -> [addr .. addr + (lookupFM areaSize a `orElse` + case Map.lookup a areaMap of + Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse` pprPanic "wordsOccupied: unknown area" (ppr a))] Nothing -> [] @@ -195,10 +198,10 @@ areaBuilder = Builder fold words -- Now, we can build the interference graph. -- The usual story: a definition interferes with all live outs and all other -- definitions. -type IGraph x = FiniteMap x (Set x) +type IGraph x = Map x (Set x) type IGPair x = (IGraph x, IGraphBuilder x) igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x -igraph builder env g = foldr interfere emptyFM (postorder_dfs g) +igraph builder env g = foldr interfere Map.empty (postorder_dfs g) where foldN = foldNodes builder interfere block igraph = let (h, l) = goto_end (unzip block) @@ -210,15 +213,15 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g) addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i addDef (igraph, out) def@(a, _, _) = (foldN def (addDefN out) igraph, - addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a))) + Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out) addDefN out n igraph = let addEdgeNO o igraph = foldN o addEdgeNN igraph addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph - addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ()) - where set = lookupWithDefaultFM igraph emptyFM n - in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out + addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph + where set = Map.findWithDefault Map.empty n igraph + in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" - in heads h $ case l of LastExit -> (igraph, emptyFM) + in heads h $ case l of LastExit -> (igraph, Map.empty) LastOther l -> (addEdges igraph l $ liveLastOut env' l, liveLastIn l env') @@ -230,7 +233,7 @@ getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap -- used for (a) variable spill slots, and (b) parameter passing ares for calls getAreaSize entry_off g@(LGraph _ _) = fold_blocks (fold_fwd_block first add_regslots last) - (unitFM (CallArea Old) entry_off) g + (Map.singleton (CallArea Old) entry_off) g where first _ z = z last l@(LastOther (LastCall _ Nothing args res _)) z = add_regslots l (add (add z area args) area res) @@ -243,7 +246,7 @@ getAreaSize entry_off g@(LGraph _ _) = addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) = add z a $ widthInBytes $ typeWidth ty addSlot z _ = z - add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a)) + add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z -- The 'max' is important. Two calls, to f and g, might share a common -- continuation (and hence a common CallArea), but their number of overflow -- parameters might differ. @@ -252,19 +255,19 @@ getAreaSize entry_off g@(LGraph _ _) = -- Find the Stack slots occupied by the subarea's conflicts conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = - foldNodes subarea foldNode emptyFM - where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n + foldNodes subarea foldNode Map.empty + where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig conflict n' () set = liveInSlots areaMap n' set -- Add stack slots occupied by igraph node n liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) - setAdd w s = addToFM s w () + setAdd w s = Map.insert w () s -- Find any open space on the stack, starting from the offset. -- If the area is a CallArea or a spill slot for a pointer, then it must -- be word-aligned. freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int freeSlotFrom ig areaSize offset areaMap area = - let size = lookupFM areaSize area `orElse` 0 + let size = Map.lookup area areaSize `orElse` 0 conflicts = conflictSlots ig areaSize areaMap (area, size, size) -- CallAreas and Ptrs need to be word-aligned (round up!) align = case area of CallArea _ -> align' @@ -274,7 +277,7 @@ freeSlotFrom ig areaSize offset areaMap area = -- Find a space big enough to hold the area findSpace curr 0 = curr findSpace curr cnt = -- part of target slot, # of bytes left to check - if elemFM curr conflicts then + if Map.member curr conflicts then findSpace (align (curr + size)) size -- try the next (possibly) open space else findSpace (curr - 1) (cnt - 1) in findSpace (align (offset + size)) size @@ -282,8 +285,8 @@ freeSlotFrom ig areaSize offset areaMap area = -- Find an open space on the stack, and assign it to the area. allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap allocSlotFrom ig areaSize from areaMap area = - if elemFM area areaMap then areaMap - else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area + if Map.member area areaMap then areaMap + else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap -- | Greedy stack layout. -- Compute liveness, build the interference graph, and allocate slots for the areas. @@ -319,7 +322,7 @@ layout procPoints env entry_off g = -- Find the slots that are live-in to a block tail live_in (ZTail m l) = liveInSlots m (live_in l) live_in (ZLast (LastOther l)) = liveLastIn l env' - live_in (ZLast LastExit) = emptyFM + live_in (ZLast LastExit) = Map.empty -- Find the youngest live stack slot that has already been allocated youngest_live :: AreaMap -- Already allocated @@ -327,17 +330,17 @@ layout procPoints env entry_off g = -> ByteOff -- Offset of the youngest byte of any -- already-allocated, live sub-area youngest_live areaMap live = fold_subareas young_slot live 0 - where young_slot (a, o, _) z = case lookupFM areaMap a of + where young_slot (a, o, _) z = case Map.lookup a areaMap of Just top -> max z $ top + o Nothing -> z - fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m + fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m -- Allocate space for spill slots and call areas allocVarSlot = allocSlotFrom ig areaSize 0 -- Update the successor's incoming SP. setSuccSPs inSp bid areaMap = - case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of + case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of (Just _, _) -> areaMap -- succ already knows incoming SP (Nothing, Just (Block _ _)) -> if elemBlockSet bid procPoints then @@ -347,18 +350,18 @@ layout procPoints env entry_off g = start = young -- maybe wrong, but I don't understand -- why the preceding is necessary... in allocSlotFrom ig areaSize start areaMap area - else addToFM areaMap area inSp + else Map.insert area inSp areaMap (_, Nothing) -> panic "Block not found in cfg" where area = CallArea (Young bid) allocLast (Block id _) areaMap l = fold_succs (setSuccSPs inSp) l areaMap - where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id)) + where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap = let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m area = CallArea (Young bid) - areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord)) + areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize in allocSlotFrom ig areaSize' young areaMap area allocMidCall _ _ areaMap = areaMap @@ -370,8 +373,8 @@ layout procPoints env entry_off g = layoutAreas areaMap b@(Block _ t) = layout areaMap t where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t layout areaMap (ZLast l) = allocLast b areaMap l - initMap = addToFM (addToFM emptyFM (CallArea Old) 0) - (CallArea (Young (lg_entry g))) 0 + initMap = Map.insert (CallArea (Young (lg_entry g))) 0 + (Map.insert (CallArea Old) 0 Map.empty) areaMap = foldl layoutAreas initMap (postorder_dfs g) in -- pprTrace "ProcPoints" (ppr procPoints) $ -- pprTrace "Area SizeMap" (ppr areaSize) $ @@ -392,7 +395,7 @@ manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Midd manifestSP areaMap entry_off g@(LGraph entry _blocks) = liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g) where slot a = -- pprTrace "slot" (ppr a) $ - lookupFM areaMap a `orElse` panic "unallocated Area" + Map.lookup a areaMap `orElse` panic "unallocated Area" slot' (Just id) = slot $ CallArea (Young id) slot' Nothing = slot $ CallArea Old sp_high = maxSlot slot g diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 9f284c8926..a36a356d6d 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -44,7 +44,6 @@ import ClosureInfo import DynFlags import Unique import UniqSet -import FiniteMap import UniqFM import FastString import Outputable @@ -57,6 +56,8 @@ import Data.List import Data.Bits import Data.Char import System.IO +import Data.Map (Map) +import qualified Data.Map as Map import Data.Word import Data.Array.ST @@ -865,12 +866,12 @@ is_cish StdCallConv = True pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) pprTempAndExternDecls stmts = (vcat (map pprTempDecl (uniqSetToList temps)), - vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))) + vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) where (temps, lbls) = runTE (mapM_ te_BB stmts) pprDataExterns :: [CmmStatic] -> SDoc pprDataExterns statics - = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)) + = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)) where (_, lbls) = runTE (mapM_ te_Static statics) pprTempDecl :: LocalReg -> SDoc @@ -901,7 +902,7 @@ pprExternDecl in_srt lbl <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth))) <> semi -type TEState = (UniqSet LocalReg, FiniteMap CLabel ()) +type TEState = (UniqSet LocalReg, Map CLabel ()) newtype TE a = TE { unTE :: TEState -> (a, TEState) } instance Monad TE where @@ -909,13 +910,13 @@ instance Monad TE where return a = TE $ \s -> (a, s) te_lbl :: CLabel -> TE () -te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ())) +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) te_temp :: LocalReg -> TE () te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) runTE :: TE () -> TEState -runTE (TE m) = snd (m (emptyUniqSet, emptyFM)) +runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) te_Static :: CmmStatic -> TE () te_Static (CmmStaticLit lit) = te_Lit lit diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index f32ce93609..21ce13dbe3 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -23,7 +23,6 @@ import FastString import HscTypes import StaticFlags import TyCon -import FiniteMap import MonadUtils import Maybes @@ -35,6 +34,8 @@ import Trace.Hpc.Util import BreakArray import Data.HashTable ( hashString ) +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -76,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = { fileName = mkFastString orig_file2 , declPath = [] , inScope = emptyVarSet - , blackList = listToFM [ (getSrcSpan (tyConName tyCon),()) - | tyCon <- tyCons ] + , blackList = Map.fromList [ (getSrcSpan (tyConName tyCon),()) + | tyCon <- tyCons ] }) (TT { tickBoxCount = 0 @@ -574,7 +575,7 @@ data TickTransState = TT { tickBoxCount:: Int data TickTransEnv = TTE { fileName :: FastString , declPath :: [String] , inScope :: VarSet - , blackList :: FiniteMap SrcSpan () + , blackList :: Map SrcSpan () } -- deriving Show @@ -658,7 +659,7 @@ bindLocals new_ids (TM m) isBlackListed :: SrcSpan -> TM Bool isBlackListed pos = TM $ \ env st -> - case lookupFM (blackList env) pos of + case Map.lookup pos (blackList env) of Nothing -> (False,noFVs,st) Just () -> (True,noFVs,st) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d64a649b37..649b2f135e 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -42,9 +42,10 @@ import SrcLoc import Maybes import Util import Name -import FiniteMap import Outputable import FastString + +import qualified Data.Map as Map \end{code} This function is a wrapper of @match@, it must be called from all the parts where @@ -801,14 +802,14 @@ subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] -- Each sub-list in the result has the same PatGroup -- See Note [Take care with pattern order] subGroup group - = map reverse $ eltsFM $ foldl accumulate emptyFM group + = map reverse $ Map.elems $ foldl accumulate Map.empty group where accumulate pg_map (pg, eqn) - = case lookupFM pg_map pg of - Just eqns -> addToFM pg_map pg (eqn:eqns) - Nothing -> addToFM pg_map pg [eqn] + = case Map.lookup pg pg_map of + Just eqns -> Map.insert pg (eqn:eqns) pg_map + Nothing -> Map.insert pg [eqn] pg_map - -- pg_map :: FiniteMap a [EquationInfo] + -- pg_map :: Map a [EquationInfo] -- Equations seen so far in reverse order of appearance \end{code} diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index d5ffae1d38..0fa7c62ff3 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -23,7 +23,6 @@ import ByteCodeItbls import Name import NameSet -import FiniteMap import Literal import TyCon import PrimOp @@ -42,6 +41,8 @@ import Data.Array.ST ( castSTUArray ) import Foreign import Data.Char ( ord ) import Data.List +import Data.Map (Map) +import qualified Data.Map as Map import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld ) @@ -128,19 +129,19 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) | wORD_SIZE_IN_BITS == 64 = 4 | wORD_SIZE_IN_BITS == 32 = 2 | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" - label_env = mkLabelEnv emptyFM lableInitialOffset instrs + label_env = mkLabelEnv Map.empty lableInitialOffset instrs - mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr] - -> FiniteMap Word16 Word + mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr] + -> Map Word16 Word mkLabelEnv env _ [] = env mkLabelEnv env i_offset (i:is) = let new_env - = case i of LABEL n -> addToFM env n i_offset ; _ -> env + = case i of LABEL n -> Map.insert n i_offset env ; _ -> env in mkLabelEnv new_env (i_offset + instrSize16s i) is findLabel :: Word16 -> Word findLabel lab - = case lookupFM label_env lab of + = case Map.lookup lab label_env of Just bco_offset -> bco_offset Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab) in diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 90931cc973..9330c7125b 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -19,7 +19,6 @@ import Outputable import Name import MkId import Id -import FiniteMap import ForeignCall import HscTypes import CoreUtils @@ -62,6 +61,10 @@ import Data.Maybe import Module import IdInfo +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -127,13 +130,13 @@ type Sequel = Word16 -- back off to this depth before ENTER -- Maps Ids to the offset from the stack _base_ so we don't have -- to mess with it after each push/pop. -type BCEnv = FiniteMap Id Word16 -- To find vars on the stack +type BCEnv = Map Id Word16 -- To find vars on the stack {- ppBCEnv :: BCEnv -> SDoc ppBCEnv p = text "begin-env" - $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) $$ text "end-env" where pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) @@ -277,7 +280,7 @@ schemeR_wrk fvs nm original_body (args, body) szsw_args = map (fromIntegral . idSizeW) all_args szw_args = sum szsw_args - p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap bits = argBits (reverse (map idCgRep all_args)) @@ -314,7 +317,7 @@ getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16) getOffSet d env id - = case lookupBCEnv_maybe env id of + = case lookupBCEnv_maybe id env of Nothing -> Nothing Just offset -> Just (id, d - offset) @@ -329,7 +332,7 @@ fvsToEnv :: BCEnv -> VarSet -> [Id] -- it, have to agree about this layout fvsToEnv p fvs = [v | v <- varSetElems fvs, isId v, -- Could be a type variable - v `elemFM` p] + v `Map.member` p] -- ----------------------------------------------------------------------------- -- schemeE @@ -389,7 +392,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) -- saturatred constructor application. -- Just allocate the constructor and carry on alloc_code <- mkConAppCode d s p data_con args_r_to_l - body_code <- schemeE (d+1) s (addToFM p x d) body + body_code <- schemeE (d+1) s (Map.insert x d p) body return (alloc_code `appOL` body_code) -- General case for let. Generates correct, if inefficient, code in @@ -411,7 +414,7 @@ schemeE d s p (AnnLet binds (_,body)) -- are ptrs, so all have size 1. d' and p' reflect the stack -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. - p' = addListToFM p (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) + p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p d' = d + n_binds zipE = zipEqual "schemeE" @@ -802,7 +805,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- Env in which to compile the alts, not including -- any vars bound by the alts themselves - p_alts = addToFM p bndr (d_bndr - 1) + p_alts = Map.insert bndr (d_bndr - 1) p bndr_ty = idType bndr isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple @@ -826,9 +829,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple bind_sizes = ptr_sizes ++ nptrs_sizes size = sum ptr_sizes + sum nptrs_sizes -- the UNPACK instruction unpacks in reverse order... - p' = addListToFM p_alts + p' = Map.insertList (zip (reverse (ptrs ++ nptrs)) (mkStackOffsets d_alts (reverse bind_sizes))) + p_alts in do MASSERT(isAlgCase) rhs_code <- schemeE (d_alts+size) s p' rhs @@ -877,7 +881,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple bitmap = intsToReverseBitmap bitmap_size'{-size-} (sortLe (<=) (filter (< bitmap_size') rel_slots)) where - binds = fmToList p + binds = Map.toList p rel_slots = map fromIntegral $ concat (map spread binds) spread (id, offset) | isFollowableArg (idCgRep id) = [ rel_offset ] @@ -1206,7 +1210,7 @@ pushAtom d p (AnnVar v) | Just primop <- isPrimOpId_maybe v = return (unitOL (PUSH_PRIMOP primop), 1) - | Just d_v <- lookupBCEnv_maybe p v -- v is a local variable + | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable = let l = d - d_v + sz - 2 in return (toOL (genericReplicate sz (PUSH_L l)), sz) -- d - d_v the number of words between the TOS @@ -1420,8 +1424,8 @@ instance Outputable Discr where ppr NoDiscr = text "DEF" -lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Word16 -lookupBCEnv_maybe = lookupFM +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16 +lookupBCEnv_maybe = Map.lookup idSizeW :: Id -> Int idSizeW id = cgRepSizeW (typeCgRep (idType id)) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index d53d2477e6..66a4576171 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -51,7 +51,6 @@ import ErrUtils import SrcLoc import qualified Maybes import UniqSet -import FiniteMap import Constants import FastString import Config ( cProjectVersion ) @@ -62,6 +61,7 @@ import Control.Monad import Data.Char import Data.IORef import Data.List +import qualified Data.Map as Map import Foreign import Control.Concurrent.MVar @@ -1001,7 +1001,7 @@ linkPackages' dflags new_pks pls = do | Just pkg_cfg <- lookupPackage pkg_map new_pkg = do { -- Link dependents first pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ - lookupFM ipid_map ipid + Map.lookup ipid ipid_map | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 84a6474077..a1bcbb4f40 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -31,7 +31,6 @@ import Module import UniqFM import FastString import UniqSupply -import FiniteMap import BasicTypes import SrcLoc import MkId @@ -40,6 +39,7 @@ import Outputable import Exception ( evaluate ) import Data.IORef ( atomicModifyIORef, readIORef ) +import qualified Data.Map as Map \end{code} @@ -176,14 +176,14 @@ newIPName occ_name_ip = ipcache = nsIPs name_cache key = occ_name_ip -- Ensures that ?x and %x get distinct Names in - case lookupFM ipcache key of + case Map.lookup key ipcache of Just name_ip -> (name_cache, name_ip) Nothing -> (new_ns, name_ip) where (us', us1) = splitUniqSupply (nsUniqs name_cache) uniq = uniqFromSupply us1 name_ip = mapIPName (mkIPName uniq) occ_name_ip - new_ipcache = addToFM ipcache key name_ip + new_ipcache = Map.insert key name_ip ipcache new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} \end{code} @@ -220,9 +220,9 @@ extendOrigNameCache nc name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name - = extendModuleEnv_C combine nc mod (unitOccEnv occ name) + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) where - combine occ_env _ = extendOccEnv occ_env occ name + combine _ occ_env = extendOccEnv occ_env occ name getNameCache :: TcRnIf a b NameCache getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; @@ -254,7 +254,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache initNameCache us names = NameCache { nsUniqs = us, nsNames = initOrigNames names, - nsIPs = emptyFM } + nsIPs = Map.empty } initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index fa9e0ec14c..68c6cf16a6 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -87,7 +87,6 @@ import BasicTypes hiding ( SuccessFlag(..) ) import UniqFM import Unique import Util hiding ( eqListBy ) -import FiniteMap import FastString import Maybes import ListSetOps @@ -97,6 +96,8 @@ import Bag import Control.Monad import Data.List +import Data.Map (Map) +import qualified Data.Map as Map import Data.IORef import System.FilePath \end{code} @@ -523,7 +524,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- wiki/Commentary/Compiler/RecompilationAvoidance -- put the declarations in a canonical order, sorted by OccName - let sorted_decls = eltsFM $ listToFM $ + let sorted_decls = Map.elems $ Map.fromList $ [(ifName d, e) | e@(_, d) <- decls_w_hashes] -- the ABI hash depends on: @@ -860,10 +861,10 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | otherwise = case nameModule_maybe name of Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name) - Just mod -> -- We use this fiddly lambda function rather than - -- (++) as the argument to extendModuleEnv_C to + Just mod -> -- This lambda function is really just a + -- specialised (++); originally came about to -- avoid quadratic behaviour (trac #2680) - extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ] + extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ] where occ = nameOccName name -- We want to create a Usage for a home module if @@ -897,7 +898,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names usg_mod_name = moduleName mod, usg_mod_hash = mod_hash, usg_exports = export_hash, - usg_entities = fmToList ent_hashs } + usg_entities = Map.toList ent_hashs } where maybe_iface = lookupIfaceByModule dflags hpt pit mod -- In one-shot mode, the interfaces for home-package @@ -914,13 +915,13 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names used_occs = lookupModuleEnv ent_map mod `orElse` [] - -- Making a FiniteMap here ensures that (a) we remove duplicates + -- Making a Map here ensures that (a) we remove duplicates -- when we have usages on several subordinates of a single parent, -- and (b) that the usages emerge in a canonical order, which - -- is why we use FiniteMap rather than OccEnv: FiniteMap works + -- is why we use Map rather than OccEnv: Map works -- using Ord on the OccNames, which is a lexicographic ordering. - ent_hashs :: FiniteMap OccName Fingerprint - ent_hashs = listToFM (map lookup_occ used_occs) + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) lookup_occ occ = case hash_env occ of @@ -960,10 +961,10 @@ mkIfaceExports :: [AvailInfo] -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence mkIfaceExports exports - = [ (mod, eltsFM avails) + = [ (mod, Map.elems avails) | (mod, avails) <- sortBy (stableModuleCmp `on` fst) (moduleEnvToList groupFM) - -- NB. the fmToList is in a random order, + -- NB. the Map.toList is in a random order, -- because Ord Module is not a predictable -- ordering. Hence we perform a final sort -- using the stable Module ordering. @@ -971,20 +972,21 @@ mkIfaceExports exports where -- Group by the module where the exported entities are defined -- (which may not be the same for all Names in an Avail) - -- Deliberately use FiniteMap rather than UniqFM so we + -- Deliberately use Map rather than UniqFM so we -- get a canonical ordering - groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName)) groupFM = foldl add emptyModuleEnv exports - add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName)) -> Module -> GenAvailInfo OccName - -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + -> ModuleEnv (Map FastString (GenAvailInfo OccName)) add_one env mod avail - = extendModuleEnv_C plusFM env mod - (unitFM (occNameFS (availName avail)) avail) + -- XXX Is there a need to flip Map.union here? + = extendModuleEnvWith (flip Map.union) env mod + (Map.singleton (occNameFS (availName avail)) avail) -- NB: we should not get T(X) and T(Y) in the export list - -- else the plusFM will simply discard one! They + -- else the Map.union will simply discard one! They -- should have been combined by now. add env (Avail n) = ASSERT( isExternalName n ) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c9ac5f9185..47d9f6da1b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -88,7 +88,6 @@ import Util import Maybes ( orElse ) import SrcLoc import FastString -import FiniteMap import Outputable import Foreign.C ( CInt ) import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -99,6 +98,8 @@ import Control.Monad ( when ) import Data.Char import Data.List +import Data.Map (Map) +import qualified Data.Map as Map import System.FilePath import System.IO ( stderr, hPutChar ) @@ -488,7 +489,7 @@ data DynFlags = DynFlags { -- These have to be IORefs, because the defaultCleanupHandler needs to -- know what to clean when an exception happens filesToClean :: IORef [FilePath], - dirsToClean :: IORef (FiniteMap FilePath FilePath), + dirsToClean :: IORef (Map FilePath FilePath), -- hsc dynamic flags flags :: [DynFlag], @@ -612,7 +613,7 @@ initDynFlags dflags = do -- someday these will be dynamic flags ways <- readIORef v_Ways refFilesToClean <- newIORef [] - refDirsToClean <- newIORef emptyFM + refDirsToClean <- newIORef Map.empty return dflags{ ways = ways, buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 92345c7314..c3aa8323de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -286,7 +286,6 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, import Annotations import Module import UniqFM -import FiniteMap import Panic import Digraph import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) @@ -303,6 +302,9 @@ import Lexer import System.Directory ( getModificationTime, doesFileExist, getCurrentDirectory ) import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map import Data.List import qualified Data.List as List import Data.Typeable ( Typeable ) @@ -1827,14 +1829,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l numbered_summaries = zip summaries [1..] lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = lookupFM node_map (mod, hs_src) + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map lookup_key :: HscSource -> ModuleName -> Maybe Int lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) node_map :: NodeMap SummaryNode - node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] -- We use integers as the keys for the SCC algorithm nodes :: [SummaryNode] @@ -1870,16 +1872,16 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] -nodeMapElts = eltsFM +nodeMapElts = Map.elems -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can @@ -1984,7 +1986,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- for those mentioned in the visited set loop [] done = return (concat (nodeMapElts done)) loop ((wanted_mod, is_boot) : ss) done - | Just summs <- lookupFM done key + | Just summs <- Map.lookup key done = if isSingleton summs then loop ss done else @@ -1995,13 +1997,15 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots Nothing excl_mods case mb_s of Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (addToFM done key [s]) + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) where key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) +-- XXX Does the (++) here need to be flipped? mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = addListToFM_C (++) emptyFM - [ (msKey s, [s]) | s <- summaries ] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- (msDeps s) returns the dependencies of the ModSummary s. @@ -2146,7 +2150,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | wanted_mod `elem` excl_mods = return Nothing - | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 5c41f68e85..bc9c9eef8f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -140,7 +140,6 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) import IfaceSyn -import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable @@ -162,6 +161,7 @@ import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) import Data.List +import Data.Map (Map) import Control.Monad ( mplus, guard, liftM, when ) import Exception \end{code} @@ -1851,7 +1851,7 @@ data NameCache type OrigNameCache = ModuleEnv (OccEnv Name) -- | Module-local cache of implicit parameter 'OccName's given 'Name's -type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) +type OrigIParamCache = Map (IPName OccName) (IPName Name) \end{code} diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 06cd573bc9..a940f99121 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -41,7 +41,6 @@ import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM -import FiniteMap import Module import Util import Panic @@ -60,6 +59,9 @@ import System.Directory import System.FilePath import Control.Monad import Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map import qualified Data.Set as Set -- --------------------------------------------------------------------------- @@ -126,9 +128,9 @@ data PackageState = PackageState { -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig' type PackageConfigMap = UniqFM PackageConfig -type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId +type InstalledPackageIdMap = Map InstalledPackageId PackageId -type InstalledPackageIndex = FiniteMap InstalledPackageId PackageConfig +type InstalledPackageIndex = Map InstalledPackageId PackageConfig emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM @@ -331,7 +333,7 @@ selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] selectPackages matches pkgs unusable = let (ps,rest) = partition matches pkgs - reasons = [ (p, lookupFM unusable (installedPackageId p)) + reasons = [ (p, Map.lookup (installedPackageId p) unusable) | p <- ps ] in if all (isJust.snd) reasons @@ -493,7 +495,7 @@ data UnusablePackageReason | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId -type UnusablePackages = FiniteMap InstalledPackageId UnusablePackageReason +type UnusablePackages = Map InstalledPackageId UnusablePackageReason pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of @@ -507,7 +509,7 @@ pprReason pref reason = case reason of pref <+> ptext (sLit "shadowed by package ") <> text (display ipid) reportUnusable :: DynFlags -> UnusablePackages -> IO () -reportUnusable dflags pkgs = mapM_ report (fmToList pkgs) +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where report (ipid, reason) = debugTraceMsg dflags 2 $ @@ -524,17 +526,18 @@ reportUnusable dflags pkgs = mapM_ report (fmToList pkgs) -- satisfied until no more can be added. -- findBroken :: [PackageConfig] -> UnusablePackages -findBroken pkgs = go [] emptyFM pkgs +findBroken pkgs = go [] Map.empty pkgs where go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - listToFM [ (installedPackageId p, MissingDependencies deps) - | (p,deps) <- not_avail ] + Map.fromList [ (installedPackageId p, MissingDependencies deps) + | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) - where new_ipids = addListToFM ipids + where new_ipids = Map.insertList [ (installedPackageId p, p) | p <- new_avail ] + ipids depsAvailable :: InstalledPackageIndex -> PackageConfig @@ -542,7 +545,7 @@ findBroken pkgs = go [] emptyFM pkgs depsAvailable ipids pkg | null dangling = Left pkg | otherwise = Right (pkg, dangling) - where dangling = filter (not . (`elemFM` ipids)) (depends pkg) + where dangling = filter (not . (`Map.member` ipids)) (depends pkg) -- ----------------------------------------------------------------------------- -- Eliminate shadowed packages, giving the user some feedback @@ -554,7 +557,7 @@ findBroken pkgs = go [] emptyFM pkgs shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages shadowPackages pkgs preferred = let (shadowed,_) = foldl check ([],emptyUFM) pkgs - in listToFM shadowed + in Map.fromList shadowed where check (shadowed,pkgmap) pkg | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) @@ -574,7 +577,7 @@ shadowPackages pkgs preferred -- ----------------------------------------------------------------------------- ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages -ignorePackages flags pkgs = listToFM (concatMap doit flags) +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of @@ -590,13 +593,13 @@ ignorePackages flags pkgs = listToFM (concatMap doit flags) depClosure :: InstalledPackageIndex -> [InstalledPackageId] -> [InstalledPackageId] -depClosure index ipids = closure emptyFM ipids +depClosure index ipids = closure Map.empty ipids where - closure set [] = keysFM set + closure set [] = Map.keys set closure set (ipid : ipids) - | ipid `elemFM` set = closure set ipids - | Just p <- lookupFM index ipid = closure (addToFM set ipid p) - (depends p ++ ipids) + | ipid `Map.member` set = closure set ipids + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + (depends p ++ ipids) | otherwise = closure set ipids -- ----------------------------------------------------------------------------- @@ -673,7 +676,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do where pid = installedPackageId p -- XXX this is just a variant of nub - ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ] + ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] ipid_selected = depClosure ipid_map [ InstalledPackageId i | ExposePackageId i <- flags ] @@ -686,9 +689,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do ignored = ignorePackages ignore_flags pkgs0_unique - pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique + pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique broken = findBroken pkgs0' - unusable = shadowed `plusFM` ignored `plusFM` broken + unusable = shadowed `Map.union` ignored `Map.union` broken reportUnusable dflags unusable @@ -697,7 +700,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- (-package, -hide-package, -ignore-package, -hide-all-packages). -- pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags - let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1 + let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" @@ -719,12 +722,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4 - ipid_map = listToFM [ (installedPackageId p, packageConfigId p) - | p <- pkgs4 ] + ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) + | p <- pkgs4 ] lookupIPID ipid@(InstalledPackageId str) - | Just pid <- lookupFM ipid_map ipid = return pid - | otherwise = missingPackageErr str + | Just pid <- Map.lookup ipid ipid_map = return pid + | otherwise = missingPackageErr str preload2 <- mapM lookupIPID preload1 @@ -890,7 +893,7 @@ getPreloadPackagesAnd dflags pkgids = -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [(PackageId, Maybe PackageId)] -> IO [PackageId] closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) @@ -901,14 +904,14 @@ throwErr m = case m of Succeeded r -> return r closeDepsErr :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [(PackageId,Maybe PackageId)] -> MaybeErr Message [PackageId] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper add_package :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr Message [PackageId] @@ -924,7 +927,7 @@ add_package pkg_db ipid_map ps (p, mb_parent) return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) - | Just pid <- lookupFM ipid_map ipid + | Just pid <- Map.lookup ipid ipid_map = add_package pkg_db ipid_map ps (pid, Just p) | otherwise = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 12b73d3bf2..1693aa06a9 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -45,7 +45,6 @@ import ErrUtils import Panic import Util import DynFlags -import FiniteMap import Exception import Data.IORef @@ -58,6 +57,7 @@ import System.IO.Error as IO import System.Directory import Data.Char import Data.List +import qualified Data.Map as Map #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -472,8 +472,8 @@ cleanTempDirs dflags = unless (dopt Opt_KeepTmpFiles dflags) $ do let ref = dirsToClean dflags ds <- readIORef ref - removeTmpDirs dflags (eltsFM ds) - writeIORef ref emptyFM + removeTmpDirs dflags (Map.elems ds) + writeIORef ref Map.empty cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags @@ -515,7 +515,7 @@ getTempDir :: DynFlags -> IO FilePath getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) = do let ref = dirsToClean dflags mapping <- readIORef ref - case lookupFM mapping tmp_dir of + case Map.lookup tmp_dir mapping of Nothing -> do x <- getProcessID let prefix = tmp_dir </> "ghc" ++ show x ++ "_" @@ -524,7 +524,7 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) mkTempDir x = let dirname = prefix ++ show x in do createDirectory dirname - let mapping' = addToFM mapping tmp_dir dirname + let mapping' = Map.insert tmp_dir dirname mapping writeIORef ref mapping' debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname) return dirname diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 4cba23b9bf..84568d9773 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -33,7 +33,6 @@ import RdrName import Outputable import Maybes import SrcLoc -import FiniteMap import ErrUtils import Util import FastString @@ -42,6 +41,8 @@ import Data.List ( partition, (\\), delete ) import qualified Data.Set as Set import System.IO import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -1256,7 +1257,7 @@ findImportUsage :: [LImportDecl Name] -> [RdrName] -> [ImportDeclUsage] -type ImportMap = FiniteMap SrcLoc [AvailInfo] +type ImportMap = Map SrcLoc [AvailInfo] -- The intermediate data struture records, for each import -- declaration, what stuff brought into scope by that -- declaration is actually used in the module. @@ -1271,12 +1272,12 @@ findImportUsage imports rdr_env rdrs = map unused_decl imports where import_usage :: ImportMap - import_usage = foldr add_rdr emptyFM rdrs + import_usage = foldr add_rdr Map.empty rdrs unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) = (decl, nubAvails used_avails, unused_imps) where - used_avails = lookupFM import_usage (srcSpanStart loc) `orElse` [] + used_avails = Map.lookup (srcSpanStart loc) import_usage `orElse` [] used_names = availsToNameSet used_avails unused_imps = case imps of @@ -1296,9 +1297,9 @@ findImportUsage imports rdr_env rdrs add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap add_imp gre (ImpSpec { is_decl = imp_decl_spec }) iu - = addToFM_C add iu decl_loc [avail] + = Map.insertWith add decl_loc [avail] iu where - add avails _ = avail : avails + add _ avails = avail : avails -- add is really just a specialised (++) decl_loc = srcSpanStart (is_dloc imp_decl_spec) name = gre_name gre avail = case gre_par gre of diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 7f43ce528f..00dedffa38 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -79,12 +79,13 @@ import Bag import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) -import FiniteMap import Util ( split ) import Data.List ( intersperse ) import Data.Dynamic import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map import Data.Word import Control.Monad @@ -559,7 +560,7 @@ data SimplCount -- recent history reasonably efficiently } -type TickCounts = FiniteMap Tick Int +type TickCounts = Map Tick Int simplCountN :: SimplCount -> Int simplCountN (VerySimplCount n) = n @@ -569,7 +570,7 @@ zeroSimplCount dflags -- This is where we decide whether to do -- the VerySimpl version or the full-stats version | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = emptyFM, + = SimplCount {ticks = 0, details = Map.empty, n_log = 0, log1 = [], log2 = []} | otherwise = VerySimplCount 0 @@ -590,19 +591,19 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1) --- Don't use plusFM_C because that's lazy, and we want to +-- Don't use Map.unionWith because that's lazy, and we want to -- be pretty strict here! addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = case lookupFM fm tick of - Nothing -> addToFM fm tick 1 - Just n -> n1 `seq` addToFM fm tick n1 +addTick fm tick = case Map.lookup tick fm of + Nothing -> Map.insert tick 1 fm + Just n -> n1 `seq` Map.insert tick n1 fm where n1 = n+1 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } + = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 } where -- A hackish way of getting recent log info log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 @@ -617,7 +618,7 @@ pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) = vcat [ptext (sLit "Total ticks: ") <+> int tks, blankLine, - pprTickCounts (fmToList dts), + pprTickCounts (Map.toList dts), if verboseSimplStats then vcat [blankLine, ptext (sLit "Log (most recent first)"), diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index 08bb1ecf40..73ffba5cb7 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -123,7 +123,7 @@ emptyIdSATInfo :: IdSATInfo emptyIdSATInfo = emptyUFM {- -pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (fmToList id_sat_info)) +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) -} diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs index 25c988d52b..74a4fc3cbf 100644 --- a/compiler/simplStg/StgStats.lhs +++ b/compiler/simplStg/StgStats.lhs @@ -34,8 +34,10 @@ module StgStats ( showStgStats ) where import StgSyn -import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap ) import Id (Id) + +import Data.Map (Map) +import qualified Data.Map as Map \end{code} \begin{code} @@ -54,24 +56,24 @@ data CounterType deriving (Eq, Ord) type Count = Int -type StatEnv = FiniteMap CounterType Count +type StatEnv = Map CounterType Count \end{code} \begin{code} emptySE :: StatEnv -emptySE = emptyFM +emptySE = Map.empty combineSE :: StatEnv -> StatEnv -> StatEnv -combineSE = plusFM_C (+) +combineSE = Map.unionWith (+) combineSEs :: [StatEnv] -> StatEnv combineSEs = foldr combineSE emptySE countOne :: CounterType -> StatEnv -countOne c = unitFM c 1 +countOne c = Map.singleton c 1 countN :: CounterType -> Int -> StatEnv -countN = unitFM +countN = Map.singleton \end{code} %************************************************************************ @@ -85,7 +87,7 @@ showStgStats :: [StgBinding] -> String showStgStats prog = "STG Statistics:\n\n" - ++ concat (map showc (fmToList (gatherStgStats prog))) + ++ concat (map showc (Map.toList (gatherStgStats prog))) where showc (x,n) = (showString (s x) . shows n) "\n" diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index f18c8f950a..2d0b383c1a 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -21,7 +21,6 @@ import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import UniqSupply ( UniqSupply, UniqSM, initUs_, MonadUnique(..) ) import Name import MkId ( voidArgId, realWorldPrimId ) -import FiniteMap import Maybes ( catMaybes, isJust ) import BasicTypes ( isNeverActive, inlinePragmaActivation ) import Bag @@ -29,6 +28,9 @@ import Util import Outputable import FastString +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map \end{code} %************************************************************************ @@ -1321,12 +1323,12 @@ emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv } type CallDetails = IdEnv CallInfoSet newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument --- CallInfo uses a FiniteMap, thereby ensuring that +-- CallInfo uses a Map, thereby ensuring that -- we record only one call instance for any key -- -- The list of types and dictionaries is guaranteed to -- match the type of f -type CallInfoSet = FiniteMap CallKey ([DictExpr], VarSet) +type CallInfoSet = Map CallKey ([DictExpr], VarSet) -- Range is dict args and the vars of the whole -- call (including tyvars) -- [*not* include the main id itself, of course] @@ -1350,7 +1352,7 @@ instance Ord CallKey where cmp (Just t1) (Just t2) = tcCmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusVarEnv_C plusFM c1 c2 +unionCalls c1 c2 = plusVarEnv_C Map.union c1 c2 -- plusCalls :: UsageDetails -> CallDetails -> UsageDetails -- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds } @@ -1359,13 +1361,13 @@ callDetailsFVs :: CallDetails -> VarSet callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs call_info = foldFM (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info +callInfoFVs call_info = Map.foldRightWithKey (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info ------------------------------------------------------------ singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails singleCall id tys dicts = MkUD {ud_binds = emptyBag, - ud_calls = unitVarEnv id (unitFM (CallKey tys) (dicts, call_fvs)) } + ud_calls = unitVarEnv id (Map.singleton (CallKey tys) (dicts, call_fvs)) } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) @@ -1539,7 +1541,7 @@ callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn } calls_for_me = case lookupVarEnv orig_calls fn of Nothing -> [] - Just cs -> filter_dfuns (fmToList cs) + Just cs -> filter_dfuns (Map.toList cs) dep_set = foldlBag go (unitVarSet fn) orig_dbs go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set @@ -1576,7 +1578,7 @@ deleteCallsMentioning bs calls = mapVarEnv filter_calls calls where filter_calls :: CallInfoSet -> CallInfoSet - filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs)) + filter_calls = Map.filterWithKey (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs)) deleteCallsFor :: [Id] -> CallDetails -> CallDetails -- Remove calls *for* bs diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 36f78cba57..8855fdcbe9 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -15,11 +15,12 @@ import Module import SrcLoc import Outputable import UniqFM -import FiniteMap import FastString import Maybes import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -70,10 +71,10 @@ instance Ord ModulePair where -- Sets of module pairs -- -type ModulePairSet = FiniteMap ModulePair () +type ModulePairSet = Map ModulePair () listToSet :: [ModulePair] -> ModulePairSet -listToSet l = listToFM (zip l (repeat ())) +listToSet l = Map.fromList (zip l (repeat ())) checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods @@ -101,7 +102,7 @@ checkFamInstConsistency famInstMods directlyImpMods -- instances of okPairs are consistent ; criticalPairs = listToSet $ allPairs famInstMods -- all pairs that we need to consider - ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs + ; toCheckPairs = Map.keys $ criticalPairs `Map.difference` okPairs -- the difference gives us the pairs we need to check now } diff --git a/compiler/typecheck/TcSimplify.lhs-old b/compiler/typecheck/TcSimplify.lhs-old index c9b57368da..274c14d70b 100644 --- a/compiler/typecheck/TcSimplify.lhs-old +++ b/compiler/typecheck/TcSimplify.lhs-old @@ -2490,7 +2490,7 @@ pprAvails (Avails imp avails) = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty) , nest 2 $ braces $ vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)] - | (inst,avail) <- fmToList avails ]] + | (inst,avail) <- Map.toList avails ]] instance Outputable AvailHow where ppr = pprAvail @@ -2504,10 +2504,10 @@ pprAvail (Rhs rhs bs) = sep [text "Rhs" <+> ppr bs, ------------------------- extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv -extendAvailEnv env inst avail = addToFM env inst avail +extendAvailEnv env inst avail = Map.insert inst avail env findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow -findAvailEnv env wanted = lookupFM env wanted +findAvailEnv env wanted = Map.lookup wanted env -- NB 1: the Ord instance of Inst compares by the class/type info -- *not* by unique. So -- d1::C Int == d2::C Int @@ -2528,7 +2528,7 @@ extendAvails avails@(Avails imp env) inst avail ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) } availsInsts :: Avails -> [Inst] -availsInsts (Avails _ avails) = keysFM avails +availsInsts (Avails _ avails) = Map.keys avails availsImproved :: Avails -> ImprovementDone availsImproved (Avails imp _) = imp @@ -2566,12 +2566,12 @@ extractResults (Avails _ avails) wanteds | isEqInst w = go binds bound_dicts (w:irreds) done' ws - | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w + | Just done_ids@(done_id : rest_done_ids) <- Map.lookup w done = if w_id `elem` done_ids then go binds bound_dicts irreds done ws else go (add_bind (nlHsVar done_id)) bound_dicts irreds - (addToFM done w (done_id : w_id : rest_done_ids)) ws + (Map.insert w (done_id : w_id : rest_done_ids) done) ws | otherwise -- Not yet done = case findAvailEnv avails w of @@ -2582,14 +2582,14 @@ extractResults (Avails _ avails) wanteds Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws) - Just (Given g) -> go binds' bound_dicts irreds (addToFM done w [g_id]) ws + Just (Given g) -> go binds' bound_dicts irreds (Map.insert w [g_id] done) ws where g_id = instToId g binds' | w_id == g_id = binds | otherwise = add_bind (nlHsVar g_id) where w_id = instToId w - done' = addToFM done w [w_id] + done' = Map.insert w [w_id] done add_bind rhs = addInstToDictBind binds w rhs \end{code} diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index 28c9620695..ca918110e3 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -1,207 +1,33 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1994-1998 -% - -``Finite maps'' are the heart of the compiler's lookup-tables/environments -and its implementation of sets. Important stuff! - -The implementation uses @Data.Map@ from the containers package, which -is both maintained and faster than the past implementation (see commit log). - -The orinigal interface is being kept around. It maps directly to Data.Map, -only ``Data.Map.union'' is left-biased and ``plusFM'' right-biased and -``addToFM\_C'' and ``Data.Map.insertWith'' differ in the order of -arguments of combining function. \begin{code} module FiniteMap ( - -- * Mappings keyed from arbitrary types - FiniteMap, -- abstract data type - - -- ** Manipulating those mappings - emptyFM, unitFM, listToFM, - - addToFM, - addToFM_C, - addListToFM, - addListToFM_C, - delFromFM, - delListFromFM, - - plusFM, - plusFM_C, - minusFM, - foldFM, - - intersectFM, - intersectFM_C, - mapFM, filterFM, - - sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, - - fmToList, keysFM, eltsFM, - - bagToFM + insertList, + insertListWith, + deleteList, + foldRightWithKey ) where -import Bag ( Bag, foldrBag ) -import Outputable - -import qualified Data.Map as M - -\end{code} - - -%************************************************************************ -%* * -\subsection{The signature of the module} -%* * -%************************************************************************ - -\begin{code} --- BUILDING -emptyFM :: FiniteMap key elt -unitFM :: key -> elt -> FiniteMap key elt --- | In the case of duplicates keys, the last item is taken -listToFM :: (Ord key) => [(key,elt)] -> FiniteMap key elt --- | In the case of duplicate keys, who knows which item is taken -bagToFM :: (Ord key) => Bag (key,elt) -> FiniteMap key elt - --- ADDING AND DELETING - --- | Throws away any previous binding -addToFM :: (Ord key) - => FiniteMap key elt -> key -> elt -> FiniteMap key elt --- | Throws away any previous binding, items are added left-to-right -addListToFM :: (Ord key) - => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt - --- | Combines added item with previous item, if any -- --- if the key is present, ``addToFM_C f`` inserts --- ``(key, f old_value new_value)'' -addToFM_C :: (Ord key) => (elt -> elt -> elt) - -> FiniteMap key elt -> key -> elt - -> FiniteMap key elt --- | Combines added item with previous item, if any, items are added left-to-right -addListToFM_C :: (Ord key) => (elt -> elt -> elt) - -> FiniteMap key elt -> [(key,elt)] - -> FiniteMap key elt - --- | Deletion doesn't complain if you try to delete something which isn't there -delFromFM :: (Ord key) - => FiniteMap key elt -> key -> FiniteMap key elt --- | Deletion doesn't complain if you try to delete something which isn't there -delListFromFM :: (Ord key) - => FiniteMap key elt -> [key] -> FiniteMap key elt +import Data.Map (Map) +import qualified Data.Map as Map --- COMBINING +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs --- | Bindings in right argument shadow those in the left -plusFM :: (Ord key) - => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs --- | Combines bindings for the same thing with the given function, --- bindings in right argument shadow those in the left -plusFM_C :: (Ord key) - => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl (flip Map.delete) m ks --- | Deletes from the left argument any bindings in the right argument -minusFM :: (Ord key) - => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt - -intersectFM :: (Ord key) - => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt --- | Combines bindings for the same thing in the two maps with the given function -intersectFM_C :: (Ord 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 -mapFM :: (key -> elt1 -> elt2) - -> FiniteMap key elt1 -> FiniteMap key elt2 -filterFM :: (Ord key) - => (key -> elt -> Bool) - -> FiniteMap key elt -> FiniteMap key elt - --- INTERROGATING -sizeFM :: FiniteMap key elt -> Int -isEmptyFM :: FiniteMap key elt -> Bool - -elemFM :: (Ord key) - => key -> FiniteMap key elt -> Bool -lookupFM :: (Ord key) - => FiniteMap key elt -> key -> Maybe elt --- | Supplies a "default" element in return for an unmapped key -lookupWithDefaultFM :: (Ord key) - => FiniteMap key elt -> elt -> key -> elt - --- LISTIFYING -fmToList :: FiniteMap key elt -> [(key,elt)] -keysFM :: FiniteMap key elt -> [key] -eltsFM :: FiniteMap key elt -> [elt] -\end{code} - -%************************************************************************ -%* * -\subsection{Implementation using ``Data.Map''} -%* * -%************************************************************************ - -\begin{code} -newtype FiniteMap key elt = FM (M.Map key elt) - -emptyFM = FM M.empty -unitFM k v = FM (M.singleton k v) -listToFM l = FM (M.fromList l) - -addToFM (FM m) k v = FM (M.insert k v m) --- Arguments of combining function of M.insertWith and addToFM_C are flipped. -addToFM_C f (FM m) k v = FM (M.insertWith (flip f) k v m) -addListToFM = foldl (\m (k, v) -> addToFM m k v) -addListToFM_C f = foldl (\m (k, v) -> addToFM_C f m k v) -delFromFM (FM m) k = FM (M.delete k m) -delListFromFM = foldl delFromFM - --- M.union is left-biased, plusFM should be right-biased. -plusFM (FM x) (FM y) = FM (M.union y x) -plusFM_C f (FM x) (FM y) = FM (M.unionWith f x y) -minusFM (FM x) (FM y) = FM (M.difference x y) -#if MIN_VERSION_containers(0,4,0) -foldFM k z (FM m) = M.foldrWithKey k z m +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +#if (MIN_VERSION_containers(0,4,0)) +foldRightWithKey = Map.foldrWithKey #else -foldFM k z (FM m) = M.foldWithKey k z m +foldRightWithKey = Map.foldWithKey #endif - -intersectFM (FM x) (FM y) = FM (M.intersection x y) -intersectFM_C f (FM x) (FM y) = FM (M.intersectionWith f x y) -mapFM f (FM m) = FM (M.mapWithKey f m) -filterFM p (FM m) = FM (M.filterWithKey p m) - -sizeFM (FM m) = M.size m -isEmptyFM (FM m) = M.null m -elemFM k (FM m) = M.member k m -lookupFM (FM m) k = M.lookup k m -lookupWithDefaultFM (FM m) v k = M.findWithDefault v k m - -fmToList (FM m) = M.toList m -keysFM (FM m) = M.keys m -eltsFM (FM m) = M.elems m - -bagToFM = foldrBag (\(k,v) m -> addToFM m k v) emptyFM - \end{code} -%************************************************************************ -%* * -\subsection{Output-ery} -%* * -%************************************************************************ - -\begin{code} -instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where - ppr fm = ppr (fmToList fm) -\end{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 7a643d7eb4..73c6bd3fc2 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -75,6 +75,8 @@ import Pretty ( Doc, Mode(..) ) import Panic import Data.Char +import Data.Map (Map) +import qualified Data.Map as M import Data.Word import System.IO ( Handle, stderr, stdout, hFlush ) import System.FilePath @@ -564,6 +566,9 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (Map key elt) where + ppr m = ppr (M.toList m) \end{code} %************************************************************************ |