Commit e95ee1f7 authored by Ian Lynagh's avatar Ian Lynagh

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.
parent 83a8fc9f
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
......@@ -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
......
......@@ -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