Commit bb66ce57 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

put CmmReturnInfo into a CmmCall (and related types)

parent fdd372f9
...@@ -12,7 +12,7 @@ module Cmm ( ...@@ -12,7 +12,7 @@ module Cmm (
CmmInfo(..), UpdateFrame(..), CmmInfo(..), UpdateFrame(..),
CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
ReturnInfo(..), CmmReturnInfo(..),
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmSafety(..), CmmSafety(..),
CmmCallTarget(..), CmmCallTarget(..),
...@@ -141,8 +141,8 @@ data ClosureTypeInfo ...@@ -141,8 +141,8 @@ data ClosureTypeInfo
[Maybe LocalReg] -- Forced stack parameters [Maybe LocalReg] -- Forced stack parameters
C_SRT C_SRT
data ReturnInfo = MayReturn data CmmReturnInfo = CmmMayReturn
| NeverReturns | CmmNeverReturns
-- TODO: These types may need refinement -- TODO: These types may need refinement
data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
...@@ -185,6 +185,7 @@ data CmmStmt ...@@ -185,6 +185,7 @@ data CmmStmt
CmmHintFormals -- zero or more results CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments CmmActuals -- zero or more arguments
CmmSafety -- whether to build a continuation CmmSafety -- whether to build a continuation
CmmReturnInfo
| CmmBranch BlockId -- branch to another BB in this fn | CmmBranch BlockId -- branch to another BB in this fn
......
...@@ -143,6 +143,7 @@ data FinalStmt ...@@ -143,6 +143,7 @@ data FinalStmt
-- (redundant with ContinuationEntry) -- (redundant with ContinuationEntry)
CmmActuals -- ^ Arguments to call CmmActuals -- ^ Arguments to call
C_SRT -- ^ SRT for the continuation's info table C_SRT -- ^ SRT for the continuation's info table
CmmReturnInfo -- ^ Does the function return?
Bool -- ^ True <=> GC block so ignore stack size Bool -- ^ True <=> GC block so ignore stack size
| FinalSwitch -- ^ Same as a 'CmmSwitch' | FinalSwitch -- ^ Same as a 'CmmSwitch'
...@@ -258,7 +259,7 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = ...@@ -258,7 +259,7 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
-- Detect this special case to remain an inverse of -- Detect this special case to remain an inverse of
-- 'cmmBlockFromBrokenBlock' -- 'cmmBlockFromBrokenBlock'
[CmmCall target results arguments (CmmSafe srt), [CmmCall target results arguments (CmmSafe srt) ret,
CmmBranch next_id] -> CmmBranch next_id] ->
([cont_info], [block]) ([cont_info], [block])
where where
...@@ -266,15 +267,15 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = ...@@ -266,15 +267,15 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
ContFormat results srt ContFormat results srt
(ident `elem` gc_block_idents)) (ident `elem` gc_block_idents))
block = do_call current_id entry accum_stmts exits next_id block = do_call current_id entry accum_stmts exits next_id
target results arguments srt target results arguments srt ret
-- Break the block on safe calls (the main job of this function) -- Break the block on safe calls (the main job of this function)
(CmmCall target results arguments (CmmSafe srt) : stmts) -> (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
(cont_info : cont_infos, block : blocks) (cont_info : cont_infos, block : blocks)
where where
next_id = BlockId $ head uniques next_id = BlockId $ head uniques
block = do_call current_id entry accum_stmts exits next_id block = do_call current_id entry accum_stmts exits next_id
target results arguments srt target results arguments srt ret
cont_info = (next_id, -- Entry convention for the cont_info = (next_id, -- Entry convention for the
-- continuation of the call -- continuation of the call
...@@ -287,12 +288,12 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = ...@@ -287,12 +288,12 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
-- Unsafe calls don't need a continuation -- Unsafe calls don't need a continuation
-- but they do need to be expanded -- but they do need to be expanded
(CmmCall target results arguments CmmUnsafe : stmts) -> (CmmCall target results arguments CmmUnsafe ret : stmts) ->
breakBlock' remaining_uniques current_id entry exits breakBlock' remaining_uniques current_id entry exits
(accum_stmts ++ (accum_stmts ++
arg_stmts ++ arg_stmts ++
caller_save ++ caller_save ++
[CmmCall target results new_args CmmUnsafe] ++ [CmmCall target results new_args CmmUnsafe ret] ++
caller_load) caller_load)
stmts stmts
where where
...@@ -309,9 +310,9 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = ...@@ -309,9 +310,9 @@ breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
stmts stmts
do_call current_id entry accum_stmts exits next_id do_call current_id entry accum_stmts exits next_id
target results arguments srt = target results arguments srt ret =
BrokenBlock current_id entry accum_stmts (next_id:exits) BrokenBlock current_id entry accum_stmts (next_id:exits)
(FinalCall next_id target results arguments srt (FinalCall next_id target results arguments srt ret
(current_id `elem` gc_block_idents)) (current_id `elem` gc_block_idents))
cond_branch_target (CmmCondBranch _ target) = [target] cond_branch_target (CmmCondBranch _ target) = [target]
...@@ -350,7 +351,7 @@ adaptBlockToFormat :: [(BlockId, ContFormat)] ...@@ -350,7 +351,7 @@ adaptBlockToFormat :: [(BlockId, ContFormat)]
adaptBlockToFormat formats unique adaptBlockToFormat formats unique
block@(BrokenBlock ident entry stmts targets block@(BrokenBlock ident entry stmts targets
exit@(FinalCall next target formals exit@(FinalCall next target formals
actuals srt is_gc)) = actuals srt ret is_gc)) =
if format_formals == formals && if format_formals == formals &&
format_srt == srt && format_srt == srt &&
format_is_gc == is_gc format_is_gc == is_gc
...@@ -367,7 +368,7 @@ adaptBlockToFormat formats unique ...@@ -367,7 +368,7 @@ adaptBlockToFormat formats unique
revised_targets = adaptor_ident : delete next targets revised_targets = adaptor_ident : delete next targets
revised_exit = FinalCall revised_exit = FinalCall
adaptor_ident -- ^ The only part that changed adaptor_ident -- ^ The only part that changed
target formals actuals srt is_gc target formals actuals srt ret is_gc
adaptor_block = mk_adaptor_block adaptor_ident adaptor_block = mk_adaptor_block adaptor_ident
(ContinuationEntry (map fst formals) srt is_gc) (ContinuationEntry (map fst formals) srt is_gc)
...@@ -401,8 +402,8 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = ...@@ -401,8 +402,8 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
FinalReturn arguments -> [CmmReturn arguments] FinalReturn arguments -> [CmmReturn arguments]
FinalJump target arguments -> [CmmJump target arguments] FinalJump target arguments -> [CmmJump target arguments]
FinalSwitch expr targets -> [CmmSwitch expr targets] FinalSwitch expr targets -> [CmmSwitch expr targets]
FinalCall branch_target call_target results arguments srt _ -> FinalCall branch_target call_target results arguments srt ret _ ->
[CmmCall call_target results arguments (CmmSafe srt), [CmmCall call_target results arguments (CmmSafe srt) ret,
CmmBranch branch_target] CmmBranch branch_target]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -355,8 +355,8 @@ continuationMaxStack formats (Continuation _ label _ False blocks) = ...@@ -355,8 +355,8 @@ continuationMaxStack formats (Continuation _ label _ False blocks) =
argumentsSize (cmmExprRep . fst) args argumentsSize (cmmExprRep . fst) args
final_arg_size (FinalJump _ args) = final_arg_size (FinalJump _ args) =
argumentsSize (cmmExprRep . fst) args argumentsSize (cmmExprRep . fst) args
final_arg_size (FinalCall next _ _ args _ True) = 0 final_arg_size (FinalCall next _ _ args _ _ True) = 0
final_arg_size (FinalCall next _ _ args _ False) = final_arg_size (FinalCall next _ _ args _ _ False) =
-- We have to account for the stack used when we build a frame -- We have to account for the stack used when we build a frame
-- for the *next* continuation from *this* continuation -- for the *next* continuation from *this* continuation
argumentsSize (cmmExprRep . fst) args + argumentsSize (cmmExprRep . fst) args +
...@@ -369,7 +369,7 @@ continuationMaxStack formats (Continuation _ label _ False blocks) = ...@@ -369,7 +369,7 @@ continuationMaxStack formats (Continuation _ label _ False blocks) =
stmt_arg_size (CmmJump _ args) = stmt_arg_size (CmmJump _ args) =
argumentsSize (cmmExprRep . fst) args argumentsSize (cmmExprRep . fst) args
stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) = stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
panic "Safe call in processFormats" panic "Safe call in processFormats"
stmt_arg_size (CmmReturn _) = stmt_arg_size (CmmReturn _) =
panic "CmmReturn in processFormats" panic "CmmReturn in processFormats"
......
...@@ -194,7 +194,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques ...@@ -194,7 +194,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-- A regular Cmm function call -- A regular Cmm function call
FinalCall next (CmmCallee target CmmCallConv) FinalCall next (CmmCallee target CmmCallConv)
results arguments _ _ -> results arguments _ _ _ ->
pack_continuation curr_format cont_format ++ pack_continuation curr_format cont_format ++
tail_call (curr_stack - cont_stack) tail_call (curr_stack - cont_stack)
target arguments target arguments
...@@ -205,7 +205,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques ...@@ -205,7 +205,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-- A safe foreign call -- A safe foreign call
FinalCall next (CmmCallee target conv) FinalCall next (CmmCallee target conv)
results arguments _ _ -> results arguments _ _ _ ->
target_stmts ++ target_stmts ++
foreignCall call_uniques' (CmmCallee new_target conv) foreignCall call_uniques' (CmmCallee new_target conv)
results arguments results arguments
...@@ -215,7 +215,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques ...@@ -215,7 +215,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-- A safe prim call -- A safe prim call
FinalCall next (CmmPrim target) FinalCall next (CmmPrim target)
results arguments _ _ -> results arguments _ _ _ ->
foreignCall call_uniques (CmmPrim target) foreignCall call_uniques (CmmPrim target)
results arguments results arguments
...@@ -229,12 +229,14 @@ foreignCall uniques call results arguments = ...@@ -229,12 +229,14 @@ foreignCall uniques call results arguments =
[CmmCall (CmmCallee suspendThread CCallConv) [CmmCall (CmmCallee suspendThread CCallConv)
[ (id,PtrHint) ] [ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
CmmUnsafe, CmmUnsafe
CmmCall call results new_args CmmUnsafe, CmmMayReturn,
CmmCall call results new_args CmmUnsafe CmmMayReturn,
CmmCall (CmmCallee resumeThread CCallConv) CmmCall (CmmCallee resumeThread CCallConv)
[ (new_base, PtrHint) ] [ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ]
CmmUnsafe, CmmUnsafe
CmmMayReturn,
-- Assign the result to BaseReg: we -- Assign the result to BaseReg: we
-- might now have a different Capability! -- might now have a different Capability!
CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++ CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
......
...@@ -122,7 +122,7 @@ lintCmmStmt (CmmStore l r) = do ...@@ -122,7 +122,7 @@ lintCmmStmt (CmmStore l r) = do
lintCmmExpr l lintCmmExpr l
lintCmmExpr r lintCmmExpr r
return () return ()
lintCmmStmt (CmmCall _target _res args _) = mapM_ (lintCmmExpr.fst) args lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return () lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
lintCmmStmt (CmmSwitch e _branches) = do lintCmmStmt (CmmSwitch e _branches) = do
erep <- lintCmmExpr e erep <- lintCmmExpr e
......
...@@ -170,7 +170,7 @@ cmmStmtLive _ (CmmAssign reg expr) = ...@@ -170,7 +170,7 @@ cmmStmtLive _ (CmmAssign reg expr) =
(CmmGlobal _) -> id (CmmGlobal _) -> id
cmmStmtLive _ (CmmStore expr1 expr2) = cmmStmtLive _ (CmmStore expr1 expr2) =
cmmExprLive expr2 . cmmExprLive expr1 cmmExprLive expr2 . cmmExprLive expr1
cmmStmtLive _ (CmmCall target results arguments _) = cmmStmtLive _ (CmmCall target results arguments _ _) =
target_liveness . target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) . foldr ((.) . cmmExprLive) id (map fst arguments) .
addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
......
...@@ -139,7 +139,7 @@ lookForInline u expr (stmt:stmts) ...@@ -139,7 +139,7 @@ lookForInline u expr (stmt:stmts)
getStmtUses :: CmmStmt -> UniqFM Int getStmtUses :: CmmStmt -> UniqFM Int
getStmtUses (CmmAssign _ e) = getExprUses e getStmtUses (CmmAssign _ e) = getExprUses e
getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2) getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
getStmtUses (CmmCall target _ es _) getStmtUses (CmmCall target _ es _ _)
= plusUFM_C (+) (uses target) (getExprsUses (map fst es)) = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
where uses (CmmCallee e _) = getExprUses e where uses (CmmCallee e _) = getExprUses e
uses _ = emptyUFM uses _ = emptyUFM
...@@ -160,8 +160,8 @@ getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es) ...@@ -160,8 +160,8 @@ getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
inlineStmt u a (CmmCall target regs es srt) inlineStmt u a (CmmCall target regs es srt ret)
= CmmCall (infn target) regs es' srt = CmmCall (infn target) regs es' srt ret
where infn (CmmCallee fn cconv) = CmmCallee fn cconv where infn (CmmCallee fn cconv) = CmmCallee fn cconv
infn (CmmPrim p) = CmmPrim p infn (CmmPrim p) = CmmPrim p
es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ] es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
......
...@@ -339,9 +339,9 @@ stmt :: { ExtCode } ...@@ -339,9 +339,9 @@ stmt :: { ExtCode }
| 'if' bool_expr '{' body '}' else | 'if' bool_expr '{' body '}' else
{ ifThenElse $2 $4 $6 } { ifThenElse $2 $4 $6 }
opt_never_returns :: { ReturnInfo } opt_never_returns :: { CmmReturnInfo }
: { MayReturn } : { CmmMayReturn }
| 'never' 'returns' { NeverReturns } | 'never' 'returns' { CmmNeverReturns }
bool_expr :: { ExtFCode BoolExpr } bool_expr :: { ExtFCode BoolExpr }
: bool_op { $1 } : bool_op { $1 }
...@@ -873,9 +873,9 @@ foreignCall ...@@ -873,9 +873,9 @@ foreignCall
-> [ExtFCode (CmmExpr,MachHint)] -> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> Maybe [GlobalReg]
-> CmmSafety -> CmmSafety
-> ReturnInfo -> CmmReturnInfo
-> P ExtCode -> P ExtCode
foreignCall conv_string results_code expr_code args_code vols safety _ret foreignCall conv_string results_code expr_code args_code vols safety ret
= do convention <- case conv_string of = do convention <- case conv_string of
"C" -> return CCallConv "C" -> return CCallConv
"C--" -> return CmmCallConv "C--" -> return CmmCallConv
...@@ -887,14 +887,14 @@ foreignCall conv_string results_code expr_code args_code vols safety _ret ...@@ -887,14 +887,14 @@ foreignCall conv_string results_code expr_code args_code vols safety _ret
--code (stmtC (CmmCall (CmmCallee expr convention) results args safety)) --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
case convention of case convention of
-- Temporary hack so at least some functions are CmmSafe -- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety)) CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
_ -> case safety of _ -> case safety of
CmmUnsafe -> CmmUnsafe ->
code (emitForeignCall' PlayRisky results code (emitForeignCall' PlayRisky results
(CmmCallee expr convention) args vols NoC_SRT) (CmmCallee expr convention) args vols NoC_SRT ret)
CmmSafe srt -> CmmSafe srt ->
code (emitForeignCall' (PlaySafe unused) results code (emitForeignCall' (PlaySafe unused) results
(CmmCallee expr convention) args vols NoC_SRT) where (CmmCallee expr convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'" unused = panic "not used by emitForeignCall'"
primCall primCall
...@@ -913,10 +913,10 @@ primCall results_code name args_code vols safety ...@@ -913,10 +913,10 @@ primCall results_code name args_code vols safety
case safety of case safety of
CmmUnsafe -> CmmUnsafe ->
code (emitForeignCall' PlayRisky results code (emitForeignCall' PlayRisky results
(CmmPrim p) args vols NoC_SRT) (CmmPrim p) args vols NoC_SRT CmmMayReturn)
CmmSafe srt -> CmmSafe srt ->
code (emitForeignCall' (PlaySafe unused) results code (emitForeignCall' (PlaySafe unused) results
(CmmPrim p) args vols NoC_SRT) where (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
unused = panic "not used by emitForeignCall'" unused = panic "not used by emitForeignCall'"
doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
......
...@@ -199,7 +199,7 @@ pprStmt stmt = case stmt of ...@@ -199,7 +199,7 @@ pprStmt stmt = case stmt of
where where
rep = cmmExprRep src rep = cmmExprRep src
CmmCall (CmmCallee fn cconv) results args safety -> CmmCall (CmmCallee fn cconv) results args safety _ret ->
-- Controversial: leave this out for now. -- Controversial: leave this out for now.
-- pprUndef fn $$ -- pprUndef fn $$
...@@ -220,7 +220,7 @@ pprStmt stmt = case stmt of ...@@ -220,7 +220,7 @@ pprStmt stmt = case stmt of
ptext SLIT("#undef") <+> pprCLabel lbl ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty pprUndef _ = empty
CmmCall (CmmPrim op) results args safety -> CmmCall (CmmPrim op) results args safety _ret ->
pprCall ppr_fn CCallConv results args safety pprCall ppr_fn CCallConv results args safety
where where
ppr_fn = pprCallishMachOp_for_C op ppr_fn = pprCallishMachOp_for_C op
...@@ -837,7 +837,7 @@ te_Lit _ = return () ...@@ -837,7 +837,7 @@ te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE () te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.fst) rs >> te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.fst) rs >>
mapM_ (te_Expr.fst) es mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e
......
...@@ -212,7 +212,7 @@ pprStmt stmt = case stmt of ...@@ -212,7 +212,7 @@ pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2]; -- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile -- ToDo ppr volatile
CmmCall (CmmCallee fn cconv) results args safety -> CmmCall (CmmCallee fn cconv) results args safety ret ->
hcat [ if null results hcat [ if null results
then empty then empty
else parens (commafy $ map ppr results) <> else parens (commafy $ map ppr results) <>
...@@ -220,14 +220,17 @@ pprStmt stmt = case stmt of ...@@ -220,14 +220,17 @@ pprStmt stmt = case stmt of
ptext SLIT("call"), space, ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space, doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ), target fn, parens ( commafy $ map ppr args ),
brackets (ppr safety), semi ] brackets (ppr safety),
case ret of CmmMayReturn -> empty
CmmNeverReturns -> ptext SLIT(" never returns"),
semi ]
where where
target (CmmLit lit) = pprLit lit target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn') target fn' = parens (ppr fn')
CmmCall (CmmPrim op) results args safety -> CmmCall (CmmPrim op) results args safety ret ->
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
results args safety) results args safety ret)
where where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
......
...@@ -73,7 +73,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live ...@@ -73,7 +73,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
= do vols <- getVolatileRegs live = do vols <- getVolatileRegs live
srt <- getSRTInfo srt <- getSRTInfo
emitForeignCall' safety results emitForeignCall' safety results
(CmmCallee cmm_target cconv) call_args (Just vols) srt (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
where where
(call_args, cmm_target) (call_args, cmm_target)
= case target of = case target of
...@@ -104,13 +104,14 @@ emitForeignCall' ...@@ -104,13 +104,14 @@ emitForeignCall'
-> [(CmmExpr,MachHint)] -- arguments -> [(CmmExpr,MachHint)] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them -> Maybe [GlobalReg] -- live vars, in case we need to save them
-> C_SRT -- the SRT of the calls continuation -> C_SRT -- the SRT of the calls continuation
-> CmmReturnInfo
-> Code -> Code
emitForeignCall' safety results target args vols srt emitForeignCall' safety results target args vols srt ret
| not (playSafe safety) = do | not (playSafe safety) = do
temp_args <- load_args_into_temps args temp_args <- load_args_into_temps args
let (caller_save, caller_load) = callerSaveVolatileRegs vols let (caller_save, caller_load) = callerSaveVolatileRegs vols
stmtsC caller_save stmtsC caller_save
stmtC (CmmCall target results temp_args CmmUnsafe) stmtC (CmmCall target results temp_args CmmUnsafe ret)
stmtsC caller_load stmtsC caller_load
| otherwise = do | otherwise = do
...@@ -131,12 +132,12 @@ emitForeignCall' safety results target args vols srt ...@@ -131,12 +132,12 @@ emitForeignCall' safety results target args vols srt
stmtC (CmmCall (CmmCallee suspendThread CCallConv) stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ (id,PtrHint) ] [ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
CmmUnsafe) CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe) stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv) stmtC (CmmCall (CmmCallee resumeThread CCallConv)
[ (new_base, PtrHint) ] [ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ]
CmmUnsafe) CmmUnsafe ret)
-- Assign the result to BaseReg: we -- Assign the result to BaseReg: we
-- might now have a different Capability! -- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
......
...@@ -76,6 +76,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ...@@ -76,6 +76,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
] ]
(Just []) (Just [])
NoC_SRT -- No SRT b/c we PlayRisky NoC_SRT -- No SRT b/c we PlayRisky
CmmMayReturn
} }
where where
mod_alloc = mkFastString "hs_hpc_module" mod_alloc = mkFastString "hs_hpc_module"
......
...@@ -121,6 +121,7 @@ emitPrimOp [res] ParOp [arg] live ...@@ -121,6 +121,7 @@ emitPrimOp [res] ParOp [arg] live
[(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
(Just vols) (Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where where
newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark"))) newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
...@@ -138,6 +139,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live ...@@ -138,6 +139,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
[(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)] [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
(Just vols) (Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
-- #define sizzeofByteArrayzh(r,a) \ -- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_)) -- r = (((StgArrWords *)(a))->words * sizeof(W_))
...@@ -344,6 +346,7 @@ emitPrimOp [res] op args live ...@@ -344,6 +346,7 @@ emitPrimOp [res] op args live
[(a,NoHint) | a<-args] -- ToDo: hints? [(a,NoHint) | a<-args] -- ToDo: hints?
(Just vols) (Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn