Commit f1ed6a10 authored by Simon Marlow's avatar Simon Marlow

New codegen: do not split proc-points when using the NCG

Proc-point splitting is only required by backends that do not support
having proc-points within a code block (that is, everything except the
native backend, i.e. LLVM and C).

Not doing proc-point splitting saves some compilation time, and might
produce slightly better code in some cases.
parent fe3753e7
......@@ -14,7 +14,7 @@ module Cmm (
CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
-- * Info Tables
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..),
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
ClosureTypeInfo(..),
C_SRT(..), needsSRT,
ProfilingInfo(..), ConstrDescription,
......@@ -96,17 +96,23 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo { info_tbl :: CmmInfoTable
data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable
, stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
data CmmStackInfo
= StackInfo {
arg_space :: ByteOff,
-- number of bytes of arguments on the stack on entry to the
-- the proc. This is filled in by StgCmm.codeGen, and used
-- by the stack allocator later.
updfr_space :: Maybe ByteOff -- XXX: comment?
}
updfr_space :: Maybe ByteOff
-- XXX: this never contains anything useful, but it should.
-- See comment in CmmLayoutStack.
}
-- | Info table as a haskell data type
data CmmInfoTable
......@@ -116,7 +122,6 @@ data CmmInfoTable
cit_prof :: ProfilingInfo,
cit_srt :: C_SRT
}
| CmmNonInfoTable -- Procedure doesn't need an info table
data ProfilingInfo
= NoProfilingInfo
......
......@@ -50,21 +50,9 @@ import Control.Monad
foldSet :: (a -> b -> b) -> b -> Set a -> b
foldSet = Set.foldr
----------------------------------------------------------------
-- Building InfoTables
-----------------------------------------------------------------------
-- SRTs
-- WE NEED AN EXAMPLE HERE.
-- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
-- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
-- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
-- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
-- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
-- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
{- EXAMPLE
f = \x. ... g ...
......@@ -100,7 +88,7 @@ h_closure with their contents:
[ g_entry{c2_closure, c1_closure} ]
[ h_entry{c2_closure} ]
This is what mkTopCAFInfo is doing.
This is what flattenCAFSets is doing.
-}
......@@ -179,8 +167,8 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT cafs =
buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT topSRT cafs =
do let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
......@@ -261,9 +249,9 @@ to_SRT top_srt off len bmp
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of
CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
case topInfoTable proc of
Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
-> (cafs, Just (toClosureLbl top_l))
_other -> (cafs, Nothing)
where
......@@ -304,16 +292,30 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset
bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (CAFSet, CmmDecl)
bundle flatmap (_, decl) (cafs, Nothing)
= (flatten flatmap cafs, decl)
bundle flatmap (_, decl) (_, Just l)
= (expectJust "bundle" $ Map.lookup l flatmap, decl)
-> (BlockEnv CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl )
where
entry = g_entry g
entry_cafs
| Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
| otherwise = flatten flatmap closure_cafs
get_cafs l _
| l == entry = entry_cafs
| otherwise = if not (mapMember l env)
then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
else flatten flatmap $ expectJust "bundle" $ mapLookup l env
bundle flatmap (_, decl) _
= ( mapEmpty, decl )
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
where
zipped = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
localCAFs = unzipWith localCAFInfo zipped
flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
......@@ -328,15 +330,35 @@ doSRTs topSRT tops
let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
return (topSRT', reverse gs' {- Note [reverse gs] -})
where
setSRT (topSRT, rst) (cafs, decl@(CmmProc{})) = do
(topSRT, cafTable, srt) <- buildSRTs topSRT cafs
let decl' = updInfo (const srt) decl
case cafTable of
Just tbl -> return (topSRT, decl': tbl : rst)
Nothing -> return (topSRT, decl' : rst)
setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
(topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map
let decl' = updInfoSRTs srt_env decl
return (topSRT, decl': srt_tables ++ rst)
setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst)
buildSRTs :: TopSRT -> BlockEnv CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
buildSRTs top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where
doOne (top_srt, decls, srt_env) (l, cafs)
= do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs
return ( top_srt, maybeToList mb_decl ++ decls
, mapInsert l srt srt_env )
{-
- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
- The one corresponding to g_entry is the closure info table, the
rest are continuations.
- Each one needs an SRT.
- We get the CAFSet for each one from the CAFEnv
- flatten gives us
[(BlockEnv CAFSet, CmmDecl)]
-
-}
{- Note [reverse gs]
It is important to keep the code blocks in the same order,
......@@ -345,12 +367,9 @@ doSRTs topSRT tops
instructions for forward refs. --SDM
-}
updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
updInfo toSrt (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g
updInfo _ t = t
updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toSrt info_tbl@(CmmInfoTable {})
= info_tbl { cit_srt = toSrt (cit_srt info_tbl) }
updInfoTbl _ t@CmmNonInfoTable = t
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
where updInfoTbl l info_tbl
= info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t
......@@ -25,14 +25,21 @@ import Prelude hiding (succ, unzip, zip)
-----------------------------------------------------------------------------
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat
cmmCfgOpts g = removeUnreachableBlocks $ fst (blockConcat g)
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts
cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl (removeUnreachableBlocks g')
where (g', env) = blockConcat g
info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top
upd_info (k,info)
| Just k' <- mapLookup k env
= (k', info{ cit_lbl = infoTblLbl k' })
| otherwise
= (k,info)
cmmCfgOptsProc top = top
-----------------------------------------------------------------------------
......@@ -41,7 +48,7 @@ optProc _ top = top
--
-----------------------------------------------------------------------------
-- This optimisation does two things:
-- This optimisation does three things:
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
......@@ -52,6 +59,10 @@ optProc _ top = top
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
--
-- - removes any unreachable blocks from the graph. This is a side
-- effect of starting with a postorder DFS traversal of the graph
--
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.
......@@ -77,9 +88,9 @@ optProc _ top = top
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat :: CmmGraph -> CmmGraph
blockConcat :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
where
-- we might be able to shortcut the entry BlockId itself
new_entry
......@@ -90,9 +101,12 @@ blockConcat g@CmmGraph { g_entry = entry_id }
= entry_id
blocks = postorderDfs g
blockmap = foldr addBlock emptyBody blocks
-- the initial blockmap is constructed from the postorderDfs result,
-- so that we automatically throw away unreachable blocks.
(new_blocks, shortcut_map) =
foldr maybe_concat (toBlockMap g, mapEmpty) blocks
foldr maybe_concat (blockmap, mapEmpty) blocks
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
......
......@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbl h) l (ofZgraph g)
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
data ValueDirection = Arguments | Results
......
......@@ -21,6 +21,7 @@ import SMRep
import Bitmap
import Stream (Stream)
import qualified Stream
import Hoopl
import Maybes
import Constants
......@@ -90,17 +91,63 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable dflags (CmmProc info entry_label blocks)
| CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info
= do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
| otherwise = panic "mkInfoTable"
-- Patern match overlap check not clever enough
mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
--
-- in the non-tables-next-to-code case, procs can have at most a
-- single info table associated with the entry label of the proc.
--
| not tablesNextToCode
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
return [CmmProc mapEmpty entry_lbl blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags info Nothing
let
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
--
case blocks of
ListGraph [] ->
-- No code; only the info table is significant
-- Use a zero place-holder in place of the
-- entry-label in the info table
return (top_decls ++
[mkRODataLits info_lbl (zeroCLit : rel_std_info ++
rel_extra_bits)])
_nonempty ->
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
return (top_decls ++
[CmmProc mapEmpty entry_lbl blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
--
-- With tables-next-to-code, we can have many info tables,
-- associated with some of the BlockIds of the proc. For each info
-- table we need to turn it into CmmStatics, and collect any new
-- CmmDecls that arise from doing so.
--
| otherwise
= do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl blocks])
where
do_one_info (lbl,itbl) = do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags itbl Nothing
let
info_lbl = cit_lbl itbl
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
--
return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
type InfoTableContents = ( [CmmLit] -- The standard part
......@@ -207,36 +254,6 @@ mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)
-- * the code
-- and lays them out in memory, producing a list of RawCmmDecl
-- The value of tablesNextToCode determines the relative positioning
-- of the extra bits and the standard info table, and whether the
-- former is reversed or not. It also decides whether pointers in the
-- info table should be expressed as offsets relative to the info
-- pointer or not (see "Position Independent Code" below.
mkInfoTableAndCode :: CLabel -- Info table label
-> InfoTableContents
-> CLabel -- Entry label
-> ListGraph CmmStmt -- Entry code
-> [RawCmmDecl]
mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
= [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info)
entry_lbl blocks]
| ListGraph [] <- blocks -- No code; only the info table is significant
= -- Use a zero place-holder in place of the
-- entry-label in the info table
[mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
| otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code
[CmmProc Nothing entry_lbl blocks,
mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]
where
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
-------------------------------------------------------------------------
--
-- Position independent code
......
......@@ -820,18 +820,17 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap stackmaps
(CmmProc top_info@TopInfo{..} l g@CmmGraph{g_entry = eid})
= CmmProc top_info{ info_tbl = fix_info info_tbl } l g
setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
where
fix_info info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness eid) }
fix_info other = other
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
fix_info _ other = other
get_liveness :: BlockId -> Liveness
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl)
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
Just sm -> stackMapToLiveness sm
setInfoTableStackMap _ d = d
......
......@@ -22,6 +22,7 @@ import CmmNode (wrapRecExp)
import CmmUtils
import DynFlags
import StaticFlags
import CLabel
import UniqFM
import Unique
......@@ -667,11 +668,12 @@ exactLog2 x_
-}
cmmLoopifyForC :: RawCmmDecl -> RawCmmDecl
cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
-- XXX: revisit if we actually want to do this
-- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
cmmLoopifyForC (CmmProc infos entry_lbl
(ListGraph blocks@(BasicBlock top_id _ : _))) =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
CmmProc (Just info) entry_lbl (ListGraph blocks')
CmmProc infos entry_lbl (ListGraph blocks')
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
......@@ -679,7 +681,7 @@ cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
= CmmBranch top_id
do_stmt stmt = stmt
jump_lbl | tablesNextToCode = info_lbl
jump_lbl | tablesNextToCode = toInfoLbl entry_lbl
| otherwise = entry_lbl
cmmLoopifyForC top = top
......
......@@ -255,7 +255,7 @@ cmmproc :: { ExtCode }
$4;
return formals }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc CmmNonInfoTable (mkCmmCodeLabel pkg $1) formals blks) }
code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
......
......@@ -10,6 +10,7 @@ module CmmPipeline (
) where
import Cmm
import CmmUtils
import CmmLint
import CmmBuildInfoTables
import CmmCommonBlockElim
......@@ -25,6 +26,7 @@ import ErrUtils
import HscTypes
import Control.Monad
import Outputable
import StaticFlags
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
......@@ -65,57 +67,84 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- elimCommonBlocks
----------- Proc points -------------------
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet (targetPlatform dflags) callPPs g
let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
proc_points <-
if splitting_proc_points
then {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet (targetPlatform dflags) call_pps g
else
return call_pps
let noncall_pps = proc_points `setDifference` call_pps
when (not (setNull noncall_pps)) $
pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
----------- Layout the stack and manifest Sp ---------------
-- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
(g, stackmaps) <- {-# SCC "layoutStack" #-}
runUniqSM $ cmmLayoutStack dflags procPoints entry_off g
runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
g <- if optLevel dflags >= 99
----------- Sink and inline assignments -------------------
g <- if dopt Opt_CmmSink dflags
then do g <- {-# SCC "sink" #-} return (cmmSink g)
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
return g
else return g
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
-- rewriteAssignments platform g
-- dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
------------- Split into separate procedures ------------
procPointMap <- {-# SCC "procPointAnalysis" #-} runUniqSM $
procPointAnalysis procPoints g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- CAF analysis ------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
------------- Populate info tables with stack info ------
gs <- {-# SCC "setInfoTableStackMap" #-}
return $ map (setInfoTableStackMap stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations -----------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
return (cafEnv, gs)
if splitting_proc_points
then do
------------- Split into separate procedures ------------
pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $
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)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info ------
gs <- {-# SCC "setInfoTableStackMap" #-}
return $ map (setInfoTableStackMap stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations ---------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
return (cafEnv, gs)
else do
-- attach info tables to return points
g <- return $ attachContInfoTables call_pps (CmmProc h l g)
------------- Populate info tables with stack info ------
g <- {-# SCC "setInfoTableStackMap" #-}
return $ setInfoTableStackMap stackmaps g
dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
----------- Control-flow optimisations ---------------
g <- {-# SCC "cmmCfgOpts(2)" #-} return $ cmmCfgOptsProc g
dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
return (cafEnv, [g])
where dflags = hsc_dflags hsc_env
dump = dumpGraph dflags
dump' = dumpWith dflags
dumps flag name
= mapM_ (dumpWith dflags flag name)
-- we don't need to split proc points for the NCG, unless
-- tablesNextToCode is off. The latter is because we have no
-- label to put on info tables for basic blocks that are not
-- the entry point.
splitting_proc_points = hscTarget dflags /= HscAsm
|| not tablesNextToCode
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
us <- mkSplitUniqSupply 'u'
......
......@@ -5,6 +5,7 @@ module CmmProcPoint
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, splitAtProcPoints, procPointAnalysis
, attachContInfoTables
)
where
......@@ -209,7 +210,7 @@ extendPPSet platform g blocks procPoints =
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbl=info_tbl})
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
let addBlock b graphEnv =
......@@ -234,10 +235,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- 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
where lbls | pp == entry = (entry_label, Just entry_info_lbl)
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp))
entry_info_lbl = cit_lbl info_tbl
procLabels = foldl add_label Map.empty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- In each new graph, add blocks jumping off to the new procedures,
......@@ -278,13 +278,13 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info