[project @ 1999-11-29 12:02:42 by keithw]

This commit adds the new RTS option `-xc', which prints the current
cost-centre stack to stderr whenever an exception is raised.  This is
intended to be a debugging tool, to help trace those "Prelude.head:
empty list" errors that are so frustrating to find.

`-xc' is only available for programs compiled with -prof, and you
probably want -auto as well to get useful information.

This is currently experimental; it would be better if it only
displayed the info for *uncaught* exceptions, but this is harder to
implement.

This commit also makes an OFTEL-inspired extension to the RTS option
space.  Since we've almost run out of options, `-x' is now reserved
for `extended' options.  `-xc' is the first of these, but that leaves
'-x[0-9A-Zabd-wyz]' still to be used!  The prefix `-xx' is reserved
for future extension.

diff --git a/ghc/docs/users_guide/runtime_control.vsgml b/ghc/docs/users_guide/runtime_control.vsgml
index 464483a..04caf42 100644 (file)
--- a/ghc/docs/users_guide/runtime_control.vsgml
+++ b/ghc/docs/users_guide/runtime_control.vsgml
@@ -255,6 +255,15 @@ on how to set things up for easy ``ticky-ticky'' profiling.  For more
 information, see Section <ref name="Using ``ticky-ticky'' profiling
 (for implementors)" id="ticky-ticky">.
 
+<tag>@-xc@:</tag>
+<nidx>-xc RTS option</nidx>
+<nidx>cost centre display on exception</nidx>
+Display the current cost centre stack whenever an exception is
+raised.  The program must have been compiled with profiling turned on:
+see Section <ref name="Profiling" id="profiling">.  This feature is
+experimental; one day it will display the information only on
+<em>uncaught</em> exceptions.
+
 <tag>@-D<num>@:</tag>
 <nidx>-D RTS option</nidx>
 An RTS debugging flag; varying quantities of output depending on which

diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index eac04b1..5657bce 100644 (file)
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.20 1999/11/02 15:06:00 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.21 1999/11/29 12:02:44 keithw Exp $
  *
  * (c) The AQUA Project, Glasgow University, 1994-1997
  * (c) The GHC Team, 1998-1999
@@ -90,6 +90,7 @@ void initRtsFlagsDefaults(void)
 
 #ifdef PROFILING
     RtsFlags.ProfFlags.doHeapProfile = rtsFalse;
+    RtsFlags.ProfFlags.showCCSOnException = rtsFalse;
 
     RtsFlags.ProfFlags.ccSelector    = NULL;
     RtsFlags.ProfFlags.modSelector   = NULL;
@@ -244,6 +245,8 @@ usage_text[] = {
 "  The selection logic used is summarised as follows:",
 "    ([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a]",
 "    where an option is true if not specified",
+"",
+"  -xc      Show current cost centre stack on raising an exception",
 # endif
 "",
 "  -z<tbl><size>  set hash table <size> for <tbl> (C, M, G, D or Y)",
@@ -363,6 +366,7 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
                 TICKY-only (same order as defined in RtsFlags.lh);
                 within those groups, mostly in case-insensitive
                 alphabetical order.
+                 Final group is x*, which allows for more options.
              */
 
 #ifdef TICKY_TICKY
@@ -804,6 +808,29 @@ error = rtsTrue;
                if (RtsFlags.TickyFlags.tickyFile == NULL) error = rtsTrue;
                ) break;
 
+             /* =========== EXTENDED OPTIONS =================== */
+
+              case 'x': /* Extend the argument space */
+                switch(rts_argv[arg][2]) {
+                  case '\0':
+                   fprintf(stderr, "setupRtsFlags: Incomplete RTS option: %s\n",rts_argv[arg]);
+                   error = rtsTrue;
+                   break;
+
+                  case 'c': /* Debugging tool: show current cost centre on an exception */
+                    PROFILING_BUILD_ONLY(
+                    RtsFlags.ProfFlags.showCCSOnException = rtsTrue;
+                    ) break;
+
+                  /* The option prefix '-xx' is reserved for future extension.  KSW 1999-11. */
+
+                 default:
+                   fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n",rts_argv[arg]);
+                   error = rtsTrue;
+                   break;
+                }
+                break;  /* defensive programming */
+
              /* =========== OH DEAR ============================ */
              default:
                fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n",rts_argv[arg]);

diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index 4e2443b..442db37 100644 (file)
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.17 1999/11/02 15:06:00 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.18 1999/11/29 12:02:45 keithw Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -93,6 +93,8 @@ struct PROFILING_FLAGS {
 # define HEAP_BY_DESCR         4
 # define HEAP_BY_TYPE          5
 # define HEAP_BY_TIME          6
+
+    rtsBool            showCCSOnException;
   
 # define CCchar    'C'
 # define MODchar   'M'

diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc
index 6f01fc8..c10b822 100644 (file)
--- a/ghc/rts/Updates.hc
+++ b/ghc/rts/Updates.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.22 1999/11/12 10:18:59 simonmar Exp $
+ * $Id: Updates.hc,v 1.23 1999/11/29 12:02:46 keithw Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -625,6 +625,19 @@ FN_(raisezh_fast)
   FB_
     /* args : R1 = error */
 
+#if defined(PROFILING)
+
+    /* Debugging tool: on raising an  exception, show where we are. */
+
+    /* ToDo: currently this is a hack.  Would be much better if
+     * the info was only displayed for an *uncaught* exception.
+     */
+    if (RtsFlags.ProfFlags.showCCSOnException) {
+      STGCALL2(print_ccs,stderr,CCCS);
+    }
+
+#endif
+
     p = Su;
 
     /* This closure represents the expression 'raise# E' where E