Commit 2e8f08c6 authored by Simon Marlow's avatar Simon Marlow

splitAtProcPoints: jump to the right place when tablesNextToCode == False

parent c90d45f2
...@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
procPointAnalysis proc_points g procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g) splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info ----------------- ------------- Populate info tables with stack info -----------------
......
...@@ -11,6 +11,7 @@ where ...@@ -11,6 +11,7 @@ where
import Prelude hiding (last, unzip, succ, zip) import Prelude hiding (last, unzip, succ, zip)
import DynFlags
import BlockId import BlockId
import CLabel import CLabel
import Cmm import Cmm
...@@ -26,8 +27,6 @@ import UniqSupply ...@@ -26,8 +27,6 @@ import UniqSupply
import Hoopl import Hoopl
import qualified Data.Map as Map
-- Compute a minimal set of proc points for a control-flow graph. -- Compute a minimal set of proc points for a control-flow graph.
-- Determine a protocol for each proc point (which live variables will -- Determine a protocol for each proc point (which live variables will
...@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints = ...@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint. -- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator -- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY -- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl] CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls}) (CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) = top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach do -- Build a map from procpoints to the blocks they reach
...@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- * Labels for the info tables of their new procedures (only if -- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP) -- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints. -- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = Map.insert pp lbls map let add_label map pp = mapInsert pp lbls map
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label)) where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >> | otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp)) Just (infoTblLbl pp))
procLabels = foldl add_label Map.empty
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = foldl add_label mapEmpty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints)) (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- In each new graph, add blocks jumping off to the new procedures, -- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks -- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) = let add_jump_block (env, bs) (pp, l) =
...@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
_ -> rst _ -> rst
add_if_pp id rst = case Map.lookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst -- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
jump_label (Just info_lbl) _
| tablesNextToCode dflags = info_lbl
| otherwise = toEntryLbl info_lbl
jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
Nothing -> rst Nothing -> rst
(jumpEnv, jumpBlocks) <- (jumpEnv, jumpBlocks) <-
foldM add_jump_block (mapEmpty, []) needed_jumps foldM add_jump_block (mapEmpty, []) needed_jumps
...@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let g' = ofBlockMap ppId blockEnv''' let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do -- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv) return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl) (lbl, Just info_lbl)
| bid == entry | bid == entry
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info}) -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
...@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
replacePPIds g = {-# SCC "replacePPIds" #-} replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) = where repl e@(CmmLit (CmmBlock bid)) =
case Map.lookup bid procLabels of case mapLookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e _ -> e
repl e = e repl e = e
...@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
return -- pprTrace "procLabels" (ppr procLabels) return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs) -- pprTrace "splitting graphs" (ppr procs)
procs procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
......
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