Attach global register liveness info to Cmm procedures.

All Cmm procedures now include the set of global registers that are live on
procedure entry, i.e., the global registers used to pass arguments to the
procedure. Only global registers that are use to pass arguments are included in
this list.
parent 82ede426
...@@ -71,6 +71,14 @@ data GenCmmDecl d h g ...@@ -71,6 +71,14 @@ data GenCmmDecl d h g
= CmmProc -- A procedure = CmmProc -- A procedure
h -- Extra header such as the info table h -- Extra header such as the info table
CLabel -- Entry label CLabel -- Entry label
[GlobalReg] -- Registers live on entry. Note that the set of live
-- registers will be correct in generated C-- code, but
-- not in hand-written C-- code. However,
-- splitAtProcPoints calculates correct liveness
-- information for CmmProc's. Right now only the LLVM
-- back-end relies on correct liveness information and
-- for that back-end we always call splitAtProcPoints, so
-- all is good.
g -- Control-flow graph for the procedure's code g -- Control-flow graph for the procedure's code
| CmmData -- Static data | CmmData -- Static data
...@@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable ...@@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable
, stack_info :: CmmStackInfo } , stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing topInfoTable _ = Nothing
data CmmStackInfo data CmmStackInfo
= StackInfo { = StackInfo {
......
...@@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp ...@@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp
-- any CAF that is reachable from c. -- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
case topInfoTable proc of case topInfoTable proc of
Just (CmmInfoTable { cit_rep = rep }) Just (CmmInfoTable { cit_rep = rep })
| not (isStaticRep rep) && not (isStackRep rep) | not (isStaticRep rep) && not (isStackRep rep)
...@@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet ...@@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl) -> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel) -> (CAFSet, Maybe CLabel)
-> (BlockEnv CAFSet, CmmDecl) -> (BlockEnv CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl) bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl ) = ( mapMapWithKey get_cafs (info_tbls infos), decl )
where where
entry = g_entry g entry = g_entry g
...@@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map ...@@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map
-} -}
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l g) = updInfoSRTs srt_env (CmmProc top_info top_l live g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
where updInfoTbl l info_tbl where updInfoTbl l info_tbl
= info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t updInfoSRTs _ t = t
...@@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph ...@@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g) cmmCfgOpts split g = fst (blockConcat split g)
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g' cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
where (g', env) = blockConcat split g where (g', env) = blockConcat split g
info' = info{ info_tbls = new_info_tbls } info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
......
...@@ -19,7 +19,7 @@ import Outputable ...@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds mapTop (CmmData s ds) = CmmData s ds
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
......
...@@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] ...@@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat) mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat] = return [CmmData sec dat]
mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
-- --
-- in the non-tables-next-to-code case, procs can have at most a -- 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. -- single info table associated with the entry label of the proc.
...@@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) ...@@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= case topInfoTable proc of -- must be at most one = case topInfoTable proc of -- must be at most one
-- no info table -- no info table
Nothing -> Nothing ->
return [CmmProc mapEmpty entry_lbl blocks] return [CmmProc mapEmpty entry_lbl live blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <- (top_decls, (std_info, extra_bits)) <-
...@@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) ...@@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
-- Separately emit info table (with the function entry -- Separately emit info table (with the function entry
-- point as first entry) and the entry code -- point as first entry) and the entry code
return (top_decls ++ return (top_decls ++
[CmmProc mapEmpty entry_lbl blocks, [CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
...@@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) ...@@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= do = do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos) (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
return (concat top_declss ++ return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl blocks]) [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
where where
do_one_info (lbl,itbl) = do do_one_info (lbl,itbl) = do
......
...@@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes ...@@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) } info_tbl { cit_rep = StackRep (get_liveness lbl) }
......
...@@ -419,10 +419,10 @@ exactLog2 x_ ...@@ -419,10 +419,10 @@ exactLog2 x_
cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl
-- XXX: revisit if we actually want to do this -- 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 p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
cmmLoopifyForC dflags (CmmProc infos entry_lbl cmmLoopifyForC dflags (CmmProc infos entry_lbl live
(ListGraph blocks@(BasicBlock top_id _ : _))) = (ListGraph blocks@(BasicBlock top_id _ : _))) =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
CmmProc infos entry_lbl (ListGraph blocks') CmmProc infos entry_lbl live (ListGraph blocks')
where blocks' = [ BasicBlock id (map do_stmt stmts) where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ] | BasicBlock id stmts <- blocks ]
......
...@@ -61,7 +61,7 @@ cpsTop hsc_env proc = ...@@ -61,7 +61,7 @@ cpsTop hsc_env proc =
-- later passes by removing lots of empty blocks, so we do it -- later passes by removing lots of empty blocks, so we do it
-- even when optimisation isn't turned on. -- even when optimisation isn't turned on.
-- --
CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-} CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
return $ cmmCfgOptsProc splitting_proc_points proc return $ cmmCfgOptsProc splitting_proc_points proc
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
...@@ -121,7 +121,7 @@ cpsTop hsc_env proc = ...@@ -121,7 +121,7 @@ cpsTop hsc_env proc =
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 dflags l call_pps proc_points pp_map splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l g) (CmmProc h l v 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 -----------------
...@@ -140,7 +140,7 @@ cpsTop hsc_env proc = ...@@ -140,7 +140,7 @@ cpsTop hsc_env proc =
else do else do
-- attach info tables to return points -- attach info tables to return points
g <- return $ attachContInfoTables call_pps (CmmProc h l g) g <- return $ attachContInfoTables call_pps (CmmProc h l v g)
------------- Populate info tables with stack info ----------------- ------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-} g <- {-# SCC "setInfoTableStackMap" #-}
......
...@@ -18,6 +18,7 @@ import Cmm ...@@ -18,6 +18,7 @@ import Cmm
import PprCmm () import PprCmm ()
import CmmUtils import CmmUtils
import CmmInfo import CmmInfo
import CmmLive (cmmGlobalLiveness)
import Data.List (sortBy) import Data.List (sortBy)
import Maybes import Maybes
import Control.Monad import Control.Monad
...@@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE ...@@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE
CmmDecl -> UniqSM [CmmDecl] CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints dflags 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
let addBlock b graphEnv = let addBlock b graphEnv =
case mapLookup bid procMap of case mapLookup bid procMap of
...@@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
where graph = mapLookup procId graphEnv `orElse` mapEmpty where graph = mapLookup procId graphEnv `orElse` mapEmpty
graph' = mapInsert bid b graph graph' = mapInsert bid b graph
let liveness = cmmGlobalLiveness dflags g
let ppLiveness pp = filter isArgReg $
regSetToList $
expectJust "ppLiveness" $ mapLookup pp liveness
graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
-- Build a map from proc point BlockId to pairs of: -- Build a map from proc point BlockId to pairs of:
...@@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
let add_jump_block (env, bs) (pp, l) = let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid) emptyBlock jump let b = blockJoin (CmmEntry bid) emptyBlock jump
jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0 live = ppLiveness pp
-- XXX: No regs are live at the call jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
return (mapInsert pp bid env, b : bs) return (mapInsert pp bid env, b : bs)
add_jumps newGraphEnv (ppId, blockEnv) = add_jumps newGraphEnv (ppId, blockEnv) =
...@@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
| bid == entry | bid == entry
= CmmProc (TopInfo {info_tbls = info_tbls, = CmmProc (TopInfo {info_tbls = info_tbls,
stack_info = stack_info}) stack_info = stack_info})
top_l (replacePPIds g) top_l live g'
| otherwise | otherwise
= case expectJust "pp label" $ mapLookup bid procLabels of = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl) (lbl, Just info_lbl)
-> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
, stack_info=stack_info}) , stack_info=stack_info})
lbl (replacePPIds g) lbl live g'
(lbl, Nothing) (lbl, Nothing)
-> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
lbl (replacePPIds g) lbl live g'
where where
g' = replacePPIds g
live = ppLiveness (g_entry g')
stack_info = StackInfo { arg_space = 0 stack_info = StackInfo { arg_space = 0
, updfr_space = Nothing , updfr_space = Nothing
, do_layout = True } , do_layout = True }
...@@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
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
-- recursive lookup, see comment below. -- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
...@@ -358,8 +365,8 @@ replaceBranches env cmmg ...@@ -358,8 +365,8 @@ replaceBranches env cmmg
-- Not splitting proc points: add info tables for continuations -- Not splitting proc points: add info tables for continuations
attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables call_proc_points (CmmProc top_info top_l g) attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
= CmmProc top_info{info_tbls = info_tbls'} top_l g = CmmProc top_info{info_tbls = info_tbls'} top_l live g
where where
info_tbls' = mapUnion (info_tbls top_info) $ info_tbls' = mapUnion (info_tbls top_info) $
mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
......
...@@ -304,20 +304,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w) ...@@ -304,20 +304,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
copyInOflow :: DynFlags -> Convention -> Area copyInOflow :: DynFlags -> Convention -> Area
-> [CmmFormal] -> [CmmFormal]
-> [CmmFormal] -> [CmmFormal]
-> (Int, CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
copyInOflow dflags conv area formals extra_stk copyInOflow dflags conv area formals extra_stk
= (offset, catAGraphs $ map mkMiddle nodes) = (offset, gregs, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn dflags conv area formals extra_stk where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
-- Return the number of bytes used for copying arguments, as well as the -- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments. -- instructions to copy the arguments.
copyIn :: DynFlags -> Convention -> Area copyIn :: DynFlags -> Convention -> Area
-> [CmmFormal] -> [CmmFormal]
-> [CmmFormal] -> [CmmFormal]
-> (ByteOff, [CmmNode O O]) -> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn dflags conv area formals extra_stk copyIn dflags conv area formals extra_stk
= (stk_size, map ci (stk_args ++ args)) = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where where
ci (reg, RegisterParam r) = ci (reg, RegisterParam r) =
CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
...@@ -386,7 +386,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff ...@@ -386,7 +386,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
-> (Int, CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
mkCallEntry dflags conv formals extra_stk mkCallEntry dflags conv formals extra_stk
= copyInOflow dflags conv Old formals extra_stk = copyInOflow dflags conv Old formals extra_stk
......
...@@ -105,7 +105,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) ...@@ -105,7 +105,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-- | Returns the info table associated with the CmmDecl's entry point, -- | Returns the info table associated with the CmmDecl's entry point,
-- if any. -- if any.
topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
topInfoTable (CmmProc infos _ (ListGraph (b:_))) topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
= mapLookup (blockId b) infos = mapLookup (blockId b) infos
topInfoTable _ topInfoTable _
= Nothing = Nothing
...@@ -118,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' ...@@ -118,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g'
cmmMapGraph f tops = map (cmmTopMapGraph f) tops cmmMapGraph f tops = map (cmmTopMapGraph f) tops
cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g)
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- CmmStmt -- CmmStmt
......
...@@ -48,7 +48,7 @@ runCmmLint _ l p = ...@@ -48,7 +48,7 @@ runCmmLint _ l p =
Right _ -> Nothing Right _ -> Nothing
lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> ppr lbl) $ = addLintInfo (text "in proc " <> ppr lbl) $
let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock dflags labels) blocks in mapM_ (lintCmmBlock dflags labels) blocks
......
...@@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops ...@@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
-- top level procs -- top level procs
-- --
pprTop :: RawCmmDecl -> SDoc pprTop :: RawCmmDecl -> SDoc
pprTop proc@(CmmProc _ clbl (ListGraph blocks)) = pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
(case topInfoTable proc of (case topInfoTable proc of
Nothing -> empty Nothing -> empty
Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
......
...@@ -92,9 +92,9 @@ pprCmmGroup tops ...@@ -92,9 +92,9 @@ pprCmmGroup tops
pprTop :: (Outputable d, Outputable info, Outputable i) pprTop :: (Outputable d, Outputable info, Outputable i)
=> GenCmmDecl d info i -> SDoc => GenCmmDecl d info i -> SDoc
pprTop (CmmProc info lbl graph) pprTop (CmmProc info lbl live graph)
= vcat [ ppr lbl <> lparen <> rparen = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live
, nest 8 $ lbrace <+> ppr info $$ rbrace , nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ ppr graph , nest 4 $ ppr graph
, rbrace ] , rbrace ]
......
...@@ -90,9 +90,9 @@ get_Regtable_addr_from_offset dflags _ offset = ...@@ -90,9 +90,9 @@ get_Regtable_addr_from_offset dflags _ offset =
fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
fixStgRegisters _ top@(CmmData _ _) = top fixStgRegisters _ top@(CmmData _ _) = top
fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) =
let blocks' = map (fixStgRegBlock dflags) blocks let blocks' = map (fixStgRegBlock dflags) blocks
in CmmProc info lbl $ ListGraph blocks' in CmmProc info lbl live $ ListGraph blocks'
fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock dflags (BasicBlock id stmts) = fixStgRegBlock dflags (BasicBlock id stmts) =
......
...@@ -717,7 +717,7 @@ emitEnter fun = do ...@@ -717,7 +717,7 @@ emitEnter fun = do
-- --
AssignTo res_regs _ -> do AssignTo res_regs _ -> do
{ lret <- newLabelC { lret <- newLabelC
; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
; lcall <- newLabelC ; lcall <- newLabelC
; updfr_off <- getUpdFrameOff ; updfr_off <- getUpdFrameOff
; let area = Young lret ; let area = Young lret
......
...@@ -213,7 +213,7 @@ emitForeignCall safety results target args ...@@ -213,7 +213,7 @@ emitForeignCall safety results target args
updfr_off <- getUpdFrameOff updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target temp_target <- load_target_into_temp target
k <- newLabelC k <- newLabelC
let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results [] let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
-- see Note [safe foreign call convention] -- see Note [safe foreign call convention]
emit $ emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
......
...@@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do ...@@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do
Nothing -> genericGC checkYield code Nothing -> genericGC checkYield code
Just gc -> do Just gc -> do
lret <- newLabelC lret <- newLabelC
let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
lcont <- newLabelC lcont <- newLabelC
emitOutOfLine lret (copyin <*> mkBranch lcont) emitOutOfLine lret (copyin <*> mkBranch lcont)
emitLabel lcont emitLabel lcont
......
...@@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack ...@@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
AssignTo res_regs _ -> do AssignTo res_regs _ -> do
k <- newLabelC k <- newLabelC
let area = Young k let area = Young k
(off, copyin) = copyInOflow dflags retConv area res_regs [] (off, _, copyin) = copyInOflow dflags retConv area res_regs []
copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
extra_stack extra_stack
emit (copyout <*> mkLabel k <*> copyin) emit (copyout <*> mkLabel k <*> copyin)
...@@ -521,7 +521,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ...@@ -521,7 +521,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
; let args' = if node_points then (node : arg_regs) else arg_regs ; let args' = if node_points then (node : arg_regs) else arg_regs
conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
else NativeDirectCall else NativeDirectCall
(offset, _) = mkCallEntry dflags conv args' [] (offset, _, _) = mkCallEntry dflags conv args' []
; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
} }
......
...@@ -713,12 +713,12 @@ emitProcWithStackFrame ...@@ -713,12 +713,12 @@ emitProcWithStackFrame
emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
} }
emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; let (offset, entry) = mkCallEntry dflags conv args stk_args ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
; emitProc_ mb_info lbl (entry <*> blocks) offset True ; emitProc_ mb_info lbl live (entry <*> blocks) offset True
} }
emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
...@@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel ...@@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
emitProcWithConvention conv mb_info lbl args blocks emitProcWithConvention conv mb_info lbl args blocks
= emitProcWithStackFrame conv mb_info lbl [] args blocks True = emitProcWithStackFrame conv mb_info lbl [] args blocks True
emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode () emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
emitProc mb_info lbl blocks offset emitProc mb_info lbl live blocks offset
= emitProc_ mb_info lbl blocks offset True = emitProc_ mb_info lbl live blocks offset True
emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
-> FCode () -> FCode ()
emitProc_ mb_info lbl blocks offset do_layout emitProc_ mb_info lbl live blocks offset do_layout
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; l <- newLabelC ; l <- newLabelC
; let ; let
...@@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout ...@@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout
tinfo = TopInfo { info_tbls = infos tinfo = TopInfo { info_tbls = infos
, stack_info=sinfo} , stack_info=sinfo}
proc_block = CmmProc tinfo lbl blks proc_block = CmmProc tinfo lbl live blks
; state <- getState ; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
...@@ -795,7 +795,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do ...@@ -795,7 +795,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
dflags <- getDynFlags dflags <- getDynFlags
k <- newLabelC k <- newLabelC
let area = Young k let area = Young k
(off, copyin) = copyInOflow dflags retConv area results [] (off, _, copyin) = copyInOflow dflags retConv area results []
copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
return (copyout <*> mkLabel k <*> copyin) return (copyout <*> mkLabel k <*> copyin)
......
...@@ -41,7 +41,7 @@ llvmCodeGen dflags h us cmms ...@@ -41,7 +41,7 @@ llvmCodeGen dflags h us cmms
(cdata,env) = {-# SCC "llvm_split" #-} (cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([], initLlvmEnv dflags) cmm foldr split ([], initLlvmEnv dflags) cmm
split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split p@(CmmProc _ l _) (d,e) = split p@(CmmProc _ l _ _) (d,e) =
let lbl = strCLabel_llvm env $ case topInfoTable p of let lbl = strCLabel_llvm env $ case topInfoTable p of
Nothing -> l Nothing -> l
Just (Statics info_lbl _) -> info_lbl Just (Statics info_lbl _) -> info_lbl
...@@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars ...@@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars = cmmProcLlvmGens dflags h us env cmms count ivars
cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars = cmmProcLlvmGens dflags h us env cmms count ivars