Skip to content

GHC
GHC
Commit b44b0bef authored by Michael D. Adams's avatar Michael D. Adams
Browse files
Options

Added support for GC block declaration to the Cmm syntax

parent 5f00461a
Hide whitespace changes
Inline Side-by-side
Showing with 57 additions and 80 deletions
compiler/cmm/Cmm.hs
View file @ b44b0bef
......@@ -113,7 +113,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
data CmmInfo
= CmmInfo
(Maybe BlockId) -- GC target
(Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
(Maybe UpdateFrame) -- Update frame
CmmInfoTable -- Info table
......
compiler/cmm/CmmCPS.hs
View file @ b44b0bef
......@@ -15,7 +15,6 @@ import CmmBrokenBlock
import CmmProcPoint
import CmmCallConv
import CmmCPSGen
import CmmInfo
import CmmUtils
import ClosureInfo
......@@ -69,37 +68,23 @@ cmmCPS dflags abstractC = do
return continuationC
stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
make_stack_check stack_check_block_id info stack_use next_block_id =
BasicBlock stack_check_block_id $
check_stmts ++ [CmmBranch next_block_id]
where
stmts = [CmmCall stg_gc_gen_target [] [] safety,
CmmJump fun_expr actuals]
stg_gc_gen_target =
CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
fun_expr = CmmLit (CmmLabel fun_label)
make_gc_check stack_use gc_block =
[CmmCondBranch
(CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
[CmmReg stack_use, CmmReg spLimReg])
gc_block]
force_gc_block old_info stack_use block_id fun_label formals =
case old_info of
CmmInfo (Just existing) _ _
-> (old_info, [], make_gc_check stack_use existing)
CmmInfo Nothing update_frame info_table
-> (CmmInfo (Just block_id) update_frame info_table,
[make_gc_block block_id fun_label formals (CmmSafe $ cmmInfoTableSRT info_table)],
make_gc_check stack_use block_id)
cmmInfoTableSRT CmmNonInfoTable = NoC_SRT
cmmInfoTableSRT (CmmInfoTable _ _ (ConstrInfo _ _ _)) = NoC_SRT
cmmInfoTableSRT (CmmInfoTable _ _ (FunInfo _ srt _ _ _ _)) = srt
cmmInfoTableSRT (CmmInfoTable _ _ (ThunkInfo _ srt)) = srt
cmmInfoTableSRT (CmmInfoTable _ _ (ThunkSelectorInfo _ srt)) = srt
cmmInfoTableSRT (CmmInfoTable _ _ (ContInfo _ srt)) = srt
check_stmts =
case info of
-- If we are given a stack check handler,
-- then great, well check the stack.
CmmInfo (Just gc_block) _ _
-> [CmmCondBranch
(CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
[CmmReg stack_use, CmmReg spLimReg])
gc_block]
-- If we aren't given a stack check handler,
-- then humph! we just won't check the stack for them.
CmmInfo Nothing _ _
-> []
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
......@@ -120,39 +105,35 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc]
-- CPS transform for those procs that actually need it
cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
where
-- We need to be generating uniques for several things.
-- We could make this function monadic to handle that
-- but since there is no other reason to make it monadic,
-- we instead will just split them all up right here.
(uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
uniques :: [[Unique]]
uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
(gc_unique:gc_block_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
(stack_check_block_unique:stack_use_unique:info_uniques) :
adaptor_uniques :
block_uniques = uniques
proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
stack_check_block_id = BlockId stack_check_block_unique
stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
-- TODO: doc
forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
(forced_info, gc_blocks, check_stmts) = forced_gc
gc_block_id = BlockId gc_block_unique
forced_blocks = stack_check_block : blocks
forced_blocks =
BasicBlock gc_block_id
(check_stmts++[CmmBranch $ blockId $ head blocks]) :
blocks ++ gc_blocks
forced_gc_id = case forced_info of
CmmInfo (Just x) _ _ -> x
update_frame = case info of CmmInfo _ u _ -> u
CmmInfo maybe_gc_block_id update_frame _ = info
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
broken_blocks =
(\x -> (concatMap fst x, concatMap snd x)) $
zipWith3 (breakBlock [forced_gc_id])
zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
block_uniques
forced_blocks
(FunctionEntry forced_info ident params :
(FunctionEntry info ident params :
repeat ControlEntry)
f' = selectContinuations (fst broken_blocks)
......@@ -243,9 +224,9 @@ gatherBlocksIntoContinuation live proc_points blocks start =
Continuation info_table clabel params is_gc_cont body
where
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
start_block = lookupWithDefaultUFM blocks (panic "TODO") start
start_block = lookupWithDefaultUFM blocks unknown_block start
children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
body = start_block : children_blocks
-- We can't properly annotate the continuation's stack parameters
......
compiler/cmm/CmmCPSGen.hs
View file @ b44b0bef
......@@ -97,11 +97,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
gc_stmts :: [CmmStmt]
gc_stmts =
case info of
CmmInfo (Just gc_block) _ _ ->
gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
CmmInfo Nothing _ _ ->
panic "continuationToProc: missing GC block"
assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
update_stmts :: [CmmStmt]
update_stmts =
......@@ -124,10 +120,11 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
prefix_blocks ++ [main_block]
where
prefix_blocks =
case gc_prefix ++ param_prefix of
[] -> []
entry_stmts -> [BasicBlock prefix_id
(entry_stmts ++ [CmmBranch ident])]
if is_entry
then [BasicBlock
(BlockId prefix_unique)
(param_stmts ++ [CmmBranch ident])]
else []
prefix_unique : call_uniques = uniques
toCLabel = mkReturnPtLabel . getUnique
......@@ -161,17 +158,9 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-- a bit. This depends on the knowledge that the
-- statements in the first block are only the GC check.
-- That's fragile but it works for now.
BasicBlock ident (stmts ++ update_stmts ++ postfix_stmts)
BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
prefix_id = BlockId prefix_unique
gc_prefix = case entry of
FunctionEntry _ _ _ -> gc_stmts
ControlEntry -> []
ContinuationEntry _ _ _ -> []
param_prefix = if is_entry
then param_stmts
else []
postfix_stmts = case exit of
FinalBranch next ->
if (mkReturnPtLabel $ getUnique next) == label
......@@ -366,7 +355,7 @@ adjust_sp_reg spRel =
then []
else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
gc_stack_check' stack_use arg_stack max_frame_size =
assign_gc_stack_use stack_use arg_stack max_frame_size =
if max_frame_size > arg_stack
then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
else [CmmAssign stack_use (CmmReg spLimReg)]
......
compiler/cmm/CmmParse.y
View file @ b44b0bef
......@@ -200,14 +200,15 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals maybe_frame '{' body '}'
{ do ((info_lbl, info, live, formals, frame), stmts) <-
: info maybe_formals maybe_frame maybe_gc_block '{' body '}'
{ do ((info_lbl, info, live, formals, frame, gc_block), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
(info_lbl, info, live) <- $1;
formals <- sequence $2;
frame <- $3;
$5;
return (info_lbl, info, live, formals, frame) }
gc_block <- $4;
$6;
return (info_lbl, info, live, formals, frame, gc_block) }
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
......@@ -216,15 +217,16 @@ cmmproc :: { ExtCode }
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
| NAME maybe_formals maybe_frame '{' body '}'
{ do ((formals, frame), stmts) <-
| NAME maybe_formals maybe_frame maybe_gc_block '{' body '}'
{ do ((formals, frame, gc_block), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2;
frame <- $3;
$5;
return (formals, frame) }
gc_block <- $4;
$6;
return (formals, frame, gc_block) }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
......@@ -511,6 +513,11 @@ maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
args <- sequence $4;
return $ Just (UpdateFrame target args) } }
maybe_gc_block :: { ExtFCode (Maybe BlockId) }
: {- empty -} { return Nothing }
| 'goto' NAME
{ do l <- lookupLabel $2; return (Just l) }
type :: { MachRep }
: 'bits8' { I8 }
| typenot8 { $1 }
......
compiler/cmm/PprCmm.hs
View file @ b44b0bef
......@@ -156,7 +156,7 @@ pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
ptext SLIT("srt: ") <> ppr srt,
ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
ptext SLIT("arity: ") <> integer (toInteger arity),
--ppr args, -- TODO: needs to be printed
--ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
ptext SLIT("slow: ") <> pprLit slow_entry
]
pprTypeInfo (ThunkInfo layout srt) =
......
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