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.

diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 9b0e564..bf25c74 100644 (file)
--- 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).
 
 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
 @end deffn
 
 @deffn {Scheme Syntax} start-stack id exp

diff --git a/libguile/programs.c b/libguile/programs.c
index fae95d0..64c861a 100644 (file)
--- 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
  * 
  * 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);
 }
 
   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),
            "")
 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 096c2c0..d170c1b 100644 (file)
--- 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
  * 
  * 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_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);
 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 7531908..a09c3b9 100644 (file)
--- 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)
 {
 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)))
     {
   /* 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;
         }
     }
             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. */
   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;
 
         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))
       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"
            "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"
             "\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"
            "@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"
             "\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"
             "\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;
 #define FUNC_NAME s_scm_make_stack
 {
   long n;

diff --git a/module/statprof.scm b/module/statprof.scm
index 76dfbea..961f769 100644 (file)
--- 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)))
   (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 ()
     (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."
   
 @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)
     (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 5344d38..8f19c54 100644 (file)
--- 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
 
             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?
             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)))))
 
            (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
 ;; 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