diff options
| author | Ian Lynagh <igloo@earth.li> | 2012-07-24 20:26:52 +0100 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2012-07-24 20:41:06 +0100 |
| commit | 229e9fc585b3003f2c26cbcf39f71a87514cd43d (patch) | |
| tree | 8214619d18d6d4024dee307435ff9e46d4ee5dbb /compiler/codeGen | |
| parent | 4b18cc53a81634951cc72aa5c3e2123688b6f512 (diff) | |
| download | haskell-229e9fc585b3003f2c26cbcf39f71a87514cd43d.tar.gz | |
Make -fscc-profiling a dynamic flag
All the flags that 'ways' imply are now dynamic
Diffstat (limited to 'compiler/codeGen')
27 files changed, 610 insertions, 504 deletions
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index c65194b62f..332ec0746a 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -42,6 +42,7 @@ import Maybes import Id import Name import Util +import DynFlags import StaticFlags import Module import FastString @@ -159,11 +160,11 @@ constructSlowCall amodes -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)] -slowArgs [] = [] -slowArgs amodes - | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest - | otherwise = this_pat ++ slowArgs rest +slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)] +slowArgs _ [] = [] +slowArgs dflags amodes + | dopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest + | otherwise = this_pat ++ slowArgs dflags rest where (arg_pat, args, rest) = matchSlowPattern amodes stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 745bf47710..ef51aaa620 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -32,8 +32,8 @@ import ClosureInfo import OldCmmUtils import OldCmm +import DynFlags import StgSyn -import StaticFlags import Id import ForeignCall import VarSet @@ -650,13 +650,13 @@ saveCurrentCostCentre :: CmmStmts) -- Assignment to save it saveCurrentCostCentre - | not opt_SccProfilingOn - = returnFC (Nothing, noStmts) - | otherwise - = do { slot <- allocPrimStack PtrArg - ; sp_rel <- getSpRelOffset slot - ; returnFC (Just slot, - oneStmt (CmmStore sp_rel curCCS)) } + = do dflags <- getDynFlags + if not (dopt Opt_SccProfilingOn dflags) + then returnFC (Nothing, noStmts) + else do slot <- allocPrimStack PtrArg + sp_rel <- getSpRelOffset slot + returnFC (Just slot, + oneStmt (CmmStore sp_rel curCCS)) -- Sometimes we don't free the slot containing the cost centre after restoring it -- (see CgLetNoEscape.cgLetNoEscapeBody). diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 8f98a5f764..7229fbdfc2 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -49,7 +49,6 @@ import Module import ListSetOps import Util import BasicTypes -import StaticFlags import DynFlags import Outputable import FastString @@ -83,10 +82,10 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; mod_name <- getModuleName ; dflags <- getDynFlags ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr + closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info - closure_rep = mkStaticClosureFields closure_info ccs True [] + closure_rep = mkStaticClosureFields dflags closure_info ccs True [] -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep @@ -123,10 +122,10 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload ; mod_name <- getModuleName ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, amodes_w_offsets) - = mkVirtHeapOffsets (isLFThunk lf_info) amodes + = mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo False -- Not static + closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds NoC_SRT -- No SRT for a std-form closure descr @@ -174,12 +173,12 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; dflags <- getDynFlags ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] (tot_wds, ptr_wds, bind_details) - = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos) add_rep info = (cgIdInfoArgRep info, info) descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo False -- Not static + closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds srt_info descr @@ -392,7 +391,8 @@ mkSlowEntryCode cl_info reg_args \begin{code} thunkWrapper:: ClosureInfo -> Code -> Code thunkWrapper closure_info thunk_code = do - { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + { dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info) -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- (we prefer fetchAndReschedule-style context switches to yield ones) @@ -416,7 +416,8 @@ funWrapper :: ClosureInfo -- Closure whose code body this is -> Code -- Body of function being compiled -> Code funWrapper closure_info arg_regs reg_save_code fun_body = do - { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + { dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info) live = Just $ map snd arg_regs {- @@ -477,7 +478,7 @@ emitBlackHoleCode is_single_entry = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. - let eager_blackholing = not opt_SccProfilingOn + let eager_blackholing = not (dopt Opt_SccProfilingOn dflags) && dopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't @@ -486,7 +487,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) stmtsC [ - CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) + CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)), CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -510,7 +511,8 @@ setupUpdate closure_info code tickyPushUpdateFrame dflags <- getDynFlags if blackHoleOnEntry closure_info && - not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + not (dopt Opt_SccProfilingOn dflags) && + dopt Opt_EagerBlackHoling dflags then pushBHUpdateFrame (CmmReg nodeReg) code else pushUpdateFrame (CmmReg nodeReg) code @@ -575,7 +577,9 @@ link_caf cl_info _is_upd = do ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) - ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)] + ; dflags <- getDynFlags + ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc + [(tso, fixedHdrSize dflags)] ; hp_rel <- getHpRelOffset hp_offset -- Call the RTS function newCAF to add the CAF to the CafList diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 78c1934869..86e6ff8589 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -50,7 +50,6 @@ import Module import DynFlags import FastString import Platform -import StaticFlags import Control.Monad \end{code} @@ -82,8 +81,9 @@ cgTopRhsCon id con args lf_info = mkConLFInfo con closure_label = mkClosureLabel name $ idCafInfo id caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes closure_rep = mkStaticClosureFields + dflags closure_info dontCareCCS -- Because it's static data caffy -- Has CAF refs @@ -191,7 +191,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] , let val_int = (fromIntegral val) :: Int , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) + offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) } @@ -203,7 +203,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] , let val_int = (fromIntegral val) :: Int , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) + offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } @@ -213,10 +213,10 @@ buildDynCon' dflags platform binder _ con [arg_amode] Now the general case. \begin{code} -buildDynCon' _ _ binder ccs con args +buildDynCon' dflags _ binder ccs con args = do { ; let - (closure_info, amodes_w_offsets) = layOutDynConstr con args + (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) } @@ -246,12 +246,12 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = do + = do dflags <- getDynFlags let -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con) - (_, args_w_offsets) = layOutDynConstr con (addIdReps args) + (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () mapCs bind_arg args_w_offsets @@ -318,14 +318,14 @@ sure the @amodes@ passed don't conflict with each other. \begin{code} cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code -cgReturnDataCon con amodes - | isUnboxedTupleCon con = returnUnboxedTuple amodes - -- when profiling we can't shortcut here, we have to enter the closure - -- for it to be marked as "used" for LDV profiling. - | opt_SccProfilingOn = build_it_then enter_it - | otherwise - = ASSERT( amodes `lengthIs` dataConRepRepArity con ) - do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo +cgReturnDataCon con amodes = do + dflags <- getDynFlags + if isUnboxedTupleCon con then returnUnboxedTuple amodes + -- when profiling we can't shortcut here, we have to enter the closure + -- for it to be marked as "used" for LDV profiling. + else if dopt Opt_SccProfilingOn dflags then build_it_then enter_it + else ASSERT( amodes `lengthIs` dataConRepRepArity con ) + do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; case sequel of CaseAlts _ (Just (alts, deflt_lbl)) bndr -> -- Ho! We know the constructor so we can @@ -445,7 +445,8 @@ static closure, for a constructor. \begin{code} cgDataCon :: DataCon -> Code cgDataCon data_con - = do { -- Don't need any dynamic closure code for zero-arity constructors + = do { dflags <- getDynFlags + -- Don't need any dynamic closure code for zero-arity constructors ; let -- To allow the debuggers, interpreters, etc to cope with @@ -453,10 +454,10 @@ cgDataCon data_con -- time), we take care that info-table contains the -- information we need. (static_cl_info, _) = - layOutStaticConstr data_con arg_reps + layOutStaticConstr dflags data_con arg_reps (dyn_cl_info, arg_things) = - layOutDynConstr data_con arg_reps + layOutDynConstr dflags data_con arg_reps emit_info cl_info ticky_code = do { code_blks <- getCgStmts the_code diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index f935f95726..0a4466292e 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -48,8 +48,8 @@ import Maybes import ListSetOps import BasicTypes import Util +import DynFlags import Outputable -import StaticFlags \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -117,6 +117,7 @@ re-enters the RTS the stack is in a sane state. \begin{code} cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do + dflags <- getDynFlags {- First, copy the args into temporaries. We're going to push a return address right before doing the call, so the args @@ -125,7 +126,7 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do reps_n_amodes <- getArgAmodes stg_args let -- Get the *non-void* args, and jiggle them with shimForeignCall - arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg) + arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg) | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, nonVoidArg rep] @@ -310,7 +311,8 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body + = do dflags <- getDynFlags + setSRT srt $ mkRhsClosure dflags name cc bi fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -333,10 +335,10 @@ form: \begin{code} -mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo +mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id -> FCode (Id, CgIdInfo) -mkRhsClosure bndr cc bi +mkRhsClosure dflags bndr cc bi [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -358,11 +360,11 @@ mkRhsClosure bndr cc bi where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset - offset_into_int = the_offset - fixedHdrSize + offset_into_int = the_offset - fixedHdrSize dflags \end{code} Ap thunks @@ -382,7 +384,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure bndr cc bi +mkRhsClosure dflags bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -392,7 +394,8 @@ mkRhsClosure bndr cc bi && all isFollowableArg (map idCgRep fvs) && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE - && not opt_SccProfilingOn -- not when profiling: we don't want to + && not (dopt Opt_SccProfilingOn dflags) + -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -410,7 +413,7 @@ mkRhsClosure bndr cc bi The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure bndr cc bi fvs upd_flag args body +mkRhsClosure _ bndr cc bi fvs upd_flag args body = cgRhsClosure bndr cc bi fvs upd_flag args body \end{code} diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs index c94f23701b..a651319a49 100644 --- a/compiler/codeGen/CgExtCode.hs +++ b/compiler/codeGen/CgExtCode.hs @@ -50,6 +50,7 @@ import OldCmm hiding( ClosureTypeInfo(..) ) -- import BasicTypes import BlockId +import DynFlags import FastString import Module import UniqFM @@ -87,6 +88,10 @@ instance Monad ExtFCode where (>>=) = thenExtFC return = returnExtFC +instance HasDynFlags ExtFCode where + getDynFlags = EC (\_ d -> do dflags <- getDynFlags + return (d, dflags)) + -- | Takes the variable decarations and imports from the monad -- and makes an environment, which is looped back into the computation. diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index e957b90b20..4a83d86592 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -31,7 +31,7 @@ import OldCmmUtils import SMRep import ForeignCall import Constants -import StaticFlags +import DynFlags import Outputable import Module import FastString @@ -51,9 +51,10 @@ cgForeignCall cgForeignCall results fcall stg_args live = do reps_n_amodes <- getArgAmodes stg_args + dflags <- getDynFlags let -- Get the *non-void* args, and jiggle them with shimForeignCall - arg_exprs = [ shimForeignCallArg stg_arg expr + arg_exprs = [ shimForeignCallArg dflags stg_arg expr | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, nonVoidArg rep] @@ -206,13 +207,14 @@ maybe_assign_temp e emitSaveThreadState :: Code emitSaveThreadState = do + dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) - stack_SP) stgSp + stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) + (stack_SP dflags)) stgSp emitCloseNursery -- and save the current cost centre stack in the TSO when profiling: - when opt_SccProfilingOn $ - stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) + when (dopt Opt_SccProfilingOn dflags) $ + stmtC (CmmStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS) -- CurrentNursery->free = Hp+1; emitCloseNursery :: Code @@ -220,18 +222,19 @@ emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) emitLoadThreadState :: Code emitLoadThreadState = do + dflags <- getDynFlags tso <- newTemp bWord -- TODO FIXME NOW stack <- newTemp bWord -- TODO FIXME NOW stmtsC [ -- tso = CurrentTSO CmmAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj - CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord), + CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), -- Sp = stack->sp; - CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) + CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK) + CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) rESERVED_STACK_WORDS), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed @@ -240,9 +243,9 @@ emitLoadThreadState = do ] emitOpenNursery -- and load the current cost centre stack from the TSO when profiling: - when opt_SccProfilingOn $ + when (dopt Opt_SccProfilingOn dflags) $ stmtC $ storeCurCCS $ - CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord + CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) bWord emitOpenNursery :: Code emitOpenNursery = stmtsC [ @@ -270,14 +273,14 @@ nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks -tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff -tso_stackobj = closureField oFFSET_StgTSO_stackobj -tso_CCCS = closureField oFFSET_StgTSO_cccs -stack_STACK = closureField oFFSET_StgStack_stack -stack_SP = closureField oFFSET_StgStack_sp +tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff +tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj +tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs +stack_STACK dflags = closureField dflags oFFSET_StgStack_stack +stack_SP dflags = closureField dflags oFFSET_StgStack_sp -closureField :: ByteOff -> ByteOff -closureField off = off + fixedHdrSize * wORD_SIZE +closureField :: DynFlags -> ByteOff -> ByteOff +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -299,13 +302,13 @@ hpAlloc = CmmGlobal HpAlloc -- value passed to the call. For ByteArray#/Array# we pass the -- address of the actual array, not the address of the heap object. -shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr -shimForeignCallArg arg expr +shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr +shimForeignCallArg dflags arg expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr arrPtrsHdrSize + = cmmOffsetB expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr arrWordsHdrSize + = cmmOffsetB expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index fd27cff766..c0c15131c4 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -44,6 +44,7 @@ import Util import Module import Constants import Outputable +import DynFlags import FastString import Data.List @@ -115,7 +116,8 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: DataCon + :: DynFlags + -> DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -123,15 +125,15 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr :: Bool -> DataCon -> [(CgRep, a)] +layOutConstr :: Bool -> DynFlags -> DataCon -> [(CgRep, a)] -> (ClosureInfo, [(a, VirtualHpOffset)]) -layOutConstr is_static data_con args - = (mkConInfo is_static data_con tot_wds ptr_wds, +layOutConstr is_static dflags data_con args + = (mkConInfo dflags is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args + things_w_offsets) = mkVirtHeapOffsets dflags False{-not a thunk-} args \end{code} @mkVirtHeapOffsets@ always returns boxed things with smaller offsets @@ -140,7 +142,8 @@ list \begin{code} mkVirtHeapOffsets - :: Bool -- True <=> is a thunk + :: DynFlags + -> Bool -- True <=> is a thunk -> [(CgRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* @@ -150,7 +153,7 @@ mkVirtHeapOffsets -- First in list gets lowest offset, which is initial offset + 1. -mkVirtHeapOffsets is_thunk things +mkVirtHeapOffsets dflags is_thunk things = let non_void_things = filterOut (isVoidArg . fst) things (ptrs, non_ptrs) = separateByPtrFollowness non_void_things (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs @@ -158,8 +161,8 @@ mkVirtHeapOffsets is_thunk things in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where - hdr_size | is_thunk = thunkHdrSize - | otherwise = fixedHdrSize + hdr_size | is_thunk = thunkHdrSize dflags + | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far)) @@ -177,13 +180,14 @@ and adding a static link field if necessary. \begin{code} mkStaticClosureFields - :: ClosureInfo + :: DynFlags + -> ClosureInfo -> CostCentreStack -> Bool -- Has CAF refs -> [CmmLit] -- Payload -> [CmmLit] -- The full closure -mkStaticClosureFields cl_info ccs caf_refs payload - = mkStaticClosure info_lbl ccs payload padding_wds +mkStaticClosureFields dflags cl_info ccs caf_refs payload + = mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field where info_lbl = infoTableLabelFromCI cl_info @@ -221,9 +225,9 @@ mkStaticClosureFields cl_info ccs caf_refs payload | caf_refs = mkIntCLit 0 | otherwise = mkIntCLit 1 -mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] +mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field +mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words ++ concatMap padLitToWord payload @@ -234,7 +238,7 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi variable_header_words = staticGranHdr ++ staticParHdr - ++ staticProfHdr ccs + ++ staticProfHdr dflags ccs ++ staticTickyHdr padLitToWord :: CmmLit -> [CmmLit] @@ -290,24 +294,29 @@ hpStkCheck cl_info is_fun reg_save_code live code { -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole codeOnly $ do - { do_checks stk_words hpHw full_save_code rts_label full_live - ; tickyAllocHeap hpHw } + + dflags <- getDynFlags + + let (node_asst, full_live) + | nodeMustPointToIt dflags (closureLFInfo cl_info) + = (noStmts, live) + | otherwise + = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + ,Just $ node : fromMaybe [] live) + -- Strictly speaking, we should tag node here. But if + -- node doesn't point to the closure, the code for the closure + -- cannot depend on the value of R1 anyway, so we're safe. + + full_save_code = node_asst `plusStmts` reg_save_code + + do_checks stk_words hpHw full_save_code rts_label full_live + tickyAllocHeap hpHw ; setRealHp hpHw ; code } } where - (node_asst, full_live) - | nodeMustPointToIt (closureLFInfo cl_info) - = (noStmts, live) - | otherwise - = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) - ,Just $ node : fromMaybe [] live) - -- Strictly speaking, we should tag node here. But if - -- node doesn't point to the closure, the code for the closure - -- cannot depend on the value of R1 anyway, so we're safe. closure_lbl = closureLabelFromCI cl_info - full_save_code = node_asst `plusStmts` reg_save_code rts_label | is_fun = CmmReg (CmmGlobal GCFun) -- Function entry point @@ -578,6 +587,7 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets = do { virt_hp <- getVirtHp -- FIND THE OFFSET OF THE INFO-PTR WORD + ; dflags <- getDynFlags ; let info_offset = virt_hp + 1 -- info_offset is the VirtualHpOffset of the first -- word of the new object @@ -585,7 +595,7 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets -- ie 1 *before* the info-ptr word of new object. info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) - hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] + hdr_w_offsets = initDynHdr dflags info_ptr use_cc `zip` [0..] -- SAY WHAT WE ARE ABOUT TO DO ; profDynAlloc cl_info use_cc @@ -596,20 +606,21 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets ; hpStore base (hdr_w_offsets ++ amodes_with_offsets) -- BUMP THE VIRTUAL HEAP POINTER - ; setVirtHp (virt_hp + closureSize cl_info) + ; setVirtHp (virt_hp + closureSize dflags cl_info) -- RETURN PTR TO START OF OBJECT ; returnFC info_offset } -initDynHdr :: CmmExpr +initDynHdr :: DynFlags + -> CmmExpr -> CmmExpr -- Cost centre to put in object -> [CmmExpr] -initDynHdr info_ptr cc +initDynHdr dflags info_ptr cc = [info_ptr] -- ToDo: Gransim stuff -- ToDo: Parallel stuff - ++ dynProfHdr cc + ++ dynProfHdr dflags cc -- No ticky header hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code @@ -620,5 +631,6 @@ hpStore base es emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code emitSetDynHdr base info_ptr ccs - = hpStore base (zip (initDynHdr info_ptr ccs) [0..]) + = do dflags <- getDynFlags + hpStore base (zip (initDynHdr dflags info_ptr ccs) [0..]) \end{code} diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 7cdb1b6f7e..80b3b06ce3 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -45,6 +45,7 @@ import Unique import StaticFlags import Constants +import DynFlags import Util import Outputable @@ -68,13 +69,14 @@ emitClosureCodeAndInfoTable cl_info args body -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable mkCmmInfo cl_info - = return (CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, - cit_rep = closureSMRep cl_info, - cit_prof = prof, - cit_srt = closureSRT cl_info }) + = do dflags <- getDynFlags + return (CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, + cit_rep = closureSMRep cl_info, + cit_prof = prof dflags, + cit_srt = closureSRT cl_info }) where - prof | not opt_SccProfilingOn = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 + prof dflags | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 ty_descr_w8 = stringToWord8s (closureTypeDescr cl_info) val_descr_w8 = stringToWord8s (closureValDescr cl_info) @@ -218,10 +220,11 @@ emitAlgReturnTarget name branches mb_deflt fam_sz branches' = [(tag+1,branch)|(tag,branch)<-branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz else do -- no, get tag from info table + dflags <- getDynFlags let -- Note that ptr _always_ has tag 1 -- when the family size is big enough untagged_ptr = cmmRegOffB nodeReg (-1) - tag_expr = getConstrTag (untagged_ptr) + tag_expr = getConstrTag dflags untagged_ptr emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) ; lbl <- emitReturnTarget name blks ; return (lbl, Nothing) } @@ -240,32 +243,32 @@ emitReturnInstr live -- ----------------------------------------------------------------------------- -stdInfoTableSizeW :: WordOff +stdInfoTableSizeW :: DynFlags -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW +stdInfoTableSizeW dflags = size_fixed + size_prof where size_fixed = 2 -- layout, type - size_prof | opt_SccProfilingOn = 2 - | otherwise = 0 + size_prof | dopt Opt_SccProfilingOn dflags = 2 + | otherwise = 0 -stdInfoTableSizeB :: ByteOff -stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE +stdInfoTableSizeB :: DynFlags -> ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE -stdSrtBitmapOffset :: ByteOff +stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE -stdClosureTypeOffset :: ByteOff +stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE -stdPtrsOffset, stdNonPtrsOffset :: ByteOff -stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE -stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -283,66 +286,66 @@ entryCode :: CmmExpr -> CmmExpr entryCode e | tablesNextToCode = e | otherwise = CmmLoad e bWord -getConstrTag :: CmmExpr -> CmmExpr +getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). -getConstrTag closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table] +getConstrTag dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -cmmGetClosureType :: CmmExpr -> CmmExpr +cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table -cmmGetClosureType closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table] +cmmGetClosureType dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -infoTable :: CmmExpr -> CmmExpr +infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) -infoTable info_ptr - | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB) +infoTable dflags info_ptr + | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer -infoTableConstrTag :: CmmExpr -> CmmExpr +infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field) infoTableConstrTag = infoTableSrtBitmap -infoTableSrtBitmap :: CmmExpr -> CmmExpr +infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table -infoTableSrtBitmap info_tbl - = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord +infoTableSrtBitmap dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord -infoTableClosureType :: CmmExpr -> CmmExpr +infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. -infoTableClosureType info_tbl - = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord +infoTableClosureType dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord -infoTablePtrs :: CmmExpr -> CmmExpr -infoTablePtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord +infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTablePtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord -infoTableNonPtrs :: CmmExpr -> CmmExpr -infoTableNonPtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord +infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTableNonPtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord -funInfoTable :: CmmExpr -> CmmExpr +funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. -funInfoTable info_ptr +funInfoTable dflags info_ptr | tablesNextToCode - = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW) + = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 641cd5d1dc..a2e50e0c0d 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -30,8 +30,8 @@ import SMRep import Module import Constants import Outputable +import DynFlags import FastString -import StaticFlags import Control.Monad @@ -154,20 +154,23 @@ emitPrimOp [res] SparkOp [arg] live = do newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) emitPrimOp [res] GetCCSOfOp [arg] _live - = stmtC (CmmAssign (CmmLocal res) val) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (val dflags)) where - val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val dflags + | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) + | otherwise = CmmLit zeroCLit emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] _live = stmtC (CmmAssign (CmmLocal res) curCCS) emitPrimOp [res] ReadMutVarOp [mutv] _ - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord)) emitPrimOp [] WriteMutVarOp [mutv,var] live - = do - stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var) + = do dflags <- getDynFlags + stmtC (CmmStore (cmmOffsetW mutv (fixedHdrSize dflags)) var) vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] @@ -182,8 +185,10 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes emitPrimOp [res] SizeofByteArrayOp [arg] _ - = stmtC $ - CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) + = do dflags <- getDynFlags + stmtC $ + CmmAssign (CmmLocal res) + (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes @@ -197,18 +202,21 @@ emitPrimOp [] TouchOp [_] _ -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] _ - = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags))) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) emitPrimOp [res] StableNameToIntOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp [res] EqStableNameOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 fixedHdrSize bWord, - cmmLoadIndexW arg2 fixedHdrSize bWord + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ + cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, + cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord ])) @@ -222,7 +230,8 @@ emitPrimOp [res] AddrToAnyOp [arg] _ -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! emitPrimOp [res] DataToTagOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) (getConstrTag (cmmUntag arg))) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -281,8 +290,9 @@ emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArr emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v emitPrimOp [res] SizeofArrayOp [arg] _ - = stmtC $ - CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) + = do dflags <- getDynFlags + stmtC $ CmmAssign (CmmLocal res) + (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) emitPrimOp [res] SizeofMutableArrayOp [arg] live = emitPrimOp [res] SizeofArrayOp [arg] live emitPrimOp [res] SizeofArrayArrayOp [arg] live @@ -797,13 +807,15 @@ doIndexOffAddrOp _ _ _ _ = panic "CgPrimOp: doIndexOffAddrOp" doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx doIndexByteArrayOp _ _ _ _ = panic "CgPrimOp: doIndexByteArrayOp" doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code doReadPtrArrayOp res addr idx - = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx + = do dflags <- getDynFlags + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx doWriteOffAddrOp, doWriteByteArrayOp @@ -815,27 +827,29 @@ doWriteOffAddrOp _ _ _ _ = panic "CgPrimOp: doWriteOffAddrOp" doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val] - = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast rep addr idx val doWriteByteArrayOp _ _ _ _ = panic "CgPrimOp: doWriteByteArrayOp" doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code doWritePtrArrayOp addr idx val - = do mkBasicIndexedWrite arrPtrsHdrSize Nothing bWord addr idx val + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing bWord addr idx val stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] stmtC $ CmmStore ( cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) - (loadArrPtrsSize addr)) + (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + (loadArrPtrsSize dflags addr)) (CmmMachOp mo_wordUShr [idx, CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: CmmExpr -> CmmExpr -loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord + where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> Code @@ -905,8 +919,9 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCopyByteArray copy src src_off dst dst_off n live = do - dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off - src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + dflags <- getDynFlags + dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n live -- ---------------------------------------------------------------------------- @@ -918,7 +933,8 @@ emitCopyByteArray copy src src_off dst dst_off n live = do doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code doSetByteArrayOp ba off len c live - = do p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + = do dflags <- getDynFlags + p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live -- ---------------------------------------------------------------------------- @@ -966,6 +982,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do + dflags <- getDynFlags -- Assign the arguments to temporaries so the code generator can -- calculate liveness for us. src <- assignTemp_ src0 @@ -977,15 +994,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do -- Set the dirty bit in the header. stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize + dst_elems_p <- assignTemp $ cmmOffsetB dst (arrPtrsHdrSize dflags) dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) copy src dst dst_p src_p bytes live -- The base address of the destination card table - dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n live @@ -996,6 +1013,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCloneArray info_p res_r src0 src_off0 n0 live = do + dflags <- getDynFlags -- Assign the arguments to temporaries so the code generator can -- calculate liveness for us. src <- assignTemp_ src0 @@ -1006,22 +1024,22 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) `cmmAddWord` CmmLit (mkIntCLit 1) size <- assignTemp $ n `cmmAddWord` card_words - words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size + words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size arr_r <- newTemp bWord emitAllocateCall arr_r myCapability words live - tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) (CmmLit $ mkIntCLit 0) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs)) n - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_size)) size - dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + dst_p <- assignTemp $ cmmOffsetB arr (arrPtrsHdrSize dflags) + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) @@ -1034,8 +1052,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do live stmtC $ CmmAssign (CmmLocal res_r) arr where - arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) wordSize = CmmLit (mkIntCLit wORD_SIZE) myCapability = CmmReg baseReg `cmmSubWord` CmmLit (mkIntCLit oFFSET_Capability_r) diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 1a5f916dbe..2eccae7926 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -49,7 +49,7 @@ import CLabel import qualified Module import CostCentre -import StaticFlags +import DynFlags import FastString import Module import Constants -- Lots of field offsets @@ -81,15 +81,15 @@ costCentreFrom :: CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord -staticProfHdr :: CostCentreStack -> [CmmLit] +staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR -staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, - staticLdvInit] +staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, + staticLdvInit] -dynProfHdr :: CmmExpr -> [CmmExpr] +dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] initUpdFrameProf :: CmmExpr -> Code -- Initialise the profiling field of an update frame @@ -107,7 +107,8 @@ initUpdFrameProf frame_amode profDynAlloc :: ClosureInfo -> CmmExpr -> Code profDynAlloc cl_info ccs = ifProfiling $ - profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs + do dflags <- getDynFlags + profAlloc (CmmLit (mkIntCLit (closureSize dflags cl_info))) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -118,13 +119,14 @@ profDynAlloc cl_info ccs profAlloc :: CmmExpr -> CmmExpr -> Code profAlloc words ccs = ifProfiling $ - stmtC (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ - [CmmMachOp mo_wordSub [words, - CmmLit (mkIntCLit profHdrSize)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. + do dflags <- getDynFlags + stmtC (addToMemE alloc_rep + (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) + (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ + [CmmMachOp mo_wordSub [words, + CmmLit (mkIntCLit (profHdrSize dflags))]])) + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. where alloc_rep = typeWidth REP_CostCentreStack_mem_alloc @@ -147,13 +149,13 @@ enterCostCentreFun ccs closure vols = ifProfiling :: Code -> Code ifProfiling code - | opt_SccProfilingOn = code - | otherwise = nopC + = do dflags <- getDynFlags + if dopt Opt_SccProfilingOn dflags then code else nopC -ifProfilingL :: [a] -> [a] -ifProfilingL xs - | opt_SccProfilingOn = xs - | otherwise = [] +ifProfilingL :: DynFlags -> [a] -> [a] +ifProfilingL dflags xs + | dopt Opt_SccProfilingOn dflags = xs + | otherwise = [] -- --------------------------------------------------------------------------- -- Initialising Cost Centres & CCSs @@ -226,12 +228,13 @@ sizeof_ccs_words emitSetCCC :: CostCentre -> Bool -> Bool -> Code emitSetCCC cc tick push - | not opt_SccProfilingOn = nopC - | otherwise = do - tmp <- newTemp bWord -- TODO FIXME NOW - pushCostCentre tmp curCCS cc - when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp))) - when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp))) + = do dflags <- getDynFlags + if dopt Opt_SccProfilingOn dflags + then do tmp <- newTemp bWord -- TODO FIXME NOW + pushCostCentre tmp curCCS cc + when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp))) + when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp))) + else nopC pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index a869795caa..217586a9d1 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -38,6 +38,7 @@ import OldCmm import OldCmmUtils import CLabel import Constants +import DynFlags import Util import OrdList import Outputable @@ -286,7 +287,8 @@ pushSpecUpdateFrame lbl updatee code when debugIsOn $ do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; ; MASSERT(case sequel of { OnStack -> True; _ -> False}) } - ; allocStackTop (fixedHdrSize + + ; dflags <- getDynFlags + ; allocStackTop (fixedHdrSize dflags + sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE) ; vsp <- getVirtSp ; setStackFrame vsp @@ -311,14 +313,16 @@ emitPushUpdateFrame = emitSpecPushUpdateFrame mkUpdInfoLabel emitSpecPushUpdateFrame :: CLabel -> CmmExpr -> CmmExpr -> Code emitSpecPushUpdateFrame lbl frame_addr updatee = do + dflags <- getDynFlags stmtsC [ -- Set the info word CmmStore frame_addr (mkLblExpr lbl) , -- And the updatee - CmmStore (cmmOffsetB frame_addr off_updatee) updatee ] + CmmStore (cmmOffsetB frame_addr (off_updatee dflags)) updatee ] initUpdFrameProf frame_addr -off_updatee :: ByteOff -off_updatee = fixedHdrSize*wORD_SIZE + oFFSET_StgUpdateFrame_updatee +off_updatee :: DynFlags -> ByteOff +off_updatee dflags + = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgUpdateFrame_updatee \end{code} diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index e933fedb5b..ee4144800a 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -41,8 +41,8 @@ import Type import Id import StgSyn import PrimOp +import DynFlags import Outputable -import StaticFlags import Util import Control.Monad @@ -112,15 +112,15 @@ performTailCall fun_info arg_amodes pending_assts | otherwise = do { fun_amode <- idInfoToAmode fun_info + ; dflags <- getDynFlags ; let assignSt = CmmAssign nodeReg fun_amode node_asst = oneStmt assignSt node_live = Just [node] (opt_node_asst, opt_node_live) - | nodeMustPointToIt lf_info = (node_asst, node_live) + | nodeMustPointToIt dflags lf_info = (node_asst, node_live) | otherwise = (noStmts, Just []) ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; dflags <- getDynFlags ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of -- Node must always point to things we enter @@ -133,7 +133,7 @@ performTailCall fun_info arg_amodes pending_assts -- so we can directly jump to the alternatives switch -- statement. jumpInstr = getEndOfBlockInfo >>= - maybeSwitchOnCons enterClosure + maybeSwitchOnCons dflags enterClosure ; doFinalJump sp False jumpInstr } -- A function, but we have zero arguments. It is already in WHNF, @@ -194,9 +194,9 @@ performTailCall fun_info arg_amodes pending_assts fun_has_cafs = idCafInfo fun_id untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) -- Test if closure is a constructor - maybeSwitchOnCons enterClosure eob + maybeSwitchOnCons dflags enterClosure eob | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, - not opt_SccProfilingOn + not (dopt Opt_SccProfilingOn dflags) -- we can't shortcut when profiling is on, because we have -- to enter a closure to mark it as "used" for LDV profiling = do { is_constr <- newLabelC @@ -251,13 +251,14 @@ directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts -> Code directCall sp lbl args extra_args live_node assts = do + dflags <- getDynFlags let -- First chunk of args go in registers (reg_arg_amodes, stk_args) = assignCallRegs args -- Any "extra" arguments are placed in frames on the -- stack after the other arguments. - slow_stk_args = slowArgs extra_args + slow_stk_args = slowArgs dflags extra_args reg_assts = assignToRegs reg_arg_amodes live_args = map snd reg_arg_amodes diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 021b0e4fd9..cfef1087cc 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -264,7 +264,7 @@ tickyDynAlloc cl_info _ -> return () } where -- will be needed when we fill in stubs - _cl_size = closureSize cl_info + -- _cl_size = closureSize dflags cl_info -- _slop_size = slopSize cl_info tick_alloc_thk diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 7a91a5e2a1..b71a722c38 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -459,14 +459,15 @@ dataConTagZ con = dataConTag con - fIRST_TAG %************************************************************************ \begin{code} -mkClosureInfo :: Bool -- Is static +mkClosureInfo :: DynFlags + -> Bool -- Is static -> Id -> LambdaFormInfo -> Int -> Int -- Total and pointer words -> C_SRT -> String -- String descriptor -> ClosureInfo -mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr +mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr = ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSMRep = sm_rep, @@ -480,18 +481,19 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr -- anything else gets eta expanded. where name = idName id - sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) nonptr_wds = tot_wds - ptr_wds -mkConInfo :: Bool -- Is static +mkConInfo :: DynFlags + -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo is_static data_con tot_wds ptr_wds +mkConInfo dflags is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con } where - sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) lf_info = mkConLFInfo data_con nonptr_wds = tot_wds - ptr_wds \end{code} @@ -503,8 +505,8 @@ mkConInfo is_static data_con tot_wds ptr_wds %************************************************************************ \begin{code} -closureSize :: ClosureInfo -> WordOff -closureSize cl_info = heapClosureSize (closureSMRep cl_info) +closureSize :: DynFlags -> ClosureInfo -> WordOff +closureSize dflags cl_info = heapClosureSize dflags (closureSMRep cl_info) \end{code} \begin{code} @@ -551,8 +553,8 @@ thunkClosureType _ = Thunk Be sure to see the stg-details notes about these... \begin{code} -nodeMustPointToIt :: LambdaFormInfo -> Bool -nodeMustPointToIt (LFReEntrant top _ no_fvs _) +nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs || -- Certainly if it has fvs we need to point to it isNotTopLevel top -- If it is not top level we will point to it @@ -564,7 +566,7 @@ nodeMustPointToIt (LFReEntrant top _ no_fvs _) -- non-inherited function i.e. not top level -- the not top case above ensures this is ok. -nodeMustPointToIt (LFCon _) = True +nodeMustPointToIt _ (LFCon _) = True -- Strictly speaking, the above two don't need Node to point -- to it if the arity = 0. But this is a *really* unlikely @@ -577,8 +579,8 @@ nodeMustPointToIt (LFCon _) = True -- having Node point to the result of an update. SLPJ -- 27/11/92. -nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || opt_SccProfilingOn +nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) + = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -586,12 +588,12 @@ nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) -- or profiling (in which case we need to recover the cost centre -- from inside it) -nodeMustPointToIt (LFThunk _ _ _ _ _) +nodeMustPointToIt _ (LFThunk _ _ _ _ _) = True -- Node must point to any standard-form thunk -nodeMustPointToIt (LFUnknown _) = True -nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt (LFLetNoEscape _) = False +nodeMustPointToIt _ (LFUnknown _) = True +nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point +nodeMustPointToIt _ (LFLetNoEscape _) = False \end{code} The entry conventions depend on the type of closure being entered, @@ -650,7 +652,7 @@ getCallMethod :: DynFlags -> CallMethod getCallMethod dflags _ _ lf_info _ - | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags + | nodeMustPointToIt dflags lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -662,10 +664,11 @@ getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel name caf) arity -getCallMethod _ _ _ (LFCon con) n_args - | opt_SccProfilingOn -- when profiling, we must always enter - = EnterIt -- a closure when we use it, so that the closure - -- can be recorded as used for LDV profiling. +getCallMethod dflags _ _ (LFCon con) n_args + -- when profiling, we must always enter a closure when we use it, so + -- that the closure can be recorded as used for LDV profiling. + | dopt Opt_SccProfilingOn dflags + = EnterIt | otherwise = ASSERT( n_args == 0 ) ReturnCon con diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index c9b2bf8ab0..29193137a7 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -104,7 +104,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info ; whenC (opt_Hpc) $ hpcTable this_mod hpc_info - ; whenC (opt_SccProfilingOn) $ do + ; whenC (dopt Opt_SccProfilingOn dflags) $ do initCostCentres cost_centre_info -- For backwards compatibility: user code may refer to this @@ -128,11 +128,11 @@ code-generator.) initCostCentres :: CollectedCCs -> Code -- Emit the declarations, and return code to register them initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - | not opt_SccProfilingOn = nopC - | otherwise - = do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs - } + = do dflags <- getDynFlags + if not (dopt Opt_SccProfilingOn dflags) + then nopC + else do mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs \end{code} %************************************************************************ diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index dae0ad05ab..70892eeb5e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -224,15 +224,16 @@ cgDataCon :: DataCon -> FCode () -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. cgDataCon data_con - = do { let + = do { dflags <- getDynFlags + ; let (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds - arg_things) = mkVirtConstrOffsets arg_reps + arg_things) = mkVirtConstrOffsets dflags arg_reps nonptr_wds = tot_wds - ptr_wds - sta_info_tbl = mkDataConInfoTable data_con True ptr_wds nonptr_wds - dyn_info_tbl = mkDataConInfoTable data_con False ptr_wds nonptr_wds + sta_info_tbl = mkDataConInfoTable dflags data_con True ptr_wds nonptr_wds + dyn_info_tbl = mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds emit_info info_tbl ticky_code = emitClosureAndInfoTable info_tbl NativeDirectCall [] diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 942a780678..2bec4208a1 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -55,7 +55,6 @@ import Outputable import FastString import Maybes import DynFlags -import StaticFlags ------------------------------------------------------------------------ -- Top-level bindings @@ -79,17 +78,17 @@ cgTopRhsClosure id ccs _ upd_flag args body = do ; mod_name <- getModuleName ; dflags <- getDynFlags ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo True id lf_info 0 0 descr + closure_info = mkClosureInfo dflags True id lf_info 0 0 descr closure_label = mkLocalClosureLabel name (idCafInfo id) cg_id_info = litIdInfo id lf_info (CmmLabel closure_label) caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut - closure_rep = mkStaticClosureFields info_tbl ccs caffy [] + closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] - (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) + (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addIdReps []) -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs @@ -161,13 +160,14 @@ cgRhs name (StgRhsCon cc con args) = buildDynCon name cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) - = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag args body + = do dflags <- getDynFlags + mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo +mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args @@ -210,7 +210,7 @@ for semi-obvious reasons. -} ---------- Note [Selectors] ------------------ -mkRhsClosure bndr cc bi +mkRhsClosure dflags bndr cc bi [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -234,14 +234,14 @@ mkRhsClosure bndr cc bi where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, _, params_w_offsets) = mkVirtConstrOffsets (addIdReps params) + (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) Just the_offset = maybe_offset - offset_into_int = the_offset - fixedHdrSize + offset_into_int = the_offset - fixedHdrSize dflags ---------- Note [Ap thunks] ------------------ -mkRhsClosure bndr cc bi +mkRhsClosure dflags bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -251,7 +251,8 @@ mkRhsClosure bndr cc bi && all (isGcPtrRep . idPrimRep . stripNV) fvs && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE - && not opt_SccProfilingOn -- not when profiling: we don't want to + && not (dopt Opt_SccProfilingOn dflags) + -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -265,7 +266,7 @@ mkRhsClosure bndr cc bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure bndr cc _ fvs upd_flag args body +mkRhsClosure _ bndr cc _ 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. @@ -289,9 +290,9 @@ mkRhsClosure bndr cc _ fvs upd_flag args body descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets (isLFThunk lf_info) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addIdReps (map stripNV reduced_fvs)) - closure_info = mkClosureInfo False -- Not static + closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -335,10 +336,10 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload mod_name <- getModuleName ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo False -- Not static + closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -419,8 +420,9 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode cl_info arg_regs + ; dflags <- getDynFlags ; let lf_info = closureLFInfo cl_info - node_points = nodeMustPointToIt lf_info + node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; tickyEnterFun cl_info ; whenC node_points (ldvEnterClosure cl_info) @@ -475,7 +477,8 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> LocalReg -> Int -> StgExpr -> FCode () thunkCode cl_info fv_details _cc node arity body - = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) + = do { dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; tickyEnterThunk cl_info ; ldvEnterClosure cl_info -- NB: Node always points when profiling @@ -532,7 +535,7 @@ emitBlackHoleCode is_single_entry = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. - let eager_blackholing = not opt_SccProfilingOn + let eager_blackholing = not (dopt Opt_SccProfilingOn dflags) && dopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't @@ -540,7 +543,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) - emitStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) + emitStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -561,7 +564,8 @@ setupUpdate closure_info node body dflags <- getDynFlags let bh = blackHoleOnEntry closure_info && - not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + not (dopt Opt_SccProfilingOn dflags) && + dopt Opt_EagerBlackHoling dflags lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel @@ -638,13 +642,14 @@ link_caf :: Bool -- True <=> updatable, False <=> single-entry -- is that we only want to update dynamic heap objects, not static ones, -- so that generational GC is easier. link_caf _is_upd = do - { -- Alloc black hole specifying CC_HDR(Node) as the cost centre + { dflags <- getDynFlags + -- Alloc black hole specifying CC_HDR(Node) as the cost centre ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) ; (hp_rel, init) <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole - use_cc blame_cc [(tso,fixedHdrSize)] + use_cc blame_cc [(tso,fixedHdrSize dflags)] ; emit init -- Call the RTS function newCAF to add the CAF to the CafList diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 8023abddec..73b3d1639e 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -376,8 +376,8 @@ thunkClosureType _ = Thunk -- Be sure to see the stg-details notes about these... -nodeMustPointToIt :: LambdaFormInfo -> Bool -nodeMustPointToIt (LFReEntrant top _ no_fvs _) +nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs || -- Certainly if it has fvs we need to point to it isNotTopLevel top -- If it is not top level we will point to it @@ -389,7 +389,7 @@ nodeMustPointToIt (LFReEntrant top _ no_fvs _) -- non-inherited function i.e. not top level -- the not top case above ensures this is ok. -nodeMustPointToIt (LFCon _) = True +nodeMustPointToIt _ (LFCon _) = True -- Strictly speaking, the above two don't need Node to point -- to it if the arity = 0. But this is a *really* unlikely @@ -402,8 +402,8 @@ nodeMustPointToIt (LFCon _) = True -- having Node point to the result of an update. SLPJ -- 27/11/92. -nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || opt_SccProfilingOn +nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) + = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -411,13 +411,13 @@ nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) -- or profiling (in which case we need to recover the cost centre -- from inside it) -nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk = True -nodeMustPointToIt (LFUnknown _) = True -nodeMustPointToIt LFUnLifted = False -nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt LFLetNoEscape = False +nodeMustPointToIt _ (LFUnknown _) = True +nodeMustPointToIt _ LFUnLifted = False +nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point +nodeMustPointToIt _ LFLetNoEscape = False ----------------------------------------------------------------------------- -- getCallMethod @@ -475,7 +475,7 @@ getCallMethod :: DynFlags -> CallMethod getCallMethod dflags _name _ lf_info _n_args - | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags + | nodeMustPointToIt dflags lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -673,13 +673,14 @@ mkCmmInfo ClosureInfo {..} -- Building ClosureInfos -------------------------------------- -mkClosureInfo :: Bool -- Is static +mkClosureInfo :: DynFlags + -> Bool -- Is static -> Id -> LambdaFormInfo -> Int -> Int -- Total and pointer words -> String -- String descriptor -> ClosureInfo -mkClosureInfo is_static id lf_info tot_wds ptr_wds val_descr +mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr = ClosureInfo { closureName = name, closureLFInfo = lf_info, closureInfoLabel = info_lbl, -- These three fields are @@ -687,8 +688,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds val_descr closureProf = prof } -- (we don't have an SRT yet) where name = idName id - sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info) - prof = mkProfilingInfo id val_descr + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) + prof = mkProfilingInfo dflags id val_descr nonptr_wds = tot_wds - ptr_wds info_lbl = mkClosureInfoTableLabel id lf_info @@ -851,9 +852,9 @@ enterIdLabel id c -- The type is determined from the type information stored with the @Id@ -- in the closure info using @closureTypeDescr@. -mkProfilingInfo :: Id -> String -> ProfilingInfo -mkProfilingInfo id val_descr - | not opt_SccProfilingOn = NoProfilingInfo +mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo +mkProfilingInfo dflags id val_descr + | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 where ty_descr_w8 = stringToWord8s (getTyDescription (idType id)) @@ -884,8 +885,8 @@ getTyLitDescription l = -- CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable -mkDataConInfoTable data_con is_static ptr_wds nonptr_wds +mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof @@ -896,13 +897,13 @@ mkDataConInfoTable data_con is_static ptr_wds nonptr_wds info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs | otherwise = mkConInfoTableLabel name NoCafRefs - sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type cl_type = Constr (fromIntegral (dataConTagZ data_con)) (dataConIdentity data_con) - prof | not opt_SccProfilingOn = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr val_descr + prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con val_descr = stringToWord8s $ occNameString $ getOccName data_con diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 03a659b2cf..3efa63d770 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -71,14 +71,14 @@ cgTopRhsCon id con args (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds - nv_args_w_offsets) = mkVirtConstrOffsets (addArgReps args) + nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) nonptr_wds = tot_wds - ptr_wds -- we're not really going to emit an info table, so having -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields -- needs to poke around inside it. - info_tbl = mkDataConInfoTable con True ptr_wds nonptr_wds + info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg ; return lit } @@ -88,6 +88,7 @@ cgTopRhsCon id con args -- NB2: all the amodes should be Lits! ; let closure_rep = mkStaticClosureFields + dflags info_tbl dontCareCCS -- Because it's static data caffy -- Has CAF refs @@ -184,7 +185,7 @@ buildDynCon' dflags platform binder _cc con [arg] , val >= fromIntegral mIN_INTLIKE -- ...ditto... = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) + offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = cmmLabelOffW intlike_lbl offsetW ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) } @@ -197,18 +198,18 @@ buildDynCon' dflags platform binder _cc con [arg] , val_int <= mAX_CHARLIKE , val_int >= mIN_CHARLIKE = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) + offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) } -------- buildDynCon': the general case ----------- -buildDynCon' _ _ binder ccs con args +buildDynCon' dflags _ binder ccs con args = do { let (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets (addArgReps args) + = mkVirtConstrOffsets dflags (addArgReps args) -- No void args in args_w_offsets nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable con False ptr_wds nonptr_wds + info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds ; (tmp, init) <- allocDynClosure info_tbl lf_info use_cc blame_cc args_w_offsets ; regIdInfo binder lf_info tmp init } @@ -233,10 +234,10 @@ bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg] -- found a con bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) - mapM bind_arg args_w_offsets + do dflags <- getDynFlags + let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) + mapM bind_arg args_w_offsets where - (_, _, args_w_offsets) = mkVirtConstrOffsets (addIdReps args) - tag = tagForCon con -- The binding below forces the masking out of the tag bits diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 9e2b78cbbd..65e2416d2f 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -505,12 +505,12 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts emitSwitch tag_expr branches' mb_deflt 1 fam_sz else -- No, get tag from info table - let -- Note that ptr _always_ has tag 1 - -- when the family size is big enough - untagged_ptr = cmmRegOffB bndr_reg (-1) - tag_expr = getConstrTag (untagged_ptr) - in - emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) } + do dflags <- getDynFlags + let -- Note that ptr _always_ has tag 1 + -- when the family size is big enough + untagged_ptr = cmmRegOffB bndr_reg (-1) + tag_expr = getConstrTag dflags (untagged_ptr) + emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) } cgAlts _ _ _ _ = panic "cgAlts" -- UbxTupAlt and PolyAlt have only one alternative @@ -633,7 +633,7 @@ cgTailCall fun_id fun_info args = do -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args - ; if node_points + ; if node_points dflags then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } @@ -644,7 +644,7 @@ cgTailCall fun_id fun_info args = do fun_name = idName fun_id fun = idInfoToAmode fun_info lf_info = cgIdInfoLF fun_info - node_points = nodeMustPointToIt lf_info + node_points dflags = nodeMustPointToIt dflags lf_info emitEnter :: CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index c67e0e0c95..8c061cf00c 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -35,7 +35,7 @@ import CLabel import SMRep import ForeignCall import Constants -import StaticFlags +import DynFlags import Maybes import Outputable import BasicTypes @@ -259,52 +259,55 @@ maybe_assign_temp e -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -saveThreadState :: CmmAGraph -saveThreadState = +saveThreadState :: DynFlags -> CmmAGraph +saveThreadState dflags = -- CurrentTSO->stackobj->sp = Sp; - mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp + mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp <*> closeNursery -- and save the current cost centre stack in the TSO when profiling: - <*> if opt_SccProfilingOn then - mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS + <*> if dopt Opt_SccProfilingOn dflags then + mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS else mkNop emitSaveThreadState :: BlockId -> FCode () emitSaveThreadState bid = do + dflags <- getDynFlags + -- CurrentTSO->stackobj->sp = Sp; - emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) + emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord))) emit closeNursery -- and save the current cost centre stack in the TSO when profiling: - when opt_SccProfilingOn $ - emitStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS + when (dopt Opt_SccProfilingOn dflags) $ + emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS -- CurrentNursery->free = Hp+1; closeNursery :: CmmAGraph closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -loadThreadState :: LocalReg -> LocalReg -> CmmAGraph -loadThreadState tso stack = do +loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +loadThreadState dflags tso stack = do -- tso <- newTemp gcWord -- TODO FIXME NOW -- stack <- newTemp gcWord -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord), + mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK) + mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) rESERVED_STACK_WORDS), openNursery, -- and load the current cost centre stack from the TSO when profiling: - if opt_SccProfilingOn then + if dopt Opt_SccProfilingOn dflags then storeCurCCS - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType) else mkNop] emitLoadThreadState :: LocalReg -> LocalReg -> FCode () -emitLoadThreadState tso stack = emit $ loadThreadState tso stack +emitLoadThreadState tso stack = do dflags <- getDynFlags + emit $ loadThreadState dflags tso stack openNursery :: CmmAGraph openNursery = catAGraphs [ @@ -334,15 +337,15 @@ nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks -tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff -tso_stackobj = closureField oFFSET_StgTSO_stackobj -tso_CCCS = closureField oFFSET_StgTSO_cccs -stack_STACK = closureField oFFSET_StgStack_stack -stack_SP = closureField oFFSET_StgStack_sp +tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff +tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj +tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs +stack_STACK dflags = closureField dflags oFFSET_StgStack_stack +stack_SP dflags = closureField dflags oFFSET_StgStack_sp -closureField :: ByteOff -> ByteOff -closureField off = off + fixedHdrSize * wORD_SIZE +closureField :: DynFlags -> ByteOff -> ByteOff +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -376,19 +379,20 @@ getFCallArgs args = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg) - ; return (Just (add_shim arg_ty cmm, hint)) } + ; dflags <- getDynFlags + ; return (Just (add_shim dflags arg_ty cmm, hint)) } where arg_ty = stgArgType arg arg_rep = typePrimRep arg_ty hint = typeForeignHint arg_ty -add_shim :: Type -> CmmExpr -> CmmExpr -add_shim arg_ty expr +add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr +add_shim dflags arg_ty expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr arrPtrsHdrSize + = cmmOffsetB expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr arrWordsHdrSize + = cmmOffsetB expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 2151f84353..e177b72385 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -41,6 +41,7 @@ import CostCentre import Outputable import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module +import DynFlags import FastString( mkFastString, fsLit ) import Constants import Util @@ -117,7 +118,8 @@ allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets ; hpStore base cmm_args offsets -- BUMP THE VIRTUAL HEAP POINTER - ; setVirtHp (virt_hp + heapClosureSize rep) + ; dflags <- getDynFlags + ; setVirtHp (virt_hp + heapClosureSize dflags rep) -- Assign to a temporary and return -- Note [Return a LocalReg] @@ -126,10 +128,11 @@ allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs - = hpStore base header [0..] + = do dflags <- getDynFlags + hpStore base (header dflags) [0..] where - header :: [CmmExpr] - header = [info_ptr] ++ dynProfHdr ccs + header :: DynFlags -> [CmmExpr] + header dflags = [info_ptr] ++ dynProfHdr dflags ccs -- ToDo: Gransim stuff -- ToDo: Parallel stuff -- No ticky header @@ -150,13 +153,14 @@ hpStore base vals offs -- and adding a static link field if necessary. mkStaticClosureFields - :: CmmInfoTable + :: DynFlags + -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -- Payload -> [CmmLit] -- The full closure -mkStaticClosureFields info_tbl ccs caf_refs payload - = mkStaticClosure info_lbl ccs payload padding +mkStaticClosureFields dflags info_tbl ccs caf_refs payload + = mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field where info_lbl = cit_lbl info_tbl @@ -197,9 +201,9 @@ mkStaticClosureFields info_tbl ccs caf_refs payload | otherwise = mkIntCLit 1 -- No CAF refs -mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] +mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field +mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words ++ concatMap padLitToWord payload @@ -210,7 +214,7 @@ mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field variable_header_words = staticGranHdr ++ staticParHdr - ++ staticProfHdr ccs + ++ staticProfHdr dflags ccs ++ staticTickyHdr -- JD: Simon had ellided this padding, but without it the C back end asserts diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 9c17716b1b..0e9cebfea4 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -53,6 +53,7 @@ import Id import Name import TyCon ( PrimRep(..) ) import BasicTypes ( RepArity ) +import DynFlags import StaticFlags import Module @@ -206,12 +207,15 @@ direct_call caller call_conv lbl arity args = emitCall (call_conv, NativeReturn) target (nonVArgs args) | otherwise -- Note [over-saturated calls] - = emitCallWithExtraStack (call_conv, NativeReturn) - target (nonVArgs fast_args) (mkStkOffsets stack_args) + = do dflags <- getDynFlags + emitCallWithExtraStack (call_conv, NativeReturn) + target + (nonVArgs fast_args) + (mkStkOffsets (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args - stack_args = slowArgs rest_args + stack_args dflags = slowArgs dflags rest_args real_arity = case call_conv of NativeNodeCall -> arity+1 _ -> arity @@ -273,11 +277,12 @@ just more arguments that we are passing on the stack (cml_args). -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] -slowArgs [] = [] -slowArgs args -- careful: reps contains voids (V), but args does not - | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest_args - | otherwise = this_pat ++ slowArgs rest_args +slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] +slowArgs _ [] = [] +slowArgs dflags args -- careful: reps contains voids (V), but args does not + | dopt Opt_SccProfilingOn dflags + = save_cccs ++ this_pat ++ slowArgs dflags rest_args + | otherwise = this_pat ++ slowArgs dflags rest_args where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args @@ -396,7 +401,8 @@ getHpRelOffset virtual_offset ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } mkVirtHeapOffsets - :: Bool -- True <=> is a thunk + :: DynFlags + -> Bool -- True <=> is a thunk -> [(PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* @@ -412,7 +418,7 @@ mkVirtHeapOffsets -- mkVirtHeapOffsets always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsets is_thunk things +mkVirtHeapOffsets dflags is_thunk things = let non_void_things = filterOut (isVoidRep . fst) things (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs @@ -420,16 +426,16 @@ mkVirtHeapOffsets is_thunk things in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where - hdr_size | is_thunk = thunkHdrSize - | otherwise = fixedHdrSize + hdr_size | is_thunk = thunkHdrSize dflags + | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) = (wds_so_far + argRepSizeW (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) -mkVirtConstrOffsets :: [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) +mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) -- Just like mkVirtHeapOffsets, but for constructors -mkVirtConstrOffsets = mkVirtHeapOffsets False +mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False ------------------------------------------------------------------------- @@ -519,11 +525,12 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body -- top-level binding, which this binding would incorrectly shadow. ; node <- if top_lvl then return $ idToReg (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; let node_points = nodeMustPointToIt lf_info + ; dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt lf_info then NativeNodeCall - else NativeDirectCall + conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall + else NativeDirectCall (offset, _) = mkCallEntry conv args' ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } @@ -544,32 +551,32 @@ emitClosureAndInfoTable info_tbl conv args body -- ----------------------------------------------------------------------------- -stdInfoTableSizeW :: WordOff +stdInfoTableSizeW :: DynFlags -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW +stdInfoTableSizeW dflags = size_fixed + size_prof where size_fixed = 2 -- layout, type - size_prof | opt_SccProfilingOn = 2 + size_prof | dopt Opt_SccProfilingOn dflags = 2 | otherwise = 0 -stdInfoTableSizeB :: ByteOff -stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff +stdInfoTableSizeB :: DynFlags -> ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff -stdSrtBitmapOffset :: ByteOff +stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE -stdClosureTypeOffset :: ByteOff +stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE -stdPtrsOffset, stdNonPtrsOffset :: ByteOff -stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE -stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -587,65 +594,65 @@ entryCode :: CmmExpr -> CmmExpr entryCode e | tablesNextToCode = e | otherwise = CmmLoad e bWord -getConstrTag :: CmmExpr -> CmmExpr +getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). -getConstrTag closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table] +getConstrTag dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -cmmGetClosureType :: CmmExpr -> CmmExpr +cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table -cmmGetClosureType closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table] +cmmGetClosureType dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -infoTable :: CmmExpr -> CmmExpr +infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) -infoTable info_ptr - | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB) +infoTable dflags info_ptr + | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer -infoTableConstrTag :: CmmExpr -> CmmExpr +infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field) infoTableConstrTag = infoTableSrtBitmap -infoTableSrtBitmap :: CmmExpr -> CmmExpr +infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table -infoTableSrtBitmap info_tbl - = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord +infoTableSrtBitmap dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord -infoTableClosureType :: CmmExpr -> CmmExpr +infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. -infoTableClosureType info_tbl - = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord +infoTableClosureType dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord -infoTablePtrs :: CmmExpr -> CmmExpr -infoTablePtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord +infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTablePtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord -infoTableNonPtrs :: CmmExpr -> CmmExpr -infoTableNonPtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord +infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTableNonPtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord -funInfoTable :: CmmExpr -> CmmExpr +funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. -funInfoTable info_ptr +funInfoTable dflags info_ptr | tablesNextToCode - = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW) + = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 15020ccf7b..e015ac7935 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -46,7 +46,6 @@ import Constants import Module import FastString import Outputable -import StaticFlags import Util import Control.Monad (liftM) @@ -233,20 +232,23 @@ emitPrimOp [res] SparkOp [arg] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) emitPrimOp [res] GetCCSOfOp [arg] - = emitAssign (CmmLocal res) val + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (val dflags) where - val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val dflags + | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) + | otherwise = CmmLit zeroCLit emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] = emitAssign (CmmLocal res) curCCS emitPrimOp [res] ReadMutVarOp [mutv] - = emitAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord) emitPrimOp [] WriteMutVarOp [mutv,var] - = do - emitStore (cmmOffsetW mutv fixedHdrSize) var + = do dflags <- getDynFlags + emitStore (cmmOffsetW mutv (fixedHdrSize dflags)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) @@ -255,8 +257,9 @@ emitPrimOp [] WriteMutVarOp [mutv,var] -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes emitPrimOp [res] SizeofByteArrayOp [arg] - = emit $ - mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) + = do dflags <- getDynFlags + emit $ + mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes @@ -270,18 +273,21 @@ emitPrimOp res@[] TouchOp args@[_arg] -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] - = emitAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) emitPrimOp [res] StableNameToIntOp [arg] - = emitAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp [res] EqStableNameOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 fixedHdrSize bWord, - cmmLoadIndexW arg2 fixedHdrSize bWord + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [ + cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, + cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord ]) @@ -295,7 +301,8 @@ emitPrimOp [res] AddrToAnyOp [arg] -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! emitPrimOp [res] DataToTagOp [arg] - = emitAssign (CmmLocal res) (getConstrTag (cmmUntag arg)) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -358,7 +365,8 @@ emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayO emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v emitPrimOp [res] SizeofArrayOp [arg] - = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) + = do dflags <- getDynFlags + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) emitPrimOp [res] SizeofMutableArrayOp [arg] = emitPrimOp [res] SizeofArrayOp [arg] emitPrimOp [res] SizeofArrayArrayOp [arg] @@ -868,13 +876,15 @@ doIndexOffAddrOp _ _ _ _ doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx doIndexByteArrayOp _ _ _ _ = panic "CgPrimOp: doIndexByteArrayOp" doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx - = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx + = do dflags <- getDynFlags + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () @@ -885,27 +895,29 @@ doWriteOffAddrOp _ _ _ doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val] - = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val doWriteByteArrayOp _ _ _ = panic "CgPrimOp: doWriteByteArrayOp" doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val - = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr idx val emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] emit $ mkStore ( cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) - (loadArrPtrsSize addr)) + (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + (loadArrPtrsSize dflags addr)) (CmmMachOp mo_wordUShr [idx, CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: CmmExpr -> CmmExpr -loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord + where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () @@ -976,8 +988,9 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do - dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off - src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + dflags <- getDynFlags + dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n -- ---------------------------------------------------------------------------- @@ -989,7 +1002,8 @@ emitCopyByteArray copy src src_off dst dst_off n = do doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c - = do p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + = do dflags <- getDynFlags + p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off emitMemsetCall p c len (CmmLit (mkIntCLit 1)) -- ---------------------------------------------------------------------------- @@ -1046,6 +1060,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do + dflags <- getDynFlags -- Passed as arguments (be careful) src <- assignTempE src0 src_off <- assignTempE src_off0 @@ -1056,15 +1071,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize + dst_elems_p <- assignTempE $ cmmOffsetB dst (arrPtrsHdrSize dflags) dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) copy src dst dst_p src_p bytes -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n @@ -1084,22 +1099,23 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) `cmmAddWord` CmmLit (mkIntCLit 1) size <- assignTempE $ n `cmmAddWord` card_words - words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size + dflags <- getDynFlags + words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size arr_r <- newTemp bWord emitAllocateCall arr_r myCapability words - tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) (CmmLit $ mkIntCLit 0) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs)) n - emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_size)) size - dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + dst_p <- assignTempE $ cmmOffsetB arr (arrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE)) @@ -1110,8 +1126,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do (CmmLit (mkIntCLit wORD_SIZE)) emit $ mkAssign (CmmLocal res_r) arr where - arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) wordSize = CmmLit (mkIntCLit wORD_SIZE) myCapability = CmmReg baseReg `cmmSubWord` CmmLit (mkIntCLit oFFSET_Capability_r) diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 9ff4d0be07..5031693cc5 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -51,7 +51,7 @@ import CLabel import qualified Module import CostCentre -import StaticFlags +import DynFlags import FastString import Module import Constants -- Lots of field offsets @@ -89,15 +89,15 @@ costCentreFrom :: CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType -staticProfHdr :: CostCentreStack -> [CmmLit] +staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR -staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, - staticLdvInit] +staticProfHdr dflags ccs + = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit] -dynProfHdr :: CmmExpr -> [CmmExpr] +dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] initUpdFrameProf :: CmmExpr -> FCode () -- Initialise the profiling field of an update frame @@ -139,12 +139,12 @@ We want this kind of code: saveCurrentCostCentre :: FCode (Maybe LocalReg) -- Returns Nothing if profiling is off saveCurrentCostCentre - | not opt_SccProfilingOn - = return Nothing - | otherwise - = do { local_cc <- newTemp ccType - ; emitAssign (CmmLocal local_cc) curCCS - ; return (Just local_cc) } + = do dflags <- getDynFlags + if not (dopt Opt_SccProfilingOn dflags) + then return Nothing + else do local_cc <- newTemp ccType + emitAssign (CmmLocal local_cc) curCCS + return (Just local_cc) restoreCurrentCostCentre :: Maybe LocalReg -> FCode () restoreCurrentCostCentre Nothing @@ -162,7 +162,8 @@ restoreCurrentCostCentre (Just local_cc) profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ - profAlloc (CmmLit (mkIntCLit (heapClosureSize rep))) ccs + do dflags <- getDynFlags + profAlloc (CmmLit (mkIntCLit (heapClosureSize dflags rep))) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -170,15 +171,16 @@ profDynAlloc rep ccs profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ - emit (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ - [CmmMachOp mo_wordSub [words, - CmmLit (mkIntCLit profHdrSize)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. + do dflags <- getDynFlags + emit (addToMemE alloc_rep + (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) + (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ + [CmmMachOp mo_wordSub [words, + CmmLit (mkIntCLit (profHdrSize dflags))]])) + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. where - alloc_rep = REP_CostCentreStack_mem_alloc + alloc_rep = REP_CostCentreStack_mem_alloc -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure @@ -190,13 +192,15 @@ enterCostCentreThunk closure = ifProfiling :: FCode () -> FCode () ifProfiling code - | opt_SccProfilingOn = code - | otherwise = nopC + = do dflags <- getDynFlags + if dopt Opt_SccProfilingOn dflags + then code + else nopC -ifProfilingL :: [a] -> [a] -ifProfilingL xs - | opt_SccProfilingOn = xs - | otherwise = [] +ifProfilingL :: DynFlags -> [a] -> [a] +ifProfilingL dflags xs + | dopt Opt_SccProfilingOn dflags = xs + | otherwise = [] --------------------------------------------------------------- @@ -206,9 +210,10 @@ ifProfilingL xs initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = whenC opt_SccProfilingOn $ - do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs } + = do dflags <- getDynFlags + whenC (dopt Opt_SccProfilingOn dflags) $ + do mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs emitCostCentreDecl :: CostCentre -> FCode () @@ -272,12 +277,13 @@ sizeof_ccs_words emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push - | not opt_SccProfilingOn = nopC - | otherwise = do - tmp <- newTemp ccsType -- TODO FIXME NOW - pushCostCentre tmp curCCS cc - when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) + = do dflags <- getDynFlags + if not (dopt Opt_SccProfilingOn dflags) + then nopC + else do tmp <- newTemp ccsType -- TODO FIXME NOW + pushCostCentre tmp curCCS cc + when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 698bf32709..ec8f674555 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -285,7 +285,7 @@ tickyDynAlloc rep lf | otherwise -> return () where -- will be needed when we fill in stubs - _cl_size = heapClosureSize rep +-- _cl_size = heapClosureSize rep -- _slop_size = slopSize cl_info tick_alloc_thk |