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