summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-05-01 14:26:20 +0200
committerAndy Wingo <wingo@pobox.com>2014-05-01 14:26:20 +0200
commitde0233af177806ac96d535bb58f27875fb8c5375 (patch)
tree2df38f60a3a772f10d8b351dde2054892ebf5ca0
parentd7a67c3e918acd8ca46dc7792a8ca98b33cb94e8 (diff)
downloadguile-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.texi54
-rw-r--r--libguile/programs.c14
-rw-r--r--libguile/programs.h4
-rw-r--r--libguile/stacks.c98
-rw-r--r--module/statprof.scm6
-rw-r--r--module/system/vm/program.scm11
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