Skip to content

GitLab

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

Added support for update frames to the CPS pass 

(This required a bit of refactoring of CmmInfo.)
parent 55f8b001
Hide whitespace changes
Inline Side-by-side
compiler/cmm/Cmm.hs
View file @ 1f8efd5d
......@@ -9,7 +9,8 @@
module Cmm (
GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop,
CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
CmmInfo(..), UpdateFrame(..),
CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmSafety(..),
......@@ -110,15 +111,19 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-- Info Tables
-----------------------------------------------------------------------------
-- Info table as a haskell data type
data CmmInfo
= CmmInfo
ProfilingInfo
(Maybe BlockId) -- GC target
(Maybe UpdateFrame) -- Update frame
CmmInfoTable -- Info table
-- Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable
ProfilingInfo
ClosureTypeTag -- Int
ClosureTypeInfo
| CmmNonInfo -- Procedure doesn't need an info table
(Maybe BlockId) -- But we still need a GC target for it
| CmmNonInfoTable -- Procedure doesn't need an info table
-- TODO: The GC target shouldn't really be part of CmmInfo
-- as it doesn't appear in the resulting info table.
......@@ -146,6 +151,13 @@ type SlowEntry = CmmLit
-- for now the parser sets this to zero on an INFO_TABLE_FUN.
type SelectorOffset = StgWord
-- | A frame that is to be pushed before entry to the function.
-- Used to handle 'update' frames.
data UpdateFrame =
UpdateFrame
CmmExpr -- Frame header. Behaves like the target of a 'jump'.
[CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'.
-----------------------------------------------------------------------------
-- CmmStmt
-- A "statement". Note that all branches are explicit: there are no
......
compiler/cmm/CmmCPS.hs
View file @ 1f8efd5d
......@@ -87,23 +87,19 @@ make_gc_check stack_use gc_block =
force_gc_block old_info stack_use block_id fun_label formals =
case old_info of
CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing)
CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing)
CmmNonInfo Nothing
-> (CmmNonInfo (Just block_id),
[make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)],
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)
CmmInfo prof Nothing type_tag type_info
-> (CmmInfo prof (Just block_id) type_tag type_info,
[make_gc_block block_id fun_label formals (CmmSafe srt)],
make_gc_check stack_use block_id)
where
srt = case type_info of
ConstrInfo _ _ _ -> NoC_SRT
FunInfo _ srt' _ _ _ _ -> srt'
ThunkInfo _ srt' -> srt'
ThunkSelectorInfo _ srt' -> srt'
ContInfo _ srt' -> srt'
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
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
......@@ -127,7 +123,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
(uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
uniques :: [[Unique]]
uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
(gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
(gc_unique:gc_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)
......@@ -136,16 +132,17 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
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 =
case blocks of
(BasicBlock id stmts) : bs ->
(BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks)
[] -> [] -- If there is no code then we don't need a stack check
forced_blocks =
BasicBlock gc_block_id
(check_stmts++[CmmBranch $ blockId $ head blocks]) :
blocks ++ gc_blocks
forced_gc_id = case forced_info of
CmmNonInfo (Just x) -> x
CmmInfo _ (Just x) _ _ -> x
CmmInfo (Just x) _ _ -> x
update_frame = case info of CmmInfo _ u _ -> u
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
......@@ -199,13 +196,13 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
-- Do a little meta-processing on the stack formats such as
-- getting the individual frame sizes and the maximum frame size
formats' :: (WordOff, [(CLabel, ContinuationFormat)])
formats' = processFormats formats continuations
formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
formats'@(_, _, format_list) = processFormats formats update_frame continuations
-- Update the info table data on the continuations with
-- the selected stack formats.
continuations' :: [Continuation CmmInfo]
continuations' = map (applyContinuationFormat (snd formats')) continuations
continuations' = map (applyContinuationFormat format_list) continuations
-- Do the actual CPS transform.
cps_procs :: [CmmTop]
......@@ -257,7 +254,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
info_table = case start_block_entry of
FunctionEntry info _ _ -> Right info
ContinuationEntry _ srt _ -> Left srt
ControlEntry -> Right (CmmNonInfo Nothing)
ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
is_gc_cont = case start_block_entry of
FunctionEntry _ _ _ -> False
......@@ -287,7 +284,7 @@ selectContinuationFormat live continuations =
where
-- User written continuations
selectContinuationFormat' (Continuation
(Right (CmmInfo _ _ _ (ContInfo format srt)))
(Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
label formals _ _) =
(formals, Just label, format)
-- Either user written non-continuation code
......@@ -306,9 +303,11 @@ selectContinuationFormat live continuations =
unknown_block = panic "unknown BlockId in selectContinuationFormat"
processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
-> Maybe UpdateFrame
-> [Continuation (Either C_SRT CmmInfo)]
-> (WordOff, [(CLabel, ContinuationFormat)])
processFormats formats continuations = (max_size, formats')
-> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
processFormats formats update_frame continuations =
(max_size + update_frame_size, update_frame_size, formats')
where
max_size = maximum $
0 : map (continuationMaxStack formats') continuations
......@@ -324,6 +323,17 @@ processFormats formats continuations = (max_size, formats')
else 0,
continuation_stack = stack })
update_frame_size = case update_frame of
Nothing -> 0
(Just (UpdateFrame _ args))
-> label_size + update_size args
update_size [] = 0
update_size (expr:exprs) = width + update_size exprs
where
width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
-- TODO: get rid of "+ 1" etc.
label_size = 1 :: WordOff
......@@ -381,9 +391,9 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)]
-- User written continuations
applyContinuationFormat formats (Continuation
(Right (CmmInfo prof gc tag (ContInfo _ srt)))
(Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
label formals is_gc blocks) =
Continuation (CmmInfo prof gc tag (ContInfo format srt))
Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
label formals is_gc blocks
where
format = continuation_stack $ maybe unknown_block id $ lookup label formats
......@@ -397,7 +407,7 @@ applyContinuationFormat formats (Continuation
-- CPS generated continuations
applyContinuationFormat formats (Continuation
(Left srt) label formals is_gc blocks) =
Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
label formals is_gc blocks
where
gc = Nothing -- Generated continuations never need a stack check
......
compiler/cmm/CmmCPSGen.hs
View file @ 1f8efd5d
......@@ -78,12 +78,12 @@ data ContinuationFormat
-- A block can be an entry to a function
-----------------------------------------------------------------------------
continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)])
continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-> CmmReg
-> [[Unique]]
-> Continuation CmmInfo
-> CmmTop
continuationToProc (max_stack, formats) stack_use uniques
continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
(Continuation info label formals _ blocks) =
CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
where
......@@ -98,14 +98,18 @@ continuationToProc (max_stack, formats) stack_use uniques
gc_stmts :: [CmmStmt]
gc_stmts =
case info of
CmmInfo _ (Just gc_block) _ _ ->
CmmInfo (Just gc_block) _ _ ->
gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
CmmInfo _ Nothing _ _ ->
CmmInfo Nothing _ _ ->
panic "continuationToProc: missing GC block"
CmmNonInfo (Just gc_block) ->
gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
CmmNonInfo Nothing ->
panic "continuationToProc: missing non-info GC block"
update_stmts :: [CmmStmt]
update_stmts =
case info of
CmmInfo _ (Just (UpdateFrame target args)) _ ->
pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
adjust_sp_reg (curr_stack - update_frame_size)
CmmInfo _ Nothing _ -> []
-- At present neither the Cmm parser nor the code generator
-- produce code that will allow the target of a CmmCondBranch
......@@ -148,7 +152,18 @@ continuationToProc (max_stack, formats) stack_use uniques
block_for_branch' unique (Just next) = (Just new_next, new_blocks)
where (new_next, new_blocks) = block_for_branch unique next
main_block = BasicBlock ident (stmts ++ postfix_stmts)
main_block =
case entry of
FunctionEntry _ _ _ ->
-- Ugh, the statements for an update frame must come
-- *after* the GC check that was added at the beginning
-- of the CPS pass. So we have do edit the statements
-- 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)
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
......@@ -336,20 +351,21 @@ currentNursery = CmmGlobal CurrentNursery
tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
tail_call spRel target arguments
= store_arguments ++ adjust_spReg ++ jump where
= store_arguments ++ adjust_sp_reg spRel ++ jump where
store_arguments =
[stack_put spRel expr offset
| ((expr, _), StackParam offset) <- argument_formats] ++
[global_put expr global
| ((expr, _), RegisterParam global) <- argument_formats]
adjust_spReg =
if spRel == 0
then []
else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
jump = [CmmJump target arguments]
argument_formats = assignArguments (cmmExprRep . fst) arguments
adjust_sp_reg spRel =
if spRel == 0
then []
else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
gc_stack_check' stack_use arg_stack max_frame_size =
if max_frame_size > arg_stack
then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
......@@ -367,10 +383,6 @@ gc_stack_check gc_block max_frame_size
gc_block]
-- TODO: fix branches to proc point
-- (we have to insert a new block to marshel the continuation)
pack_continuation :: Bool -- ^ Whether to set the top/header
-- of the stack. We only need to
-- set it if we are calling down
......@@ -382,35 +394,52 @@ pack_continuation :: Bool -- ^ Whether to set the top/header
pack_continuation allow_header_set
(ContinuationFormat _ curr_id curr_frame_size _)
(ContinuationFormat _ cont_id cont_frame_size live_regs)
= store_live_values ++ set_stack_header where
= pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
where
continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
live_regs
needs_header_set =
case (curr_id, cont_id) of
(Just x, Just y) -> x /= y
_ -> isJust cont_id
maybe_header = if allow_header_set && needs_header_set
then Just continuation_function
else Nothing
pack_frame :: WordOff -- ^ Current frame size
-> WordOff -- ^ Next frame size
-> Maybe CmmExpr -- ^ Next frame header if any
-> [Maybe CmmExpr] -- ^ Next frame data
-> [CmmStmt]
pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
store_live_values ++ set_stack_header
where
-- TODO: only save variables when actually needed
-- (may be handled by latter pass)
store_live_values =
[stack_put spRel (CmmReg (CmmLocal reg)) offset
| (reg, offset) <- cont_offsets]
[stack_put spRel expr offset
| (expr, offset) <- cont_offsets]
set_stack_header =
if needs_header_set && allow_header_set
then [stack_put spRel continuation_function 0]
else []
case next_frame_header of
Nothing -> []
Just expr -> [stack_put spRel expr 0]
-- TODO: factor with function_entry and CmmInfo.hs(?)
cont_offsets = mkOffsets label_size live_regs
cont_offsets = mkOffsets label_size frame_args
label_size = 1 :: WordOff
mkOffsets size [] = []
mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
where
width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
spRel = curr_frame_size - cont_frame_size
continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
needs_header_set =
case (curr_id, cont_id) of
(Just x, Just y) -> x /= y
_ -> isJust cont_id
spRel = curr_frame_size - next_frame_size
-- Lazy adjustment of stack headers assumes all blocks
-- that could branch to eachother (i.e. control blocks)
......
compiler/cmm/CmmInfo.hs
View file @ 1f8efd5d
......@@ -71,15 +71,15 @@ cmmToRawCmm cmm = do
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
case info of
-- | Code without an info table. Easy.
CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
-- | A function entry point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(FunInfo (ptrs, nptrs) srt fun_type fun_arity
pap_bitmap slow_entry) ->
CmmInfoTable (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
where
......@@ -97,8 +97,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout = packHalfWordsCLit ptrs nptrs
-- | A constructor.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ConstrInfo (ptrs, nptrs) con_tag descr) ->
CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
(ConstrInfo (ptrs, nptrs) con_tag descr) ->
mkInfoTableAndCode info_label std_info [con_name] entry_label
arguments blocks
where
......@@ -108,8 +108,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout = packHalfWordsCLit ptrs nptrs
-- | A thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkInfo (ptrs, nptrs) srt) ->
CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
(ThunkInfo (ptrs, nptrs) srt) ->
mkInfoTableAndCode info_label std_info srt_label entry_label
arguments blocks
where
......@@ -119,8 +119,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout = packHalfWordsCLit ptrs nptrs
-- | A selector thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkSelectorInfo offset srt) ->
CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
(ThunkSelectorInfo offset srt) ->
mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
arguments blocks
where
......@@ -128,7 +128,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
info_label = entryLblToInfoLbl entry_label
-- A continuation/return-point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
(ContInfo stack_layout srt) ->
liveness_data ++
mkInfoTableAndCode info_label std_info srt_label entry_label
arguments blocks
......
compiler/cmm/CmmParse.y
View file @ 1f8efd5d
......@@ -200,47 +200,49 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals '{' body '}'
{ do ((info_lbl, info, live, formals), stmts) <-
: info maybe_formals maybe_frame '{' body '}'
{ do ((info_lbl, info, live, formals, frame), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
(info_lbl, info, live) <- $1;
formals <- sequence $2;
$4;
return (info_lbl, info, live, formals) }
frame <- $3;
$5;
return (info_lbl, info, live, formals, frame) }
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl info formals blks) }
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
| info maybe_formals ';'
{ do (info_lbl, info, live) <- $1;
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl info formals []) }
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
| NAME maybe_formals '{' body '}'
{ do (formals, stmts) <-
| NAME maybe_formals maybe_frame '{' body '}'
{ do ((formals, frame), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2;
$4;
return formals }
frame <- $3;
$5;
return (formals, frame) }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
CmmInfoTable prof (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
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit),
CmmInfoTable prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit),
[]) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
......@@ -252,31 +254,31 @@ info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
-- 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),
CmmInfoTable prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{ do prof <- profilingInfo $9 $11
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
CmmInfoTable prof (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),
CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- 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),
CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
body :: { ExtCode }
......@@ -503,6 +505,12 @@ formal :: { ExtFCode LocalReg }
| STRING type NAME {% do k <- parseKind $1;
return $ newLocal k $2 $3 }
maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
: {- empty -} { return Nothing }
| 'jump' expr '(' exprs0 ')' { do { target <- $2;
args <- sequence $4;
return $ Just (UpdateFrame target args) } }
type :: { MachRep }
: 'bits8' { I8 }
| typenot8 { $1 }
......
compiler/cmm/PprCmm.hs
View file @ 1f8efd5d
......@@ -129,17 +129,19 @@ instance Outputable CmmSafety where
-- 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 gc_target) =
ptext SLIT("gc_target: ") <>
ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
-- ^ gc_target is currently unused and wired to a panic
pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
gc_target tag info) =
vcat [ptext SLIT("type: ") <> pprLit closure_type,
pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
vcat [ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target,
ptext SLIT("update_frame: ") <>
maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
pprInfo (CmmInfo gc_target update_frame
(CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
vcat [ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target,
ptext SLIT("update_frame: ") <>
maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
ptext SLIT("type: ") <> pprLit closure_type,
ptext SLIT("desc: ") <> pprLit closure_desc,
ptext SLIT("gc_target: ") <>
ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
-- ^ gc_target is currently unused and wired to a panic
ptext SLIT("tag: ") <> integer (toInteger tag),
pprTypeInfo info]
......@@ -168,6 +170,19 @@ pprTypeInfo (ContInfo stack srt) =
vcat [ptext SLIT("stack: ") <> ppr stack,
ptext SLIT("srt: ") <> ppr srt]
pprUpdateFrame :: UpdateFrame -> SDoc
pprUpdateFrame (UpdateFrame expr args) =
hcat [ ptext SLIT("jump")
, space
, if isTrivialCmmExpr expr
then pprExpr expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
, space
, parens ( commafy $ map ppr args ) ]
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
......
compiler/codeGen/CgInfoTbls.hs
View file @ 1f8efd5d
......@@ -89,12 +89,12 @@ mkCmmInfo cl_info = do
info = ConstrInfo (ptrs, nptrs)
(fromIntegral (dataConTagZ con))
conName
return $ CmmInfo prof gc_target cl_type info
return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
ClosureInfo { closureName = name,
closureLFInfo = lf_info,
closureSRT = srt } ->
return $ CmmInfo prof gc_target cl_type info
return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
where
info =