diff options
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} %************************************************************************ |