From 30b9061317ea7b834339d9458c46bd6b9108d947 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 17 Mar 2016 16:33:18 +0100 Subject: Be more explicit about closure types in ticky-ticky-report The report now distinguishes thunks (in the variants single-entry and standard thunks), constructors and functions (possibly single-entry). Forthermore, for standard thunks (AP and selector), do not count an entry when they are allocated. It is not possible to count their entries, as their code is shared, but better count nothing than count the wrong thing. --- compiler/codeGen/StgCmmBind.hs | 15 ++++++--- compiler/codeGen/StgCmmClosure.hs | 49 ++++++++++++++------------- compiler/codeGen/StgCmmTicky.hs | 69 +++++++++++++++++++++++++++++---------- 3 files changed, 88 insertions(+), 45 deletions(-) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index f34186a8ac..d5a3be98c5 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -206,7 +206,7 @@ cgRhs :: Id ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterThunk False (idName id) $ -- False for "not static" + = withNewTickyCounterCon (idName id) $ buildDynCon id True cc con args {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} @@ -386,7 +386,7 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static" + = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $ do { -- LAY OUT THE OBJECT mod_name <- getModuleName @@ -402,7 +402,6 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - ; tickyEnterStdThunk closure_info -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info @@ -453,7 +452,10 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details | arity == 0 -- No args i.e. thunk - = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $ + = withNewTickyCounterThunk + (isStaticClosure cl_info) + (closureUpdReqd cl_info) + (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -462,7 +464,10 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = -- Note: args may be [], if all args are Void - withNewTickyCounterFun (closureName cl_info) args $ do { + withNewTickyCounterFun + (closureSingleEntry cl_info) + (closureName cl_info) + args $ do { ; let lf_info = closureLFInfo cl_info diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 9b1545f2db..f9d0990576 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -110,9 +110,9 @@ type SelfLoopInfo = (Id, BlockId, [LocalReg]) -- used by ticky profiling isKnownFun :: LambdaFormInfo -> Bool -isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun LFLetNoEscape = True -isKnownFun _ = False +isKnownFun LFReEntrant{} = True +isKnownFun LFLetNoEscape = True +isKnownFun _ = False ----------------------------------------------------------------------------- @@ -148,6 +148,7 @@ argPrimRep arg = typePrimRep (stgArgType arg) data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level + OneShotInfo !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) @@ -228,8 +229,11 @@ mkLFReEntrant :: TopLevelFlag -- True of top level -> ArgDescr -- Argument descriptor -> LambdaFormInfo +mkLFReEntrant _ _ [] _ + = pprPanic "mkLFReEntrant" empty mkLFReEntrant top fvs args arg_descr - = LFReEntrant top (length args) (null fvs) arg_descr + = LFReEntrant top os_info (length args) (null fvs) arg_descr + where os_info = idOneShotInfo (head args) ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo @@ -278,7 +282,7 @@ mkLFImported id -- the id really does point directly to the constructor | arity > 0 - = LFReEntrant TopLevel arity True (panic "arg_descr") + = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr") | otherwise = mkLFArgument id -- Not sure of exact arity @@ -331,9 +335,9 @@ tagForArity dflags arity lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -359,11 +363,11 @@ isLFReEntrant _ = False ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) +lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" thunkClosureType :: StandardFormInfo -> ClosureTypeInfo thunkClosureType (SelectorThunk off) = ThunkSelector off @@ -383,7 +387,7 @@ nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument -nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) +nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _) = not no_fvs -- Certainly if it has fvs we need to point to it || isNotTopLevel top -- See Note [GC recovery] -- For lex_profiling we also access the cost centre for a @@ -518,7 +522,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc -- self-recursive tail calls] in StgCmmExpr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc +getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all @@ -654,7 +658,7 @@ staticClosureRequired -> LambdaFormInfo -> Bool staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _) -- It's a function + (LFReEntrant top_level _ _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding not (satCallsOnly bndr_info) @@ -760,7 +764,7 @@ blackHoleOnEntry cl_info | otherwise = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False + LFReEntrant {} -> False LFLetNoEscape -> False LFThunk _ _no_fvs upd _ _ -> upd -- See Note [Black-holing non-updatable thunks] _other -> panic "blackHoleOnEntry" @@ -844,18 +848,19 @@ lfUpdatable _ = False closureSingleEntry :: ClosureInfo -> Bool closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd +closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True closureSingleEntry _ = False closureReEntrant :: ClosureInfo -> Bool -closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True +closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True closureReEntrant _ = False closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing +lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing funTag :: DynFlags -> ClosureInfo -> DynTag funTag dflags (ClosureInfo { closureLFInfo = lf_info }) @@ -864,9 +869,9 @@ funTag dflags (ClosureInfo { closureLFInfo = lf_info }) isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of - LFReEntrant TopLevel _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _other -> False + LFReEntrant TopLevel _ _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + _other -> False -------------------------------------- -- Label generation diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 95dfa99389..d4f352c7d8 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -70,6 +70,7 @@ module StgCmmTicky ( withNewTickyCounterLNE, withNewTickyCounterThunk, withNewTickyCounterStdThunk, + withNewTickyCounterCon, tickyDynAlloc, tickyAllocHeap, @@ -143,24 +144,55 @@ import Control.Monad ( unless, when ) -- ----------------------------------------------------------------------------- -data TickyClosureType = TickyFun | TickyThunk | TickyLNE +data TickyClosureType + = TickyFun + Bool -- True <-> single entry + | TickyCon + | TickyThunk + Bool -- True <-> updateable + Bool -- True <-> standard thunk (AP or selector), has no entry counter + | TickyLNE -withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounterFun = withNewTickyCounter TickyFun +withNewTickyCounterFun :: Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry) +withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do b <- tickyLNEIsOn if not b then code else withNewTickyCounter TickyLNE nm args code -withNewTickyCounterThunk,withNewTickyCounterStdThunk :: - Bool -> Name -> FCode a -> FCode a -withNewTickyCounterThunk isStatic name code = do +withNewTickyCounterThunk + :: Bool -- ^ static + -> Bool -- ^ updateable + -> Name + -> FCode a + -> FCode a +withNewTickyCounterThunk isStatic isUpdatable name code = do b <- tickyDynThunkIsOn if isStatic || not b -- ignore static thunks then code - else withNewTickyCounter TickyThunk name [] code + else withNewTickyCounter (TickyThunk isUpdatable False) name [] code + +withNewTickyCounterStdThunk + :: Bool -- ^ updateable + -> Name + -> FCode a + -> FCode a +withNewTickyCounterStdThunk isUpdatable name code = do + b <- tickyDynThunkIsOn + if not b + then code + else withNewTickyCounter (TickyThunk isUpdatable True) name [] code -withNewTickyCounterStdThunk = withNewTickyCounterThunk +withNewTickyCounterCon + :: Name + -> FCode a + -> FCode a +withNewTickyCounterCon name code = do + b <- tickyDynThunkIsOn + if not b + then code + else withNewTickyCounter TickyCon name [] code -- args does not include the void arguments withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a @@ -184,21 +216,22 @@ emitTickyCounter cloType name args ; let ppr_for_ticky_name :: SDoc ppr_for_ticky_name = let n = ppr name + ext = case cloType of + TickyFun single_entry -> parens $ hcat $ punctuate comma $ + [text "fun"] ++ [text "se"|single_entry] + TickyCon -> parens (text "con") + TickyThunk upd std -> parens $ hcat $ punctuate comma $ + [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] + TickyLNE | isInternalName name -> parens (text "LNE") + | otherwise -> panic "emitTickyCounter: how is this an external LNE?" p = case hasHaskellName parent of -- NB the default "top" ticky ctr does not -- have a Haskell name Just pname -> text "in" <+> ppr (nameUnique pname) _ -> empty - in (<+> p) $ if isInternalName name - then let s = n <+> (parens (ppr mod_name)) - in case cloType of - TickyFun -> s - TickyThunk -> s <+> parens (text "thk") - TickyLNE -> s <+> parens (text "LNE") - else case cloType of - TickyFun -> n - TickyThunk -> n <+> parens (text "thk") - TickyLNE -> panic "emitTickyCounter: how is this an external LNE?" + in if isInternalName name + then n <+> parens (ppr mod_name) <+> ext <+> p + else n <+> ext <+> p ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args -- cgit v1.2.1