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.

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
+@var{arg} @dots{} can be any combination of integer, procedure, address
-tag and @code{#t} values.
+range, and prompt tag values.
 
-These values specify various ways of cutting away uninteresting
+These values specify various ways of cutting away uninteresting stack
-stack frames from the top and bottom of the stack that
+frames from the top and bottom of the stack that @code{make-stack}
-@code{make-stack} returns.  They come in pairs like this:
+returns.  They come in pairs like this:  @code{(@var{inner_cut_1}
-@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}
+@var{outer_cut_1} @var{inner_cut_2} @var{outer_cut_2} @dots{})}.
-@var{outer_cut_2} @dots{})}.
 
-Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt
+Each @var{inner_cut_i} can be an integer, a procedure, an address range,
-tag, or a procedure.  @code{#t} means to cut away all frames up
+or a prompt tag.  An integer means to cut away exactly that number of
-to but excluding the first user module frame.  An integer means
+frames.  A procedure means to cut away all frames up to but excluding
-to cut away exactly that number of frames.  A prompt tag means
+the frame whose procedure matches the specified one.  An address range
-to cut away all frames that are inside a prompt with the given
+is a pair of integers indicating the low and high addresses of a
-tag. A procedure means to cut away all frames up to but
+procedure's code, and is the same as cutting away to a procedure (though
-excluding the application frame whose procedure matches the
+with less work).  Anything else is interpreted as a prompt tag which
-specified one.
+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
+Each @var{outer_cut_i} can likewise be an integer, a procedure, an
-procedure.  An integer means to cut away that number of frames.
+address range, or a prompt tag.  An integer means to cut away that
-A prompt tag means to cut away all frames that are outside a
+number of frames.  A procedure means to cut away frames down to but
-prompt with the given tag. A procedure means to cut away
+excluding the frame whose procedure matches the specified one.  An
-frames down to but excluding the application frame whose
+address range is the same, but with the procedure's code specified as an
-procedure matches the specified one.
+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

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

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

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. */
@@ -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,21 +285,25 @@ 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"
+	    "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
-            "tag, or a procedure.  @code{#t} means to cut away all frames up\n"
+            "address range, or a prompt tag.  An integer means to cut away\n"
-            "to but excluding the first user module frame.  An integer means\n"
+            "exactly that number of frames.  A procedure means to cut\n"
-            "to cut away exactly that number of frames.  A prompt tag means\n"
+            "away all frames up to but excluding the frame whose procedure\n"
-            "to cut away all frames that are inside a prompt with the given\n"
+            "matches the specified one.  An address range is a pair of\n"
-            "tag. A procedure means to cut away all frames up to but\n"
+            "integers indicating the low and high addresses of a procedure's\n"
-            "excluding the application frame whose procedure matches the\n"
+            "code, and is the same as cutting away to a procedure (though\n"
-            "specified one.\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"
+	    "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
-            "procedure.  An integer means to cut away that number of frames.\n"
+            "address range, or a prompt tag.  An integer means to cut away\n"
-            "A prompt tag means to cut away all frames that are outside a\n"
+            "that number of frames.  A procedure means to cut away frames\n"
-            "prompt with the given tag. A procedure means to cut away\n"
+            "down to but excluding the frame whose procedure matches the\n"
-            "frames down to but excluding the application frame whose\n"
+            "specified one.  An address range is the same, but with the\n"
-            "procedure matches the specified one.\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.")

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)

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