diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-05-25 19:20:25 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-02 20:08:36 -0400 |
commit | f08d6316d3d19b627550d99b4364e9bf0b45c329 (patch) | |
tree | 65e52dcc0b0fc940da95885e7e3e4ca5e585ce49 /compiler | |
parent | 4d90b3ff02002ea25460d087dde56f69a9641096 (diff) | |
download | haskell-f08d6316d3d19b627550d99b4364e9bf0b45c329.tar.gz |
Replace Opt_SccProfilingOn flag with sccProfilingEnabled helper function
SCC profiling was enabled in a convoluted way: if WayProf was enabled,
Opt_SccProfilingOn general flag was set (in
`GHC.Driver.Ways.wayGeneralFlags`), and then this flag was queried in
various places.
There is no need to go via general flags, so this patch defines a
`sccProfilingEnabled :: DynFlags -> Bool` helper function that just
checks whether WayProf is enabled.
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Info.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Parser.y | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Driver/Ways.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Recomp/Flags.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Heap/Layout.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Foreign.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Layout.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Prof.hs | 16 |
19 files changed, 54 insertions, 44 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 4cb2977155..d5d15143c2 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -605,10 +605,12 @@ setSessionDynFlags dflags = do then do let prog = pgm_i dflags ++ flavour + profiled = ways dflags `hasWay` WayProf + dynamic = ways dflags `hasWay` WayDyn flavour - | WayProf `S.member` ways dflags = "-prof" - | WayDyn `S.member` ways dflags = "-dyn" - | otherwise = "" + | profiled = "-prof" -- FIXME: can't we have both? + | dynamic = "-dyn" + | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) @@ -617,8 +619,8 @@ setSessionDynFlags dflags = do conf = IServConfig { iservConfProgram = prog , iservConfOpts = getOpts dflags opt_i - , iservConfProfiled = gopt Opt_SccProfilingOn dflags - , iservConfDynamic = WayDyn `S.member` ways dflags + , iservConfProfiled = profiled + , iservConfDynamic = dynamic , iservConfHook = createIservProcessHook (hooks dflags) , iservConfTrace = tr } diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 3dcff4a517..0e187a97b2 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -405,7 +405,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit where platform = targetPlatform dflags prof_info - | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] + | sccProfilingEnabled dflags = [type_descr, closure_descr] | otherwise = [] tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform) @@ -565,7 +565,7 @@ stdInfoTableSizeW :: DynFlags -> WordOff -- It must vary in sync with mkStdInfoTable stdInfoTableSizeW dflags = fixedInfoTableSizeW - + if gopt Opt_SccProfilingOn dflags + + if sccProfilingEnabled dflags then profInfoTableSizeW else 0 diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 7bf60f58da..cadda66b11 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -1168,7 +1168,7 @@ reserveStackFrame psize preg body = do withUpdFrameOff frame body profilingInfo dflags desc_str ty_str - = if not (gopt Opt_SccProfilingOn dflags) + = if not (sccProfilingEnabled dflags) then NoProfilingInfo else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 8d4726baf6..b8b48425e9 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -275,11 +275,9 @@ outputForeignStubs_help fname doc_str header footer -- module; -- | Generate code to initialise cost centres -profilingInitCode :: DynFlags -> Module -> CollectedCCs -> SDoc -profilingInitCode dflags this_mod (local_CCs, singleton_CCSs) - = if not (gopt Opt_SccProfilingOn dflags) - then empty - else vcat +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, singleton_CCSs) + = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs ++ [emit_cc_list local_CCs] diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 5f4d14723e..93748bbc06 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -252,7 +252,6 @@ data GeneralFlag | Opt_PIE -- ^ @-fPIE@ | Opt_PICExecutable -- ^ @-pie@ | Opt_ExternalDynamicRefs - | Opt_SccProfilingOn | Opt_Ticky | Opt_Ticky_Allocd | Opt_Ticky_LNE diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 9bfd3704cd..62f7467b11 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1412,7 +1412,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) - prof_init = profilingInitCode dflags this_mod cost_centre_info + prof_init + | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info + | otherwise = empty foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 0a45d96621..85eca17aed 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -42,6 +42,7 @@ module GHC.Driver.Session ( whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, dynamicOutputFile, + sccProfilingEnabled, DynFlags(..), FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), @@ -5094,6 +5095,10 @@ isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of ArchX86 -> bmiVersion dflags >= Just BMI2 _ -> False +-- | Indicate if cost-centre profiling is enabled +sccProfilingEnabled :: DynFlags -> Bool +sccProfilingEnabled dflags = ways dflags `hasWay` WayProf + -- ----------------------------------------------------------------------------- -- Linker/compiler information diff --git a/compiler/GHC/Driver/Ways.hs b/compiler/GHC/Driver/Ways.hs index c33cf24702..29a4d72082 100644 --- a/compiler/GHC/Driver/Ways.hs +++ b/compiler/GHC/Driver/Ways.hs @@ -20,6 +20,7 @@ -- this compilation. module GHC.Driver.Ways ( Way(..) + , hasWay , allowed_combination , wayGeneralFlags , wayUnsetGeneralFlags @@ -60,12 +61,15 @@ data Way | WayDyn -- ^ Dynamic linking deriving (Eq, Ord, Show) +-- | Test if a ways is enabled +hasWay :: Set Way -> Way -> Bool +hasWay ws w = Set.member w ws -- | Check if a combination of ways is allowed allowed_combination :: Set Way -> Bool allowed_combination ways = not disallowed where - disallowed = or [ Set.member ways x && Set.member ways y + disallowed = or [ hasWay ways x && hasWay ways y | (x,y) <- couples ] -- List of disallowed couples of ways @@ -121,7 +125,7 @@ wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] -- .so before loading the .so using the system linker. Since only -- PIC objects can be linked into a .so, we have to compile even -- modules of the main program with -fPIC when using -dynamic. -wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayProf = [] wayGeneralFlags _ WayEventLog = [] -- | Turn these flags off when enabling this way diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 17335eb6b3..7451d0113d 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -1040,7 +1040,7 @@ coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ - ifa (gopt Opt_SccProfilingOn dflags && + ifa (sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto) ProfNotes $ ifa (debugLevel dflags > 0) SourceNotes [] where ifa f x xs | f = x:xs diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index fe60d06f83..696cebe565 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -813,7 +813,7 @@ dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags + if sccProfilingEnabled dflags then do mod_name <- getModule count <- goptM Opt_ProfCountEntries diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index eac1277b75..391aaf2c86 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -55,7 +55,7 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = paths = [ hcSuf ] -- -fprof-auto etc. - prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 + prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0 -- Ticky ticky = diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 4f43c13344..a092b04a22 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -282,8 +282,8 @@ fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags -- (StgProfHeader in includes\/rts\/storage\/Closures.h) profHdrSize :: DynFlags -> WordOff profHdrSize dflags - | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags - | otherwise = 0 + | sccProfilingEnabled dflags = pROF_HDR_SIZE dflags + | otherwise = 0 -- | The garbage collector requires that every closure is at least as -- big as this. diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index ec8e30e689..ea6eef7d22 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -805,7 +805,7 @@ pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc pprStgRhs (StgRhsClosure ext cc upd_flag args body) = sdocWithDynFlags $ \dflags -> - hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, + hang (hsep [if sccProfilingEnabled dflags then ppr cc else empty, ppUnlessOption sdocSuppressStgExts (ppr ext), char '\\' <> ppr upd_flag, brackets (interppSP args)]) 4 (ppr body) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 2217724922..c83bca2217 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -307,7 +307,7 @@ mkRhsClosure dflags bndr _cc , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= mAX_SPEC_AP_SIZE dflags - , not (gopt Opt_SccProfilingOn dflags) + , not (sccProfilingEnabled dflags) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -626,7 +626,7 @@ emitBlackHoleCode node = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (gopt Opt_SccProfilingOn dflags) + let eager_blackholing = not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't @@ -655,7 +655,7 @@ setupUpdate closure_info node body dflags <- getDynFlags let bh = blackHoleOnEntry closure_info && - not (gopt Opt_SccProfilingOn dflags) && + not (sccProfilingEnabled dflags) && gopt Opt_EagerBlackHoling dflags lbl | bh = mkBHUpdInfoLabel diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 98a9c878af..a21be98ceb 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -381,7 +381,7 @@ nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame - || gopt Opt_SccProfilingOn dflags + || sccProfilingEnabled dflags -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -508,7 +508,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (gopt Opt_SccProfilingOn dflags) + && not (sccProfilingEnabled dflags) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args @@ -859,7 +859,7 @@ enterIdLabel platform id c mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo mkProfilingInfo dflags id val_descr - | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | not (sccProfilingEnabled dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id)) @@ -906,8 +906,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr val_descr + prof | not (sccProfilingEnabled dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con val_descr = BS8.pack $ occNameString $ getOccName data_con diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 87e4ae6ccb..aaffa17699 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -306,7 +306,7 @@ saveThreadState dflags = do spExpr, close_nursery, -- and save the current cost centre stack in the TSO when profiling: - if gopt Opt_SccProfilingOn dflags then + if sccProfilingEnabled dflags then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr else mkNop ] @@ -421,7 +421,7 @@ loadThreadState dflags = do mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: - if gopt Opt_SccProfilingOn dflags + if sccProfilingEnabled dflags then storeCurCCS (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType platform)) diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 646f4fa1d9..3ccc3c51ac 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -367,7 +367,7 @@ just more arguments that we are passing on the stack (cml_args). slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] slowArgs _ [] = [] slowArgs dflags args -- careful: reps contains voids (V), but args does not - | gopt Opt_SccProfilingOn dflags + | sccProfilingEnabled dflags = save_cccs ++ this_pat ++ slowArgs dflags rest_args | otherwise = this_pat ++ slowArgs dflags rest_args where diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 5aa7566846..6c785d24ff 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -300,8 +300,8 @@ emitPrimOp dflags = \case GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do let val - | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) - | otherwise = CmmLit (zeroCLit platform) + | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 8de1445d21..1381617f89 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -76,15 +76,15 @@ costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs -- | The profiling header words in a static closure staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] staticProfHdr dflags ccs - | gopt Opt_SccProfilingOn dflags = [mkCCostCentreStack ccs, staticLdvInit platform] - | otherwise = [] + | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform] + | otherwise = [] where platform = targetPlatform dflags -- | Profiling header words in a dynamic closure dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] dynProfHdr dflags ccs - | gopt Opt_SccProfilingOn dflags = [ccs, dynLdvInit dflags] - | otherwise = [] + | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags] + | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () @@ -130,7 +130,7 @@ saveCurrentCostCentre :: FCode (Maybe LocalReg) saveCurrentCostCentre = do dflags <- getDynFlags platform <- getPlatform - if not (gopt Opt_SccProfilingOn dflags) + if not (sccProfilingEnabled dflags) then return Nothing else do local_cc <- newTemp (ccType platform) emitAssign (CmmLocal local_cc) cccsExpr @@ -195,7 +195,7 @@ enterCostCentreFun ccs closure = ifProfiling :: FCode () -> FCode () ifProfiling code = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags + if sccProfilingEnabled dflags then code else return () @@ -207,7 +207,7 @@ initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs) = do dflags <- getDynFlags - when (gopt Opt_SccProfilingOn dflags) $ + when (sccProfilingEnabled dflags) $ do mapM_ emitCostCentreDecl local_CCs mapM_ emitCostCentreStackDecl singleton_CCSs @@ -277,7 +277,7 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push = do dflags <- getDynFlags platform <- getPlatform - if not (gopt Opt_SccProfilingOn dflags) + if not (sccProfilingEnabled dflags) then return () else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc |