diff --git a/libguile/continuations.c b/libguile/continuations.c index a0e2f6d4f..7013e3d66 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -84,7 +84,6 @@ scm_make_continuation (int *first) continuation->dynenv = scm_i_dynwinds (); continuation->throw_value = SCM_EOL; continuation->root = thread->continuation_root; - continuation->dframe = scm_i_last_debug_frame (); src = thread->continuation_base; #if ! SCM_STACK_GROWS_UP src -= stack_size; @@ -190,8 +189,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, data.dst = dst; scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data); - scm_i_set_last_debug_frame (continuation->dframe); - continuation->throw_value = val; SCM_I_LONGJMP (continuation->jmpbuf, 1); } @@ -276,17 +273,14 @@ scm_i_with_continuation_barrier (scm_t_catch_body body, scm_i_thread *thread = SCM_I_CURRENT_THREAD; SCM old_controot; SCM_STACKITEM *old_contbase; - scm_t_debug_frame *old_lastframe; SCM result; /* Establish a fresh continuation root. */ old_controot = thread->continuation_root; old_contbase = thread->continuation_base; - old_lastframe = thread->last_debug_frame; thread->continuation_root = scm_cons (thread->handle, old_controot); thread->continuation_base = &stack_item; - thread->last_debug_frame = NULL; /* Call FUNC inside a catch all. This is now guaranteed to return directly and exactly once. @@ -298,7 +292,6 @@ scm_i_with_continuation_barrier (scm_t_catch_body body, /* Return to old continuation root. */ - thread->last_debug_frame = old_lastframe; thread->continuation_base = old_contbase; thread->continuation_root = old_controot; diff --git a/libguile/continuations.h b/libguile/continuations.h index 82cf178b0..8f7e38eba 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -3,7 +3,7 @@ #ifndef SCM_CONTINUATIONS_H #define SCM_CONTINUATIONS_H -/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -64,11 +64,6 @@ typedef struct */ scm_t_ptrdiff offset; - /* The most recently created debug frame on the live stack, before - it was saved. This needs to be adjusted with OFFSET, above. - */ - struct scm_t_debug_frame *dframe; - SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */ } scm_t_contregs; diff --git a/libguile/debug.c b/libguile/debug.c index f0dd29a0a..91eef165b 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -49,6 +49,7 @@ #include "libguile/fluids.h" #include "libguile/programs.h" #include "libguile/memoize.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/debug.h" @@ -73,7 +74,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, scm_dynwind_critical_section (SCM_BOOL_F); ans = scm_options (setting, scm_debug_opts, FUNC_NAME); - if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) + if (SCM_N_FRAMES < 1) { scm_options (ans, scm_debug_opts, FUNC_NAME); SCM_OUT_OF_RANGE (1, setting); @@ -246,52 +247,10 @@ SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0, "Call @var{thunk} on an evaluator stack tagged with @var{id}.") #define FUNC_NAME s_scm_sys_start_stack { - SCM answer; - scm_t_debug_frame vframe; - scm_t_debug_info vframe_vect_body; - vframe.prev = scm_i_last_debug_frame (); - vframe.status = SCM_VOIDFRAME; - vframe.vect = &vframe_vect_body; - vframe.vect[0].id = id; - scm_i_set_last_debug_frame (&vframe); - answer = scm_call_0 (thunk); - scm_i_set_last_debug_frame (vframe.prev); - return answer; + return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id); } #undef FUNC_NAME -/* {Debug Objects} - * - * The debugging evaluator throws these on frame traps. - */ - -scm_t_bits scm_tc16_debugobj; - -static int -debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_puts ("#', port); - return 1; -} - -SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a debug object.") -#define FUNC_NAME s_scm_debug_object_p -{ - return scm_from_bool(SCM_DEBUGOBJP (obj)); -} -#undef FUNC_NAME - - -SCM -scm_make_debugobj (scm_t_debug_frame *frame) -{ - return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame); -} - /* Undocumented debugging procedure */ @@ -337,9 +296,6 @@ scm_init_debug () init_stack_limit (); scm_init_opts (scm_debug_options, scm_debug_opts); - scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); - scm_set_smob_print (scm_tc16_debugobj, debugobj_print); - scm_add_feature ("debug-extensions"); #include "libguile/debug.x" diff --git a/libguile/debug.h b/libguile/debug.h index 24c6b9e94..2ca0b529a 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -29,22 +29,6 @@ #include "libguile/options.h" -/* - * Here comes some definitions for the debugging machinery. - * It might seem strange to represent debug flags as ints, - * but consider that any particular piece of code is normally - * only interested in one flag at a time. This is then - * the most efficient representation. - */ - -/* {Options} - */ - -/* scm_debug_opts is defined in eval.c. - */ - - - /* {Evaluator} */ @@ -55,57 +39,8 @@ typedef union scm_t_debug_info SCM id; } scm_t_debug_info; -typedef struct scm_t_debug_frame -{ - struct scm_t_debug_frame *prev; - long status; - scm_t_debug_info *vect; - scm_t_debug_info *info; -} scm_t_debug_frame; - -#define SCM_EVALFRAME (0L << 11) -#define SCM_APPLYFRAME (1L << 11) -#define SCM_VOIDFRAME (3L << 11) -#define SCM_MACROEXPF (1L << 10) -#define SCM_TAILREC (1L << 9) -#define SCM_TRACED_FRAME (1L << 8) -#define SCM_ARGS_READY (1L << 7) -#define SCM_DOVERFLOW (1L << 6) -#define SCM_MAX_FRAME_SIZE 63 - -#define SCM_FRAMETYPE (3L << 11) - -#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME) -#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME) -#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME) -#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0) -#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0) -#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0) -#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0) -#define SCM_MACROEXPP(x) (((x).status & SCM_MACROEXPF) != 0) -#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW) -#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY) -#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY) -#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME) -#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME) -#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC) -#define SCM_SET_MACROEXP(x) ((x).status |= SCM_MACROEXPF) -#define SCM_CLEAR_MACROEXP(x) ((x).status &= ~SCM_MACROEXPF) - -/* {Debug Objects} - */ - -SCM_API scm_t_bits scm_tc16_debugobj; - -#define SCM_DEBUGOBJP(x) \ - SCM_TYP16_PREDICATE (scm_tc16_debugobj, x) -#define SCM_DEBUGOBJ_FRAME(x) \ - ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x)) -#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f) - -SCM_API SCM scm_debug_object_p (SCM obj); SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); SCM_API SCM scm_procedure_module (SCM proc); @@ -114,9 +49,7 @@ SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_with_traps (SCM thunk); SCM_API SCM scm_evaluator_traps (SCM setting); SCM_API SCM scm_debug_options (SCM setting); -SCM_API SCM scm_make_debugobj (scm_t_debug_frame *debug); -SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized); SCM_INTERNAL void scm_init_debug (void); #ifdef GUILE_DEBUG diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 1f35d2a55..8b1fce81a 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1416,14 +1416,6 @@ scm_i_deprecated_dynwinds (void) return scm_i_dynwinds (); } -scm_t_debug_frame * -scm_i_deprecated_last_debug_frame (void) -{ - scm_c_issue_deprecation_warning - ("scm_last_debug_frame is deprecated. Do not use it."); - return scm_i_last_debug_frame (); -} - SCM_STACKITEM * scm_i_stack_base (void) { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5570a4386..1c8a6442b 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -499,7 +499,6 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a); #define scm_cur_loadp scm_i_cur_loadp () #define scm_progargs scm_i_progargs () #define scm_dynwinds scm_i_deprecated_dynwinds () -#define scm_last_debug_frame scm_i_deprecated_last_debug_frame () #define scm_stack_base scm_i_stack_base () SCM_DEPRECATED SCM scm_i_cur_inp (void); @@ -508,7 +507,6 @@ SCM_DEPRECATED SCM scm_i_cur_errp (void); SCM_DEPRECATED SCM scm_i_cur_loadp (void); SCM_DEPRECATED SCM scm_i_progargs (void); SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void); -SCM_DEPRECATED scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void); SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void); /* Deprecated because it evaluates its argument twice. diff --git a/libguile/stacks.c b/libguile/stacks.c index 79fe2bda6..16c851f6e 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -43,32 +43,6 @@ /* {Frames and stacks} - * - * The debugging evaluator creates debug frames on the stack. These - * are linked from the innermost frame and outwards. The last frame - * created can always be accessed as SCM_LAST_DEBUG_FRAME. - * Continuations contain a pointer to the innermost debug frame on the - * continuation stack. - * - * Each debug frame contains a set of flags and information about one - * or more stack frames. The case of multiple frames occurs due to - * tail recursion. The maximal number of stack frames which can be - * recorded in one debug frame can be set dynamically with the debug - * option FRAMES. - * - * Stack frame information is of two types: eval information (the - * expression being evaluated and its environment) and apply - * information (the procedure being applied and its arguments). A - * stack frame normally corresponds to an eval/apply pair, but macros - * and special forms (which are implemented as macros in Guile) only - * have eval information and apply calls leads to apply only frames. - * - * Since we want to record the total stack information and later - * manipulate this data at the scheme level in the debugger, we need - * to transform it into a new representation. In the following code - * section you'll find the functions implementing this data type. - * - * Representation: * * The stack is represented as a struct with an id slot and a tail * array of scm_t_info_frame structs. @@ -104,248 +78,48 @@ -/* Some auxiliary functions for reading debug frames off the stack. - */ +static SCM stack_id_with_fp (SCM vmframe, SCM **fp); -/* Stacks often contain pointers to other items on the stack; for - example, each scm_t_debug_frame structure contains a pointer to the - next frame out. When we capture a continuation, we copy the stack - into the heap, and just leave all the pointers unchanged. This - makes it simple to restore the continuation --- just copy the stack - back! However, if we retrieve a pointer from the heap copy to - another item that was originally on the stack, we have to add an - offset to the pointer to discover the new referent. - - If PTR is a pointer retrieved from a continuation, whose original - target was on the stack, and OFFSET is the appropriate offset from - the original stack to the continuation, then RELOC_MUMBLE (PTR, - OFFSET) is a pointer to the copy in the continuation of the - original referent, cast to an scm_debug_MUMBLE *. */ -#define RELOC_INFO(ptr, offset) \ - ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) -#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. +/* Count number of debug info frames on a stack, beginning with VMFRAME. */ static long -stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe, - SCM *id) +stack_depth (SCM vmframe, SCM *fp) { long n; - for (n = 0; - dframe && !SCM_VOIDFRAMEP (*dframe); - dframe = RELOC_FRAME (dframe->prev, offset)) - { - if (SCM_EVALFRAMEP (*dframe)) - { - scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); - scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); - /* If current frame is a macro during expansion, we should - skip the previously recorded macro transformer - application frame. */ - if (SCM_MACROEXPP (*dframe) && n > 0) - --n; - n += (info - vect) / 2 + 1; - /* Data in the apply part of an eval info frame comes from previous - stack frame if the scm_t_debug_info vector is overflowed. */ - if ((((info - vect) & 1) == 0) - && SCM_OVERFLOWP (*dframe) - && !SCM_UNBNDP (info[1].a.proc)) - ++n; - } - else - { - 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 */ - } - } - if (dframe && SCM_VOIDFRAMEP (*dframe)) - *id = RELOC_INFO(dframe->vect, offset)[0].id; + /* count vmframes, skipping boot frames */ + for (; scm_is_true (vmframe) && SCM_VM_FRAME_FP (vmframe) > fp; + vmframe = scm_c_vm_frame_prev (vmframe)) + if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + ++n; return n; } -/* Read debug info from DFRAME into IFRAME. - */ -static void -read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, - scm_t_info_frame *iframe) -{ - scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ - if (SCM_EVALFRAMEP (*dframe)) - { - scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); - scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); - if ((info - vect) & 1) - { - /* Debug.vect ends with apply info. */ - --info; - if (!SCM_UNBNDP (info[1].a.proc)) - { - flags |= SCM_FRAMEF_PROC; - iframe->proc = info[1].a.proc; - iframe->args = info[1].a.args; - if (!SCM_ARGS_READY_P (*dframe)) - flags |= SCM_FRAMEF_EVAL_ARGS; - } - } - } - else - { - scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); - flags |= SCM_FRAMEF_PROC; - iframe->proc = vect[0].a.proc; - iframe->args = vect[0].a.args; - } - iframe->flags = flags; -} - -/* Look up the first body form of the apply closure. We'll use this - below to prevent it from being displayed. -*/ -static SCM -get_applybody () -{ - SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) - return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var))); - else - return SCM_UNDEFINED; -} - -#define NEXT_FRAME(iframe, n, quit) \ -do { \ - ++iframe; \ - if (--n == 0) \ - goto quit; \ -} while (0) - - /* Fill the scm_t_info_frame vector IFRAME with data from N stack frames - * starting with the first stack frame represented by debug frame - * DFRAME. + * starting with the first stack frame represented by VMFRAME. */ static scm_t_bits -read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, - SCM vmframe, long n, scm_t_info_frame *iframes) +read_frames (SCM vmframe, long n, scm_t_info_frame *iframes) { scm_t_info_frame *iframe = iframes; - scm_t_debug_info *info, *vect; - static SCM applybody = SCM_UNDEFINED; - - /* The value of applybody has to be setup after r4rs.scm has executed. */ - if (SCM_UNBNDP (applybody)) - applybody = get_applybody (); - for (; - dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0; - dframe = RELOC_FRAME (dframe->prev, offset)) + + for (; scm_is_true (vmframe); + vmframe = scm_c_vm_frame_prev (vmframe)) { - read_frame (dframe, offset, iframe); - if (SCM_EVALFRAMEP (*dframe)) - { - /* If current frame is a macro during expansion, we should - skip the previously recorded macro transformer - application frame. */ - if (SCM_MACROEXPP (*dframe) && iframe > iframes) - { - *(iframe - 1) = *iframe; - --iframe; - ++n; - } - info = RELOC_INFO (dframe->info, offset); - vect = RELOC_INFO (dframe->vect, offset); - if ((info - vect) & 1) - --info; - /* Data in the apply part of an eval info frame comes from - previous stack frame if the scm_t_debug_info vector is - overflowed. */ - else if (SCM_OVERFLOWP (*dframe) - && !SCM_UNBNDP (info[1].a.proc)) - { - NEXT_FRAME (iframe, n, quit); - iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC; - iframe->proc = info[1].a.proc; - iframe->args = info[1].a.args; - } - if (SCM_OVERFLOWP (*dframe)) - iframe->flags |= SCM_FRAMEF_OVERFLOW; - info -= 2; - NEXT_FRAME (iframe, n, quit); - while (info >= vect) - { - if (!SCM_UNBNDP (info[1].a.proc)) - { - iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC; - iframe->proc = info[1].a.proc; - iframe->args = info[1].a.args; - } - else - iframe->flags = SCM_UNPACK (SCM_INUM0); - iframe->source = SCM_BOOL_F; - info -= 2; - NEXT_FRAME (iframe, n, quit); - } - } - else if (SCM_PROGRAM_P (iframe->proc)) + if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + /* skip boot frame */ + continue; + else { - 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; - } - } + /* 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) + break; } - else - { - NEXT_FRAME (iframe, n, quit); - } - quit: - if (iframe > iframes) - (iframe - 1) -> flags |= SCM_FRAMEF_REAL; } return iframe - iframes; /* Number of frames actually read */ } @@ -448,11 +222,10 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { long n, size; int maxp; - scm_t_debug_frame *dframe; scm_t_info_frame *iframe; SCM vmframe; - long offset = 0; - SCM stack, id; + SCM stack; + SCM id, *id_fp; SCM inner_cut, outer_cut; /* Extract a pointer to the innermost frame of whatever object @@ -460,24 +233,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, 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; - } + 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; @@ -497,12 +259,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* not reached */ } + if (scm_is_false (vmframe)) + return SCM_BOOL_F; + + /* Get ID of the stack corresponding to the given frame. */ + id = stack_id_with_fp (vmframe, &id_fp); + /* Count number of frames. Also get stack id tag and check whether there are more stackframes than we want to record (SCM_BACKTRACE_MAXDEPTH). */ id = SCM_BOOL_F; maxp = 0; - n = stack_depth (dframe, offset, vmframe, &id); + n = stack_depth (vmframe, id_fp); /* FIXME: redo maxp? */ size = n * SCM_FRAME_N_SLOTS; @@ -514,7 +282,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, SCM_STACK (stack) -> length = n; /* Translate the current chain of stack frames into debugging information. */ - n = read_frames (dframe, offset, vmframe, n, iframe); + n = read_frames (vmframe, n, iframe); if (n != SCM_STACK (stack)->length) { scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); @@ -561,39 +329,58 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, "Return the identifier given to @var{stack} by @code{start-stack}.") #define FUNC_NAME s_scm_stack_id { - scm_t_debug_frame *dframe; - long offset = 0; + SCM vmframe, *id_fp; + if (scm_is_eq (stack, SCM_BOOL_T)) { - dframe = scm_i_last_debug_frame (); - } - else if (SCM_DEBUGOBJP (stack)) - { - dframe = SCM_DEBUGOBJ_FRAME (stack); + struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); + vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); } + else if (SCM_VM_FRAME_P (stack)) + vmframe = stack; else if (SCM_CONTINUATIONP (stack)) { scm_t_contregs *cont = SCM_CONTREGS (stack); - offset = cont->offset; - dframe = RELOC_FRAME (cont->dframe, offset); - } - else if (SCM_STACKP (stack)) - { - return SCM_STACK (stack) -> id; + 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 { - SCM_WRONG_TYPE_ARG (1, stack); + SCM_WRONG_TYPE_ARG (SCM_ARG1, stack); + /* not reached */ } - while (dframe && !SCM_VOIDFRAMEP (*dframe)) - dframe = RELOC_FRAME (dframe->prev, offset); - if (dframe && SCM_VOIDFRAMEP (*dframe)) - return RELOC_INFO (dframe->vect, offset)[0].id; - return SCM_BOOL_F; + return stack_id_with_fp (vmframe, &id_fp); } #undef FUNC_NAME +static SCM +stack_id_with_fp (SCM vmframe, SCM **fp) +{ + SCM holder = SCM_VM_FRAME_STACK_HOLDER (vmframe); + + if (SCM_VM_CONT_P (holder)) + { + *fp = NULL; + return SCM_BOOL_F; + } + else + { + *fp = NULL; + return SCM_BOOL_F; + } +} + SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, (SCM stack, SCM index), "Return the @var{index}'th frame from @var{stack}.") @@ -629,46 +416,6 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, - (SCM obj), - "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; - long offset = 0; - SCM stack; - - if (SCM_DEBUGOBJP (obj)) - { - dframe = SCM_DEBUGOBJ_FRAME (obj); - } - else if (SCM_CONTINUATIONP (obj)) - { - scm_t_contregs *cont = SCM_CONTREGS (obj); - offset = cont->offset; - dframe = RELOC_FRAME (cont->dframe, offset); - } - else - { - SCM_WRONG_TYPE_ARG (1, obj); - /* not reached */ - } - - if (!dframe || SCM_VOIDFRAMEP (*dframe)) - return SCM_BOOL_F; - - stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS), - SCM_EOL); - SCM_STACK (stack) -> length = 1; - SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; - read_frame (dframe, offset, - (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); - - return scm_cons (stack, SCM_INUM0); -} -#undef FUNC_NAME - SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, (SCM frame), "Return the frame number of @var{frame}.") diff --git a/libguile/threads.c b/libguile/threads.c index 1527e01d1..bf2fdb226 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -338,7 +338,6 @@ guilify_self_1 (SCM_STACKITEM *base) t->block_asyncs = 1; t->pending_asyncs = 1; t->critical_section_level = 0; - t->last_debug_frame = NULL; t->base = base; #ifdef __ia64__ /* Calculate and store off the base of this thread's register diff --git a/libguile/threads.h b/libguile/threads.h index 5afe45faa..4b06590e4 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -79,7 +79,6 @@ typedef struct scm_i_thread { /* Other thread local things. */ SCM dynamic_state; - scm_t_debug_frame *last_debug_frame; SCM dynwinds; /* For system asyncs. @@ -209,9 +208,6 @@ SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key; # define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds) # define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w)) -# define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame) -# define scm_i_set_last_debug_frame(f) \ - (SCM_I_CURRENT_THREAD->last_debug_frame = (f)) #endif /* BUILDING_LIBGUILE */ diff --git a/libguile/throw.c b/libguile/throw.c index 14153cf91..051f6d382 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -62,8 +62,6 @@ static scm_t_bits tc16_jmpbuffer; #define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) -#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) -#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v))) #define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x)) #define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v))) @@ -187,7 +185,6 @@ scm_c_catch (SCM tag, answer = SCM_EOL; scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ())); SETJBJMPBUF(jmpbuf, &jbr.buf); - SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ()); pre_unwind.handler = pre_unwind_handler; pre_unwind.handler_data = pre_unwind_handler_data; @@ -888,7 +885,6 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); jbr->throw_tag = key; jbr->retval = args; - scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf)); SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1); } diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 03993ec7e..2f3320c29 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -23,13 +23,11 @@ #define VM_USE_CLOCK 0 /* Bogoclock */ #define VM_CHECK_OBJECT 1 /* Check object table */ #define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */ -#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 #define VM_CHECK_OBJECT 1 #define VM_CHECK_FREE_VARIABLES 1 -#define VM_PUSH_DEBUG_FRAMES 1 #else #error unknown debug engine VM_ENGINE #endif @@ -66,12 +64,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) static void **jump_table = NULL; #endif -#if VM_PUSH_DEBUG_FRAMES - scm_t_debug_frame debug; - scm_t_debug_info debug_vect_body; - debug.status = SCM_VOIDFRAME; -#endif - #ifdef HAVE_LABELS_AS_VALUES if (SCM_UNLIKELY (!jump_table)) { @@ -95,15 +87,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Boot program */ program = vm_make_boot_program (nargs); -#if VM_PUSH_DEBUG_FRAMES - debug.prev = scm_i_last_debug_frame (); - debug.status = SCM_APPLYFRAME; - debug.vect = &debug_vect_body; - debug.vect[0].a.proc = program; /* the boot program */ - debug.vect[0].a.args = SCM_EOL; - scm_i_set_last_debug_frame (&debug); -#endif - /* Initial frame */ CACHE_REGISTER (); PUSH ((SCM)fp); /* dynamic link */ @@ -147,9 +130,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_done: SYNC_ALL (); -#if VM_PUSH_DEBUG_FRAMES - scm_i_set_last_debug_frame (debug.prev); -#endif return finish_args; /* Errors */ @@ -278,7 +258,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) #undef VM_USE_CLOCK #undef VM_CHECK_OBJECT #undef VM_CHECK_FREE_VARIABLE -#undef VM_PUSH_DEBUG_FRAMES /* Local Variables: diff --git a/libguile/vm.c b/libguile/vm.c index 247bb7d09..4652cc03d 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -531,6 +531,12 @@ scm_vm_apply (SCM vm, SCM program, SCM args) } #undef FUNC_NAME +SCM +scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id) +{ + return scm_c_vm_run (vm, thunk, NULL, 0); +} + /* Scheme interface */ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, diff --git a/libguile/vm.h b/libguile/vm.h index eace1cb69..8ec26826d 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -65,6 +65,7 @@ SCM_API SCM scm_the_vm (); SCM_API SCM scm_make_vm (void); SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); +SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id); SCM_API SCM scm_vm_option_ref (SCM vm, SCM key); SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test index d96274e32..f6db40e58 100644 --- a/test-suite/tests/continuations.test +++ b/test-suite/tests/continuations.test @@ -1,7 +1,7 @@ ;;;; -*- scheme -*- ;;;; continuations.test --- test suite for continutations ;;;; -;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -87,9 +87,6 @@ (pass-if "get a continuation's stack ID" (let ((id (call-with-current-continuation stack-id))) - (or (boolean? id) (symbol? id)))) - - (pass-if "get a continuation's innermost frame" - (pair? (call-with-current-continuation last-stack-frame)))) + (or (boolean? id) (symbol? id))))) )