FIX biographical profiling (#3039, probably #2297)

Since we introduced pointer tagging, we no longer always enter a
closure to evaluate it.  However, the biographical profiler relies on
closures being entered in order to mark them as "used", so we were
getting spurious amounts of data attributed to VOID.  It turns out
there are various places that need to be fixed, and I think at least
one of them was also wrong before pointer tagging (CgCon.cgReturnDataCon).

diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index a700ccd..0fb90b0 100644 (file)
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -47,6 +47,9 @@ import Outputable
 import ListSetOps
 import Util
 import FastString
+import StaticFlags
+
+import Control.Monad
 \end{code}
 
 
@@ -296,6 +299,11 @@ sure the @amodes@ passed don't conflict with each other.
 cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
 
 cgReturnDataCon con amodes
+  | isUnboxedTupleCon con = returnUnboxedTuple amodes
+      -- when profiling we can't shortcut here, we have to enter the closure
+      -- for it to be marked as "used" for LDV profiling.
+  | opt_SccProfilingOn    = build_it_then enter_it
+  | otherwise
   = ASSERT( amodes `lengthIs` dataConRepArity con )
     do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
        ; case sequel of
@@ -319,11 +327,12 @@ cgReturnDataCon con amodes
                        | isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
                        | otherwise         -> build_it_then (jump_to deflt_lbl) }
     
-           _   -- The usual case
-             | isUnboxedTupleCon con -> returnUnboxedTuple amodes
-              | otherwise -> build_it_then emitReturnInstr
+           _otherwise  -- The usual case
+              -> build_it_then emitReturnInstr
        }
   where
+    enter_it    = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
+                           CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg))) [] ]
     jump_to lbl = stmtC (CmmJump (CmmLit lbl) [])
     build_it_then return_code
       = do {   -- BUILD THE OBJECT IN THE HEAP

diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index e4f79a7..60a8561 100644 (file)
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -35,6 +35,7 @@ import Id
 import StgSyn
 import PrimOp
 import Outputable
+import StaticFlags
 
 import Control.Monad
 
@@ -183,7 +184,10 @@ performTailCall fun_info arg_amodes pending_assts
     untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
     -- Test if closure is a constructor
     maybeSwitchOnCons enterClosure eob
-              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob
+              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
+                not opt_SccProfilingOn
+                -- we can't shortcut when profiling is on, because we have
+                -- to enter a closure to mark it as "used" for LDV profiling
               = do { is_constr <- newLabelC
                    -- Is the pointer tagged?
                    -- Yes, jump to switch statement

diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 9598233..8c36ab2 100644 (file)
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -598,6 +598,10 @@ getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
 getCallMethod _ _ _ (LFCon con) n_args
+  | opt_SccProfilingOn     -- when profiling, we must always enter
+  = EnterIt                -- a closure when we use it, so that the closure
+                           -- can be recorded as used for LDV profiling.
+  | otherwise
   = ASSERT( n_args == 0 )
     ReturnCon con
 

diff --git a/includes/Cmm.h b/includes/Cmm.h
index 06a66a7..da0a2ac 100644 (file)
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -252,13 +252,34 @@
    Indirections can contain tagged pointers, so their tag is checked.
    -------------------------------------------------------------------------- */
 
+#ifdef PROFILING
+
+// When profiling, we cannot shortcut ENTER() by checking the tag,
+// because LDV profiling relies on entering closures to mark them as
+// "used".
+
+#define LOAD_INFO \
+    info = %INFO_PTR(UNTAG(P1));
+
+#define UNTAG_R1 \
+    P1 = UNTAG(P1);
+
+#else
+
+#define LOAD_INFO                               \
+  if (GETTAG(P1) != 0) {                        \
+      jump %ENTRY_CODE(Sp(0));                  \
+  }                                             \
+  info = %INFO_PTR(P1);
+
+#define UNTAG_R1 /* nothing */
+
+#endif
+
 #define ENTER()                                                \
  again:                                                        \
   W_ info;                                             \
-  if (GETTAG(P1) != 0) {                                \
-      jump %ENTRY_CODE(Sp(0));                         \
-  }                                                     \
-  info = %INFO_PTR(P1);                                        \
+  LOAD_INFO                                             \
   switch [INVALID_OBJECT .. N_CLOSURE_TYPES]           \
          (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {      \
   case                                                 \
@@ -285,6 +306,7 @@
    }                                                   \
   default:                                             \
    {                                                   \
+      UNTAG_R1                                          \
       jump %ENTRY_CODE(info);                          \
    }                                                   \
   }

diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm
index fecbb4c..be85999 100644 (file)
--- a/rts/StgStdThunks.cmm
+++ b/rts/StgStdThunks.cmm
@@ -52,7 +52,22 @@
  * so we untag it before accessing the field.
  *
  */
-#define SELECTOR_CODE_UPD(offset) \
+#ifdef PROFILING
+// When profiling, we cannot shortcut by checking the tag,
+// because LDV profiling relies on entering closures to mark them as
+// "used".
+#define SEL_ENTER(offset)                       \
+      R1 = UNTAG(R1);                           \
+      jump %GET_ENTRY(R1);
+#else
+#define SEL_ENTER(offset)                               \
+      if (GETTAG(R1) != 0) {                            \
+          jump RET_LBL(stg_sel_ret_##offset##_upd);     \
+      }                                                 \
+      jump %GET_ENTRY(R1);
+#endif
+
+#define SELECTOR_CODE_UPD(offset)                                       \
   INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_SMALL, RET_PARAMS)    \
   {                                                                    \
       R1 = StgClosure_payload(UNTAG(R1),offset);                       \
@@ -73,10 +88,7 @@
       W_[Sp-WITHUPD_FRAME_SIZE] = stg_sel_ret_##offset##_upd_info;     \
       Sp = Sp - WITHUPD_FRAME_SIZE;                                    \
       R1 = StgThunk_payload(R1,0);                                     \
-      if (GETTAG(R1) != 0) {                                            \
-          jump RET_LBL(stg_sel_ret_##offset##_upd);                    \
-      }                                                                 \
-      jump %GET_ENTRY(R1);                                             \
+      SEL_ENTER(offset);                                                \
   }
   /* NOTE: no need to ENTER() here, we know the closure cannot evaluate to a function,
      because we're going to do a field selection on the result. */