insert z succId m =
do (b, bmap) <- z
(b, bs) <- insertBetween b m succId
- pprTrace "insert for succ" (ppr succId <> ppr m) $
- return $ (b, foldl (flip insertBlock) bmap bs)
+ -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
+ return $ (b, foldl (flip insertBlock) bmap bs)
finish (b@(Block bid _ _), bmap) =
return $ (extendBlockEnv bmap bid b)
skip b@(Block bid _ _) bs =
-- Input invariant: A block should only be reachable from a single ProcPoint.
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap areaMap
+splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
(CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
g@(LGraph entry e_off blocks)) =
do -- Build a map from procpoints to the blocks they reach
where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
graph' = extendBlockEnv graph bid b
graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
- graphEnv <- return $ pprTrace "graphEnv" (ppr graphEnv_pre) graphEnv_pre
+ graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
-- Build a map from proc point BlockId to labels for their new procedures
let add_label map pp = return $ addToFM map pp lbl
where lbl = if pp == entry then entry_label else blockLbl pp
l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
return (extendBlockEnv env pp bid, b : bs)
add_jumps (newGraphEnv) (ppId, blockEnv) =
- do (jumpEnv, jumpBlocks) <-
- foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels)
+ do let needed_jumps = -- find which procpoints we currently branch to
+ foldBlockEnv' add_if_branch_to_pp [] blockEnv
+ add_if_branch_to_pp block rst =
+ case last (unzip block) of
+ LastOther (LastBranch id) -> add_if_pp id rst
+ LastOther (LastCondBranch _ ti fi) ->
+ 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
+ Just x -> (id, x) : rst
+ Nothing -> rst
+ -- fmToList procLabels
+ (jumpEnv, jumpBlocks) <-
+ foldM add_jump_block (emptyBlockEnv, []) needed_jumps
+ -- update the entry block
let (b_off, b) = -- get the stack offset on entry into the block and
-- remove the offset from the block (it goes in new graph)
case lookupBlockEnv blockEnv ppId of -- get the procpoint block
Nothing -> panic "couldn't find entry block while splitting"
blockEnv' = extendBlockEnv blockEnv ppId b
off = if ppId == entry then e_off else b_off
+ -- replace branches to procpoints with branches to jumps
LGraph _ _ blockEnv'' =
replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+ -- add the jump blocks to the graph
blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
let g' = LGraph ppId off blockEnv'''
- pprTrace "g' pre jumps" (ppr g') $
- return (extendBlockEnv newGraphEnv ppId g')
+ -- pprTrace "g' pre jumps" (ppr g') $ do
+ return (extendBlockEnv newGraphEnv ppId g')
graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
- graphEnv <- return $ pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
+ graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
graphEnv_pre
- let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
+ let to_proc (bid, g) | elemBlockSet bid callPPs =
if bid == entry then
CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
else
compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
(expectJust "block_order" $ lookupBlockEnv block_order bid')
procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
- return $ pprTrace "procLabels" (ppr procLabels)
- $ pprTrace "splitting graphs" (ppr procs)
- $ procs
+ return -- pprTrace "procLabels" (ppr procLabels)
+ -- pprTrace "splitting graphs" (ppr procs)
+ procs
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
----------------------------------------------------------------