diff options
47 files changed, 786 insertions, 654 deletions
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index a171faa057..3970f249d3 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -24,8 +24,8 @@ import qualified Stream import Maybes import Constants +import DynFlags import Panic -import Platform import StaticFlags import UniqSupply import MonadUtils @@ -42,12 +42,12 @@ mkEmptyContInfoTable info_lbl , cit_prof = NoProfilingInfo , cit_srt = NoC_SRT } -cmmToRawCmm :: Platform -> Stream IO Old.CmmGroup () +cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup () -> IO (Stream IO Old.RawCmmGroup ()) -cmmToRawCmm platform cmms +cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' ; let do_one uniqs cmm = do - case initUs uniqs $ concatMapM (mkInfoTable platform) cmm of + case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of (b,uniqs') -> return (uniqs',b) -- NB. strictness fixes a space leak. DO NOT REMOVE. ; return (Stream.mapAccumL do_one uniqs cmms >> return ()) @@ -86,16 +86,16 @@ cmmToRawCmm platform cmms -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl] +mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable platform (CmmProc info entry_label blocks) +mkInfoTable dflags (CmmProc info entry_label blocks) | CmmNonInfoTable <- info -- Code without an info table. Easy. = return [CmmProc Nothing entry_label blocks] | CmmInfoTable { cit_lbl = info_lbl } <- info - = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing + = do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing ; return (top_decls ++ mkInfoTableAndCode info_lbl info_cts entry_label blocks) } @@ -107,20 +107,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: Platform +mkInfoTableContents :: DynFlags -> CmmInfoTable -> Maybe StgHalfWord -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits -mkInfoTableContents platform +mkInfoTableContents dflags info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep - = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag) + = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) -- Completely override the rts_tag that mkInfoTableContents would -- otherwise compute, with the rts_tag stored in the RTSRep -- (which in turn came from a handwritten .cmm file) @@ -130,7 +130,7 @@ mkInfoTableContents platform ; let (srt_label, srt_bitmap) = mkSRTLit srt ; (liveness_lit, liveness_data) <- mkLivenessBits frame ; let - std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit + std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag | null liveness_data = rET_SMALL -- Fits in extra_bits | otherwise = rET_BIG -- Does not; extra_bits is @@ -143,7 +143,7 @@ mkInfoTableContents platform ; let (srt_label, srt_bitmap) = mkSRTLit srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label - ; let std_info = mkStdInfoTable prof_lits + ; let std_info = mkStdInfoTable dflags prof_lits (mb_rts_tag `orElse` rtsClosureType smrep) (mb_srt_field `orElse` srt_bitmap) (mb_layout `orElse` layout) @@ -326,13 +326,14 @@ mkLivenessBits liveness -- so we can't use constant offsets from Constants mkStdInfoTable - :: (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + :: DynFlags + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> StgHalfWord -- Closure RTS tag -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] -mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit +mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit = -- Parallel revertible-black hole field prof_info -- Ticky info (none at present) @@ -341,8 +342,8 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit where prof_info - | opt_SccProfilingOn = [type_descr, closure_descr] - | otherwise = [] + | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] + | otherwise = [] type_lit = packHalfWordsCLit cl_type srt_len diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 209ef8f8fd..5f44013145 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -23,6 +23,7 @@ import Maybes import UniqFM import Util +import DynFlags import FastString import Outputable import Data.Map (Map) @@ -103,9 +104,9 @@ instance Outputable StackMap where text "sm_regs = " <> ppr (eltsUFM sm_regs) -cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph +cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph -> UniqSM (CmmGraph, BlockEnv StackMap) -cmmLayoutStack procpoints entry_args +cmmLayoutStack dflags procpoints entry_args graph0@(CmmGraph { g_entry = entry }) = do -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return () @@ -118,7 +119,7 @@ cmmLayoutStack procpoints entry_args layout procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks - new_blocks' <- mapM lowerSafeForeignCall new_blocks + new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return () return (ofBlockList entry new_blocks', final_stackmaps) @@ -870,8 +871,8 @@ Note the copyOut, which saves the results in the places that L1 is expecting them (see Note {safe foreign call convention]). -} -lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock -lowerSafeForeignCall block +lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock +lowerSafeForeignCall dflags block | (entry, middle, CmmForeignCall { .. }) <- blockSplit block = do -- Both 'id' and 'new_base' are KindNonPtr because they're @@ -881,7 +882,7 @@ lowerSafeForeignCall block let (caller_save, caller_load) = callerSaveVolatileRegs load_tso <- newTemp gcWord load_stack <- newTemp gcWord - let suspend = saveThreadState <*> + let suspend = saveThreadState dflags <*> caller_save <*> mkMiddle (callSuspendThread id intrbl) midCall = mkUnsafeCall tgt res args @@ -890,7 +891,7 @@ lowerSafeForeignCall block -- might now have a different Capability! mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> caller_load <*> - loadThreadState load_tso load_stack + loadThreadState dflags load_tso load_stack -- Note: The successor must be a procpoint, and we have already split, -- so we use a jump, not a branch. succLbl = CmmLit (CmmLabel (infoTblLbl succ)) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index f46d49e022..0d1c788113 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -216,12 +216,13 @@ static :: { ExtFCode [CmmStatic] } (widthInBytes (typeWidth $1) * fromIntegral $3)] } | 'CLOSURE' '(' NAME lits ')' - { do lits <- sequence $4; - return $ map CmmStaticLit $ - mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) + { do { lits <- sequence $4 + ; dflags <- getDynFlags + ; return $ map CmmStaticLit $ + mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. - dontCareCCS (map getLit lits) [] [] [] } + dontCareCCS (map getLit lits) [] [] [] } } -- arrays of closures required for the CHARLIKE & INTLIKE arrays lits :: { [ExtFCode CmmExpr] } @@ -260,9 +261,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type {% withThisPackage $ \pkg -> - do let prof = profilingInfo $11 $13 + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep False (fromIntegral $5) + mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) Thunk -- not really Thunk, but that makes the info table -- we want. @@ -275,11 +277,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type {% withThisPackage $ \pkg -> - do let prof = profilingInfo $11 $13 + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 ty = Fun 0 (ArgSpec (fromIntegral $15)) -- Arity zero, arg_type $15 rep = mkRTSRep (fromIntegral $9) $ - mkHeapRep False (fromIntegral $5) + mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 @@ -292,11 +295,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type {% withThisPackage $ \pkg -> - do let prof = profilingInfo $13 $15 + do dflags <- getDynFlags + let prof = profilingInfo dflags $13 $15 ty = Constr (fromIntegral $9) -- Tag (stringToWord8s $13) rep = mkRTSRep (fromIntegral $11) $ - mkHeapRep False (fromIntegral $5) + mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 @@ -310,10 +314,11 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type {% withThisPackage $ \pkg -> - do let prof = profilingInfo $9 $11 + do dflags <- getDynFlags + let prof = profilingInfo dflags $9 $11 ty = ThunkSelector (fromIntegral $5) rep = mkRTSRep (fromIntegral $7) $ - mkHeapRep False 0 0 ty + mkHeapRep dflags False 0 0 ty return (mkCmmEntryLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep @@ -639,8 +644,9 @@ nameToMachOp name = Just m -> return m exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr) -exprOp name args_code = - case lookupUFM exprMacros name of +exprOp name args_code = do + dflags <- getDynFlags + case lookupUFM (exprMacros dflags) name of Just f -> return $ do args <- sequence args_code return (f args) @@ -648,18 +654,18 @@ exprOp name args_code = mo <- nameToMachOp name return $ mkMachOp mo args_code -exprMacros :: UniqFM ([CmmExpr] -> CmmExpr) -exprMacros = listToUFM [ +exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) +exprMacros dflags = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode x ), ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), - ( fsLit "STD_INFO", \ [x] -> infoTable x ), - ( fsLit "FUN_INFO", \ [x] -> funInfoTable x ), + ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), ( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ), - ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType x ), - ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs x ), - ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs x ) + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) ] -- we understand a subset of C-- primitives: @@ -824,15 +830,17 @@ stmtMacros = listToUFM [ ] -profilingInfo desc_str ty_str - | not opt_SccProfilingOn = NoProfilingInfo - | otherwise = ProfilingInfo (stringToWord8s desc_str) - (stringToWord8s ty_str) +profilingInfo dflags desc_str ty_str + = if not (dopt Opt_SccProfilingOn dflags) + then NoProfilingInfo + else ProfilingInfo (stringToWord8s desc_str) + (stringToWord8s ty_str) staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode staticClosure pkg cl_label info payload - = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits - where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + = do dflags <- getDynFlags + let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits foreignCall :: String @@ -1036,12 +1044,12 @@ doSwitch mb_range scrut arms deflt -- The initial environment: we define some constants that the compiler -- knows about here. -initEnv :: Env -initEnv = listToUFM [ +initEnv :: DynFlags -> Env +initEnv dflags = listToUFM [ ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )), + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )), ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) )) + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) )) ] parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) @@ -1059,7 +1067,7 @@ parseCmmFile dflags filename = do return ((emptyBag, unitBag msg), Nothing) POk pst code -> do st <- initC - let (cmm,_) = runC dflags no_module st (getCmm (unEC code initEnv [] >> return ())) + let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ())) let ms = getMessages pst if (errorsFound dflags ms) then return (ms, Nothing) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index f2a2855d7b..9aac09f29f 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Layout the stack and manifest Sp --------------- -- (also does: removeDeadAssignments, and lowerSafeForeignCalls) (g, stackmaps) <- {-# SCC "layoutStack" #-} - runUniqSM $ cmmLayoutStack procPoints entry_off g + runUniqSM $ cmmLayoutStack dflags procPoints entry_off g dump Opt_D_dump_cmmz_sp "Layout Stack" g g <- if optLevel dflags >= 99 diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 92f3e08ab3..1d5574ae8f 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -44,7 +44,7 @@ module SMRep ( #include "../HsVersions.h" #include "../includes/MachDeps.h" -import StaticFlags +import DynFlags import Constants import Outputable import FastString @@ -161,8 +161,9 @@ data ArgDescr ----------------------------------------------------------------------------- -- Construction -mkHeapRep :: IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep -mkHeapRep is_static ptr_wds nonptr_wds cl_type_info +mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo + -> SMRep +mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info = HeapRep is_static ptr_wds (nonptr_wds + slop_wds) @@ -170,9 +171,9 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info where slop_wds | is_static = 0 - | otherwise = max 0 (minClosureSize - (hdr_size + payload_size)) + | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) - hdr_size = closureTypeHdrSize cl_type_info + hdr_size = closureTypeHdrSize dflags cl_type_info payload_size = ptr_wds + nonptr_wds mkRTSRep :: StgHalfWord -> SMRep -> SMRep @@ -217,29 +218,33 @@ isStaticNoCafCon _ = False -- Size-related things -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -fixedHdrSize :: WordOff -fixedHdrSize = sTD_HDR_SIZE + profHdrSize +fixedHdrSize :: DynFlags -> WordOff +fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags -- | Size of the profiling part of a closure header -- (StgProfHeader in includes/rts/storage/Closures.h) -profHdrSize :: WordOff -profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE - | otherwise = 0 +profHdrSize :: DynFlags -> WordOff +profHdrSize dflags + | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE + | otherwise = 0 --- | The garbage collector requires that every closure is at least as big as this. -minClosureSize :: WordOff -minClosureSize = fixedHdrSize + mIN_PAYLOAD_SIZE +-- | The garbage collector requires that every closure is at least as +-- big as this. +minClosureSize :: DynFlags -> WordOff +minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE -arrWordsHdrSize :: ByteOff -arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr +arrWordsHdrSize :: DynFlags -> ByteOff +arrWordsHdrSize dflags + = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr -arrPtrsHdrSize :: ByteOff -arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr +arrPtrsHdrSize :: DynFlags -> ByteOff +arrPtrsHdrSize dflags + = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. -thunkHdrSize :: WordOff -thunkHdrSize = fixedHdrSize + smp_hdr +thunkHdrSize :: DynFlags -> WordOff +thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE @@ -248,16 +253,17 @@ nonHdrSize (HeapRep _ p np _) = p + np nonHdrSize (StackRep bs) = length bs nonHdrSize (RTSRep _ rep) = nonHdrSize rep -heapClosureSize :: SMRep -> WordOff -heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np -heapClosureSize _ = panic "SMRep.heapClosureSize" - -closureTypeHdrSize :: ClosureTypeInfo -> WordOff -closureTypeHdrSize ty = case ty of - Thunk{} -> thunkHdrSize - ThunkSelector{} -> thunkHdrSize - BlackHole{} -> thunkHdrSize - _ -> fixedHdrSize +heapClosureSize :: DynFlags -> SMRep -> WordOff +heapClosureSize dflags (HeapRep _ p np ty) + = closureTypeHdrSize dflags ty + p + np +heapClosureSize _ _ = panic "SMRep.heapClosureSize" + +closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff +closureTypeHdrSize dflags ty = case ty of + Thunk{} -> thunkHdrSize dflags + ThunkSelector{} -> thunkHdrSize dflags + BlackHole{} -> thunkHdrSize dflags + _ -> fixedHdrSize dflags -- All thunks use thunkHdrSize, even if they are non-updatable. -- this is because we don't have separate closure types for -- updatable vs. non-updatable thunks, so the GC can't tell the 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 diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index ff3cfc5189..4e04a29a3c 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -254,6 +254,8 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do + env <- getEnv + let dflags = tte_dflags env let name = getOccString id decl_path <- getPathEntry density <- getDensity @@ -263,7 +265,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do || id `elemVarSet` inline_ids -- See Note [inline sccs] - if inline && opt_SccProfilingOn then return (L pos funBind) else do + if inline && dopt Opt_SccProfilingOn dflags then return (L pos funBind) else do (fvs, (MatchGroup matches' ty)) <- getFreeVars $ @@ -1054,12 +1056,14 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c) - count = countEntries && dopt Opt_ProfCountEntries (tte_dflags env) + dflags = tte_dflags env + + count = countEntries && dopt Opt_ProfCountEntries dflags tickish - | opt_Hpc = HpcTick (this_mod env) c - | opt_SccProfilingOn = ProfNote cc count True{-scopes-} - | otherwise = Breakpoint c ids + | opt_Hpc = HpcTick (this_mod env) c + | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-} + | otherwise = Breakpoint c ids in ( tickish , fvs diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 2b068bbd46..c1855e46ef 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -112,7 +112,7 @@ deSugar hsc_env let want_ticks = opt_Hpc || target == HscInterpreted - || (opt_SccProfilingOn + || (dopt Opt_SccProfilingOn dflags && case profAuto dflags of NoProfAuto -> False _ -> True) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 5e5a5f0c62..73724c007e 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -121,7 +121,7 @@ instance Outputable UnlinkedBCO where -- Top level assembler fn. assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode assembleBCOs dflags proto_bcos tycons - = do itblenv <- mkITbls tycons + = do itblenv <- mkITbls dflags tycons bcos <- mapM (assembleBCO dflags) proto_bcos return (ByteCode bcos itblenv) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index a19d2ecf0b..b277a1ed30 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -84,8 +84,8 @@ byteCodeGen dflags this_mod binds tycs modBreaks | (bndr, rhs) <- flattenBinds binds] us <- mkSplitUniqSupply 'y' - (BcM_State _us _this_mod _final_ctr mallocd _, proto_bcos) - <- runBc us this_mod modBreaks (mapM schemeTopBind flatBinds) + (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos) + <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds) when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -115,8 +115,8 @@ coreExprToBCOs dflags this_mod expr -- the uniques are needed to generate fresh variables when we introduce new -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' - (BcM_State _us _this_mod _final_ctr mallocd _ , proto_bco) - <- runBc us this_mod emptyModBreaks $ + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco) + <- runBc dflags us this_mod emptyModBreaks $ schemeTopBind (invented_id, freeVars expr) when (notNull mallocd) @@ -942,13 +942,15 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- contains. Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do rest <- pargs (d + fromIntegral addr_sizeW) az - code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a + -> do dflags <- getDynFlags + rest <- pargs (d + fromIntegral addr_sizeW) az + code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do rest <- pargs (d + fromIntegral addr_sizeW) az - code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a + -> do dflags <- getDynFlags + rest <- pargs (d + fromIntegral addr_sizeW) az + code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact. @@ -1526,7 +1528,8 @@ type BcPtr = Either ItblPtr (Ptr ()) data BcM_State = BcM_State - { uniqSupply :: UniqSupply -- for generating fresh variable names + { bcm_dflags :: DynFlags + , uniqSupply :: UniqSupply -- for generating fresh variable names , thisModule :: Module -- current module (for breakpoints) , nextlabel :: Word16 -- for generating local labels , malloced :: [BcPtr] -- thunks malloced for current BCO @@ -1541,9 +1544,10 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r) -runBc us this_mod modBreaks (BcM m) - = m (BcM_State us this_mod 0 [] breakArray) +runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r + -> IO (BcM_State, r) +runBc dflags us this_mod modBreaks (BcM m) + = m (BcM_State dflags us this_mod 0 [] breakArray) where breakArray = modBreaks_flags modBreaks @@ -1568,6 +1572,9 @@ instance Monad BcM where (>>) = thenBc_ return = returnBc +instance HasDynFlags BcM where + getDynFlags = BcM $ \st -> return (st, bcm_dflags st) + emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 7378141e3d..9b22ec8cd6 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -20,6 +20,7 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls #include "HsVersions.h" +import DynFlags import Name ( Name, getName ) import NameEnv import ClosureInfo @@ -66,31 +67,31 @@ mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] -- Make info tables for the data decls in this module -mkITbls :: [TyCon] -> IO ItblEnv -mkITbls [] = return emptyNameEnv -mkITbls (tc:tcs) = do itbls <- mkITbl tc - itbls2 <- mkITbls tcs - return (itbls `plusNameEnv` itbls2) - -mkITbl :: TyCon -> IO ItblEnv -mkITbl tc +mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv +mkITbls _ [] = return emptyNameEnv +mkITbls dflags (tc:tcs) = do itbls <- mkITbl dflags tc + itbls2 <- mkITbls dflags tcs + return (itbls `plusNameEnv` itbls2) + +mkITbl :: DynFlags -> TyCon -> IO ItblEnv +mkITbl dflags tc | not (isDataTyCon tc) = return emptyNameEnv | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls dcs + = make_constr_itbls dflags dcs where dcs = tyConDataCons tc n = tyConFamilySize tc -mkITbl _ = error "Unmatched patter in mkITbl: assertion failed!" +mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!" #include "../includes/rts/storage/ClosureTypes.h" cONSTR :: Int -- Defined in ClosureTypes.h cONSTR = CONSTR -- Assumes constructors are numbered from zero, not one -make_constr_itbls :: [DataCon] -> IO ItblEnv -make_constr_itbls cons +make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv +make_constr_itbls dflags cons = do is <- mapM mk_dirret_itbl (zip cons [0..]) return (mkItblEnv is) where @@ -100,7 +101,7 @@ make_constr_itbls cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = do let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] - (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args ptrs' = ptr_wds nptrs' = tot_wds - ptr_wds diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 331c294973..19a3cbb721 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -36,9 +36,10 @@ import Data.List -- dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) dataConInfoPtrToName x = do + dflags <- getDynFlags theString <- liftIO $ do let ptr = castPtr x :: Ptr StgInfoTable - conDescAddress <- getConDescAddress ptr + conDescAddress <- getConDescAddress dflags ptr peekArray0 0 conDescAddress let (pkg, mod, occ) = parse theString pkgFS = mkFastStringByteList pkg @@ -46,7 +47,6 @@ dataConInfoPtrToName x = do occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) - dflags <- getDynFlags return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) `recoverM` (Right `fmap` lookupOrig modName occName) @@ -92,14 +92,13 @@ dataConInfoPtrToName x = do in the memory location: info_table_ptr + info_table_size -} - getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress ptr + getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) + getConDescAddress dflags ptr | ghciTablesNextToCode = do offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) - return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) + return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord)) | otherwise = - peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB - + peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) -- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index b9e37941b3..e568d556f2 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -14,7 +14,6 @@ import Module import Name import Fingerprint -- import Outputable -import StaticFlags import qualified Data.IntSet as IntSet import System.FilePath (normalise) @@ -44,7 +43,7 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = paths = [ hcSuf ] -- -fprof-auto etc. - prof = if opt_SccProfilingOn then fromEnum profAuto else 0 + prof = if dopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $ computeFingerprint nameio (mainis, safeHs, lang, cpp, paths, prof) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index fc11f2d52d..4d41642e75 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -321,6 +321,7 @@ data DynFlag | Opt_Parallel | Opt_GranMacros | Opt_PIC + | Opt_SccProfilingOn -- output style opts | Opt_PprCaseAsLet @@ -2045,6 +2046,7 @@ fFlags = [ ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "defer-type-errors", Opt_DeferTypeErrors, nop ), ( "parallel", Opt_Parallel, nop ), + ( "scc-profiling", Opt_SccProfilingOn, nop ), ( "gransim", Opt_GranMacros, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 215a654185..9474ca2a8b 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1249,7 +1249,6 @@ hscGenHardCode cgguts mod_summary = do cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env - platform = targetPlatform dflags location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1283,7 +1282,7 @@ hscGenHardCode cgguts mod_summary = do ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - cmmToRawCmm platform cmms + cmmToRawCmm dflags cmms let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr a) @@ -1342,7 +1341,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - rawCmms <- cmmToRawCmm (targetPlatform dflags) (Stream.yield cmm) + rawCmms <- cmmToRawCmm dflags (Stream.yield cmm) _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 2ef2914b30..ddb40268fb 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -170,7 +170,6 @@ flagsStatic = [ isStaticFlag :: String -> Bool isStaticFlag f = f `elem` [ - "fscc-profiling", "fdicts-strict", "fspec-inline-join-points", "fno-hi-version-check", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 3d33565b5a..79faf1ec2f 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -40,9 +40,6 @@ module StaticFlags ( opt_SuppressTypeSignatures, opt_SuppressVarKinds, - -- profiling opts - opt_SccProfilingOn, - -- Hpc opts opt_Hpc, @@ -250,10 +247,6 @@ opt_Fuel = lookup_def_int "-dopt-fuel" maxBound opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") --- profiling opts -opt_SccProfilingOn :: Bool -opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling") - -- Hpc opts opt_Hpc :: Bool opt_Hpc = lookUp (fsLit "-fhpc") diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index cef5974fb0..b872a7d953 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -57,7 +57,7 @@ module Lexer ( extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, typeLiteralsEnabled, - explicitNamespacesEnabled, + explicitNamespacesEnabled, sccProfilingOn, addWarning, lexTokenStream ) where @@ -1849,6 +1849,8 @@ inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included +sccProfilingOnBit :: Int +sccProfilingOnBit = 21 alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 relaxedLayoutBit :: Int @@ -1909,6 +1911,8 @@ relaxedLayout :: Int -> Bool relaxedLayout flags = testBit flags relaxedLayoutBit nondecreasingIndentation :: Int -> Bool nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit +sccProfilingOn :: Int -> Bool +sccProfilingOn flags = testBit flags sccProfilingOnBit traditionalRecordSyntaxEnabled :: Int -> Bool traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit typeLiteralsEnabled :: Int -> Bool @@ -1975,6 +1979,7 @@ mkPState flags buf loc = .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. sccProfilingOnBit `setBitIf` dopt Opt_SccProfilingOn flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags .|. safeHaskellBit `setBitIf` safeImportsOn flags .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 62132277d9..6c19812762 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -43,7 +43,7 @@ import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc import Module -import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) +import StaticFlags ( opt_Hpc ) import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) import Class ( FunDep ) import BasicTypes @@ -1402,9 +1402,10 @@ exp10 :: { LHsExpr RdrName } | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } - | scc_annot exp { LL $ if opt_SccProfilingOn - then HsSCC (unLoc $1) $2 - else HsPar $2 } + | scc_annot exp {% do { on <- extension sccProfilingOn + ; return $ LL $ if on + then HsSCC (unLoc $1) $2 + else HsPar $2 } } | hpc_annot exp { LL $ if opt_Hpc then HsTickPragma (unLoc $1) $2 else HsPar $2 } diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs index 7e223f80e9..0866c03395 100644 --- a/compiler/profiling/ProfInit.hs +++ b/compiler/profiling/ProfInit.hs @@ -10,8 +10,8 @@ module ProfInit (profilingInitCode) where import CLabel import CostCentre +import DynFlags import Outputable -import StaticFlags import FastString import Module @@ -23,9 +23,10 @@ import Module profilingInitCode :: Module -> CollectedCCs -> SDoc profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) - | not opt_SccProfilingOn = empty - | otherwise - = vcat + = sdocWithDynFlags $ \dflags -> + if not (dopt Opt_SccProfilingOn dflags) + then empty + else vcat [ text "static void prof_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));" , text "static void prof_init_" <> ppr this_mod <> text "(void)" diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 3e801c6328..1b608bdc4d 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -60,7 +60,6 @@ import Packages ( isDllName ) import Platform import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) -import StaticFlags ( opt_SccProfilingOn ) import TyCon ( PrimRep(..) ) import TyCon ( TyCon ) import Type ( Type ) @@ -810,7 +809,8 @@ pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp fun -- general case pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) - = hang (hsep [if opt_SccProfilingOn then ppr cc else empty, + = sdocWithDynFlags $ \dflags -> + hang (hsep [if dopt Opt_SccProfilingOn dflags then ppr cc else empty, pp_binder_info bi, ifPprDebug (brackets (interppSP free_vars)), char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) |