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
= CmmProc -- A procedure
h -- Extra header such as the info table
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
| CmmData -- Static data
......@@ -100,8 +108,8 @@ 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
topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
data CmmStackInfo
= StackInfo {
......
......@@ -250,7 +250,7 @@ to_SRT dflags 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 proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
case topInfoTable proc of
Just (CmmInfoTable { cit_rep = rep })
| not (isStaticRep rep) && not (isStackRep rep)
......@@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (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 )
where
entry = g_entry g
......@@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map
-}
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
updInfoSRTs srt_env (CmmProc top_info top_l live g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
where updInfoTbl l info_tbl
= info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t
......@@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g)
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
info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
......
......@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
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
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
......
......@@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (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
-- single info table associated with the entry label of the proc.
......@@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
return [CmmProc mapEmpty entry_lbl blocks]
return [CmmProc mapEmpty entry_lbl live blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
......@@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
return (top_decls ++
[CmmProc mapEmpty entry_lbl blocks,
[CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
......@@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
= do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl blocks])
[CmmProc (mapFromList raw_infos) entry_lbl live blocks])
where
do_one_info (lbl,itbl) = do
......
......@@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
......
......@@ -419,10 +419,10 @@ exactLog2 x_
cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl
-- 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 dflags (CmmProc infos entry_lbl
cmmLoopifyForC dflags (CmmProc infos entry_lbl live
(ListGraph blocks@(BasicBlock top_id _ : _))) =
-- 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)
| BasicBlock id stmts <- blocks ]
......
......@@ -61,7 +61,7 @@ cpsTop hsc_env proc =
-- later passes by removing lots of empty blocks, so we do it
-- 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
dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
......@@ -121,7 +121,7 @@ cpsTop hsc_env proc =
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
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
------------- Populate info tables with stack info -----------------
......@@ -140,7 +140,7 @@ cpsTop hsc_env proc =
else do
-- 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 -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
......
......@@ -18,6 +18,7 @@ import Cmm
import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive (cmmGlobalLiveness)
import Data.List (sortBy)
import Maybes
import Control.Monad
......@@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints dflags entry_label callPPs procPoints procMap
(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
let addBlock b graphEnv =
case mapLookup bid procMap of
......@@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
where graph = mapLookup procId graphEnv `orElse` mapEmpty
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
-- Build a map from proc point BlockId to pairs of:
......@@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid) emptyBlock jump
jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0
-- XXX: No regs are live at the call
live = ppLiveness pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
return (mapInsert pp bid env, b : bs)
add_jumps newGraphEnv (ppId, blockEnv) =
......@@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
| bid == entry
= CmmProc (TopInfo {info_tbls = info_tbls,
stack_info = stack_info})
top_l (replacePPIds g)
top_l live g'
| otherwise
= case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
-> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
, stack_info=stack_info})
lbl (replacePPIds g)
lbl live g'
(lbl, Nothing)
-> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
lbl (replacePPIds g)
lbl live g'
where
g' = replacePPIds g
live = ppLiveness (g_entry g')
stack_info = StackInfo { arg_space = 0
, updfr_space = Nothing
, do_layout = True }
......@@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
procs
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
......@@ -358,8 +365,8 @@ replaceBranches env cmmg
-- Not splitting proc points: add info tables for continuations
attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables call_proc_points (CmmProc top_info top_l g)
= CmmProc top_info{info_tbls = info_tbls'} top_l g
attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
= CmmProc top_info{info_tbls = info_tbls'} top_l live g
where
info_tbls' = mapUnion (info_tbls top_info) $
mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
......
......@@ -304,20 +304,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
copyInOflow :: DynFlags -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (Int, CmmAGraph)
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow dflags conv area formals extra_stk
= (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn dflags conv area formals extra_stk
= (offset, gregs, catAGraphs $ map mkMiddle nodes)
where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: DynFlags -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [CmmNode O O])
-> (ByteOff, [GlobalReg], [CmmNode O O])
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
ci (reg, RegisterParam r) =
CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
......@@ -386,7 +386,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
-> (Int, CmmAGraph)
-> (Int, [GlobalReg], CmmAGraph)
mkCallEntry dflags conv formals extra_stk
= copyInOflow dflags conv Old formals extra_stk
......
......@@ -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,
-- if any.
topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
topInfoTable (CmmProc infos _ (ListGraph (b:_)))
topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
= mapLookup (blockId b) infos
topInfoTable _
= Nothing
......@@ -118,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g'
cmmMapGraph f tops = map (cmmTopMapGraph f) tops
cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g)
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g)
cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
-----------------------------------------------------------------------------
-- CmmStmt
......
......@@ -48,7 +48,7 @@ runCmmLint _ l p =
Right _ -> Nothing
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) $
let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock dflags labels) blocks
......
......@@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
-- top level procs
--
pprTop :: RawCmmDecl -> SDoc
pprTop proc@(CmmProc _ clbl (ListGraph blocks)) =
pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
(case topInfoTable proc of
Nothing -> empty
Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
......
......@@ -92,9 +92,9 @@ pprCmmGroup tops
pprTop :: (Outputable d, Outputable info, Outputable i)
=> 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 4 $ ppr graph
, rbrace ]
......
......@@ -90,9 +90,9 @@ get_Regtable_addr_from_offset dflags _ offset =
fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
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
in CmmProc info lbl $ ListGraph blocks'
in CmmProc info lbl live $ ListGraph blocks'
fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock dflags (BasicBlock id stmts) =
......
......@@ -717,7 +717,7 @@ emitEnter fun = do
--
AssignTo res_regs _ -> do
{ lret <- newLabelC
; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
; lcall <- newLabelC
; updfr_off <- getUpdFrameOff
; let area = Young lret
......
......@@ -213,7 +213,7 @@ emitForeignCall safety results target args
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
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]
emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
......
......@@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do
Nothing -> genericGC checkYield code
Just gc -> do
lret <- newLabelC
let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
lcont <- newLabelC
emitOutOfLine lret (copyin <*> mkBranch lcont)
emitLabel lcont
......
......@@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
AssignTo res_regs _ -> do
k <- newLabelC
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
extra_stack
emit (copyout <*> mkLabel k <*> copyin)
......@@ -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
conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
else NativeDirectCall
(offset, _) = mkCallEntry dflags conv args' []
(offset, _, _) = mkCallEntry dflags conv args' []
; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
}
......
......@@ -713,12 +713,12 @@ emitProcWithStackFrame
emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
= 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
= do { dflags <- getDynFlags
; let (offset, entry) = mkCallEntry dflags conv args stk_args
; emitProc_ mb_info lbl (entry <*> blocks) offset True
; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
; emitProc_ mb_info lbl live (entry <*> blocks) offset True
}
emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
......@@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
emitProcWithConvention conv mb_info lbl args blocks
= emitProcWithStackFrame conv mb_info lbl [] args blocks True
emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode ()
emitProc mb_info lbl blocks offset
= emitProc_ mb_info lbl blocks offset True
emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
emitProc mb_info lbl live blocks offset
= emitProc_ mb_info lbl live blocks offset True
emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool
emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
-> FCode ()
emitProc_ mb_info lbl blocks offset do_layout
emitProc_ mb_info lbl live blocks offset do_layout
= do { dflags <- getDynFlags
; l <- newLabelC
; let
......@@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout
tinfo = TopInfo { info_tbls = infos
, stack_info=sinfo}
proc_block = CmmProc tinfo lbl blks
proc_block = CmmProc tinfo lbl live blks
; state <- getState
; 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
dflags <- getDynFlags
k <- newLabelC
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
return (copyout <*> mkLabel k <*> copyin)
......
......@@ -41,7 +41,7 @@ llvmCodeGen dflags h us cmms
(cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([], initLlvmEnv dflags) cmm
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
Nothing -> l
Just (Statics info_lbl _) -> info_lbl
......@@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars
cmmProcLlvmGens dflags h us env ((CmmData _ _) : 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 (cmm : cmms) count ivars = do
......
......@@ -37,10 +37,10 @@ type LlvmStatements = OrdList LlvmStatement
-- | Top-level of the LLVM proc Code generator
--
genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do
genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
(env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
let info = topInfoTable proc0
proc = CmmProc info lbl (ListGraph lmblocks)
proc = CmmProc info lbl live (ListGraph lmblocks)
return (env', proc:lmdata)
genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
......
......@@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
pprLlvmCmmDecl _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl _ (ListGraph blks))
= let (idoc, ivar) = case mb_info of
Nothing -> (empty, [])
Just (Statics info_lbl dat)
......
......@@ -290,7 +290,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
| gopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph [])
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
......@@ -550,8 +550,8 @@ cmmNativeGen dflags ncgImpl us cmm count
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
-- | Build a doc for all the imports.
......@@ -627,8 +627,8 @@ sequenceTop
=> NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
sequenceTop _ top@(CmmData _ _) = top
sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
......@@ -744,7 +744,7 @@ generateJumpTables
:: NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
......@@ -768,10 +768,10 @@ build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl d (BlockEnv t) (ListGraph instr)
-> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl (ListGraph []))
= (CmmProc info lbl (ListGraph []), emptyUFM)
build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
= (CmmProc info lbl (ListGraph (head:others)), mapping)
build_mapping _ (CmmProc info lbl live (ListGraph []))
= (CmmProc info lbl live (ListGraph []), emptyUFM)
build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
= (CmmProc info lbl live (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
where
......@@ -804,8 +804,8 @@ apply_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl statics h (ListGraph instr)
apply_mapping ncgImpl ufm (CmmData sec statics)
= CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
= CmmProc info lbl (ListGraph $ map short_bb blocks)
apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
= CmmProc info lbl live (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
......@@ -878,9 +878,9 @@ Ideas for other things we could do (put these in Hoopl please!):
cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold blocks
return $ CmmProc info lbl (ListGraph blocks')
return $ CmmProc info lbl live (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
......
......@@ -693,7 +693,7 @@ initializePicBase_ppc
-> NatM [NatCmmDecl CmmStatics PPC.Instr]
initializePicBase_ppc ArchPPC os picReg
(CmmProc info lab (ListGraph blocks) : statics)
(CmmProc info lab live (ListGraph blocks) : statics)
| osElfTarget os
= do
dflags <- getDynFlags
......@@ -719,11 +719,11 @@ initializePicBase_ppc ArchPPC os picReg
: PPC.ADD picReg picReg (PPC.RIReg tmp)
: insns)
return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics)
return (CmmProc info lab live (ListGraph (b' : tail blocks)) : gotOffset : statics)
initializePicBase_ppc ArchPPC OSDarwin picReg
(CmmProc info lab (ListGraph blocks) : statics)
= return (CmmProc info lab (ListGraph (b':tail blocks)) : statics)
(CmmProc info lab live (ListGraph blocks) : statics)
= return (CmmProc info lab live (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks
b' = BasicBlock bID (PPC.FETCHPC picReg : insns)
......@@ -746,9 +746,9 @@ initializePicBase_x86
-> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
initializePicBase_x86 ArchX86 os picReg
(CmmProc info lab (ListGraph blocks) : statics)
(CmmProc info lab live (ListGraph blocks) : statics)
| osElfTarget os
= return (CmmProc info lab (ListGraph blocks') : statics)
= return (CmmProc info lab live (ListGraph blocks') : statics)
where blocks' = case blocks of
[] -> []
(b:bs) -> fetchGOT b : map maybeFetchGOT bs
......@@ -764,8 +764,8 @@ initializePicBase_x86 ArchX86 os picReg
BasicBlock bID (X86.FETCHGOT picReg : insns)
initializePicBase_x86 ArchX86 OSDarwin picReg
(CmmProc info lab (ListGraph blocks) : statics)
= return (CmmProc info lab (ListGraph blocks') : statics)
(CmmProc info lab live (ListGraph blocks) : statics)
= return (CmmProc info lab live (ListGraph blocks') : statics)
where blocks' = case blocks of
[] -> []
......
......@@ -71,11 +71,11 @@ cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat