compiler/CodeGen.Platform.h

@@ -566,6 +566,9 @@ callerSaves Hp                = True
 #if defined(CALLER_SAVES_HpLim)
 callerSaves HpLim             = True
 #endif
+#if defined(CALLER_SAVES_ProfStatus)
+callerSaves ProfStatus        = True
+#endif
 #if defined(CALLER_SAVES_CCCS)
 callerSaves CCCS              = True
 #endif

compiler/GHC/Cmm/Expr.hs

@@ -11,7 +11,7 @@ module GHC.Cmm.Expr
     , GlobalReg(..), isArgReg, globalRegSpillType
     , GlobalRegUse(..)
     , spReg, hpReg, spLimReg, hpLimReg, nodeReg
-    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg, profStatusReg
     , node, baseReg
 
     , DefinerOfRegs, UserOfRegs

compiler/GHC/Cmm/Reg.hs

@@ -13,7 +13,7 @@ module GHC.Cmm.Reg
       -- * Global registers
     , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg
     , spReg, hpReg, spLimReg, hpLimReg, nodeReg
-    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg, profStatusReg
     , node, baseReg
     , GlobalRegUse(..), pprGlobalRegUse
     ) where
@@ -217,6 +217,7 @@ data GlobalReg
   | Hp                  -- Heap ptr; points to last occupied heap location.
   | HpLim               -- Heap limit register
   | CCCS                -- Current cost-centre stack
+  | ProfStatus          -- Profiling status
   | CurrentTSO          -- pointer to current thread's TSO
   | CurrentNursery      -- pointer to allocation area
   | HpAlloc             -- allocation count for heap check failure
@@ -289,7 +290,7 @@ pprGlobalReg gr
 
 -- convenient aliases
 baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
-  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg
+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg, profStatusReg :: Platform -> CmmReg
 baseReg           p = CmmGlobal (GlobalRegUse BaseReg        $ bWord p)
 spReg             p = CmmGlobal (GlobalRegUse Sp             $ bWord p)
 hpReg             p = CmmGlobal (GlobalRegUse Hp             $ gcWord p)
@@ -300,6 +301,7 @@ currentTSOReg     p = CmmGlobal (GlobalRegUse CurrentTSO     $ bWord p)
 currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p)
 hpAllocReg        p = CmmGlobal (GlobalRegUse HpAlloc        $ bWord p)
 cccsReg           p = CmmGlobal (GlobalRegUse CCCS           $ bWord p)
+profStatusReg     p = CmmGlobal (GlobalRegUse ProfStatus     $ bWord p)
 
 node :: GlobalReg
 node = VanillaReg 1

compiler/GHC/Cmm/Utils.hs

@@ -42,7 +42,7 @@ module GHC.Cmm.Utils(
         cmmMkAssign,
 
         baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
-        currentTSOExpr, currentNurseryExpr, cccsExpr,
+        currentTSOExpr, currentNurseryExpr, cccsExpr, profStatusExpr,
 
         -- Tagging
         cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
@@ -592,7 +592,7 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
 -- Access to common global registers
 
 baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
-  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr
+  spLimExpr, hpLimExpr, cccsExpr, profStatusExpr :: Platform -> CmmExpr
 baseExpr           p = CmmReg $ baseReg           p
 spExpr             p = CmmReg $ spReg             p
 spLimExpr          p = CmmReg $ spLimReg          p
@@ -601,3 +601,5 @@ hpLimExpr          p = CmmReg $ hpLimReg          p
 currentTSOExpr     p = CmmReg $ currentTSOReg     p
 currentNurseryExpr p = CmmReg $ currentNurseryReg p
 cccsExpr           p = CmmReg $ cccsReg           p
+profStatusExpr     p = CmmReg $ profStatusReg     p
+

compiler/GHC/StgToCmm/CgUtils.hs

@@ -85,6 +85,7 @@ baseRegOffset platform reg = case reg of
    Hp                   -> pc_OFFSET_StgRegTable_rHp             constants
    HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants
    CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants
+   ProfStatus           -> pc_OFFSET_StgRegTable_rProfStatus     constants
    CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants
    CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants
    HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants

compiler/GHC/StgToCmm/Foreign.hs

@@ -30,7 +30,7 @@ import GHC.Platform
 import GHC.Platform.Profile
 
 import GHC.Stg.Syntax
-import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
+import GHC.StgToCmm.Prof (storeCurCCS, ccsType, storeCurProfStatus, profStatusType)
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Closure
@@ -332,6 +332,13 @@ saveThreadState profile = do
          then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile))
                       (cccsExpr platform)
          else mkNop
+
+    , -- and save the profiling status in the TSO when profiling:
+      if profileIsProfiling profile
+         then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_ProfStatus profile))
+                      (profStatusExpr platform)
+         else mkNop
+
     ]
 
 
@@ -505,6 +512,10 @@ loadThreadState profile = do
     if profileIsProfiling profile
        then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)
             in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned)
+       else mkNop,
+    if profileIsProfiling profile
+       then let prof_status_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_ProfStatus profile)
+            in storeCurProfStatus platform (CmmLoad prof_status_ptr (profStatusType platform) NaturallyAligned)
        else mkNop
    ]
 
@@ -604,10 +615,11 @@ nursery_bdescr_start  platform cn =
 nursery_bdescr_blocks platform cn =
   cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform))
 
-tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff
+tso_stackobj, tso_CCCS, tso_ProfStatus, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff
 tso_stackobj    profile = closureField profile (pc_OFFSET_StgTSO_stackobj    (profileConstants profile))
 tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile))
 tso_CCCS        profile = closureField profile (pc_OFFSET_StgTSO_cccs        (profileConstants profile))
+tso_ProfStatus  profile = closureField profile (pc_OFFSET_StgTSO_prof_status (profileConstants profile))
 stack_STACK     profile = closureField profile (pc_OFFSET_StgStack_stack     (profileConstants profile))
 stack_SP        profile = closureField profile (pc_OFFSET_StgStack_sp        (profileConstants profile))
 

compiler/GHC/StgToCmm/Prof.hs

@@ -7,7 +7,7 @@
 -----------------------------------------------------------------------------
 
 module GHC.StgToCmm.Prof (
-        initCostCentres, ccType, ccsType,
+        initCostCentres, ccType, ccsType, profStatusType,
         mkCCostCentre, mkCCostCentreStack,
 
         -- infoTablePRov
@@ -18,6 +18,7 @@ module GHC.StgToCmm.Prof (
         enterCostCentreThunk, enterCostCentreFun,
         costCentreFrom,
         storeCurCCS,
+        storeCurProfStatus,
         emitSetCCC,
 
         saveCurrentCostCentre, restoreCurrentCostCentre,
@@ -68,12 +69,18 @@ import GHC.Utils.Monad (whenM)
 ccsType :: Platform -> CmmType -- Type of a cost-centre stack
 ccsType = bWord
 
+profStatusType :: Platform -> CmmType -- Type of profiling status register
+profStatusType = bWord
+
 ccType :: Platform -> CmmType -- Type of a cost centre
 ccType = bWord
 
 storeCurCCS :: Platform -> CmmExpr -> CmmAGraph
 storeCurCCS platform = mkAssign (cccsReg platform)
 
+storeCurProfStatus :: Platform -> CmmExpr -> CmmAGraph
+storeCurProfStatus platform = mkAssign (profStatusReg platform)
+
 mkCCostCentre :: CostCentre -> CmmLit
 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
 

rts/Threads.c

@@ -117,6 +117,8 @@ createThread(Capability *cap, W_ size)
 
 #if defined(PROFILING)
     tso->prof.cccs = CCS_MAIN;
+    // XXX how do we init the prof_status value?
+    tso->prof.prof_status = 0;
 #endif
 
     // put a stop frame on the stack

rts/include/rts/storage/TSO.h

@@ -15,6 +15,7 @@
  */
 typedef struct {
   CostCentreStack *cccs;       /* thread's current CCS */
+  StgWord         prof_status; /* profiling status word */
 } StgTSOProfInfo;
 
 /*

rts/include/stg/Regs.h

@@ -104,6 +104,7 @@ typedef struct {
   StgPtr          rHp;
   StgPtr          rHpLim;
   struct CostCentreStack_ * rCCCS;  /* current cost-centre-stack */
+  StgWord         rProfStatus;
   struct StgTSO_ *     rCurrentTSO;
   struct nursery_ *    rNursery;
   struct bdescr_ *     rCurrentNursery; /* Hp/HpLim point into this block */
@@ -475,6 +476,12 @@ GLOBAL_REG_DECL(struct CostCentreStack_ *,CCCS,REG_CCCS)
 #define CCCS (BaseReg->rCCCS)
 #endif
 
+#if defined(REG_ProfStatus) && !defined(NO_GLOBAL_REG_DECLS)
+#error ProfStatus cannot be in a register
+#else
+#define CurrentTSO (BaseReg->rProfStatus)
+#endif
+
 #if defined(REG_CurrentTSO) && !defined(NO_GLOBAL_REG_DECLS)
 GLOBAL_REG_DECL(struct _StgTSO *,CurrentTSO,REG_CurrentTSO)
 #else