diff options
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 15 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 49 | ||||
| -rw-r--r-- | 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 |