Commit 1f46671f authored by Michael D. Adams's avatar Michael D. Adams
Browse files

Added stack checks to the CPS algorithm

This eliminates one of the panics introduced by 
the previous patch:
'First pass at implementing info tables for CPS'
  
The other panic introduced by that patch still remains.
It was due to the need to convert from a
  ContinuationInfo to a CmmInfo.
  (codeGen/CgInfoTbls.hs:emitClosureCodeAndInfoTable)
  (codeGen/CgInfoTbls.hs:emitReturnTarget)
parent f96e9aa0
......@@ -115,11 +115,17 @@ data CmmInfo
ClosureTypeTag -- Int
ClosureTypeInfo
| CmmNonInfo -- Procedure doesn't need an info table
(Maybe BlockId) -- But we still need a GC target for it
-- TODO: The GC target shouldn't really be part of CmmInfo
-- as it doesn't appear in the resulting info table.
-- It should be factored out.
data ClosureTypeInfo
= ConstrInfo ClosureLayout ConstrTag ConstrDescription
| FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
| ThunkInfo ClosureLayout C_SRT
| ThunkSelectorInfo SelectorOffset C_SRT
| ContInfo
[Maybe LocalReg] -- Forced stack parameters
C_SRT
......@@ -129,10 +135,11 @@ data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
type ClosureTypeTag = StgHalfWord
type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
type ConstrTag = StgHalfWord
type ConstrDescription = CLabel
type ConstrDescription = CmmLit
type FunType = StgHalfWord
type FunArity = StgHalfWord
type SlowEntry = CLabel
type SelectorOffset = StgWord
-----------------------------------------------------------------------------
-- CmmStmt
......
......@@ -69,6 +69,34 @@ 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 srt = BasicBlock block_id stmts
where
stmts = [CmmCall stg_gc_gen_target [] [] srt,
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)
force_gc_block old_info block_id fun_label formals blocks =
case old_info of
CmmNonInfo (Just _) -> (old_info, [])
CmmInfo _ (Just _) _ _ -> (old_info, [])
CmmNonInfo Nothing
-> (CmmNonInfo (Just block_id),
[make_gc_block block_id fun_label formals NoC_SRT])
CmmInfo prof Nothing type_tag type_info
-> (CmmInfo prof (Just block_id) type_tag type_info,
[make_gc_block block_id fun_label formals srt])
where
srt = case type_info of
ConstrInfo _ _ _ -> NoC_SRT
FunInfo _ srt' _ _ _ _ -> srt'
ThunkInfo _ srt' -> srt'
ThunkSelectorInfo _ srt' -> srt'
ContInfo _ srt' -> srt'
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
-- Only 'CmmProc' are transformed 'CmmData' will be left alone.
......@@ -82,14 +110,24 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
where
uniques :: [[Unique]]
uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
info_uniques:block_uniques = uniques
(gc_unique:info_uniques):block_uniques = uniques
-- Ensure that
forced_gc :: (CmmInfo, [CmmBasicBlock])
forced_gc = force_gc_block info (BlockId gc_unique) ident params blocks
forced_info = fst forced_gc
forced_blocks = blocks ++ snd forced_gc
forced_gc_id = case forced_info of
CmmNonInfo (Just x) -> x
CmmInfo _ (Just x) _ _ -> x
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks :: [BrokenBlock]
broken_blocks =
concat $ zipWith3 breakBlock block_uniques blocks
(FunctionEntry info ident params:repeat ControlEntry)
concat $ zipWith3 breakBlock block_uniques forced_blocks
(FunctionEntry forced_info ident params:repeat ControlEntry)
-- Calculate live variables for each broken block.
--
......@@ -109,8 +147,10 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
-- Group the blocks into continuations based on the set of proc-points.
continuations :: [Continuation (Either C_SRT CmmInfo)]
continuations = map (gatherBlocksIntoContinuation proc_points block_env)
(uniqSetToList proc_points)
continuations = zipWith
(gatherBlocksIntoContinuation proc_points block_env)
(uniqSetToList proc_points)
(Just forced_gc_id : repeat Nothing)
-- Select the stack format on entry to each continuation.
-- Return the max stack offset and an association list
......@@ -191,18 +231,22 @@ data StackFormat
collectNonProcPointTargets ::
UniqSet BlockId -> BlockEnv BrokenBlock
-> UniqSet BlockId -> BlockId -> UniqSet BlockId
collectNonProcPointTargets proc_points blocks current_targets block =
-> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
collectNonProcPointTargets proc_points blocks current_targets new_blocks =
if sizeUniqSet current_targets == sizeUniqSet new_targets
then current_targets
else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
else foldl
(collectNonProcPointTargets proc_points blocks)
new_targets
(map (:[]) targets)
where
block' = lookupWithDefaultUFM blocks (panic "TODO") block
blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
targets =
-- Note the subtlety that since the extra branch after a call
-- will always be to a block that is a proc-point,
-- this subtraction will always remove that case
uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
`minusUniqSet` proc_points
-- TODO: remove redundant uniqSetToList
new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
......@@ -213,14 +257,16 @@ collectNonProcPointTargets proc_points blocks current_targets block =
gatherBlocksIntoContinuation ::
UniqSet BlockId -> BlockEnv BrokenBlock
-> BlockId -> Continuation (Either C_SRT CmmInfo)
gatherBlocksIntoContinuation proc_points blocks start =
-> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
gatherBlocksIntoContinuation proc_points blocks start gc =
Continuation info_table clabel params body
where
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
start_and_gc = start : maybeToList gc
children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
start_block = lookupWithDefaultUFM blocks (panic "TODO") start
gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)")) (maybeToList gc)
children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
body = start_block : children_blocks
body = start_block : gc_block ++ children_blocks
-- We can't properly annotate the continuation's stack parameters
-- at this point because this is before stack selection
......@@ -228,7 +274,7 @@ gatherBlocksIntoContinuation proc_points blocks start =
info_table = case start_block_entry of
FunctionEntry info _ _ -> Right info
ContinuationEntry _ srt -> Left srt
ControlEntry -> Right CmmNonInfo
ControlEntry -> Right (CmmNonInfo Nothing)
start_block_entry = brokenBlockEntry start_block
clabel = case start_block_entry of
......@@ -342,11 +388,12 @@ continuationToProc (max_stack, formats)
gc_stack_check gc_block max_stack ++
function_entry formals curr_format
FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
panic "continuationToProc: TODO generate GC block" ++
function_entry formals curr_format
FunctionEntry CmmNonInfo _ formals ->
panic "TODO: gc_stack_check gc_block max_stack" ++
panic "continuationToProc: missing GC block"
FunctionEntry (CmmNonInfo (Just gc_block)) _ formals ->
gc_stack_check gc_block max_stack ++
function_entry formals curr_format
FunctionEntry (CmmNonInfo Nothing) _ formals ->
panic "continuationToProc: missing non-info GC block"
ContinuationEntry formals _ ->
function_entry formals curr_format
postfix = case exit of
......@@ -395,10 +442,12 @@ gc_stack_check gc_block max_frame_size
check_stack_limit = [
CmmCondBranch
(CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
[CmmRegOff spReg max_frame_size, CmmReg spLimReg])
[CmmRegOff spReg (-max_frame_size*wORD_SIZE),
CmmReg spLimReg])
gc_block]
-- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
-- TODO: fix branches to proc point
-- (we have to insert a new block to marshel the continuation)
pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
pack_continuation (StackFormat curr_id curr_frame_size _)
(StackFormat cont_id cont_frame_size live_regs)
......
......@@ -26,7 +26,7 @@ mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
case info of
CmmNonInfo -> [CmmProc [] entry_label arguments blocks]
CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
......@@ -55,7 +55,7 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
info_label = entryLblToInfoLbl entry_label
con_name = makeRelativeRefTo info_label (CmmLabel descr)
con_name = makeRelativeRefTo info_label descr
layout = packHalfWordsCLit ptrs nptrs
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
......@@ -72,6 +72,19 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
bitmap)
layout = packHalfWordsCLit ptrs nptrs
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkSelectorInfo offset srt) ->
mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
info_label = entryLblToInfoLbl entry_label
(srt_label, srt_bitmap) =
case srt of
NoC_SRT -> ([], 0)
(C_SRT lbl off bitmap) ->
([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
bitmap)
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
liveness_data ++
mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
......
......@@ -200,44 +200,70 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
-- : info maybe_formals '{' body '}'
-- { do (info_lbl, info1, info2) <- $1;
-- formals <- sequence $2;
-- stmts <- getCgStmtsEC (loopDecls $4)
-- blks <- code (cgStmtsToBlocks stmts)
-- code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
--
-- | info maybe_formals ';'
-- { do (info_lbl, info1, info2) <- $1;
-- formals <- sequence $2;
-- code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
: NAME maybe_formals '{' body '}'
: info maybe_formals '{' body '}'
{ do (info_lbl, info) <- $1;
formals <- sequence $2;
stmts <- getCgStmtsEC (loopDecls $4)
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl info formals blks) }
| info maybe_formals ';'
{ do (info_lbl, info) <- $1;
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl info formals []) }
| NAME maybe_formals '{' body '}'
{ do formals <- sequence $2;
stmts <- getCgStmtsEC (loopDecls $4);
blks <- code (cgStmtsToBlocks stmts);
code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
info :: { ExtFCode (CLabel, CmmInfo) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{ stdInfo $3 $5 $7 0 $9 $11 $13 }
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT)) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{ funInfo $3 $5 $7 $9 $11 $13 $15 }
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{ conInfo $3 $5 $7 $9 $11 $13 $15 }
{ do prof <- profilingInfo $13 $15
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit)) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{ basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT ')'
-- size, live bits, closure type
{ retInfo $3 $5 $7 $9 }
{ do prof <- profilingInfo $9 $11
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT)) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
{ return (mkRtsInfoLabelFS $3,
CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
(ContInfo [] NoC_SRT)) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsInfoLabelFS $3,
CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
(ContInfo live NoC_SRT)) }
body :: { ExtCode }
: {- empty -} { return () }
......@@ -809,6 +835,15 @@ funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
where
zero = mkIntCLit 0
profilingInfo desc_str ty_str = do
lit1 <- if opt_SccProfilingOn
then code $ mkStringCLit desc_str
else return (mkIntCLit 0)
lit2 <- if opt_SccProfilingOn
then code $ mkStringCLit ty_str
else return (mkIntCLit 0)
return (ProfilingInfo lit1 lit2)
staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
staticClosure cl_label info payload
......
......@@ -39,7 +39,8 @@ calculateOwnership blocks_ufm proc_points blocks =
unknown_block = panic "unknown BlockId in selectStackFormat"
calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
calculateProcPoints blocks =
calculateProcPoints' init_proc_points blocks
where
init_proc_points = mkUniqSet $
map brokenBlockId $
......
......@@ -126,7 +126,9 @@ pprTop (CmmData section ds) =
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
pprInfo CmmNonInfo = empty
pprInfo (CmmNonInfo gc_target) =
ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target
pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
gc_target tag info) =
vcat [ptext SLIT("type: ") <> pprLit closure_type,
......@@ -140,7 +142,7 @@ pprTypeInfo (ConstrInfo layout constr descr) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("constructor: ") <> integer (toInteger constr),
ppr descr]
pprLit descr]
pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
......@@ -154,6 +156,9 @@ pprTypeInfo (ThunkInfo layout srt) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("srt: ") <> ppr srt]
pprTypeInfo (ThunkSelectorInfo offset srt) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
ptext SLIT("srt: ") <> ppr srt]
pprTypeInfo (ContInfo stack srt) =
vcat [ptext SLIT("stack: ") <> ppr stack,
ptext SLIT("srt: ") <> ppr srt]
......
......@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
; emitProc CmmNonInfo lbl [] blks }
; emitProc (CmmNonInfo Nothing) lbl [] blks }
getCmm :: Code -> FCode Cmm
-- Get all the CmmTops (there should be no stmts)
......
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