Author: jrieks
Date: Mon Apr 18 08:32:05 2005
New Revision: 7862
Modified:
trunk/classes/continuation.pmc
trunk/include/parrot/sub.h
trunk/include/parrot/warnings.h
trunk/src/debug.c
trunk/src/exceptions.c
trunk/src/sub.c
trunk/src/warnings.c
trunk/t/op/debuginfo.t
trunk/t/pmc/perlarray.t
trunk/t/pmc/perlundef.t
trunk/t/pmc/sub.t
Log:
- improved PDB_backtrace
- added recursion detection ("... call repeated X times")
- removed src/warnings.c:find_line, print_pbc_location_stdio
- refactored pbc location printing/formating code, it is now in:
- added Parrot_Context_info and Parrot_Context_infostr,
they encapuslate the "called from Sub '...' pc .. (file:line)"-logic
- show a backtrace if an exception was not caught (before parrot exits)
- if "debug 1" was executed, all (real_)exceptions are shown (including
a backtrace), even if an exception handler was installed
- adjusted tests to reflect changed output
Modified: trunk/classes/continuation.pmc
==============================================================================
--- trunk/classes/continuation.pmc (original)
+++ trunk/classes/continuation.pmc Mon Apr 18 08:32:05 2005
@@ -230,20 +230,7 @@
*/
STRING* get_string() {
- struct Parrot_cont * cc = PMC_cont(SELF);
- PMC *caller;
- STRING *s;
-
- caller = cc->ctx.current_sub;
- s = NULL;
- if (caller && PMC_sub(caller)->address) {
- size_t offs = cc->ctx.current_pc -
- PMC_sub(caller)->seg->base.data;
- s = Parrot_sprintf_c(INTERP,
- "called from Sub '%Ss' pc %d\n",
- Parrot_full_sub_name(INTERP, caller), (int)offs);
- }
- return s;
+ return Parrot_Context_infostr(INTERP, &PMC_cont(SELF)->ctx);
}
/*
Modified: trunk/include/parrot/sub.h
==============================================================================
--- trunk/include/parrot/sub.h (original)
+++ trunk/include/parrot/sub.h Mon Apr 18 08:32:05 2005
@@ -84,6 +84,16 @@
#define PMC_cont(pmc) LVALUE_CAST(parrot_cont_t, PMC_struct_val(pmc))
+struct Parrot_Context_info {
+ STRING* subname;
+ STRING* nsname;
+ STRING* fullname;
+ int pc;
+ const char *file;
+ int line;
+ opcode_t *address;
+};
+
struct Parrot_sub * new_sub(Interp * interp);
struct Parrot_sub * new_closure(Interp * interp);
struct Parrot_coro * new_coroutine(Interp * interp);
@@ -104,6 +114,8 @@
void add_to_retc_cache(Interp *interpreter, PMC *pmc);
void mark_retc_cache(Interp *);
STRING* Parrot_full_sub_name(Interp* interpreter, PMC* sub);
+int Parrot_Context_info(Interp *interpreter, struct Parrot_Context *, struct
Parrot_Context_info *);
+STRING* Parrot_Context_infostr(Interp *interpreter, struct Parrot_Context *);
#endif /* PARROT_SUB_H_GUARD */
Modified: trunk/include/parrot/warnings.h
==============================================================================
--- trunk/include/parrot/warnings.h (original)
+++ trunk/include/parrot/warnings.h Mon Apr 18 08:32:05 2005
@@ -46,7 +46,6 @@
#include "parrot/parrot.h"
void print_pbc_location(Parrot_Interp);
-void print_pbc_location_stdio(Parrot_Interp);
INTVAL Parrot_warn(Parrot_Interp, INTVAL warnclass, const char *message, ...);
Modified: trunk/src/debug.c
==============================================================================
--- trunk/src/debug.c (original)
+++ trunk/src/debug.c Mon Apr 18 08:32:05 2005
@@ -2942,27 +2942,44 @@
{
STRING *str;
PMC *sub;
-
+ PMC *old = PMCNULL;
+ int rec_level = 0;
+
/* information about the current sub */
sub = interpinfo_p(interpreter, CURRENT_SUB);
if (!PMC_IS_NULL(sub)) {
- str = VTABLE_get_string(interpreter, sub);
- PIO_eprintf(interpreter, "current instr.: '%Ss' pc %d\n",
- str,
- interpreter->ctx.current_pc - PMC_sub(sub)->address
- );
+ str = Parrot_Context_infostr(interpreter, &interpreter->ctx);
+ if (str)
+ PIO_eprintf(interpreter, "%Ss", str);
}
+ /* backtrace: follow the continuation chain */
sub = interpinfo_p(interpreter, CURRENT_CONT);
- while (!PMC_IS_NULL(sub) && sub->vtable->base_type ==
enum_class_Continuation) {
- str = VTABLE_get_string(interpreter, sub);
- if (!str)
- break;
- PIO_eprintf(interpreter, "%Ss",
- str
- );
+ while (!PMC_IS_NULL(sub) &&
+ sub->vtable->base_type == enum_class_Continuation &&
+ NULL != (str = Parrot_Context_infostr(interpreter,
+ &PMC_cont(sub)->ctx)) ) {
+
+ /* recursion detection */
+ if (!PMC_IS_NULL(old) && PMC_cont(old) &&
+ PMC_cont(old)->ctx.current_pc == PMC_cont(sub)->ctx.current_pc &&
+ PMC_cont(old)->ctx.current_sub == PMC_cont(sub)->ctx.current_sub) {
+ ++rec_level;
+ } else if (rec_level != 0) {
+ PIO_eprintf(interpreter, "... call repeated %d times\n", rec_level);
+ rec_level = 0;
+ }
+
+ /* print the context description */
+ if (rec_level == 0)
+ PIO_eprintf(interpreter, "%Ss", str);
+
/* get the next Continuation */
- sub = PMC_cont(sub)->ctx.current_cont;
+ old = sub;
+ sub = PMC_cont(sub)->ctx.current_cont;
+ }
+ if (rec_level != 0) {
+ PIO_eprintf(interpreter, "... call repeated %d times\n", rec_level);
}
}
Modified: trunk/src/exceptions.c
==============================================================================
--- trunk/src/exceptions.c (original)
+++ trunk/src/exceptions.c Mon Apr 18 08:32:05 2005
@@ -270,7 +270,7 @@
if (m)
string_cstring_free(m);
if (print_location)
- print_pbc_location_stdio(interpreter);
+ PDB_backtrace(interpreter);
/*
* returning NULL from here returns resume address NULL to the
* runloop, which will terminate the thread function finally
Modified: trunk/src/sub.c
==============================================================================
--- trunk/src/sub.c (original)
+++ trunk/src/sub.c Mon Apr 18 08:32:05 2005
@@ -539,12 +539,115 @@
if (PMC_IS_NULL(s->name_space)) {
return s->name;
} else {
- STRING* ns = VTABLE_get_string(interpreter, s->name_space);
-
- ns = string_concat(interpreter, ns, string_from_cstring(interpreter, "
:: ", 4), 0);
if (s->name) {
- return string_concat(interpreter, ns, s->name, 0);
- }
+ STRING* ns = VTABLE_get_string(interpreter, s->name_space);
+
+ ns = string_concat(interpreter, ns,
+ string_from_cstring(interpreter, " :: ", 4), 0);
+ return string_concat(interpreter, ns, s->name, 0);
+ } else {
+ STRING* ns = string_from_cstring(interpreter, "??? :: ", 7);
+ return string_concat(interpreter, ns, s->name, 0);
+ }
+ }
+ return NULL;
+}
+
+int
+Parrot_Context_info(Interp *interpreter, struct Parrot_Context *ctx,
+ struct Parrot_Context_info *info)
+{
+ struct Parrot_sub *sub;
+
+ /* set file/line/pc defaults */
+ info->file = "(unknown file)";
+ info->line = -1;
+ info->pc = -1;
+
+ /* is the current sub of the specified context valid? */
+ if (PMC_IS_NULL(ctx->current_sub)) {
+ info->subname = string_from_cstring(interpreter, "???", 3);
+ info->nsname = info->subname;
+ info->fullname = string_from_cstring(interpreter, "??? :: ???", 10);
+ info->pc = -1;
+ return 0;
+ }
+
+ /* make sure there is a sub (not always the case, e.g in pasm code) */
+ if (ctx->current_sub->vtable->base_type == enum_class_Undef ||
+ PMC_sub(ctx->current_sub)->address == 0) {
+ info->nsname = NULL;
+ info->subname = NULL;
+ info->fullname = NULL;
+ /* XXX: is this correct? (try with load_bytecode) */
+ /* use the current interpreter's bytecode as start address */
+ if (ctx->current_pc != NULL)
+ info->pc = ctx->current_pc - interpreter->code->byte_code;
+ return 1;
+ }
+
+ /* fetch struct Parrot_sub of the current sub in the given context */
+ sub = PMC_sub(ctx->current_sub);
+
+ /* set the sub name */
+ info->subname = sub->name;
+
+ /* set the namespace name and fullname of the sub */
+ if (PMC_IS_NULL(sub->name_space)) {
+ info->nsname = string_from_cstring(interpreter, "", 0);
+ info->fullname = info->subname;
+ } else {
+ info->nsname = VTABLE_get_string(interpreter, sub->name_space);
+ info->fullname = string_concat(interpreter, info->nsname,
+ string_from_cstring(interpreter, " :: ", 4), 0);
+ info->fullname = string_concat(interpreter, info->fullname,
+ info->subname, 1);
+ }
+
+ /* return here if there is no current pc */
+ if (ctx->current_pc == NULL)
+ return 1;
+
+ /* calculate the current pc */
+ info->pc = ctx->current_pc - sub->seg->base.data;
+
+ /* determine the current source file/line */
+ if (interpreter->ctx.current_pc) {
+ size_t offs = info->pc;
+ size_t i, n;
+ /* XXX: interpreter->code->cur_cs is not correct, is it? */
+ opcode_t *pc = interpreter->code->cur_cs->base.data;
+ struct PackFile_Debug *debug = interpreter->code->cur_cs->debugs;
+
+ /*assert(pc == sub->seg->base.data);*/
+ /* set source file */
+ info->file = debug->filename;
+ for (i = n = 0; n < interpreter->code->cur_cs->base.size; i++) {
+ op_info_t *op_info = &interpreter->op_info_table[*pc];
+ if (n >= offs) {
+ /* set source line */
+ info->line = debug->base.data[i];
+ break;
+ }
+ n += op_info->arg_count;
+ pc += op_info->arg_count;
+ }
+ }
+ return 1;
+}
+
+STRING*
+Parrot_Context_infostr(Interp *interpreter, struct Parrot_Context *ctx)
+{
+ struct Parrot_Context_info info;
+ const char* msg = (&interpreter->ctx == ctx) ?
+ "current instr.:":
+ "called from Sub";
+
+ if (Parrot_Context_info(interpreter, ctx, &info)) {
+ return Parrot_sprintf_c(interpreter,
+ "%s '%Ss' pc %d (%s:%d)\n", msg,
+ info.fullname, info.pc, info.file, info.line);
}
return NULL;
}
Modified: trunk/src/warnings.c
==============================================================================
--- trunk/src/warnings.c (original)
+++ trunk/src/warnings.c Mon Apr 18 08:32:05 2005
@@ -22,46 +22,6 @@
/*
-=head2 Internal Functions
-
-=over 4
-
-=item C<static int
-find_line(Interp *interpreter, struct PackFile_Debug * debug)>
-
-Find the line number.
-
-Returns -2 if the interpreter has no current profile counter.
-
-I<What does returning -1 mean?>
-
-=cut
-
-*/
-
-static int
-find_line(Interp *interpreter, struct PackFile_Debug * debug)
-{
- size_t offs, i, n;
- op_info_t *op_info;
- opcode_t *pc;
-
- if (!interpreter->ctx.current_pc)
- return -2;
- pc = interpreter->code->cur_cs->base.data;
- offs = interpreter->ctx.current_pc - pc;
- for (i = n = 0; n < interpreter->code->cur_cs->base.size; i++) {
- op_info = &interpreter->op_info_table[*pc];
- if (n >= offs)
- return (int) debug->base.data[i];
- n += op_info->arg_count;
- pc += op_info->arg_count;
- }
- return -1;
-}
-
-/*
-
=item C<void
print_pbc_location(Parrot_Interp interpreter)>
@@ -72,50 +32,9 @@
*/
void
-print_pbc_location(Parrot_Interp interpreter)
-{
- const char *file;
- int line;
- struct PackFile_Debug * debugs = interpreter->code->cur_cs->debugs;
- if (debugs) {
- file = debugs->filename;
- line = find_line(interpreter, debugs);
- }
- else {
- file = "(unknown file)";
- line = -1;
- }
- PIO_eprintf(interpreter, "\tin file '%s' near line %d\n", file, line);
-}
-
-/*
-
-=item C<void
-print_pbc_location_stdio(Parrot_Interp interpreter)>
-
-Prints the bytecode location of the warning or error to C<stderr>.
-
-Uses C<fprintf()> only. This may be called from exceptions.
-
-=cut
-
-*/
-
-void
-print_pbc_location_stdio(Parrot_Interp interpreter)
+print_pbc_location(Parrot_Interp inter)
{
- const char *file;
- int line;
- struct PackFile_Debug * debugs = interpreter->code->cur_cs->debugs;
- if (debugs) {
- file = debugs->filename;
- line = find_line(interpreter, debugs);
- }
- else {
- file = "(unknown file)";
- line = -1;
- }
- fprintf(stderr, "\tin file '%s' near line %d\n", file, line);
+ PIO_eprintf(inter, "%Ss", Parrot_Context_infostr(inter, &inter->ctx));
}
/*
Modified: trunk/t/op/debuginfo.t
==============================================================================
--- trunk/t/op/debuginfo.t (original)
+++ trunk/t/op/debuginfo.t Mon Apr 18 08:32:05 2005
@@ -17,7 +17,7 @@
=cut
-use Parrot::Test tests => 6;
+use Parrot::Test tests => 8;
SKIP:
{
@@ -75,31 +75,29 @@
pir_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - Null PMC access" );
.sub main
print "ok 1\n"
- debug 1
- print "ok 2\n"
a()
- print "not ok 11\n"
+ print "not ok 10\n"
.end
.sub a
- print "ok 3\n"
+ print "ok 2\n"
b()
- print "not ok 10\n"
+ print "not ok 9\n"
.end
.sub b
- print "ok 4\n"
+ print "ok 3\n"
c()
- print "not ok 9\n"
+ print "not ok 8\n"
.end
.sub c
- print "ok 5\n"
+ print "ok 4\n"
d()
- print "not ok 8\n"
+ print "not ok 7\n"
.end
.sub d
- print "ok 6\n"
+ print "ok 5\n"
$P0 = null
$P0()
- print "not ok 7\n"
+ print "not ok 6\n"
.end
CODE
/^ok 1
@@ -107,20 +105,18 @@
ok 3
ok 4
ok 5
-ok 6
Null PMC access in invoke\(\)
-current instr\.: 'd' pc \d+
-called from Sub 'c' pc \d+
-called from Sub 'b' pc \d+
-called from Sub 'a' pc \d+
-called from Sub 'main' pc \d+
-\*\*\* Parrot VM: Dumping GC info \*\*\*/
+current instr\.: 'd' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'c' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'b' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'a' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
OUTPUT
pir_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - method not found" );
+.namespace ["Test1"]
.sub main
print "ok 1\n"
- debug 1
foo()
print "not ok 5\n"
.end
@@ -135,19 +131,16 @@
/^ok 1
ok 2
ok 3
-real_exception \(severity:2 error:81\): Method 'nosuchmethod' not found
-current instr.: 'foo' pc \d+
-called from Sub 'main' pc \d+
Method 'nosuchmethod' not found
-\s+in file '.*?' near line 11
-\*\*\* Parrot VM: Dumping GC info \*\*\*/
+current instr.: 'Test1 :: foo' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'Test1 :: main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
OUTPUT
pir_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - fetch of unknown
lexical" );
+.namespace ["Test2"]
.sub main
new_pad 0
print "ok 1\n"
- debug 1
foo()
print "not ok 3\n"
.end
@@ -159,10 +152,40 @@
CODE
/^ok 1
ok 2
-real_exception \(severity:2 error:77\): Lexical 'nosuchlex' not found
-current instr.: 'foo' pc \d+
-called from Sub 'main' pc \d+
Lexical 'nosuchlex' not found
-\s+in file '.*?' near line 10
-\*\*\* Parrot VM: Dumping GC info \*\*\*/
+current instr.: 'Test2 :: foo' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'Test2 :: main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
+OUTPUT
+
+pir_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - recursion 1" );
+.sub main
+ main()
+.end
+CODE
+/^maximum recursion depth exceeded
+current instr\.: 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)
+\.\.\. call repeated 999 times$/
+OUTPUT
+
+pir_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - recursion 2" );
+.sub main
+ rec(91)
+.end
+.sub rec
+ .param int i
+ if i == 0 goto END
+ dec i
+ rec(i)
+ .return()
+END:
+ $P0 = null
+ $P0()
+.end
+CODE
+/^Null PMC access in invoke\(\)
+current instr\.: 'rec' pc (\d+|-1) \(.*?:(\d+|-1)\)
+called from Sub 'rec' pc (\d+|-1) \(.*?:(\d+|-1)\)
+\.\.\. call repeated 90 times
+called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
OUTPUT
Modified: trunk/t/pmc/perlarray.t
==============================================================================
--- trunk/t/pmc/perlarray.t (original)
+++ trunk/t/pmc/perlarray.t Mon Apr 18 08:32:05 2005
@@ -1377,23 +1377,22 @@
OK4: print "ok 4\\n"
end
CODE
-/Use of uninitialized value
-\s+in file.*
+/^Use of uninitialized value
+current instr\.: '\(null\)' pc (\d+|-1) .*?
ok 1
Use of uninitialized value
-\s+in file.*
+current instr\.: '\(null\)' pc (\d+|-1) .*?
ok 2
Use of uninitialized value
-\s+in file.*
+current instr\.: '\(null\)' pc (\d+|-1) .*?
ok 3
Use of uninitialized value
-\s+in file.*
+current instr\.: '\(null\)' pc (\d+|-1) .*?
ok 4
-/
+$/
OUTPUT
pir_output_is(<< 'CODE', << 'OUTPUT', "check whether interface is done");
-
.sub _main
.local pmc pmc1
pmc1 = new PerlArray
Modified: trunk/t/pmc/perlundef.t
==============================================================================
--- trunk/t/pmc/perlundef.t (original)
+++ trunk/t/pmc/perlundef.t Mon Apr 18 08:32:05 2005
@@ -326,8 +326,8 @@
print P0
end
CODE
-/Use of uninitialized.*
-\s+in file .*pasm/i
+/^Use of uninitialized.*
+current instr\.: '\(null\)' pc (\d+|-1) /
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "bor undef");
Modified: trunk/t/pmc/sub.t
==============================================================================
--- trunk/t/pmc/sub.t (original)
+++ trunk/t/pmc/sub.t Mon Apr 18 08:32:05 2005
@@ -379,7 +379,8 @@
returncc
CODE
/^main:Use of uninitialized value in integer context
-\s+in file.*:back$/s
+current instr\.: '\(null\)' pc (\d+|-1) \(.*?:(\d+|-1)\)
+:back$/s
OUTPUT
output_like(<<'CODE', <<'OUTPUT', "interp - warnings 2");
@@ -402,7 +403,8 @@
returncc
CODE
/^Use of uninitialized value in integer context
-\s+in file.*:main:back:Use of un.*$/sm
+current instr\.: '\(null\)' pc (\d+|-1) .*?
+:main:back:Use of un.*$/sm
OUTPUT
output_like(<<'CODE', <<'OUTPUT', "interp - warnings 2 - updatecc");
@@ -430,7 +432,8 @@
returncc
CODE
/^Use of uninitialized value in integer context
-\s+in file.*:main:back:Use of un.*$/sm
+current instr\.: '\(null\)' pc (\d+|-1) .*?
+:main:back:Use of un.*$/sm
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "pcc sub");
@@ -1070,7 +1073,6 @@
pir_output_like(<<'CODE', <<'OUTPUT', "warn on in main");
-
.sub _main @MAIN
.include "warnings.pasm"
warningson .PARROT_WARNINGS_UNDEF_FLAG
@@ -1085,7 +1087,6 @@
OUTPUT
pir_output_is(<<'CODE', <<'OUTPUT', "warn on in sub");
-
.sub _main @MAIN
.include "warnings.pasm"
_f1()
@@ -1101,7 +1102,6 @@
OUTPUT
pir_output_like(<<'CODE', <<'OUTPUT', "warn on in sub, turn off in f2");
-
.sub _main @MAIN
.include "warnings.pasm"
_f1()
@@ -1191,7 +1191,6 @@
OUTPUT
pir_output_is(<<'CODE', <<'OUTPUT', "sub names w newsub");
-
.sub main @MAIN
.include "interpinfo.pasm"
$P0 = interpinfo .INTERPINFO_CURRENT_SUB
@@ -1215,7 +1214,6 @@
OUTPUT
pir_output_is(<<'CODE', <<'OUTPUT', "caller introspection");
-
.sub main @MAIN
.include "interpinfo.pasm"
# this test will fail when run with -Oc
@@ -1290,7 +1288,7 @@
main
OUTPUT
my $descr = '@IMMEDIATE, @POSTCOMP';
- if ( $ENV{TEST_PROG_ARGS} =~ m/-r / )
+ if ( exists $ENV{TEST_PROG_ARGS} and $ENV{TEST_PROG_ARGS} =~ m/-r / )
{
TODO:
{
