Commit b44b0bef authored by Michael D. Adams's avatar Michael D. Adams

Added support for GC block declaration to the Cmm syntax

parent 5f00461a
......@@ -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
......
......@@ -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
......
......@@ -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)]
......
......@@ -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 }
......
......@@ -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