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
+make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
where
- stmts = [CmmCall stg_gc_gen_target [] [] srt,
+ stmts = [CmmCall stg_gc_gen_target [] [] safety,
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 =
+force_gc_block old_info block_id fun_label formals =
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])
+ [make_gc_block block_id fun_label formals (CmmSafe 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])
+ [make_gc_block block_id fun_label formals (CmmSafe srt)])
where
srt = case type_info of
ConstrInfo _ _ _ -> NoC_SRT
-- Ensure that
forced_gc :: (CmmInfo, [CmmBasicBlock])
- forced_gc = force_gc_block info (BlockId gc_unique) ident params blocks
+ forced_gc = force_gc_block info (BlockId gc_unique) ident params
forced_info = fst forced_gc
forced_blocks = blocks ++ snd forced_gc
--
-- This is an association list instead of a UniqFM because
-- CLabel's don't have a 'Uniqueable' instance.
- formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
+ formats :: [(CLabel, -- key
+ (Maybe CLabel, -- label in top slot
+ [Maybe LocalReg]))] -- slots
formats = selectStackFormat live continuations
-- Do a little meta-processing on the stack formats such as
-- getting the individual frame sizes and the maximum frame size
formats' :: (WordOff, [(CLabel, StackFormat)])
- formats' = processFormats formats
-
- -- TODO FIXME NOW: calculate a real max stack (including function call args)
- -- TODO: from the maximum frame size get the maximum stack size.
- -- The difference is due to the size taken by function calls.
+ formats' = processFormats formats continuations
-- Update the info table data on the continuations with
-- the selected stack formats.
continuationLabel (Continuation _ l _ _) = l
data Continuation info =
Continuation
- info --(Either C_SRT CmmInfo) -- Left <=> Continuation created by the CPS
+ info -- Left <=> Continuation created by the CPS
-- Right <=> Function or Proc point
CLabel -- Used to generate both info & entry labels
CmmFormals -- Argument locals live on entry (C-- procedure params)
unknown_block = panic "unknown BlockId in selectStackFormat"
processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
+ -> [Continuation (Either C_SRT CmmInfo)]
-> (WordOff, [(CLabel, StackFormat)])
-processFormats formats = (max_size, formats')
+processFormats formats continuations = (max_size, formats')
where
- max_size = foldl max 0 (map (stack_frame_size . snd) formats')
+ max_size = maximum $
+ 0 : map (continuationMaxStack formats') continuations
formats' = map make_format formats
make_format (label, format) =
(label,
width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
+continuationMaxStack :: [(CLabel, StackFormat)]
+ -> Continuation a
+ -> WordOff
+continuationMaxStack formats (Continuation _ label _ blocks) =
+ max_arg_size + stack_frame_size stack_format
+ where
+ stack_format = maybe unknown_format id $ lookup label formats
+ unknown_format = panic "Unknown format in continuationMaxStack"
+
+ max_arg_size = maximum $ 0 : map block_max_arg_size blocks
+
+ block_max_arg_size block =
+ maximum (final_arg_size (brokenBlockExit block) :
+ map stmt_arg_size (brokenBlockStmts block))
+
+ final_arg_size (FinalReturn args) =
+ argumentsSize (cmmExprRep . fst) args
+ final_arg_size (FinalJump _ args) =
+ argumentsSize (cmmExprRep . fst) args
+ final_arg_size (FinalCall next _ _ args) =
+ -- We have to account for the stack used when we build a frame
+ -- for the *next* continuation from *this* continuation
+ argumentsSize (cmmExprRep . fst) args +
+ stack_frame_size next_format
+ where
+ next_format = maybe unknown_format id $ lookup next' formats
+ next' = mkReturnPtLabel $ getUnique next
+
+ final_arg_size _ = 0
+
+ stmt_arg_size (CmmJump _ args) =
+ argumentsSize (cmmExprRep . fst) args
+ stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
+ panic "Safe call in processFormats"
+ stmt_arg_size (CmmReturn _) =
+ panic "CmmReturn in processFormats"
+ stmt_arg_size _ = 0
+
-----------------------------------------------------------------------------
applyStackFormat :: [(CLabel, StackFormat)]
-> Continuation (Either C_SRT CmmInfo)
-- TODO prof: this is the same as the current implementation
-- but I think it could be improved
prof = ProfilingInfo zeroCLit zeroCLit
- tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
- then rET_BIG
- else rET_SMALL
+ tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in applyStackFormat"
where
curr_format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in continuationToProc"
+ curr_stack = stack_frame_size curr_format
continuationToProc' :: BrokenBlock -> CmmBasicBlock
continuationToProc' (BrokenBlock ident entry stmts _ exit) =
prefix = case entry of
ControlEntry -> []
FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
- gc_stack_check gc_block max_stack ++
+ gc_stack_check gc_block (max_stack - curr_stack) ++
function_entry formals curr_format
FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
panic "continuationToProc: missing GC block"
FunctionEntry (CmmNonInfo (Just gc_block)) _ formals ->
- gc_stack_check gc_block max_stack ++
+ gc_stack_check gc_block (max_stack - curr_stack) ++
function_entry formals curr_format
FunctionEntry (CmmNonInfo Nothing) _ formals ->
panic "continuationToProc: missing non-info GC block"
FinalBranch next -> [CmmBranch next]
FinalSwitch expr targets -> [CmmSwitch expr targets]
FinalReturn arguments ->
- tail_call (stack_frame_size curr_format)
+ tail_call curr_stack
(CmmLoad (CmmReg spReg) wordRep)
arguments
FinalJump target arguments ->
- tail_call (stack_frame_size curr_format) target arguments
+ tail_call curr_stack target arguments
FinalCall next (CmmForeignCall target CmmCallConv)
results arguments ->
pack_continuation curr_format cont_format ++
- tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
+ tail_call (curr_stack - cont_stack)
target arguments
where
cont_format = maybe unknown_block id $
lookup (mkReturnPtLabel $ getUnique next) formats
+ cont_stack = stack_frame_size cont_format
FinalCall next _ results arguments -> panic "unimplemented CmmCall"
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff