Commit affbe8da authored by Michael D. Adams's avatar Michael D. Adams

Added an SRT to each CmmCall and added the current SRT to the CgMonad

parent 20780258
......@@ -11,7 +11,6 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
mkSRTDescLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
......@@ -20,6 +19,7 @@ module CLabel (
mkRednCountsLabel,
mkConInfoTableLabel,
mkStaticInfoTableLabel,
mkLargeSRTLabel,
mkApEntryLabel,
mkApInfoTableLabel,
mkClosureTableLabel,
......@@ -210,12 +210,14 @@ data CLabel
| HpcTicksLabel Module -- Per-module table of tick locations
| HpcModuleNameLabel -- Per-module name of the module for Hpc
| LargeSRTLabel -- Label of an StgLargeSRT
{-# UNPACK #-} !Unique
deriving (Eq, Ord)
data IdLabelInfo
= Closure -- Label for closure
| SRT -- Static reference table
| SRTDesc -- Static reference table descriptor
| InfoTable -- Info tables for closures; always read-only
| Entry -- entry point
| Slow -- slow entry point
......@@ -287,7 +289,6 @@ data DynamicLinkerLabelInfo
-- These are always local:
mkSRTLabel name = IdLabel name SRT
mkSRTDescLabel name = IdLabel name SRTDesc
mkSlowEntryLabel name = IdLabel name Slow
mkBitmapLabel name = IdLabel name Bitmap
mkRednCountsLabel name = IdLabel name RednCounts
......@@ -333,6 +334,7 @@ mkStaticConEntryLabel this_pkg name
| isDllName this_pkg name = DynIdLabel name StaticConEntry
| otherwise = IdLabel name StaticConEntry
mkLargeSRTLabel uniq = LargeSRTLabel uniq
mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
......@@ -467,7 +469,7 @@ needsCDecl :: CLabel -> Bool
-- don't bother declaring SRT & Bitmap labels, we always make sure
-- they are defined before use.
needsCDecl (IdLabel _ SRT) = False
needsCDecl (IdLabel _ SRTDesc) = False
needsCDecl (LargeSRTLabel _) = False
needsCDecl (IdLabel _ Bitmap) = False
needsCDecl (IdLabel _ _) = True
needsCDecl (DynIdLabel _ _) = True
......@@ -697,6 +699,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext SLIT("_dflt")]
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
pprCLbl (RtsLabel (RtsCode str)) = ptext str
pprCLbl (RtsLabel (RtsData str)) = ptext str
pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
......@@ -791,7 +795,6 @@ ppIdFlavor x = pp_cSEP <>
(case x of
Closure -> ptext SLIT("closure")
SRT -> ptext SLIT("srt")
SRTDesc -> ptext SLIT("srtd")
InfoTable -> ptext SLIT("info")
Entry -> ptext SLIT("entry")
Slow -> ptext SLIT("slow")
......
......@@ -28,6 +28,7 @@ module Cmm (
import MachOp
import CLabel
import ForeignCall
import ClosureInfo
import Unique
import UniqFM
import FastString
......@@ -116,6 +117,7 @@ data CmmStmt
CmmCallTarget
CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments
C_SRT -- SRT for the continuation of the call
| CmmBranch BlockId -- branch to another BB in this fn
......
......@@ -12,6 +12,8 @@ module CmmBrokenBlock (
import Cmm
import CLabel
import ClosureInfo
import Maybes
import Panic
import Unique
......@@ -50,6 +52,7 @@ data BlockEntryInfo
| ContinuationEntry -- ^ Return point of a function call
CmmFormals -- ^ return values (argument to continuation)
C_SRT -- ^ SRT for the continuation's info table
| ControlEntry -- ^ Any other kind of block.
-- Only entered due to control flow.
......@@ -136,13 +139,13 @@ breakBlock uniques (BasicBlock ident stmts) entry =
block = do_call current_id entry accum_stmts exits next_id
target results arguments
-}
(CmmCall target results arguments:stmts) -> block : rest
(CmmCall target results arguments srt:stmts) -> block : rest
where
next_id = BlockId $ head uniques
block = do_call current_id entry accum_stmts exits next_id
target results arguments
rest = breakBlock' (tail uniques) next_id
(ContinuationEntry (map fst results)) [] [] stmts
(ContinuationEntry (map fst results) srt) [] [] stmts
(s:stmts) ->
breakBlock' uniques current_id entry
(cond_branch_target s++exits)
......@@ -171,7 +174,7 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
FinalJump target arguments -> [CmmJump target arguments]
FinalSwitch expr targets -> [CmmSwitch expr targets]
FinalCall branch_target call_target results arguments ->
[CmmCall call_target results arguments,
[CmmCall call_target results arguments (panic "needed SRT from cmmBlockFromBrokenBlock"),
CmmBranch branch_target]
-----------------------------------------------------------------------------
......
......@@ -209,7 +209,7 @@ gatherBlocksIntoContinuation proc_points blocks start =
_ -> mkReturnPtLabel $ getUnique start
params = case start_block_entry of
FunctionEntry _ args -> args
ContinuationEntry args -> args
ContinuationEntry args _ -> args
ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
--------------------------------------------------------------------------------
......@@ -256,7 +256,7 @@ continuationToProc formats (Continuation is_entry info label formals blocks) =
ControlEntry -> []
FunctionEntry _ formals -> -- TODO: gc_stack_check
function_entry formals curr_format
ContinuationEntry formals ->
ContinuationEntry formals _ ->
function_entry formals curr_format
postfix = case exit of
FinalBranch next -> [CmmBranch next]
......
......@@ -117,7 +117,7 @@ lintCmmStmt (CmmStore l r) = do
lintCmmExpr l
lintCmmExpr r
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 (CmmSwitch e _branches) = do
erep <- lintCmmExpr e
......
......@@ -170,7 +170,7 @@ cmmStmtLive _ (CmmAssign reg expr) =
(CmmGlobal _) -> id
cmmStmtLive _ (CmmStore expr1 expr2) =
cmmExprLive expr2 . cmmExprLive expr1
cmmStmtLive _ (CmmCall target results arguments) =
cmmStmtLive _ (CmmCall target results arguments _) =
target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) .
addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
......
......@@ -140,7 +140,7 @@ lookForInline u expr (stmt:stmts)
getStmtUses :: CmmStmt -> UniqFM Int
getStmtUses (CmmAssign _ e) = getExprUses e
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))
where uses (CmmForeignCall e _) = getExprUses e
uses _ = emptyUFM
......@@ -161,8 +161,8 @@ getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
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 (CmmCall target regs es)
= CmmCall (infn target) regs es'
inlineStmt u a (CmmCall target regs es srt)
= CmmCall (infn target) regs es' srt
where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
......
......@@ -267,10 +267,11 @@ stmt :: { ExtCode }
-- { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
| type '[' expr ']' '=' expr ';'
{ doStore $1 $3 $6 }
-- TODO: add real SRT to parsed Cmm
| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
{% foreignCall $3 $1 $4 $6 $8 }
{% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
{% primCall $1 $4 $6 $8 }
{% primCall $1 $4 $6 $8 NoC_SRT }
-- stmt-level macros, stealing syntax from ordinary C-- function calls.
-- Perhaps we ought to use the %%-form?
| NAME '(' exprs0 ')' ';'
......@@ -818,8 +819,10 @@ foreignCall
-> [ExtFCode (CmmFormal,MachHint)]
-> ExtFCode CmmExpr
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
foreignCall conv_string results_code expr_code args_code vols
-> Maybe [GlobalReg]
-> C_SRT
-> P ExtCode
foreignCall conv_string results_code expr_code args_code vols srt
= do convention <- case conv_string of
"C" -> return CCallConv
"C--" -> return CmmCallConv
......@@ -829,20 +832,22 @@ foreignCall conv_string results_code expr_code args_code vols
expr <- expr_code
args <- sequence args_code
code (emitForeignCall' PlayRisky results
(CmmForeignCall expr convention) args vols) where
(CmmForeignCall expr convention) args vols srt) where
primCall
:: [ExtFCode (CmmFormal,MachHint)]
-> FastString
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
primCall results_code name args_code vols
-> Maybe [GlobalReg]
-> C_SRT
-> P ExtCode
primCall results_code name args_code vols srt
= case lookupUFM callishMachOps name of
Nothing -> fail ("unknown primitive " ++ unpackFS name)
Just p -> return $ do
results <- sequence results_code
args <- sequence args_code
code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code
......
......@@ -47,7 +47,7 @@ calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
always_proc_point BrokenBlock {
brokenBlockEntry = FunctionEntry _ _ } = True
always_proc_point BrokenBlock {
brokenBlockEntry = ContinuationEntry _ } = True
brokenBlockEntry = ContinuationEntry _ _ } = True
always_proc_point _ = False
calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
......
......@@ -28,6 +28,7 @@ import Cmm
import CLabel
import MachOp
import ForeignCall
import ClosureInfo
-- Utils
import DynFlags
......@@ -198,11 +199,11 @@ pprStmt stmt = case stmt of
where
rep = cmmExprRep src
CmmCall (CmmForeignCall fn cconv) results args ->
CmmCall (CmmForeignCall fn cconv) results args srt ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
pprCall ppr_fn cconv results args
pprCall ppr_fn cconv results args srt
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
......@@ -219,8 +220,8 @@ pprStmt stmt = case stmt of
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
CmmCall (CmmPrim op) results args ->
pprCall ppr_fn CCallConv results args
CmmCall (CmmPrim op) results args srt ->
pprCall ppr_fn CCallConv results args srt
where
ppr_fn = pprCallishMachOp_for_C op
......@@ -718,10 +719,10 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals
pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
-> SDoc
pprCall ppr_fn cconv results args
pprCall ppr_fn cconv results args _
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
......@@ -839,7 +840,7 @@ te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
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
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
......
......@@ -150,20 +150,21 @@ pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall (CmmForeignCall fn cconv) results args ->
CmmCall (CmmForeignCall fn cconv) results args srt ->
hcat [ ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
(if null results
then empty
else brackets( commafy $ map ppr results)), semi ]
else brackets( commafy $ map ppr results)),
brackets (ppr srt), semi ]
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
CmmCall (CmmPrim op) results args ->
CmmCall (CmmPrim op) results args srt ->
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
results args)
results args srt)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
......
......@@ -95,7 +95,6 @@ cgCase :: StgExpr
-> StgLiveVars
-> StgLiveVars
-> Id
-> SRT
-> AltType
-> [StgAlt]
-> Code
......@@ -104,7 +103,7 @@ cgCase :: StgExpr
Special case #1: case of literal.
\begin{code}
cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
cgCase (StgLit lit) live_in_whole_case live_in_alts bndr
alt_type@(PrimAlt tycon) alts
= do { tmp_reg <- bindNewToTemp bndr
; cm_lit <- cgLit lit
......@@ -120,7 +119,7 @@ allocating more heap than strictly necessary, but it will sometimes
eliminate a heap check altogether.
\begin{code}
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr
alt_type@(PrimAlt tycon) alts
= do { -- Careful! we can't just bind the default binder to the same thing
-- as the scrutinee, since it might be a stack location, and having
......@@ -137,7 +136,7 @@ Special case #3: inline PrimOps and foreign calls.
\begin{code}
cgCase (StgOpApp op@(StgPrimOp primop) args _)
live_in_whole_case live_in_alts bndr srt alt_type alts
live_in_whole_case live_in_alts bndr alt_type alts
| not (primOpOutOfLine primop)
= cgInlinePrimOp primop args bndr alt_type live_in_alts alts
\end{code}
......@@ -152,7 +151,7 @@ right here, just like an inline primop.
\begin{code}
cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
live_in_whole_case live_in_alts bndr srt alt_type alts
live_in_whole_case live_in_alts bndr alt_type alts
| unsafe_foreign_call
= ASSERT( isSingleton alts )
do -- *must* be an unboxed tuple alt.
......@@ -177,7 +176,7 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
live_in_whole_case live_in_alts bndr srt alt_type alts
live_in_whole_case live_in_alts bndr alt_type alts
= do { fun_info <- getCgIdInfo fun
; arg_amodes <- getArgAmodes args
......@@ -195,7 +194,7 @@ cgCase (StgApp fun args)
<- forkEval alts_eob_info
(allocStackTop retAddrSizeW >> nopC)
(do { deAllocStackTop retAddrSizeW
; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
; cgEvalAlts maybe_cc_slot bndr alt_type alts })
; setEndOfBlockInfo scrut_eob_info
(performTailCall fun_info arg_amodes save_assts) }
......@@ -215,7 +214,7 @@ deAllocStackTop call is doing above.
Finally, here is the general case.
\begin{code}
cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
cgCase expr live_in_whole_case live_in_alts bndr alt_type alts
= do { -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_case
......@@ -232,7 +231,7 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
; allocStackTop retAddrSizeW -- space for retn address
; nopC })
(do { deAllocStackTop retAddrSizeW
; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
; cgEvalAlts maybe_cc_slot bndr alt_type alts })
; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
}
......@@ -355,14 +354,13 @@ is some evaluation to be done.
\begin{code}
cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
-> Id
-> SRT -- SRT for the continuation
-> AltType
-> [StgAlt]
-> FCode Sequel -- Any addr modes inside are guaranteed
-- to be a label so that we can duplicate it
-- without risk of duplicating code
cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts
= do { let rep = tyConCgRep tycon
reg = dataReturnConvPrim rep -- Bottom for voidRep
......@@ -374,10 +372,10 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
; restoreCurrentCostCentre cc_slot True
; cgPrimAlts GCMayHappen alt_type reg alts }
; lbl <- emitReturnTarget (idName bndr) abs_c srt
; lbl <- emitReturnTarget (idName bndr) abs_c
; returnFC (CaseAlts lbl Nothing bndr) }
cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
= -- Unboxed tuple case
-- By now, the simplifier should have have turned it
-- into case e of (# a,b #) -> e
......@@ -396,10 +394,10 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
-- and finally the code for the alternative
; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
(cgExpr rhs) }
; lbl <- emitReturnTarget (idName bndr) abs_c srt
; lbl <- emitReturnTarget (idName bndr) abs_c
; returnFC (CaseAlts lbl Nothing bndr) }
cgEvalAlts cc_slot bndr srt alt_type alts
cgEvalAlts cc_slot bndr alt_type alts
= -- Algebraic and polymorphic case
do { -- Bind the default binder
bindNewToReg bndr nodeReg (mkLFArgument bndr)
......@@ -416,7 +414,7 @@ cgEvalAlts cc_slot bndr srt alt_type alts
; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
alts mb_deflt srt fam_sz
alts mb_deflt fam_sz
; returnFC (CaseAlts lbl branches bndr) }
where
......
......@@ -61,17 +61,16 @@ They should have no free variables.
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> SRT
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
cgTopRhsClosure id ccs binder_info upd_flag args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
; srt_info <- getSRTInfo name srt
; srt_info <- getSRTInfo
; mod_name <- getModuleName
; let descr = closureDescription mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
......@@ -136,14 +135,13 @@ Here's the general case.
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> SRT
-> [Id] -- Free vars
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
{ -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
......@@ -161,7 +159,7 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
; fv_infos <- mapFCs getCgIdInfo reduced_fvs
; srt_info <- getSRTInfo name srt
; srt_info <- getSRTInfo
; mod_name <- getModuleName
; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
(tot_wds, ptr_wds, bind_details)
......
......@@ -203,7 +203,7 @@ module, @CgCase@.
\begin{code}
cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
= cgCase expr live_vars save_vars bndr srt alt_type alts
= setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts
\end{code}
......@@ -293,7 +293,7 @@ cgRhs name (StgRhsCon maybe_cc con args)
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= do this_pkg <- getThisPackage
mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body
setSRT srt $ mkRhsClosure this_pkg name cc bi fvs upd_flag args body
\end{code}
mkRhsClosure looks for two special forms of the right-hand side:
......@@ -316,12 +316,12 @@ form:
\begin{code}
mkRhsClosure this_pkg bndr cc bi srt
mkRhsClosure this_pkg bndr cc bi
[the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
_ _ _ srt -- ignore uniq, etc.
(AlgAlt tycon)
[(DataAlt con, params, use_mask,
(StgApp selectee [{-no args-}]))])
......@@ -334,7 +334,7 @@ mkRhsClosure this_pkg bndr cc bi srt
-- other constructors in the datatype. It's still ok to make a selector
-- thunk in this case, because we *know* which constructor the scrutinee
-- will evaluate to.
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
......@@ -362,7 +362,7 @@ We only generate an Ap thunk if all the free variables are pointers,
for semi-obvious reasons.
\begin{code}
mkRhsClosure this_pkg bndr cc bi srt
mkRhsClosure this_pkg bndr cc bi
fvs
upd_flag
[] -- No args; a thunk
......@@ -387,8 +387,8 @@ mkRhsClosure this_pkg bndr cc bi srt
The default case
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body
= cgRhsClosure bndr cc bi srt fvs upd_flag args body
mkRhsClosure this_pkg bndr cc bi fvs upd_flag args body
= cgRhsClosure bndr cc bi fvs upd_flag args body
\end{code}
......@@ -434,7 +434,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
-- case upd_flag of
-- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
maybe_cc_slot rec args body
-- For a constructor RHS we want to generate a single chunk of code which
......@@ -442,7 +442,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
= cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
= setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
......
......@@ -32,6 +32,7 @@ import CmmUtils
import MachOp
import SMRep
import ForeignCall
import ClosureInfo
import Constants
import StaticFlags
import Outputable
......@@ -76,8 +77,9 @@ emitForeignCall
emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
= do vols <- getVolatileRegs live
srt <- getSRTInfo
emitForeignCall' safety results
(CmmForeignCall cmm_target cconv) call_args (Just vols)
(CmmForeignCall cmm_target cconv) call_args (Just vols) srt
where
(call_args, cmm_target)
= case target of
......@@ -96,7 +98,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
-- ToDo: this might not be correct for 64-bit API
arg_size rep = max (machRepByteWidth rep) wORD_SIZE
emitForeignCall results (DNCall _) args live
emitForeignCall _ (DNCall _) _ _
= panic "emitForeignCall: DNCall"
......@@ -107,13 +109,14 @@ emitForeignCall'
-> CmmCallTarget -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them
-> C_SRT -- the SRT of the calls continuation
-> Code
emitForeignCall' safety results target args vols
emitForeignCall' safety results target args vols srt
| not (playSafe safety) = do
temp_args <- load_args_into_temps args
let (caller_save, caller_load) = callerSaveVolatileRegs vols
stmtsC caller_save
stmtC (CmmCall target results temp_args)
stmtC (CmmCall target results temp_args srt)
stmtsC caller_load
| otherwise = do
......@@ -126,15 +129,17 @@ emitForeignCall' safety results target args vols
let (caller_save, caller_load) = callerSaveVolatileRegs vols
emitSaveThreadState
stmtsC caller_save
-- Using the same SRT for each of these is a little bit conservative
-- but it should work for now.
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
)
stmtC (CmmCall temp_target results temp_args)
srt)
stmtC (CmmCall temp_target results temp_args srt)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
)
srt)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
......
......@@ -17,6 +17,7 @@ import CgUtils
import CgMonad
import CgForeignCall
import ForeignCall
import ClosureInfo
import FastString
import HscTypes
import Char
......@@ -70,6 +71,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
, (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
]
(Just [])
C_SRT -- No SRT b/c we PlayRisky
}
where
mod_alloc = mkFastString "hs_hpc_module"
......
......@@ -10,7 +10,6 @@ module CgInfoTbls (