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 | |
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.
-rw-r--r-- | doc/ref/api-debug.texi | 54 | ||||
-rw-r--r-- | libguile/programs.c | 14 | ||||
-rw-r--r-- | libguile/programs.h | 4 | ||||
-rw-r--r-- | libguile/stacks.c | 98 | ||||
-rw-r--r-- | module/statprof.scm | 6 | ||||
-rw-r--r-- | module/system/vm/program.scm | 11 |
6 files changed, 139 insertions, 48 deletions
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 9b0e56448..bf25c74c9 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -88,33 +88,33 @@ evaluation stack is used for creating the stack frames, otherwise the frames are taken from @var{obj} (which must be a continuation or a frame object). -@var{arg} @dots{} can be any combination of integer, procedure, prompt -tag and @code{#t} values. - -These values specify various ways of cutting away uninteresting -stack frames from the top and bottom of the stack that -@code{make-stack} returns. They come in pairs like this: -@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2} -@var{outer_cut_2} @dots{})}. - -Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt -tag, or a procedure. @code{#t} means to cut away all frames up -to but excluding the first user module frame. An integer means -to cut away exactly that number of frames. A prompt tag means -to cut away all frames that are inside a prompt with the given -tag. A procedure means to cut away all frames up to but -excluding the application frame whose procedure matches the -specified one. - -Each @var{outer_cut_i} can be an integer, a prompt tag, or a -procedure. An integer means to cut away that number of frames. -A prompt tag means to cut away all frames that are outside a -prompt with the given tag. A procedure means to cut away -frames down to but excluding the application frame whose -procedure matches the specified one. - -If the @var{outer_cut_i} of the last pair is missing, it is -taken as 0. +@var{arg} @dots{} can be any combination of integer, procedure, address +range, and prompt tag values. + +These values specify various ways of cutting away uninteresting stack +frames from the top and bottom of the stack that @code{make-stack} +returns. They come in pairs like this: @code{(@var{inner_cut_1} +@var{outer_cut_1} @var{inner_cut_2} @var{outer_cut_2} @dots{})}. + +Each @var{inner_cut_i} can be an integer, a procedure, an address range, +or a prompt tag. An integer means to cut away exactly that number of +frames. A procedure means to cut away all frames up to but excluding +the frame whose procedure matches the specified one. An address range +is a pair of integers indicating the low and high addresses of a +procedure's code, and is the same as cutting away to a procedure (though +with less work). Anything else is interpreted as a prompt tag which +cuts away all frames that are inside a prompt with the given tag. + +Each @var{outer_cut_i} can likewise be an integer, a procedure, an +address range, or a prompt tag. An integer means to cut away that +number of frames. A procedure means to cut away frames down to but +excluding the frame whose procedure matches the specified one. An +address range is the same, but with the procedure's code specified as an +address range. Anything else is taken to be a prompt tag, which cuts +away all frames that are outside a prompt with the given tag. + + +If the @var{outer_cut_i} of the last pair is missing, it is taken as 0. @end deffn @deffn {Scheme Syntax} start-stack id exp diff --git a/libguile/programs.c b/libguile/programs.c index fae95d0ab..64c861a71 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -180,6 +180,18 @@ scm_find_source_for_addr (SCM ip) return scm_call_1 (scm_variable_ref (source_for_addr), ip); } +SCM +scm_program_address_range (SCM program) +{ + static SCM program_address_range = SCM_BOOL_F; + + if (scm_is_false (program_address_range) && scm_module_system_booted_p) + program_address_range = + scm_c_private_variable ("system vm program", "program-address-range"); + + return scm_call_1 (scm_variable_ref (program_address_range), program); +} + SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0, (SCM program), "") diff --git a/libguile/programs.h b/libguile/programs.h index 096c2c02a..d170c1b77 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -67,6 +67,8 @@ SCM_INTERNAL SCM scm_i_program_properties (SCM program); SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip); +SCM_INTERNAL SCM scm_program_address_range (SCM program); + SCM_API SCM scm_program_num_free_variables (SCM program); SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i); SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x); 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; diff --git a/module/statprof.scm b/module/statprof.scm index 76dfbea57..961f769e4 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -845,7 +845,8 @@ operation is somewhat expensive." (let ((state (fresh-profiler-state #:count-calls? count-calls? #:sampling-period (inexact->exact (round (/ 1e6 hz))) - #:outer-cut call-thunk))) + #:outer-cut + (program-address-range call-thunk)))) (parameterize ((profiler-state state)) (dynamic-wind (lambda () @@ -905,7 +906,8 @@ Since GC does not occur very frequently, you may need to use the @var{loop} parameter, to cause @var{thunk} to be called @var{loop} times." - (let ((state (fresh-profiler-state #:outer-cut call-thunk))) + (let ((state (fresh-profiler-state #:outer-cut + (program-address-range call-thunk)))) (parameterize ((profiler-state state)) (define (gc-callback) (unless (inside-profiler? state) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 5344d3882..8f19c5468 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -28,6 +28,8 @@ source:line-for-user program-sources program-sources-pre-retire program-source + program-address-range + program-arities program-arity arity:start arity:end arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? @@ -97,6 +99,15 @@ (lp s sources) source))))) +(define (program-address-range program) + "Return the start and end addresses of @var{program}'s code, as a pair +of integers." + (let ((pdi (find-program-debug-info (program-code program)))) + (and pdi + (cons (program-debug-info-addr pdi) + (+ (program-debug-info-addr pdi) + (program-debug-info-size pdi)))))) + ;; Source information could in theory be correlated with the ip of the ;; instruction, or the ip just after the instruction is retired. Guile ;; does the latter, to make backtraces easy -- an error produced while |