+RTS -xc: print a the closure type of the exception too

4 files changed, 27 insertions, 5 deletions

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 9f48f5d8f5..586086ebf3 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -427,7 +427,9 @@ stg_raisezh
      */
     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
         SAVE_THREAD_STATE();
-        foreign "C" fprintCCS_stderr(W_[CCCS] "ptr", CurrentTSO "ptr") [];
+        foreign "C" fprintCCS_stderr(W_[CCCS] "ptr",
+                                     exception "ptr",
+                                     CurrentTSO "ptr") [];
         LOAD_THREAD_STATE();
     }
 #endif
diff --git a/rts/Profiling.c b/rts/Profiling.c
index c75a344c7f..38191ff4bd 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -17,6 +17,7 @@
 #include "ProfHeap.h"
 #include "Arena.h"
 #include "RetainerProfile.h"
+#include "Printer.h"
 
 #include <string.h>
 
@@ -1001,7 +1002,7 @@ static rtsBool fprintCallStack (CostCentreStack *ccs)
 
 /* For calling from .cmm code, where we can't reliably refer to stderr */
 void
-fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso)
+fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso)
 {
     rtsBool is_caf;
     StgPtr frame;
@@ -1010,7 +1011,26 @@ fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso)
     nat depth = 0;
     const nat MAX_DEPTH = 10; // don't print gigantic chains of stacks
 
-    fprintf(stderr, "*** Exception raised (reporting due to +RTS -xc), stack trace:\n  ");
+    {
+        char *desc;
+        StgInfoTable *info;
+        info = get_itbl(exception);
+        switch (info->type) {
+        case CONSTR:
+        case CONSTR_1_0:
+        case CONSTR_0_1:
+        case CONSTR_2_0:
+        case CONSTR_1_1:
+        case CONSTR_0_2:
+        case CONSTR_STATIC:
+        case CONSTR_NOCAF_STATIC:
+            desc = GET_CON_DESC(itbl_to_con_itbl(info));
+        default:
+            desc = closure_type_names[info->type];
+        }
+        fprintf(stderr, "*** Exception (reporting due to +RTS -xc): (%s), stack trace: \n  ", desc);
+    }
+
     is_caf = fprintCallStack(ccs);
 
     // traverse the stack down to the enclosing update frame to
diff --git a/rts/Profiling.h b/rts/Profiling.h
index 2ee3311c81..8c365220fb 100644
--- a/rts/Profiling.h
+++ b/rts/Profiling.h
@@ -35,7 +35,7 @@ void reportCCSProfiling ( void );
 void PrintNewStackDecls ( void );
 
 void fprintCCS( FILE *f, CostCentreStack *ccs );
-void fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso);
+void fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso);
 
 #ifdef DEBUG
 void debugCCS( CostCentreStack *ccs );
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index acc87b1938..c7b10b856e 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -739,7 +739,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
      */
     if (RtsFlags.ProfFlags.showCCSOnException)
     {
-        fprintCCS_stderr(tso->prof.CCCS,tso);
+        fprintCCS_stderr(tso->prof.CCCS,exception,tso);
     }
 #endif
     // ASSUMES: the thread is not already complete or dead