summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/codeGen/StgCmmBind.hs13
-rw-r--r--compiler/codeGen/StgCmmProf.hs3
-rw-r--r--compiler/codeGen/StgCmmTicky.hs62
3 files changed, 54 insertions, 24 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index f34186a8ac..eae599ca6c 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
@@ -576,8 +578,7 @@ thunkCode cl_info fv_details _cc node arity body
-- that cc of enclosing scope will be recorded
-- in update frame CAF/DICT functions will be
-- subsumed by this enclosing cc
- do { tickyEnterThunk cl_info
- ; enterCostCentreThunk (CmmReg nodeReg)
+ do { enterCostCentreThunk (CmmReg nodeReg)
; let lf_info = closureLFInfo cl_info
; fv_bindings <- mapM bind_fv fv_details
; load_fvs node lf_info fv_bindings
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index c1b149dba2..434d7b50de 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -328,8 +328,7 @@ ldvRecordCreate closure = do
--
-- | Called when a closure is entered, marks the closure as having
-- been "used". The closure is not an "inherently used" one. The
--- closure is not @IND@ or @IND_OLDGEN@ because neither is considered
--- for LDV profiling.
+-- closure is not @IND@ because that is not considered for LDV profiling.
--
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure closure_info node_reg = do
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 95dfa99389..0ffe6a3ca4 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -70,6 +70,7 @@ module StgCmmTicky (
withNewTickyCounterLNE,
withNewTickyCounterThunk,
withNewTickyCounterStdThunk,
+ withNewTickyCounterCon,
tickyDynAlloc,
tickyAllocHeap,
@@ -143,7 +144,13 @@ import Control.Monad ( unless, when )
--
-----------------------------------------------------------------------------
-data TickyClosureType = TickyFun | TickyThunk | TickyLNE
+data TickyClosureType
+ = TickyFun
+ | 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
@@ -152,15 +159,38 @@ 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 +214,21 @@ emitTickyCounter cloType name args
; let ppr_for_ticky_name :: SDoc
ppr_for_ticky_name =
let n = ppr name
+ ext = case cloType of
+ TickyFun -> empty
+ 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
View Lorry Controller Status