[commit: ghc] master: splitAtProcPoints: jump to the right place when tablesNextToCode == False (2e8f08c)
Simon Marlow
marlowsd at gmail.com
Thu Sep 20 17:35:34 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/2e8f08c68fc2dabeec6bdd829c17a5946bb51e3a
>---------------------------------------------------------------
commit 2e8f08c68fc2dabeec6bdd829c17a5946bb51e3a
Author: Simon Marlow <marlowsd at gmail.com>
Date: Thu Sep 20 15:54:55 2012 +0100
splitAtProcPoints: jump to the right place when tablesNextToCode == False
>---------------------------------------------------------------
compiler/cmm/CmmPipeline.hs | 3 ++-
compiler/cmm/CmmProcPoint.hs | 35 ++++++++++++++++++++++++-----------
2 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 25fda1c..5fca9e7 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
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
------------- Populate info tables with stack info -----------------
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 58f2e54..471faf8 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -11,6 +11,7 @@ where
import Prelude hiding (last, unzip, succ, zip)
+import DynFlags
import BlockId
import CLabel
import Cmm
@@ -26,8 +27,6 @@ import UniqSupply
import Hoopl
-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
@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
-splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl]
-splitAtProcPoints entry_label callPPs procPoints procMap
+splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP)
-- 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))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
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))
+
-- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
_ -> 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
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (mapEmpty, []) needed_jumps
@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv)
+
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)
| bid == entry
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
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)
_ -> e
repl e = e
@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
-splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
More information about the Cvs-ghc
mailing list