Fix cost-centre-stack bug when creating new PAP (#5654)

See comment in `AutoApply.h`.  This partly fixes #5654.  New test
added, and renamed the old test to match the ticket number.

8 files changed, 116 insertions, 11 deletions

diff --git a/rts/AutoApply.h b/rts/AutoApply.h
index 74af74b5d3..7c8af93942 100644
--- a/rts/AutoApply.h
+++ b/rts/AutoApply.h
@@ -37,6 +37,17 @@
     Sp_adj(1 + n);                                      \
     jump %ENTRY_CODE(Sp(0)) [R1];
 
+// Just like when we enter a PAP, if we're building a new PAP by applying more
+// arguments to an existing PAP, we must construct the CCS for the new PAP as if
+// we had entered the existing PAP from the current CCS.  Otherwise, we lose any
+// stack information in the existing PAP.  See #5654, and the test T5654b-O0.
+#ifdef PROFILING
+#define ENTER_FUN_CCS_NEW_PAP(pap) \
+  ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(pap) "ptr");
+#else
+#define ENTER_FUN_CCS_NEW_PAP(pap) /* empty */
+#endif
+
 // Copy the old PAP, build a new one with the extra arg(s)
 // ret addr and m arguments taking up n words are on the stack.
 // NB. x is a dummy argument attached to the 'for' label so that
@@ -51,6 +62,7 @@
      HP_CHK_NP_ASSIGN_SP0(size,f);                              \
      TICK_ALLOC_PAP(size, 0);                                   \
      CCCS_ALLOC(size);                                          \
+     ENTER_FUN_CCS_NEW_PAP(pap);                                \
      new_pap = Hp + WDS(1) - size;                              \
      SET_HDR(new_pap, stg_PAP_info, CCCS);                      \
      StgPAP_arity(new_pap) = HALF_W_(arity - m);                \
