Make GHCi & TH work when the compiler is built with -prof

Summary:
Amazingly, there were zero changes to the byte code generator and very
few changes to the interpreter - mainly because we've used good
abstractions that hide the differences between profiling and
non-profiling.  So that bit was pleasantly straightforward, but there
were a pile of other wibbles to get the whole test suite through.

Note that a compiler built with -prof is now like one built with
-dynamic, in that to use TH you have to build the code the same way.
For dynamic, we automatically enable -dynamic-too when TH is required,
but we don't have anything equivalent for profiling, so you have to
explicitly use -prof when building code that uses TH with a profiled
compiler.  For this reason Cabal won't work with TH.  We don't expect
to ship a profiled compiler, so I think that's OK.

Test Plan: validate with GhcProfiled=YES in validate.mk

Reviewers: goldfire, bgamari, rwbarton, austin, hvr, erikd, ezyang

Reviewed By: ezyang

Subscribers: thomie

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

GHC Trac Issues: #4837, #545

8 files changed, 67 insertions, 40 deletions

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 573e4991f7..3ad3bc6d5b 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -340,6 +340,8 @@ eval_obj:
             RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
         }
 
+        ENTER_CCS_THUNK(cap,ap);
+
         /* Ok; we're safe.  Party on.  Push an update frame. */
         Sp -= sizeofW(StgUpdateFrame);
         {
@@ -529,7 +531,7 @@ do_return_unboxed:
         // get the offset of the stg_ctoi_ret_XXX itbl
         offset = stack_frame_sizeW((StgClosure *)Sp);
 
-        switch (get_itbl((StgClosure *)Sp+offset)->type) {
+        switch (get_itbl((StgClosure*)((StgPtr)Sp+offset))->type) {
 
         case RET_BCO:
             // Returning to an interpreted continuation: put the object on
@@ -883,7 +885,7 @@ run_BCO:
                   // the BCO
                   size_words = BCO_BITMAP_SIZE(obj) + 2;
                   new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
-                  SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
+                  SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
                   new_aps->size = size_words;
                   new_aps->fun = &stg_dummy_ret_closure;
 
@@ -1098,7 +1100,7 @@ run_BCO:
             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
             Sp[-1] = (W_)ap;
             ap->n_args = n_payload;
-            SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1109,7 +1111,7 @@ run_BCO:
             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
             Sp[-1] = (W_)ap;
             ap->n_args = n_payload;
-            SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1122,7 +1124,7 @@ run_BCO:
             Sp[-1] = (W_)pap;
             pap->n_args = n_payload;
             pap->arity = arity;
-            SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1192,7 +1194,7 @@ run_BCO:
                                                itbl->layout.payload.nptrs );
             StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
             ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
-            SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
+            SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
             for (i = 0; i < n_words; i++) {
                 con->payload[i] = (StgClosure*)Sp[i];
             }
diff --git a/rts/Linker.c b/rts/Linker.c
index fb7653960b..0507c9c268 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -31,6 +31,7 @@
 #include "GetEnv.h"
 #include "Stable.h"
 #include "RtsSymbols.h"
+#include "Profiling.h"
 
 #if !defined(mingw32_HOST_OS)
 #include "posix/Signals.h"
@@ -1831,9 +1832,15 @@ static HsInt loadArchive_ (pathchar *path)
         IF_DEBUG(linker,
                  debugBelch("loadArchive: Found member file `%s'\n", fileName));
 
-        isObject = thisFileNameSize >= 2
-                && fileName[thisFileNameSize - 2] == '.'
-                && fileName[thisFileNameSize - 1] == 'o';
+        isObject =
+               (thisFileNameSize >= 2 &&
+                fileName[thisFileNameSize - 2] == '.' &&
+                fileName[thisFileNameSize - 1] == 'o')
+            || (thisFileNameSize >= 4 &&
+                fileName[thisFileNameSize - 4] == '.' &&
+                fileName[thisFileNameSize - 3] == 'p' &&
+                fileName[thisFileNameSize - 2] == '_' &&
+                fileName[thisFileNameSize - 1] == 'o');
 
         IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize));
         IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject));
@@ -2260,6 +2267,12 @@ static HsInt resolveObjs_ (void)
             oc->status = OBJECT_RESOLVED;
         }
     }
