narrowing stacks to prompts; backtrace shows frames from start-stack

* libguile/stacks.c (scm_sys_stacks): New global variable, moved here
  from boot-9.scm.
  (scm_init_stacks): Define scm_sys_stacks to %stacks.
  (stack_depth): Remove narrowing by frame pointer.
  (find_prompt): New helper.
  (narrow_stack): Clean up a bit, and allow narrowing by prompt tag.
  (scm_make_stack): Update docs, and use scm_stack_id to get the stack
  id.
  (scm_stack_id): The current stack id may be fetched as the cdar of
  %stacks.
  (stack_id_with_fp): Remove helper.

* module/ice-9/boot-9.scm (%start-stack): Fix indentation.
  (%stacks): Remove definition, it's in stacks.c now.
  (default-pre-unwind-handler): Narrow by another frame.
  (save-stack): Remove special handling for certain stack ids, as it is
  often possible that the function isn't on the stack -- in the
  interpreter, or after a tail call. Better to narrow by prompt ids.

* module/system/vm/debug.scm (print-frames): Change to operate on a
  vector of frames.
  (run-debugger): Change to receive a vector of frames. The debugger
  also has the full stack, so it can re-narrow (or widen) to get the
  whole stack, if the user wants.
  (stack->vector): New helper.
  (debug-pre-unwind-handler): Narrow by more frames, and to the most
  recent start-stack invocation. Adapt to run-debugger change.

1 files changed, 110 insertions, 67 deletions

diff --git a/libguile/stacks.c b/libguile/stacks.c
index 431d6b1e2..a7ebda03a 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -24,6 +24,7 @@
 #endif
 
 #include "libguile/_scm.h"
+#include "libguile/control.h"
 #include "libguile/eval.h"
 #include "libguile/debug.h"
 #include "libguile/continuations.h"
@@ -41,6 +42,8 @@
 #include "libguile/private-options.h"
 
 
+static SCM scm_sys_stacks;
+
 
 /* {Stacks}
  *
@@ -59,17 +62,14 @@
 
 
 
-static SCM stack_id_with_fp (SCM frame, SCM **fp);
-
 /* Count number of debug info frames on a stack, beginning with FRAME.
  */
 static long
-stack_depth (SCM frame, SCM *fp)
+stack_depth (SCM frame)
 {
   long n = 0;
   /* count frames, skipping boot frames */
-  for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
-       frame = scm_frame_previous (frame))
+  for (; scm_is_true (frame); frame = scm_frame_previous (frame))
     ++n;
   return n;
 }
@@ -95,6 +95,21 @@ stack_depth (SCM frame, SCM *fp)
  * encountered.
  */
 
