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, 24 insertions, 54 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index eae599ca6c..f34186a8ac 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -206,7 +206,7 @@ cgRhs :: Id
)
cgRhs id (StgRhsCon cc con args)
- = withNewTickyCounterCon (idName id) $
+ = withNewTickyCounterThunk False (idName id) $ -- False for "not static"
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 (lfUpdatable lf_info) (idName bndr) $
+ = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static"
do
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
@@ -402,6 +402,7 @@ 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
@@ -452,10 +453,7 @@ 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)
- (closureUpdReqd cl_info)
- (closureName cl_info) $
+ = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $
emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
\(_, node, _) -> thunkCode cl_info fv_details cc node arity body
where
@@ -578,7 +576,8 @@ 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 { enterCostCentreThunk (CmmReg nodeReg)
+ do { tickyEnterThunk cl_info
+ ; 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 434d7b50de..c1b149dba2 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -328,7 +328,8 @@ 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@ because that is not considered for LDV profiling.
+-- closure is not @IND@ or @IND_OLDGEN@ because neither is 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 0ffe6a3ca4..95dfa99389 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -70,7 +70,6 @@ module StgCmmTicky (
withNewTickyCounterLNE,
withNewTickyCounterThunk,
withNewTickyCounterStdThunk,
- withNewTickyCounterCon,
tickyDynAlloc,
tickyAllocHeap,
@@ -144,13 +143,7 @@ import Control.Monad ( unless, when )
--
-----------------------------------------------------------------------------
-data TickyClosureType
- = TickyFun
- | TickyCon
- | TickyThunk
- Bool -- True <-> updateable
- Bool -- True <-> standard thunk (AP or selector), has no entry counter
- | TickyLNE
+data TickyClosureType = TickyFun | TickyThunk | TickyLNE
withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun = withNewTickyCounter TickyFun
@@ -159,38 +152,15 @@ withNewTickyCounterLNE nm args code = do
b <- tickyLNEIsOn
if not b then code else withNewTickyCounter TickyLNE nm args code
-withNewTickyCounterThunk
- :: Bool -- ^ static
- -> Bool -- ^ updateable
- -> Name
- -> FCode a
- -> FCode a
-withNewTickyCounterThunk isStatic isUpdatable name code = do
+withNewTickyCounterThunk,withNewTickyCounterStdThunk ::
+ Bool -> Name -> FCode a -> FCode a
+withNewTickyCounterThunk isStatic name code = do
b <- tickyDynThunkIsOn
if isStatic || not b -- ignore static thunks
then 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
+ else withNewTickyCounter TickyThunk name [] code
-withNewTickyCounterCon
- :: Name
- -> FCode a
- -> FCode a
-withNewTickyCounterCon name code = do
- b <- tickyDynThunkIsOn
- if not b
- then code
- else withNewTickyCounter TickyCon name [] code
+withNewTickyCounterStdThunk = withNewTickyCounterThunk
-- args does not include the void arguments
withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
@@ -214,21 +184,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 if isInternalName name
- then n <+> parens (ppr mod_name) <+> ext <+> p
- else n <+> ext <+> p
+ 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?"
; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args
View Lorry Controller Status