X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPointZ.hs;h=c972ad59abbc1e76e67b5a531eeb2a1fac8c35cc;hb=8350c21760d8610b0b2f329095ffb80bb1bc20d9;hp=c34f041bedd3125b20a4d821e1cb76d6291412cd;hpb=1e50fd4185479a62e02d987bdfcb1c62712859ca;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index c34f041..c972ad5 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 @@ -127,18 +128,21 @@ forward = ForwardTransfers first middle last exit -- those that are induced by calls in the original graph -- and those that are introduced because they're reachable from multiple proc points. callProcPoints :: CmmGraph -> ProcPointSet -minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet - callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g where add b set = case last $ unzip b of LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k _ -> set +minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure ou the minimal set of necessary proc-points minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status) +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from procPointAnalysis procPoints g = let addPP env id = extendBlockEnv env id ProcPoint initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints) @@ -396,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: @@ -431,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) <- @@ -453,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