[commit: ghc] master: Fix a bug in the canned selector code when profiling. (83be3d7)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/83be3d7b8881eca63adf834e425e6799e572bd1f/ghc

>---------------------------------------------------------------

commit 83be3d7b8881eca63adf834e425e6799e572bd1f
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Fri Oct 11 10:35:14 2013 +0100

    Fix a bug in the canned selector code when profiling.


>---------------------------------------------------------------

83be3d7b8881eca63adf834e425e6799e572bd1f
 compiler/codeGen/StgCmm.hs |    7 ++++++-
 rts/StgStdThunks.cmm       |   22 +++++++++++++++-------
 2 files changed, 21 insertions(+), 8 deletions(-)

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index bf950c4..a92f804 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -233,7 +233,12 @@ cgDataCon data_con
                              $ mk_code ticky_code
 
             mk_code ticky_code
-              =         -- NB: We don't set CC when entering data (WDP 94/06)
+              = -- NB: the closure pointer is assumed *untagged* on
+                -- entry to a constructor.  If the pointer is tagged,
+                -- then we should not be entering it.  This assumption
+                -- is used in ldvEnter and when tagging the pointer to
+                -- return it.
+                -- NB 2: We don't set CC when entering data (WDP 94/06)
                 do { _ <- ticky_code
                    ; ldvEnter (CmmReg nodeReg)
                    ; tickyReturnOldCon (length arg_things)
diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm
index 979f749..ba15d3c 100644
--- a/rts/StgStdThunks.cmm
+++ b/rts/StgStdThunks.cmm
@@ -49,9 +49,15 @@
  *
  */
 #ifdef PROFILING
-// When profiling, we cannot shortcut by checking the tag,
-// because LDV profiling relies on entering closures to mark them as
-// "used".
+/* When profiling, we cannot shortcut by checking the tag,
+ * because LDV profiling relies on entering closures to mark them as
+ * "used".
+ *
+ * Note [untag for prof]: when we enter a closure, the convention is
+ * that the closure pointer passed in the first argument is
+ * *untagged*.  Without profiling we don't have to worry about this,
+ * because we never enter a tagged pointer.
+ */
 #define NEED_EVAL(__x__) 1
 #else
 #define NEED_EVAL(__x__) GETTAG(__x__) == 0
@@ -61,7 +67,7 @@
   INFO_TABLE_SELECTOR(stg_sel_##offset##_upd, offset, THUNK_SELECTOR, "stg_sel_upd", "stg_sel_upd") \
       (P_ node)                                                         \
   {                                                                     \
-      P_ selectee, field;                                               \
+      P_ selectee, field, dest;                                         \
       TICK_ENT_DYN_THK();                                               \
       STK_CHK_NP(node);                                                 \
       UPD_BH_UPDATABLE(node);                                           \
@@ -71,7 +77,8 @@
         ENTER_CCS_THUNK(node);                                          \
         if (NEED_EVAL(selectee)) {                                      \
           SAVE_CCS;                                                     \
-          (P_ constr) = call %GET_ENTRY(UNTAG_IF_PROF(selectee)) (selectee); \
+          dest = UNTAG_IF_PROF(selectee); /* Note [untag for prof] */   \
+          (P_ constr) = call %GET_ENTRY(dest) (dest);                   \
           RESTORE_CCS;                                                  \
           selectee = constr;                                            \
         }                                                               \
@@ -105,7 +112,7 @@ SELECTOR_CODE_UPD(15)
   INFO_TABLE_SELECTOR(stg_sel_##offset##_noupd, offset, THUNK_SELECTOR, "stg_sel_noupd", "stg_sel_noupd") \
       (P_ node)                                                         \
   {                                                                     \
-      P_ selectee, field;                                               \
+      P_ selectee, field, dest;                                         \
       TICK_ENT_DYN_THK();                                               \
       STK_CHK_NP(node);                                                 \
       UPD_BH_UPDATABLE(node);                                           \
@@ -114,7 +121,8 @@ SELECTOR_CODE_UPD(15)
       ENTER_CCS_THUNK(node);                                            \
       if (NEED_EVAL(selectee)) {                                        \
           SAVE_CCS;                                                     \
-          (P_ constr) = call %GET_ENTRY(UNTAG_IF_PROF(selectee)) (selectee);           \
+          dest = UNTAG_IF_PROF(selectee); /* Note [untag for prof] */   \
+          (P_ constr) = call %GET_ENTRY(dest) (dest);                   \
           RESTORE_CCS;                                                  \
           selectee = constr;                                            \
       }                                                                 \