diff options
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r-- | libguile/stacks.c | 104 |
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; } |