module CmmCPSGen (
continuationToProc,
Continuation(..), continuationLabel,
ContinuationFormat(..),
) where
import BlockId
import Cmm
import CLabel
import CmmBrokenBlock
import CmmUtils
import CmmCallConv
import ClosureInfo
import CgProf
import CgUtils
import CgInfoTbls
import SMRep
import ForeignCall
import Module
import Constants
import StaticFlags
import Unique
import Data.Maybe
import FastString
import Panic
continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel
continuationLabel (Continuation _ l _ _ _) = l
data Continuation info =
Continuation
info
CLabel
CmmFormals
Bool
[BrokenBlock]
data ContinuationFormat
= ContinuationFormat {
continuation_formals :: CmmFormals,
continuation_label :: Maybe CLabel,
continuation_frame_size :: WordOff,
continuation_stack :: [Maybe LocalReg]
}
continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-> CmmReg
-> [[[Unique]]]
-> Continuation CmmInfo
-> CmmTop
continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
(Continuation info label formals _ blocks) =
CmmProc info label formals (ListGraph blocks')
where
blocks' = concat $ zipWith3 continuationToProc' uniques blocks
(True : repeat False)
curr_format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in continuationToProc"
curr_stack = continuation_frame_size curr_format
arg_stack = argumentsSize localRegType formals
param_stmts :: [CmmStmt]
param_stmts = function_entry curr_format
gc_stmts :: [CmmStmt]
gc_stmts =
assign_gc_stack_use stack_use arg_stack (max_stack curr_stack)
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 _ -> []
continuationToProc' :: [[Unique]]
-> BrokenBlock
-> Bool
-> [CmmBasicBlock]
continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
where
prefix_blocks =
if is_entry
then [BasicBlock
(BlockId prefix_unique)
(param_stmts ++ [CmmBranch ident])]
else []
(prefix_unique : call_uniques) : new_block_uniques = uniques
toCLabel = mkReturnPtLabel . getUnique
block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
block_for_branch unique next
| (mkReturnPtLabel $ getUnique next) == label
= (next, [])
| (Just cont_format) <- lookup (toCLabel next) formats
= let
new_next = BlockId unique
cont_stack = continuation_frame_size cont_format
arguments = map formal_to_actual (continuation_formals cont_format)
in (new_next,
[BasicBlock new_next $
pack_continuation curr_format cont_format ++
tail_call (curr_stack cont_stack)
(CmmLit $ CmmLabel $ toCLabel next)
arguments])
| otherwise
= (next, [])
block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
block_for_branch' _ Nothing = (Nothing, [])
block_for_branch' unique (Just next) = (Just new_next, new_blocks)
where (new_next, new_blocks) = block_for_branch unique next
proc_point_fix unique (CmmCondBranch test target)
= (CmmCondBranch test new_target, new_blocks)
where (new_target, new_blocks) = block_for_branch (head unique) target
proc_point_fix unique (CmmSwitch test targets)
= (CmmSwitch test new_targets, concat new_blocks)
where (new_targets, new_blocks) =
unzip $ zipWith block_for_branch' unique targets
proc_point_fix unique (CmmBranch target)
= (CmmBranch new_target, new_blocks)
where (new_target, new_blocks) = block_for_branch (head unique) target
proc_point_fix _ other = (other, [])
(fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
main_stmts =
case entry of
FunctionEntry _ _ _ ->
gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
ControlEntry -> stmts ++ postfix_stmts
ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
postfix_stmts = case exit of
FinalBranch next -> [CmmBranch next]
FinalSwitch expr targets -> [CmmSwitch expr targets]
FinalReturn arguments ->
tail_call curr_stack
(entryCode (CmmLoad (CmmReg spReg) bWord))
arguments
FinalJump target arguments ->
tail_call curr_stack target arguments
FinalCall next (CmmCallee target CmmCallConv)
_ arguments _ _ _ ->
pack_continuation curr_format cont_format ++
tail_call (curr_stack cont_stack)
target arguments
where
cont_format = maybe unknown_block id $
lookup (mkReturnPtLabel $ getUnique next) formats
cont_stack = continuation_frame_size cont_format
FinalCall _ (CmmCallee target conv)
results arguments _ _ _ ->
target_stmts ++
foreignCall call_uniques' (CmmCallee new_target conv)
results arguments
where
(call_uniques', target_stmts, new_target) =
maybeAssignTemp call_uniques target
FinalCall _ (CmmPrim target)
results arguments _ _ _ ->
foreignCall call_uniques (CmmPrim target)
results arguments
formal_to_actual :: LocalReg -> CmmHinted CmmExpr
formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt]
foreignCall uniques call results arguments =
arg_stmts ++
saveThreadState ++
caller_save ++
[CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
CmmUnsafe
CmmMayReturn,
CmmCall call results new_args CmmUnsafe CmmMayReturn,
CmmCall (CmmCallee resumeThread CCallConv)
[ CmmHinted new_base AddrHint ]
[ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
CmmUnsafe
CmmMayReturn,
CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
caller_load ++
loadThreadState tso_unique ++
[CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
where
(_, arg_stmts, new_args) =
loadArgsIntoTemps argument_uniques arguments
(caller_save, caller_load) =
callerSaveVolatileRegs (Just [])
new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg))
id = LocalReg id_unique bWord
tso_unique : base_unique : id_unique : argument_uniques = uniques
suspendThread, resumeThread :: CmmExpr
suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
saveThreadState :: [CmmStmt]
saveThreadState =
[CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
closeNursery] ++
if opt_SccProfilingOn
then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
else []
closeNursery :: CmmStmt
closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
loadThreadState :: Unique -> [CmmStmt]
loadThreadState tso_unique =
[
CmmAssign (CmmLocal tso) stgCurrentTSO,
CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
bWord),
CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
rESERVED_STACK_WORDS)
] ++
openNursery ++
if opt_SccProfilingOn
then [CmmStore curCCSAddr
(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
else []
where tso = LocalReg tso_unique bWord
openNursery :: [CmmStmt]
openNursery = [
CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (1)),
CmmAssign hpLim
(cmmOffsetExpr
(CmmLoad nursery_bdescr_start bWord)
(cmmOffset
(CmmMachOp mo_wordMul [
CmmMachOp (MO_SS_Conv W32 wordWidth)
[CmmLoad nursery_bdescr_blocks b32],
CmmLit (mkIntCLit bLOCK_SIZE)
])
(1)
)
)
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_SP, tso_STACK, tso_CCCS :: ByteOff
tso_SP = tsoFieldB oFFSET_StgTSO_sp
tso_STACK = tsoFieldB oFFSET_StgTSO_stack
tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
tsoFieldB :: ByteOff -> ByteOff
tsoFieldB off
| opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
| otherwise = off + fixedHdrSize * wORD_SIZE
tsoProfFieldB :: ByteOff -> ByteOff
tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
stgSp = CmmReg sp
stgHp = CmmReg hp
stgCurrentTSO = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery
sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
sp = CmmGlobal Sp
spLim = CmmGlobal SpLim
hp = CmmGlobal Hp
hpLim = CmmGlobal HpLim
currentTSO = CmmGlobal CurrentTSO
currentNursery = CmmGlobal CurrentNursery
tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
tail_call spRel target arguments
= store_arguments ++ adjust_sp_reg spRel ++ jump where
store_arguments =
[stack_put spRel expr offset
| ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
[global_put expr global
| ((CmmHinted expr _), RegisterParam global) <- argument_formats]
jump = [CmmJump target arguments]
argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
adjust_sp_reg :: Int -> [CmmStmt]
adjust_sp_reg spRel =
if spRel == 0
then []
else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
assign_gc_stack_use stack_use arg_stack max_frame_size =
if max_frame_size > arg_stack
then [CmmAssign stack_use (CmmRegOff spReg (max_frame_size*wORD_SIZE))]
else [CmmAssign stack_use (CmmReg spLimReg)]
pack_continuation :: ContinuationFormat
-> ContinuationFormat
-> [CmmStmt]
pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
(ContinuationFormat _ cont_id cont_frame_size live_regs)
= pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
where
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 needs_header_set
then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
else Nothing
pack_frame :: WordOff
-> WordOff
-> Maybe CmmExpr
-> [Maybe CmmExpr]
-> [CmmStmt]
pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
store_live_values ++ set_stack_header
where
store_live_values =
[stack_put spRel expr offset
| (expr, offset) <- cont_offsets]
set_stack_header =
case next_frame_header of
Nothing -> []
Just expr -> [stack_put spRel expr 0]
cont_offsets = mkOffsets label_size frame_args
label_size = 1 :: WordOff
mkOffsets _ [] = []
mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
where
width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
spRel = curr_frame_size next_frame_size
function_entry :: ContinuationFormat -> [CmmStmt]
function_entry (ContinuationFormat formals _ _ live_regs)
= load_live_values ++ load_args where
load_live_values =
[stack_get 0 reg offset
| (reg, offset) <- curr_offsets]
load_args =
[stack_get 0 reg offset
| (reg, StackParam offset) <- argument_formats] ++
[global_get reg global
| (reg, RegisterParam global) <- argument_formats]
argument_formats = assignArguments (localRegType) formals
curr_offsets = mkOffsets label_size live_regs
label_size = 1 :: WordOff
mkOffsets _ [] = []
mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
where
width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
stack_put :: WordOff
-> CmmExpr
-> WordOff
-> CmmStmt
stack_put spRel expr offset =
CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
stack_get :: WordOff
-> LocalReg
-> WordOff
-> CmmStmt
stack_get spRel reg offset =
CmmAssign (CmmLocal reg)
(CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
(localRegType reg))
global_put :: CmmExpr -> GlobalReg -> CmmStmt
global_put expr global = CmmAssign (CmmGlobal global) expr
global_get :: LocalReg -> GlobalReg -> CmmStmt
global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))