+
+#ifdef PROFILING
+    // collect any new cost centres & CCSs that were defined during runInit
+    initProfiling2();
+#endif
+
     IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
     return 1;
 }
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index f44519d4d3..7d0c661937 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1960,8 +1960,6 @@ stg_mkApUpd0zh ( P_ bco )
 
 stg_unpackClosurezh ( P_ closure )
 {
-// TODO: Consider the absence of ptrs or nonptrs as a special case ?
-
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
     info  = %GET_STD_INFO(UNTAG(closure));
 
diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index 0259a191eb..bfb8aaae2d 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -311,7 +311,7 @@ nextEra( void )
 FILE *hp_file;
 static char *hp_filename;
 
-void initProfiling1 (void)
+void initProfiling (void)
 {
 }
 
diff --git a/rts/Profiling.c b/rts/Profiling.c
index 23a48993fd..982b9461a0 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -142,8 +142,7 @@ static  void              initProfilingLogFile ( void );
    Initialise the profiling environment
    -------------------------------------------------------------------------- */
 
-void
-initProfiling1 (void)
+void initProfiling (void)
 {
     // initialise our arena
     prof_arena = newArena();
@@ -159,18 +158,6 @@ initProfiling1 (void)
 #ifdef THREADED_RTS
     initMutex(&ccs_mutex);
 #endif
-}
-
-void
-freeProfiling (void)
-{
-    arenaFree(prof_arena);
-}
-
-void
-initProfiling2 (void)
-{
-    CostCentreStack *ccs, *next;
 
     /* Set up the log file, and dump the header and cost centre
      * information into it.
@@ -205,14 +192,7 @@ initProfiling2 (void)
     CCS_MAIN->root = CCS_MAIN;
     ccsSetSelected(CCS_MAIN);
 
-    // make CCS_MAIN the parent of all the pre-defined CCSs.
-    for (ccs = CCS_LIST; ccs != NULL; ) {
-        next = ccs->prevStack;
-        ccs->prevStack = NULL;
-        actualPush_(CCS_MAIN,ccs->cc,ccs);
-        ccs->root = ccs;
-        ccs = next;
-    }
+    initProfiling2();
 
     if (RtsFlags.CcFlags.doCostCentres) {
         initTimeProfiling();
@@ -223,6 +203,29 @@ initProfiling2 (void)
     }
 }
 
+//
+// Should be called after loading any new Haskell code.
+//
+void initProfiling2 (void)
+{
+    CostCentreStack *ccs, *next;
+
+    // make CCS_MAIN the parent of all the pre-defined CCSs.
+    for (ccs = CCS_LIST; ccs != NULL; ) {
+        next = ccs->prevStack;
+        ccs->prevStack = NULL;
+        actualPush_(CCS_MAIN,ccs->cc,ccs);
+        ccs->root = ccs;
+        ccs = next;
+    }
+    CCS_LIST = NULL;
+}
+
+void
+freeProfiling (void)
+{
+    arenaFree(prof_arena);
+}
 
 static void
 initProfilingLogFile(void)
diff --git a/rts/Profiling.h b/rts/Profiling.h
index 8c365220fb..4158020596 100644
--- a/rts/Profiling.h
+++ b/rts/Profiling.h
@@ -20,7 +20,7 @@
 #define PROFILING_ONLY(s) doNothing()
 #endif
 
-void initProfiling1 (void);
+void initProfiling  (void);
 void initProfiling2 (void);
 void endProfiling   (void);
 void freeProfiling  (void);
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 584c31ef81..35e52aa36e 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -230,7 +230,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     initThreadLabelTable();
 #endif
 
-    initProfiling1();
+    initProfiling();
 
     /* start the virtual timer 'subsystem'. */
     initTimer();
@@ -255,10 +255,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
 
     startupHpc();
 
-    // This must be done after module initialisation.
-    // ToDo: make this work in the presence of multiple hs_add_root()s.
-    initProfiling2();
-
     // ditto.
 #if defined(THREADED_RTS)
     ioManagerStart();
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 569255094f..3a4355797e 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -641,10 +641,25 @@
       SymI_HasProto(stg_INTLIKE_closure)
 #endif
 
+#if defined(PROFILING)
+#define RTS_PROF_SYMBOLS                        \
+      SymI_HasProto(CCS_DONT_CARE)              \
+      SymI_HasProto(CC_LIST)                    \
+      SymI_HasProto(CC_ID)                      \
+      SymI_HasProto(CCS_LIST)                   \
+      SymI_HasProto(CCS_ID)                     \
+      SymI_HasProto(stg_restore_cccs_info)      \
+      SymI_HasProto(enterFunCCS)                \
+      SymI_HasProto(pushCostCentre)             \
+      SymI_HasProto(era)
+#else
+#define RTS_PROF_SYMBOLS /* empty */
+#endif
 
 #define RTS_SYMBOLS                                                     \
       Maybe_Stable_Names                                                \
       RTS_TICKY_SYMBOLS                                                 \
+      RTS_PROF_SYMBOLS                                                  \
       SymI_HasProto(StgReturn)                                          \
       SymI_HasProto(stg_gc_noregs)                                      \
       SymI_HasProto(stg_ret_v_info)                                     \