diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/CgCase.lhs | 30 | ||||
| -rw-r--r-- | compiler/codeGen/CgClosure.lhs | 10 | ||||
| -rw-r--r-- | compiler/codeGen/CgExpr.lhs | 20 | ||||
| -rw-r--r-- | compiler/codeGen/CgForeignCall.hs | 19 | ||||
| -rw-r--r-- | compiler/codeGen/CgHpc.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 34 | ||||
| -rw-r--r-- | compiler/codeGen/CgLetNoEscape.lhs | 5 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 19 | ||||
| -rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 44 | ||||
| -rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 5 |
12 files changed, 117 insertions, 79 deletions
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index a473e9158e..11a3c3e1d8 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -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 diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index fd851157d7..2c72860a29 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -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) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 43f69906e6..a71493a28b 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -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) diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 48015fa45a..b2ca5b166a 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -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))) diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index e457e4c944..caf68cd154 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -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" diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index d3b54a2f65..4220b47210 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -10,7 +10,6 @@ module CgInfoTbls ( emitClosureCodeAndInfoTable, emitInfoTableAndCode, dataConTagZ, - getSRTInfo, emitReturnTarget, emitAlgReturnTarget, emitReturnInstr, mkRetInfoTable, @@ -187,12 +186,11 @@ mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry 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 @@ -231,15 +229,14 @@ emitAlgReturnTarget :: 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' @@ -425,29 +422,6 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks -- ------------------------------------------------------------------------- --- 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) diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index 99705f6de6..3913a99ef0 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -136,7 +136,6 @@ cgLetNoEscapeClosure :: 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? @@ -149,7 +148,7 @@ cgLetNoEscapeClosure -- 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 @@ -168,7 +167,7 @@ cgLetNoEscapeClosure -- 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) } diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 61b358a6ba..ca08e06582 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -32,6 +32,7 @@ module CgMonad ( EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, + setSRT, getSRT, setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, @@ -65,6 +66,7 @@ import PackageConfig import Cmm import CmmUtils import CLabel +import StgSyn (SRT) import SMRep import Module import Id @@ -98,7 +100,8 @@ data CgInfoDownwards -- information only passed *downwards* by the monad 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: } @@ -108,6 +111,7 @@ initCgInfoDown dflags mod = 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 } @@ -828,12 +832,21 @@ getEndOfBlockInfo = do 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 diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 17ecfa0856..01279b453d 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -13,6 +13,7 @@ module CgPrimOp ( #include "HsVersions.h" import ForeignCall +import ClosureInfo import StgSyn import CgForeignCall import CgBindery @@ -122,6 +123,7 @@ emitPrimOp [res] ParOp [arg] live (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"))) @@ -138,6 +140,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live 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_)) @@ -342,6 +345,7 @@ emitPrimOp [res] op args live (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 diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index a4d2338e52..26857d386c 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -29,7 +29,9 @@ module CgUtils ( mkWordCLit, mkStringCLit, mkByteStringCLit, packHalfWordsCLit, - blankWord + blankWord, + + getSRTInfo ) where #include "HsVersions.h" @@ -45,6 +47,8 @@ import CLabel import CmmUtils import MachOp import ForeignCall +import ClosureInfo +import StgSyn (SRT(..)) import Literal import Digraph import ListSetOps @@ -284,8 +288,9 @@ emitRtsCall' -> 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 @@ -705,3 +710,38 @@ possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 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 diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 27aed3a70e..ad26b2ec7c 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -127,6 +127,10 @@ data C_SRT = NoC_SRT 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} %************************************************************************ diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 13e9c4a59c..4c7f570ff4 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -323,8 +323,9 @@ cgTopRhs bndr (StgRhsCon cc con args) 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} |