mkClosureLabel,
mkSRTLabel,
- mkSRTDescLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
mkStaticInfoTableLabel,
+ mkLargeSRTLabel,
mkApEntryLabel,
mkApInfoTableLabel,
mkClosureTableLabel,
| 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
-- 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
| 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
-- 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
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
(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")
import MachOp
import CLabel
import ForeignCall
+import ClosureInfo
import Unique
import UniqFM
import FastString
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
import Cmm
import CLabel
+import ClosureInfo
+
import Maybes
import Panic
import Unique
| 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.
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)
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]
-----------------------------------------------------------------------------
_ -> 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
--------------------------------------------------------------------------------
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]
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
(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
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
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 ]
-- { 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 ')' ';'
-> [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
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
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
import CLabel
import MachOp
import ForeignCall
+import ClosureInfo
-- Utils
import DynFlags
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
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
-- -----------------------------------------------------------------------------
-- 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"
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
-- 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)
-> StgLiveVars
-> StgLiveVars
-> Id
- -> SRT
-> AltType
-> [StgAlt]
-> Code
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
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
\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}
\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.
\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
<- 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) }
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
; 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)
}
\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
; 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
-- 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)
; (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
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
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.
; 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)
\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}
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:
\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-}]))])
-- 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)
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
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}
-- 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
-- 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)
import MachOp
import SMRep
import ForeignCall
+import ClosureInfo
import Constants
import StaticFlags
import Outputable
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
-- 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"
-> 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
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)))
import CgMonad
import CgForeignCall
import ForeignCall
+import ClosureInfo
import FastString
import HscTypes
import Char
, (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
]
(Just [])
+ C_SRT -- No SRT b/c we PlayRisky
}
where
mod_alloc = mkFastString "hs_hpc_module"
emitClosureCodeAndInfoTable,
emitInfoTableAndCode,
dataConTagZ,
- getSRTInfo,
emitReturnTarget, emitAlgReturnTarget,
emitReturnInstr,
mkRetInfoTable,
emitReturnTarget
:: Name
-> CgStmts -- The direct-return code (if any)
- -> SRT
-> FCode CLabel
-emitReturnTarget name stmts srt
+emitReturnTarget name stmts
= do { live_slots <- getLiveStackSlots
; liveness <- buildContLiveness name live_slots
- ; srt_info <- getSRTInfo name srt
+ ; srt_info <- getSRTInfo
; let
cl_type | isBigLiveness liveness = rET_BIG
:: Name -- Just for its unique
-> [(ConTagZ, CgStmts)] -- Tagged branches
-> Maybe CgStmts -- Default branch (if any)
- -> SRT -- Continuation's SRT
-> Int -- family size
-> FCode (CLabel, SemiTaggingStuff)
-emitAlgReturnTarget name branches mb_deflt srt fam_sz
+emitAlgReturnTarget name branches mb_deflt fam_sz
= do { blks <- getCgStmts $
emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
-- NB: tag_expr is zero-based
- ; lbl <- emitReturnTarget name blks srt
+ ; lbl <- emitReturnTarget name blks
; return (lbl, Nothing) }
-- Nothing: the internal branches in the switch don't have
-- global labels, so we can't use them at the 'call site'
--
-------------------------------------------------------------------------
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT. The label is passed down to
--- the nested bindings via the monad.
-
-getSRTInfo :: Name -> SRT -> FCode C_SRT
-getSRTInfo id NoSRT = return NoC_SRT
-getSRTInfo id (SRT off len bmp)
- | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
- = do { srt_lbl <- getSRTLabel
- ; let srt_desc_lbl = mkSRTDescLabel id
- ; emitRODataLits srt_desc_lbl
- ( cmmLabelOffW srt_lbl off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
- ; return (C_SRT srt_desc_lbl 0 srt_escape) }
-
- | otherwise
- = do { srt_lbl <- getSRTLabel
- ; return (C_SRT srt_lbl off (fromIntegral (head bmp))) }
- -- The fromIntegral converts to StgHalfWord
-
-srt_escape = (-1) :: StgHalfWord
-
srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
srtLabelAndLength NoC_SRT _
= (zeroCLit, 0)
:: Id -- binder
-> CostCentreStack -- NB: *** NOT USED *** ToDo (WDP 94/06)
-> StgBinderInfo -- NB: ditto
- -> SRT
-> StgLiveVars -- variables live in RHS, including the binders
-- themselves in the case of a recursive group
-> EndOfBlockInfo -- where are we going to?
-- ToDo: deal with the cost-centre issues
cgLetNoEscapeClosure
- bndr cc binder_info srt full_live_in_rhss
+ bndr cc binder_info full_live_in_rhss
rhs_eob_info cc_slot rec args body
= let
arity = length args
-- Ignore the label that comes back from
-- mkRetDirectTarget. It must be conjured up elswhere
- ; emitReturnTarget (idName bndr) abs_c srt
+ ; emitReturnTarget (idName bndr) abs_c
; return () })
; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
+ setSRT, getSRT,
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
import Cmm
import CmmUtils
import CLabel
+import StgSyn (SRT)
import SMRep
import Module
import Id
cgd_dflags :: DynFlags,
cgd_mod :: Module, -- Module being compiled
cgd_statics :: CgBindings, -- [Id -> info] : static environment
- cgd_srt :: CLabel, -- label of the current SRT
+ cgd_srt_lbl :: CLabel, -- label of the current SRT
+ cgd_srt :: SRT, -- the current SRT
cgd_ticky :: CLabel, -- current destination for ticky counts
cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
}
= MkCgInfoDown { cgd_dflags = dflags,
cgd_mod = mod,
cgd_statics = emptyVarEnv,
+ cgd_srt_lbl = error "initC: srt_lbl",
cgd_srt = error "initC: srt",
cgd_ticky = mkTopTickyCtrLabel,
cgd_eob = initEobInfo }
getSRTLabel :: FCode CLabel -- Used only by cgPanic
getSRTLabel = do info <- getInfoDown
- return (cgd_srt info)
+ return (cgd_srt_lbl info)
setSRTLabel :: CLabel -> FCode a -> FCode a
setSRTLabel srt_lbl code
= do info <- getInfoDown
- withInfoDown code (info { cgd_srt = srt_lbl})
+ withInfoDown code (info { cgd_srt_lbl = srt_lbl})
+
+getSRT :: FCode SRT
+getSRT = do info <- getInfoDown
+ return (cgd_srt info)
+
+setSRT :: SRT -> FCode a -> FCode a
+setSRT srt code
+ = do info <- getInfoDown
+ withInfoDown code (info { cgd_srt = srt})
-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label
#include "HsVersions.h"
import ForeignCall
+import ClosureInfo
import StgSyn
import CgForeignCall
import CgBindery
(CmmForeignCall newspark CCallConv)
[(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
(Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
where
newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
CCallConv)
[(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
(Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
-- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
(CmmPrim prim)
[(a,NoHint) | a<-args] -- ToDo: hints?
(Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
| Just mop <- translateOp op
= let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
mkWordCLit,
mkStringCLit, mkByteStringCLit,
packHalfWordsCLit,
- blankWord
+ blankWord,
+
+ getSRTInfo
) where
#include "HsVersions.h"
import CmmUtils
import MachOp
import ForeignCall
+import ClosureInfo
+import StgSyn (SRT(..))
import Literal
import Digraph
import ListSetOps
-> Maybe [GlobalReg]
-> Code
emitRtsCall' res fun args vols = do
+ srt <- getSRTInfo
stmtsC caller_save
- stmtC (CmmCall target res args)
+ stmtC (CmmCall target res args srt)
stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
+
+-------------------------------------------------------------------------
+--
+-- Static Reference Tables
+--
+-------------------------------------------------------------------------
+
+-- There is just one SRT for each top level binding; all the nested
+-- bindings use sub-sections of this SRT. The label is passed down to
+-- the nested bindings via the monad.
+
+getSRTInfo :: FCode C_SRT
+getSRTInfo = do
+ srt_lbl <- getSRTLabel
+ srt <- getSRT
+ case srt of
+ -- TODO: Should we panic in this case?
+ -- Someone obviously thinks there should be an SRT
+ NoSRT -> return NoC_SRT
+ SRT off len bmp
+ | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+ -> do id <- newUnique
+ let srt_desc_lbl = mkLargeSRTLabel id
+ emitRODataLits srt_desc_lbl
+ ( cmmLabelOffW srt_lbl off
+ : mkWordCLit (fromIntegral len)
+ : map mkWordCLit bmp)
+ return (C_SRT srt_desc_lbl 0 srt_escape)
+
+ SRT off len bmp
+ | otherwise
+ -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+ -- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord
needsSRT :: C_SRT -> Bool
needsSRT NoC_SRT = False
needsSRT (C_SRT _ _ _) = True
+
+instance Outputable C_SRT where
+ ppr (NoC_SRT) = ptext SLIT("_no_srt_")
+ ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
\end{code}
%************************************************************************
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
= ASSERT(null fvs) -- There should be no free variables
- setSRTLabel (mkSRTLabel (idName bndr)) $
- forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
+ setSRTLabel (mkSRTLabel (idName bndr)) $
+ setSRT srt $
+ forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
\end{code}
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
- CmmCall target regs args
+ CmmCall target regs args srt
-> do target' <- case target of
CmmForeignCall e conv -> do
e' <- cmmExprConFold CallReference e
args' <- mapM (\(arg, hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
- return $ CmmCall target' regs args'
+ return $ CmmCall target' regs args' srt
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
import Cmm
import MachOp
import CLabel
+import ClosureInfo ( C_SRT(..) )
-- The rest:
import StaticFlags ( opt_PIC )
| otherwise -> assignMem_IntCode kind addr src
where kind = cmmExprRep src
- CmmCall target result_regs args
+ CmmCall target result_regs args _
-> genCCall target result_regs args
CmmBranch id -> genBranch id
if localRegRep res == F64
then
- stmtToInstrs (CmmCall target [(res,FloatHint)] args)
+ stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT)
else do
uq <- getUniqueNat
let
tmp = LocalReg uq F64 KindNonPtr
-- in
- code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args)
+ code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT)
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
projects / ghc-hetmet.git / commitdiff