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

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)
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