X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/7f12a94355dbe2dc78b682f35d40fa7d9c9961e8..3b91e017e32e1fb6b911f456c61aea6386075095:/libguile/stacks.c diff --git a/libguile/stacks.c b/libguile/stacks.c index 9a38ff0f9..5b2eea99d 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,5 +1,5 @@ /* Representation of stack frame debug information - * Copyright (C) 1996,1997,2000,2001 Free Software Foundation + * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -13,11 +13,14 @@ * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#ifdef HAVE_CONFIG_H +# include +#endif #include "libguile/_scm.h" #include "libguile/eval.h" @@ -29,9 +32,14 @@ #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" +#include "libguile/private-options.h" + /* {Frames and stacks} @@ -118,19 +126,17 @@ #define RELOC_FRAME(ptr, offset) \ ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) - /* 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)) @@ -143,15 +149,39 @@ 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)) + { + if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + /* count vmframe back to previous boot frame */ + for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe)) + { + if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + ++n; + else + { /* skip boot frame, cut out of the vm backtrace */ + vmframe = scm_c_vm_frame_prev (vmframe); + break; + } + } + } + else + ++n; /* increment for non-program apply frame */ + } else ++n; } if (dframe && SCM_VOIDFRAMEP (*dframe)) *id = RELOC_INFO(dframe->vect, offset)[0].id; - else if (dframe) - *maxp = 1; return n; } @@ -229,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; @@ -288,13 +318,39 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, NEXT_FRAME (iframe, n, quit); } } - else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply)) - /* Skip gsubr apply frames. */ - continue; + else if (SCM_PROGRAM_P (iframe->proc)) + { + if (!SCM_PROGRAM_IS_BOOT (iframe->proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + 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 + { + /* 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; + } + } + } else - { - NEXT_FRAME (iframe, n, quit); - } + { + NEXT_FRAME (iframe, n, quit); + } quit: if (iframe > iframes) (iframe - 1) -> flags |= SCM_FRAMEF_REAL; @@ -426,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; @@ -434,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)) { - dframe = scm_last_debug_frame; + 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->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); + } else + vmframe = SCM_BOOL_F; } else { @@ -457,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. */ @@ -465,10 +543,15 @@ 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, n, iframe); - SCM_STACK (stack) -> length = n; + n = read_frames (dframe, offset, vmframe, n, iframe); + if (n != SCM_STACK (stack)->length) + { + scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); + SCM_STACK (stack)->length = n; + } /* Narrow the stack according to the arguments given to scm_make_stack. */ SCM_VALIDATE_REST_ARGUMENT (args); @@ -495,12 +578,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; } @@ -515,7 +597,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, long offset = 0; if (scm_is_eq (stack, SCM_BOOL_T)) { - dframe = scm_last_debug_frame; + dframe = scm_i_last_debug_frame (); } else if (SCM_DEBUGOBJP (stack)) { @@ -581,9 +663,8 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, (SCM obj), - "Return a stack which consists of a single frame, which is the\n" - "last stack frame for @var{obj}. @var{obj} must be either a\n" - "debug object or a continuation.") + "Return the last (innermost) frame of @var{obj}, which must be\n" + "either a debug object or a continuation.") #define FUNC_NAME s_scm_last_stack_frame { scm_t_debug_frame *dframe; @@ -740,14 +821,10 @@ SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, void scm_init_stacks () { - SCM vtable; - SCM stack_layout - = scm_make_struct_layout (scm_from_locale_string (SCM_STACK_LAYOUT)); - vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - scm_stack_type - = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, - scm_cons (stack_layout, - SCM_EOL))); + scm_stack_type = + scm_permanent_object + (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), + SCM_UNDEFINED)); scm_set_struct_vtable_name_x (scm_stack_type, scm_from_locale_symbol ("stack")); #include "libguile/stacks.x"