Various ticky-related work
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 23 Mar 2016 15:20:36 +0000 (16:20 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 24 Mar 2016 09:53:27 +0000 (10:53 +0100)
this Diff contains small, self-contained changes as I work towards
fixing #10613. It is mostly created to let harbormaster do its job, but
feedback is welcome as well.

Please do not merge this via arc; I’d like to push the individual
patches as layed out here. I might push mostly trivial ones even without
review, as long as the build passes.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2014

compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
rts/sm/Scav.c

index f34186a..eae599c 100644 (file)
@@ -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
index c1b149d..434d7b5 100644 (file)
@@ -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
index 95dfa99..0ffe6a3 100644 (file)
@@ -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
index 953f055..abb7726 100644 (file)
@@ -1533,7 +1533,7 @@ scavenge_one(StgPtr p)
         } else {
           size = gen->scan - start;
         }
-        debugBelch("evac IND_OLDGEN: %ld bytes", size * sizeof(W_));
+        debugBelch("evac IND: %ld bytes", size * sizeof(W_));
       }
 #endif
       break;