summaryrefslogtreecommitdiff
path: root/libguile/stacks.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r--libguile/stacks.c104
1 files changed, 88 insertions, 16 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 4b97a1827..85527bd6a 100644
--- 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;
}