From: keithw Date: Mon, 29 Nov 1999 12:02:46 +0000 (+0000) Subject: [project @ 1999-11-29 12:02:42 by keithw] X-Git-Tag: Approximately_9120_patches~5475 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0ee487727b8410f7f9a35a212f06809c395fe70b;p=ghc-hetmet.git [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 --- 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 . +@-xc@: +-xc RTS option +cost centre display on exception +Display the current cost centre stack whenever an exception is +raised. The program must have been compiled with profiling turned on: +see Section . This feature is +experimental; one day it will display the information only on +uncaught exceptions. + @-D@: -D RTS option 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 --- 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 set hash table for (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 --- 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 --- 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