remove heap links in VM frames, incorporate vm frames into normal backtraces

[bpt/guile.git] / libguile / stacks.c

diff --git a/libguile/stacks.c b/libguile/stacks.c
index 4b97a18..85527bd 100644 (file)
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -32,6 +32,9 @@
 #include "libguile/modules.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
+#include "libguile/vm.h" /* to capture vm stacks */
+#include "libguile/frames.h" /* vm frames */
+#include "libguile/instructions.h" /* scm_op_halt */
 
 #include "libguile/validate.h"
 #include "libguile/stacks.h"
@@ -123,19 +126,24 @@
 #define RELOC_FRAME(ptr, offset) \
   ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
 
+/* FIXME: factor this out somewhere? */
+static int is_vm_bootstrap_frame (SCM f)
+{
+  struct scm_program *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
+  return bp->base[bp->size-1] == scm_op_halt;
+}
 
 /* Count number of debug info frames on a stack, beginning with
  * DFRAME.  OFFSET is used for relocation of pointers when the stack
  * is read from a continuation.
  */
-static scm_t_bits
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
-            SCM *id, int *maxp)
+static long
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
+            SCM *id)
 {
   long n;
-  long max_depth = SCM_BACKTRACE_MAXDEPTH;
   for (n = 0;
-       dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+       dframe && !SCM_VOIDFRAMEP (*dframe);
        dframe = RELOC_FRAME (dframe->prev, offset))
     {
       if (SCM_EVALFRAMEP (*dframe))
@@ -148,15 +156,32 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
          if ((((info - vect) & 1) == 0)
              && SCM_OVERFLOWP (*dframe)
              && !SCM_UNBNDP (info[1].a.proc))
-           ++n;
+            ++n;
        }
+      else if (SCM_APPLYFRAMEP (*dframe))
+        {
+          scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+          if (SCM_PROGRAM_P (vect[0].a.proc))
+            {
+              /* count vmframe back to previous bootstrap frame */
+              for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
+                {
+                  if (is_vm_bootstrap_frame (vmframe))
+                    { /* skip bootstrap frame, cut out of the vm backtrace */
+                      vmframe = scm_c_vm_frame_prev (vmframe);
+                      break;
+                    }
+                  else
+                    ++n;
+                }
+            }
+          ++n; /* increment for apply frame in any case */
+        }
       else
        ++n;
     }
   if (dframe && SCM_VOIDFRAMEP (*dframe))
     *id = RELOC_INFO(dframe->vect, offset)[0].id;
-  else if (dframe)
-    *maxp = 1;
   return n;
 }
 
@@ -234,7 +259,7 @@ do { \
 
 static scm_t_bits
 read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
-            long n, scm_t_info_frame *iframes)
+            SCM vmframe, long n, scm_t_info_frame *iframes)
 {
   scm_t_info_frame *iframe = iframes;
   scm_t_debug_info *info, *vect;
@@ -298,6 +323,32 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
        continue;
       else
        {
+          if (SCM_PROGRAM_P (iframe->proc))
+            {
+              scm_t_info_frame saved = *iframe;
+              for (; scm_is_true (vmframe);
+                   vmframe = scm_c_vm_frame_prev (vmframe))
+                {
+                  if (is_vm_bootstrap_frame (vmframe))
+                    { /* skip bootstrap frame, back to interpreted frames */
+                      vmframe = scm_c_vm_frame_prev (vmframe);
+                      break;
+                    }
+                  else 
+                    {
+                      /* Oh dear, oh dear, oh dear. */
+                      iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
+                      iframe->source = scm_vm_frame_source (vmframe);
+                      iframe->proc = scm_vm_frame_program (vmframe);
+                      iframe->args = scm_vm_frame_arguments (vmframe);
+                      ++iframe;
+                      if (--n == 0)
+                        goto quit;
+                    }
+                }
+              *iframe = saved;
+            }
+
          NEXT_FRAME (iframe, n, quit);
        }
     quit:
@@ -431,6 +482,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   int maxp;
   scm_t_debug_frame *dframe;
   scm_t_info_frame *iframe;
+  SCM vmframe;
   long offset = 0;
   SCM stack, id;
   SCM inner_cut, outer_cut;
@@ -439,17 +491,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
      scm_make_stack was given.  */
   if (scm_is_eq (obj, SCM_BOOL_T))
     {
+      struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
       dframe = scm_i_last_debug_frame ();
+      vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
     }
   else if (SCM_DEBUGOBJP (obj))
     {
       dframe = SCM_DEBUGOBJ_FRAME (obj);
+      vmframe = SCM_BOOL_F;
+    }
+  else if (SCM_VM_FRAME_P (obj))
+    {
+      dframe = NULL;
+      vmframe = obj;
     }
   else if (SCM_CONTINUATIONP (obj))
     {
       scm_t_contregs *cont = SCM_CONTREGS (obj);
       offset = cont->offset;
       dframe = RELOC_FRAME (cont->dframe, offset);
+      if (!scm_is_null (cont->vm_conts))
+        { SCM vm_cont;
+          struct scm_vm_cont *data;
+          vm_cont = scm_cdr (scm_car (cont->vm_conts));
+          data = SCM_VM_CONT_DATA (vm_cont);
+          vmframe = scm_c_make_vm_frame (vm_cont,
+                                         data->stack_base + data->fp,
+                                         data->stack_base + data->sp,
+                                         data->ip,
+                                         data->reloc);
+        } else 
+          vmframe = SCM_BOOL_F;
     }
   else
     {
@@ -462,7 +534,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
      (SCM_BACKTRACE_MAXDEPTH). */
   id = SCM_BOOL_F;
   maxp = 0;
-  n = stack_depth (dframe, offset, &id, &maxp);
+  n = stack_depth (dframe, offset, vmframe, &id);
+  /* FIXME: redo maxp? */
   size = n * SCM_FRAME_N_SLOTS;
 
   /* Make the stack object. */
@@ -472,7 +545,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   SCM_STACK (stack) -> frames = iframe;
 
   /* Translate the current chain of stack frames into debugging information. */
-  n = read_frames (dframe, offset, n, iframe);
+  n = read_frames (dframe, offset, vmframe, n, iframe);
   SCM_STACK (stack) -> length = n;
 
   /* Narrow the stack according to the arguments given to scm_make_stack. */
@@ -500,12 +573,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       n = SCM_STACK (stack) -> length;
     }
   
+  if (n > 0 && maxp)
+    iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+
   if (n > 0)
-    {
-      if (maxp)
-       iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
-      return stack;
-    }
+    return stack;
   else
     return SCM_BOOL_F;
 }