diff --git a/testsuite/tests/profiling/should_run/T5654.hs b/testsuite/tests/profiling/should_run/T5654.hs
new file mode 100644
index 0000000000..d7f83bf9fa
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T5654.hs
@@ -0,0 +1,14 @@
+-- Tests for a bug in the handling of cost-centre stacks in the
+-- runtime, where we lose the current cost-centre stack when
+-- evaluating a function.
+
+{-# NOINLINE f #-}
+f :: Int -> Int
+f = g   -- here we should remember the stack under which g was evaluated
+
+{-# NOINLINE g #-}
+g :: Int -> Int
+g x = x + 1
+
+main =  return $! f 3
+
diff --git a/testsuite/tests/profiling/should_run/scc004.prof.sample b/testsuite/tests/profiling/should_run/T5654.prof.sample
index 7d12acdaab..7d12acdaab 100644
--- a/testsuite/tests/profiling/should_run/scc004.prof.sample
+++ b/testsuite/tests/profiling/should_run/T5654.prof.sample
diff --git a/testsuite/tests/profiling/should_run/T5654b-O0.prof.sample b/testsuite/tests/profiling/should_run/T5654b-O0.prof.sample
new file mode 100644
index 0000000000..f98fcf0cbf
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T5654b-O0.prof.sample
@@ -0,0 +1,29 @@
+	Wed Jan 27 08:16 2016 Time and Allocation Profiling Report  (Final)
+
+	   T5654b-O0 +RTS -p -RTS
+
+	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
+	total alloc =      39,248 bytes  (excludes profiling overheads)
+
+COST CENTRE MODULE            %time %alloc
+
+CAF         GHC.IO.Handle.FD    0.0   88.0
+CAF         GHC.IO.Encoding     0.0    7.3
+CAF         GHC.Conc.Signal     0.0    1.7
+
+
+                                                     individual      inherited
+COST CENTRE MODULE                no.     entries  %time %alloc   %time %alloc
+
+MAIN        MAIN                  105           0    0.0    0.9     0.0  100.0
+ CAF        Main                  209           0    0.0    0.9     0.0    1.5
+  g         Main                  212           1    0.0    0.1     0.0    0.1
+  f         Main                  211           1    0.0    0.1     0.0    0.1
+  main      Main                  210           1    0.0    0.2     0.0    0.4
+   f        Main                  214           0    0.0    0.0     0.0    0.2
+    g       Main                  215           0    0.0    0.0     0.0    0.2
+     h      Main                  216           1    0.0    0.2     0.0    0.2
+ CAF        GHC.Conc.Signal       203           0    0.0    1.7     0.0    1.7
+ CAF        GHC.IO.Encoding       193           0    0.0    7.3     0.0    7.3
+ CAF        GHC.IO.Encoding.Iconv 191           0    0.0    0.6     0.0    0.6
+ CAF        GHC.IO.Handle.FD      183           0    0.0   88.0     0.0   88.0
diff --git a/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample b/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample
new file mode 100644
index 0000000000..317e492dbd
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample
@@ -0,0 +1,28 @@
+	Wed Jan 27 08:16 2016 Time and Allocation Profiling Report  (Final)
+
+	   T5654b-O1 +RTS -p -RTS
+
+	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
+	total alloc =      39,016 bytes  (excludes profiling overheads)
+
+COST CENTRE MODULE            %time %alloc
+
+MAIN        MAIN                0.0    1.7
+CAF         GHC.IO.Handle.FD    0.0   88.5
+CAF         GHC.IO.Encoding     0.0    7.4
+CAF         GHC.Conc.Signal     0.0    1.7
+
+
+                                                     individual      inherited
+COST CENTRE MODULE                no.     entries  %time %alloc   %time %alloc
+
+MAIN        MAIN                  105           0    0.0    1.7     0.0  100.0
+ CAF        Main                  209           0    0.0    0.0     0.0    0.1
+  main      Main                  210           1    0.0    0.1     0.0    0.1
+   f        Main                  211           1    0.0    0.0     0.0    0.0
+    g       Main                  212           1    0.0    0.0     0.0    0.0
+     h      Main                  213           1    0.0    0.0     0.0    0.0
+ CAF        GHC.Conc.Signal       203           0    0.0    1.7     0.0    1.7
+ CAF        GHC.IO.Encoding       193           0    0.0    7.4     0.0    7.4
+ CAF        GHC.IO.Encoding.Iconv 191           0    0.0    0.6     0.0    0.6
+ CAF        GHC.IO.Handle.FD      183           0    0.0   88.5     0.0   88.5
diff --git a/testsuite/tests/profiling/should_run/T5654b.hs b/testsuite/tests/profiling/should_run/T5654b.hs
new file mode 100644
index 0000000000..2a00abf912
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T5654b.hs
@@ -0,0 +1,22 @@
+-- A variant of T5654 where instead of evaluating directly to a
+-- funciton, f evaluates to a new PAP.  This exposes a slightly
+-- different but related bug, where when we create a new PAP by
+-- applying arguments to an existing PAP, we should take into account
+-- the stack on the original PAP.
+
+-- The stack we should see is main->f->g->h, but if we get this wrong
+-- (GHC 7.10) then the stack is main->f->h.
+
+{-# NOINLINE f #-}
+f :: Int -> Int
+f = g 3
+
+{-# NOINLINE g #-}
+g :: Int -> Int -> Int
+g = h 4
+
+{-# NOINLINE h #-}
+h :: Int -> Int -> Int -> Int
+h x y z = x + y + z
+
+main =  return $! f 5
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 52bd62c16b..891303e5d7 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -47,12 +47,22 @@ test('scc003', [req_profiling,
      compile_and_run,
      ['-fno-state-hack']) # Note [consistent stacks]
 
-test('scc004', [req_profiling,
+test('T5654', [req_profiling,
                 extra_ways(['prof']), only_ways(prof_ways),
                 expect_broken(5654)],
      compile_and_run,
      [''])
 
+test('T5654b-O0', [req_profiling,
+                extra_ways(['prof']), only_ways(['prof'])],
+     compile_and_run,
+     [''])
+
+test('T5654b-O1', [req_profiling,
+                only_ways(['profasm'])],
+     compile_and_run,
+     [''])
+
 test('scc005', [req_profiling,
                 extra_ways(['prof']), only_ways(prof_ways)],
      compile_and_run,
diff --git a/testsuite/tests/profiling/should_run/scc004.hs b/testsuite/tests/profiling/should_run/scc004.hs
deleted file mode 100644
index bdb73d83ab..0000000000
--- a/testsuite/tests/profiling/should_run/scc004.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# NOINLINE f #-}
-f :: Int -> Int
-f = {-# SCC f #-} g
-
-{-# NOINLINE g #-}
-g :: Int -> Int
-g x = {-# SCC g #-} x + 1
-
-main = {-# SCC main #-} return $! f 3
-