+static SCM
+find_prompt (SCM key)
+{
+  SCM winds;
+  for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
+    {
+      SCM elt = scm_car (winds);
+      if (SCM_PROMPT_P (elt) && SCM_PROMPT_TAG (elt) == key)
+        return elt;
+    }
+  scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+                  scm_list_1 (key));
+  return SCM_BOOL_F; /* not reached */
+}
+
 static void
 narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
 {
@@ -105,25 +120,35 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
   frame = SCM_STACK_FRAME (stack);
 
   /* Cut inner part. */
-  if (scm_is_eq (inner_key, SCM_BOOL_T))
+  if (scm_is_true (scm_procedure_p (inner_key)))
     {
-      /* Cut specified number of frames. */
-      for (; inner && len; --inner)
+      /* Cut until the given procedure is seen. */
+      for (; inner && len ; --inner)
         {
+          SCM proc = scm_frame_procedure (frame);
           len--;
           frame = scm_frame_previous (frame);
+          if (scm_is_eq (proc, inner_key))
+            break;
         }
     }
+  else if (scm_is_symbol (inner_key))
+    {
+      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+         symbols. */
+      SCM prompt = find_prompt (inner_key);
+      for (; len; len--, frame = scm_frame_previous (frame))
+        if (SCM_PROMPT_REGISTERS (prompt)->fp
+            == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+          break;
+    }
   else
     {
-      /* Cut until the given procedure is seen. */
-      for (; inner && len ; --inner)
+      /* Cut specified number of frames. */
+      for (; inner && len; --inner)
         {
-          SCM proc = scm_frame_procedure (frame);
           len--;
           frame = scm_frame_previous (frame);
-          if (scm_is_eq (proc, inner_key))
-            break;
         }
     }
 
@@ -131,12 +156,39 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
   SCM_SET_STACK_FRAME (stack, frame);
 
   /* Cut outer part. */
-  for (; outer && len ; --outer)
+  if (scm_is_true (scm_procedure_p (outer_key)))
     {
-      frame = scm_stack_ref (stack, scm_from_long (len - 1));
-      len--;
-      if (scm_is_eq (scm_frame_procedure (frame), outer_key))
-        break;
+      /* Cut until the given procedure is seen. */
+      for (; outer && len ; --outer)
+        {
+          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+          len--;
+          if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+            break;
+        }
+    }
+  else if (scm_is_symbol (outer_key))
+    {
+      /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+         symbols. */
+      SCM prompt = find_prompt (outer_key);
+      while (len)
+        {
+          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+          len--;
+          if (SCM_PROMPT_REGISTERS (prompt)->fp
+              == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+            break;
+        }
+    }
+  else
+    {
+      /* Cut specified number of frames. */
+      for (; outer && len ; --outer)
+        {
+          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+          len--;
+        }
     }
 
   SCM_SET_STACK_LENGTH (stack, len);
@@ -163,24 +215,33 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 	    "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 	    "evaluation stack is used for creating the stack frames,\n"
 	    "otherwise the frames are taken from @var{obj} (which must be\n"
-	    "either a debug object or a continuation).\n\n"
+	    "a continuation or a frame object).\n"
+            "\n"
 	    "@var{args} should be a list containing any combination of\n"
-	    "integer, procedure and @code{#t} values.\n\n"
+	    "integer, procedure, prompt tag and @code{#t} 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"
 	    "@code{make-stack} returns.  They come in pairs like this:\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_N} can be @code{#t}, an integer, or a\n"
-	    "procedure.  @code{#t} means to cut away all frames up to but\n"
-	    "excluding the first user module frame.  An integer means to cut\n"
-	    "away exactly that number of frames.  A procedure means to cut\n"
-	    "away all frames up to but excluding the application frame whose\n"
-	    "procedure matches the specified one.\n\n"
-	    "Each @var{outer_cut_N} can be an integer or a procedure.  An\n"
-	    "integer means to cut away that number of frames.  A procedure\n"
-	    "means to cut away frames down to but excluding the application\n"
-	    "frame whose procedure matches the specified one.\n\n"
+	    "@var{outer_cut_2} @dots{})}.\n"
+            "\n"
+	    "Each @var{inner_cut_N} 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"
+            "\n"
+	    "Each @var{outer_cut_N} 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"
+            "\n"
 	    "If the @var{outer_cut_N} of the last pair is missing, it is\n"
 	    "taken as 0.")
 #define FUNC_NAME s_scm_make_stack
@@ -189,7 +250,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   int maxp;
   SCM frame;
   SCM stack;
-  SCM id, *id_fp;
   SCM inner_cut, outer_cut;
 
   /* Extract a pointer to the innermost frame of whatever object
@@ -209,6 +269,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   else if (SCM_VM_FRAME_P (obj))
     frame = obj;
   else if (SCM_CONTINUATIONP (obj))
+    /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
+       that were in place when the continuation was captured. */
     frame = scm_i_continuation_to_frame (obj);
   else
     {
@@ -224,20 +286,16 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   if (scm_is_false (frame))
     return SCM_BOOL_F;
 
-  /* Get ID of the stack corresponding to the given frame. */
-  id = stack_id_with_fp (frame, &id_fp);
-
   /* Count number of frames.  Also get stack id tag and check whether
      there are more stackframes than we want to record
      (SCM_BACKTRACE_MAXDEPTH). */
-  id = SCM_BOOL_F;
   maxp = 0;
-  n = stack_depth (frame, id_fp);
+  n = stack_depth (frame);
 
   /* Make the stack object. */
   stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
   SCM_SET_STACK_LENGTH (stack, n);
-  SCM_SET_STACK_ID (stack, id);
+  SCM_SET_STACK_ID (stack, scm_stack_id (obj));
   SCM_SET_STACK_FRAME (stack, frame);
   
   /* Narrow the stack according to the arguments given to scm_make_stack. */
@@ -258,9 +316,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       
       narrow_stack (stack,
 		    scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
-		    scm_is_integer (inner_cut) ? 0 : inner_cut,
+		    scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
 		    scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
-		    scm_is_integer (outer_cut) ? 0 : outer_cut);
+		    scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
 
       n = SCM_STACK_LENGTH (stack);
     }
@@ -277,44 +335,26 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 	    "Return the identifier given to @var{stack} by @code{start-stack}.")
 #define FUNC_NAME s_scm_stack_id
 {
-  SCM frame, *id_fp;
-  
-  if (scm_is_eq (stack, SCM_BOOL_T))
+  if (scm_is_eq (stack, SCM_BOOL_T)
+      /* FIXME: frame case assumes frame still live on the stack, and no
+         intervening start-stack. Hmm... */
+      || SCM_VM_FRAME_P (stack))
     {
-      struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
-      frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+      /* Fetch most recent start-stack tag. */
+      SCM stacks = scm_fluid_ref (scm_sys_stacks);
+      return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
     }
-  else if (SCM_VM_FRAME_P (stack))
-    frame = stack;
   else if (SCM_CONTINUATIONP (stack))
-    frame = scm_i_continuation_to_frame (stack);
+    /* FIXME: implement me */
+    return SCM_BOOL_F;
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
       /* not reached */
     }
-
-  return stack_id_with_fp (frame, &id_fp);
 }
 #undef FUNC_NAME
 
-static SCM
-stack_id_with_fp (SCM frame, SCM **fp)
-{
-  SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
-
-  if (SCM_VM_CONT_P (holder))
-    {
-      *fp = NULL;
-      return SCM_BOOL_F;
-    }
-  else
-    {
-      *fp = NULL;
-      return SCM_BOOL_F;
-    }
-}
-
 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
             (SCM stack, SCM index),
 	    "Return the @var{index}'th frame from @var{stack}.")
@@ -347,6 +387,9 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 void
 scm_init_stacks ()
 {
+  scm_sys_stacks = scm_make_fluid ();
+  scm_c_define ("%stacks", scm_sys_stacks);
+  
   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
                                     SCM_UNDEFINED);
   scm_set_struct_vtable_name_x (scm_stack_type,