Commit 27287c80 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

procPointAnalysis doesn't need UniqSM

`procPointAnalysis` doesn't need to run in `UniqSM` (it consists of a
single `return` and the call to `analyzeCmm` function which is pure).
Making it non-monadic simplifies the code a bit.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: validate

Reviewers: austin, bgamari, simonmar

Reviewed By: simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2837
parent be5384ce
...@@ -109,8 +109,8 @@ cpsTop hsc_env proc = ...@@ -109,8 +109,8 @@ cpsTop hsc_env proc =
g <- if splitting_proc_points g <- if splitting_proc_points
then do then do
------------- Split into separate procedures ----------------------- ------------- Split into separate procedures -----------------------
pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $ let pp_map = {-# SCC "procPointAnalysis" #-}
procPointAnalysis proc_points g procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $ dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
ppr pp_map ppr pp_map
g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
......
...@@ -131,10 +131,9 @@ instance Outputable Status where ...@@ -131,10 +131,9 @@ instance Outputable Status where
-- Once you know what the proc-points are, figure out -- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from -- what proc-points each block is reachable from
-- See Note [Proc-point analysis] -- See Note [Proc-point analysis]
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (LabelMap Status) procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
return $ analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
where where
initProcPoints = initProcPoints =
mkFactBase mkFactBase
...@@ -189,36 +188,31 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph ...@@ -189,36 +188,31 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
minimalProcPointSet platform callProcPoints g minimalProcPointSet platform callProcPoints g
= extendPPSet platform g (postorderDfs g) callProcPoints = extendPPSet platform g (postorderDfs g) callProcPoints
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet extendPPSet
:: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
extendPPSet platform g blocks procPoints = extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g let env = procPointAnalysis procPoints g
-- pprTrace "extensPPSet" (ppr env) $ return () add block pps = let id = entryLabel block
let add block pps = let id = entryLabel block in case mapLookup id env of
in case mapLookup id env of Just ProcPoint -> setInsert id pps
Just ProcPoint -> setInsert id pps _ -> pps
_ -> pps procPoints' = foldGraphBlocks add setEmpty g
procPoints' = foldGraphBlocks add setEmpty g newPoints = mapMaybe ppSuccessor blocks
newPoints = mapMaybe ppSuccessor blocks newPoint = listToMaybe newPoints
newPoint = listToMaybe newPoints ppSuccessor b =
ppSuccessor b = let nreached id = case mapLookup id env `orElse`
let nreached id = case mapLookup id env `orElse` pprPanic "no ppt" (ppr id <+> ppr b) of
pprPanic "no ppt" (ppr id <+> ppr b) of ProcPoint -> 1
ProcPoint -> 1 ReachedBy ps -> setSize ps
ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b)
block_procpoints = nreached (entryLabel b) -- | Looking for a successor of b that is reached by
-- | Looking for a successor of b that is reached by -- more proc points than b and is not already a proc
-- more proc points than b and is not already a proc -- point. If found, it can become a proc point.
-- point. If found, it can become a proc point. newId succ_id = not (setMember succ_id procPoints') &&
newId succ_id = not (setMember succ_id procPoints') && nreached succ_id > block_procpoints
nreached succ_id > block_procpoints in listToMaybe $ filter newId $ successors b
in listToMaybe $ filter newId $ successors b
{- in case newPoint of
case newPoints of
[] -> return procPoints'
pps -> extendPPSet g blocks
(foldl extendBlockSet procPoints' pps)
-}
case newPoint of
Just id -> Just id ->
if setMember id procPoints' if setMember id procPoints'
then panic "added old proc pt" then panic "added old proc pt"
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment