diff options
author | Andy Wingo <wingo@pobox.com> | 2014-05-01 14:26:20 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-05-01 14:26:20 +0200 |
commit | de0233af177806ac96d535bb58f27875fb8c5375 (patch) | |
tree | 2df38f60a3a772f10d8b351dde2054892ebf5ca0 /libguile/stacks.c | |
parent | d7a67c3e918acd8ca46dc7792a8ca98b33cb94e8 (diff) | |
download | guile-de0233af177806ac96d535bb58f27875fb8c5375.tar.gz |
Fix inner and outer stack cuts to match on procedure code
* doc/ref/api-debug.texi (Stack Capture): Update make-stack docs.
* libguile/programs.h:
* libguile/programs.c (scm_program_address_range): New internal
procedure.
* libguile/stacks.c (narrow_stack): Interpret a pair of integers as an
address range. If a cut is a procedure, attempt to resolve it to an
address range.
(scm_make_stack): Update docstring.
* module/system/vm/program.scm (program-address-range): New exported
procedure.
* module/statprof.scm (statprof, gcprof): Use program-address-range to
get the outer-cut, for efficiency.
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r-- | libguile/stacks.c | 98 |
1 files changed, 81 insertions, 17 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c index 7531908f2..a09c3b9a3 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -113,6 +113,22 @@ static long narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame, SCM inner_cut, SCM outer_cut) { + /* Resolve procedure cuts to address ranges, if possible. If the + debug information has been stripped, this might not be + possible. */ + if (scm_is_true (scm_program_p (inner_cut))) + { + SCM addr_range = scm_program_address_range (inner_cut); + if (scm_is_pair (addr_range)) + inner_cut = addr_range; + } + if (scm_is_true (scm_program_p (outer_cut))) + { + SCM addr_range = scm_program_address_range (outer_cut); + if (scm_is_pair (addr_range)) + outer_cut = addr_range; + } + /* Cut inner part. */ if (scm_is_true (scm_procedure_p (inner_cut))) { @@ -126,6 +142,25 @@ narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame, break; } } + else if (scm_is_pair (inner_cut) + && scm_is_integer (scm_car (inner_cut)) + && scm_is_integer (scm_cdr (inner_cut))) + { + /* Cut until an IP within the given range is found. */ + scm_t_uintptr low_pc, high_pc, pc; + + low_pc = scm_to_uintptr_t (scm_car (inner_cut)); + high_pc = scm_to_uintptr_t (scm_cdr (inner_cut)); + + for (; len ;) + { + pc = (scm_t_uintptr) frame->ip; + len--; + scm_c_frame_previous (kind, frame); + if (low_pc <= pc && pc < high_pc) + break; + } + } else if (scm_is_integer (inner_cut)) { /* Cut specified number of frames. */ @@ -161,6 +196,30 @@ narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame, len = new_len; } + else if (scm_is_pair (outer_cut) + && scm_is_integer (scm_car (outer_cut)) + && scm_is_integer (scm_cdr (outer_cut))) + { + /* Cut until an IP within the given range is found. */ + scm_t_uintptr low_pc, high_pc, pc; + long i, new_len; + struct scm_frame tmp; + + low_pc = scm_to_uintptr_t (scm_car (outer_cut)); + high_pc = scm_to_uintptr_t (scm_cdr (outer_cut)); + + memcpy (&tmp, frame, sizeof tmp); + + /* Cut until the given procedure is seen. */ + for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp)) + { + pc = (scm_t_uintptr) tmp.ip; + if (low_pc <= pc && pc < high_pc) + new_len = i; + } + + len = new_len; + } else if (scm_is_integer (outer_cut)) { /* Cut specified number of frames. */ @@ -217,7 +276,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "a continuation or a frame object).\n" "\n" "@var{args} should be a list containing any combination of\n" - "integer, procedure, prompt tag and @code{#t} values.\n" + "integer, procedure, address range, prompt tag and @code{#t}\n" + "values.\n" "\n" "These values specify various ways of cutting away uninteresting\n" "stack frames from the top and bottom of the stack that\n" @@ -225,24 +285,28 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" "@var{outer_cut_2} @dots{})}.\n" "\n" - "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n" - "tag, or a procedure. @code{#t} means to cut away all frames up\n" - "to but excluding the first user module frame. An integer means\n" - "to cut away exactly that number of frames. A prompt tag means\n" - "to cut away all frames that are inside a prompt with the given\n" - "tag. A procedure means to cut away all frames up to but\n" - "excluding the application frame whose procedure matches the\n" - "specified one.\n" + "Each @var{inner_cut_i} can be an integer, a procedure, an\n" + "address range, or a prompt tag. An integer means to cut away\n" + "exactly that number of frames. A procedure means to cut\n" + "away all frames up to but excluding the frame whose procedure\n" + "matches the specified one. An address range is a pair of\n" + "integers indicating the low and high addresses of a procedure's\n" + "code, and is the same as cutting away to a procedure (though\n" + "with less work). Anything else is interpreted as a prompt tag\n" + "which cuts away all frames that are inside a prompt with the\n" + "given tag.\n" "\n" - "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n" - "procedure. An integer means to cut away that number of frames.\n" - "A prompt tag means to cut away all frames that are outside a\n" - "prompt with the given tag. A procedure means to cut away\n" - "frames down to but excluding the application frame whose\n" - "procedure matches the specified one.\n" + "Each @var{outer_cut_i} can be an integer, a procedure, an\n" + "address range, or a prompt tag. An integer means to cut away\n" + "that number of frames. A procedure means to cut away frames\n" + "down to but excluding the frame whose procedure matches the\n" + "specified one. An address range is the same, but with the\n" + "procedure's code specified as an address range. Anything else\n" + "is taken to be a prompt tag, which cuts away all frames that are\n" + "outside a prompt with the given tag.\n" "\n" - "If the @var{outer_cut_i} of the last pair is missing, it is\n" - "taken as 0.") + "If the @var{outer_cut_i} of the last pair is missing, it is\n" + "taken as 0.") #define FUNC_NAME s_scm_make_stack { long n; |