mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 19:20:21 +02:00
Code Activity

Fix inner and outer stack cuts to match on procedure code

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-05-01 14:26:20 +02:00
parent d7a67c3e91
commit de0233af17
6 changed files with 135 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

46
doc/ref/api-debug.texi
View file

@ -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.
@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{})}.
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{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 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.
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.
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

14
libguile/programs.c
View file

@ -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),
"")

4
libguile/programs.h
View file

@ -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);

98
libguile/stacks.c
View file

@ -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. */
@ -159,6 +194,30 @@ narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
new_len = i;
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))
@ -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;

6
module/statprof.scm
View file

@ -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)

11
module/system/vm/program.scm
View file

@ -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