Skip to content

GitLab

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

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
Showing with 204 additions and 127 deletions
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 =
case lf_info of
......@@ -145,10 +145,12 @@ emitReturnTarget name stmts
; blks <- cgStmtsToBlocks stmts
; frame <- mkStackLayout
; let info = CmmInfo
(ProfilingInfo zeroCLit zeroCLit)
gc_target
rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
(ContInfo frame srt_info)
Nothing
(CmmInfoTable
(ProfilingInfo zeroCLit zeroCLit)
rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
(ContInfo frame srt_info))
; emitInfoTableAndCode info_lbl info args blks
; return info_lbl }
where
......
compiler/codeGen/CgMonad.lhs
View file @ 1f8efd5d
......@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code
= do { stmts <- getCgStmts code