)
where
-import qualified Prelude as P
import Prelude hiding (zip, unzip, last)
import BlockId
import CLabel
import Cmm hiding (blockId)
import CmmContFlowOpt
-import CmmExpr
import CmmInfo
import CmmLiveZ
import CmmTx
import DFMonad
import FiniteMap
-import List (sortBy)
+import Data.List (sortBy)
import Maybes
import MkZipCfg
import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
-import Monad
+import Control.Monad
import Outputable
-import Panic
import UniqSet
import UniqSupply
import ZipCfg
-- 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)
graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
let to_proc (bid, g) | elemBlockSet bid callPPs =
if bid == entry then
- CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
+ CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
else
- CmmProc emptyContInfoTable lbl [] g
+ CmmProc emptyContInfoTable lbl [] (replacePPIds g)
where lbl = expectJust "pp label" $ lookupFM procLabels bid
to_proc (bid, g) =
- CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
+ CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
where lbl = expectJust "pp label" $ lookupFM procLabels bid
+ -- 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
+ Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+ Nothing -> e
+ repl e = e
-- The C back end expects to see return continuations before the call sites.
-- Here, we sort them in reverse order -- it gets reversed later.
let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)