fix boot program detection, which in turn makes `make-stack' actually work

* libguile/programs.h (SCM_F_PROGRAM_IS_BOOT, SCM_PROGRAM_IS_BOOT): Flags
  for determining if a program is a boot program. It turns out that our
  heuristics e.g. in stacks.c would catch non-boot programs, like
  programs that end with (goto/args 1), because the 1 is the same byte as
  `halt'. That took a while to find...

* libguile/stacks.c (stack_depth, read_frames): Use the new boot prog
  macros.
  (scm_make_stack): Assert that we read the number of frames that we said
  we would.

* libguile/vm.c (really_make_boot_program): Mark boot programs
  appropriately.

diff --git a/libguile/programs.h b/libguile/programs.h
index 7d94788..263228b 100644 (file)
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -53,12 +53,15 @@ typedef unsigned char scm_byte_t;
 
 extern scm_t_bits scm_tc16_program;
 
+#define SCM_F_PROGRAM_IS_BOOT (1<<0)
+
 #define SCM_PROGRAM_P(x)       (SCM_SMOB_PREDICATE (scm_tc16_program, x))
 #define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
 #define SCM_PROGRAM_OBJTABLE(x)        (SCM_SMOB_OBJECT_2 (x))
 #define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
 #define SCM_PROGRAM_DATA(x)    (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
 #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
 
 extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
 

diff --git a/libguile/stacks.c b/libguile/stacks.c
index cef01e4..8f4e886 100644 (file)
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -126,13 +126,6 @@
 #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_objcode *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
-  return bp->base[bp->len-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.
@@ -163,19 +156,25 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
           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 */
+              /* count vmframe back to previous boot 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 */
+                  if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+                    { /* skip boot frame, cut out of the vm backtrace */
                       vmframe = scm_c_vm_frame_prev (vmframe);
                       break;
                     }
                   else
                     ++n;
                 }
+              if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
+                ++n; /* increment for apply frame if this isn't a boot frame */
             }
-          ++n; /* increment for apply frame in any case */
+          else if (scm_is_eq (vect[0].a.proc, scm_f_gsubr_apply))
+            /* Skip gsubr apply frames. */
+            continue;
+          else
+            ++n; /* increment for non-program apply frame */
         }
       else
        ++n;
@@ -321,36 +320,39 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
       else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
        /* Skip gsubr apply frames. */
        continue;
-      else
-       {
-          if (SCM_PROGRAM_P (iframe->proc))
+      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))
             {
-              scm_t_info_frame saved = *iframe;
-              for (; scm_is_true (vmframe);
-                   vmframe = scm_c_vm_frame_prev (vmframe))
+              if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+                { /* skip boot frame, back to interpreted frames */
+                  vmframe = scm_c_vm_frame_prev (vmframe);
+                  break;
+                }
+              else 
                 {
-                  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;
-                    }
+                  /* 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;
                 }
+            }
+          if (!SCM_PROGRAM_IS_BOOT (saved.proc))
+            {
               *iframe = saved;
+              NEXT_FRAME (iframe, n, quit);
             }
-
-         NEXT_FRAME (iframe, n, quit);
-       }
+        }
+      else
+        {
+          NEXT_FRAME (iframe, n, quit);
+        }
     quit:
       if (iframe > iframes)
        (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
@@ -543,10 +545,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   SCM_STACK (stack) -> id = id;
   iframe = &SCM_STACK (stack) -> tail[0];
   SCM_STACK (stack) -> frames = iframe;
+  SCM_STACK (stack) -> length = n;
 
   /* Translate the current chain of stack frames into debugging information. */
-  n = read_frames (dframe, offset, vmframe, n, iframe);
-  SCM_STACK (stack) -> length = n;
+  if (read_frames (dframe, offset, vmframe, n, iframe) != n)
+    abort (); /* we counted wrong, this really shouldn't happen */
 
   /* Narrow the stack according to the arguments given to scm_make_stack. */
   SCM_VALIDATE_REST_ARGUMENT (args);

diff --git a/libguile/vm.c b/libguile/vm.c
index 5dcce1b..ca60fc7 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -255,12 +255,15 @@ really_make_boot_program (long nargs)
                         0, 0, 0, 0,
                         0, 0, 0, 0,
                         scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
+  SCM ret;
   ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
     abort ();
   bytes[13] = (scm_byte_t)nargs;
-  return scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
-                           SCM_BOOL_F, SCM_EOL);
+  ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
+                          SCM_BOOL_F, SCM_EOL);
+  SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+  return ret;
 }
 #define NUM_BOOT_PROGS 8
 static SCM