diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1996-10-14 03:26:51 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1996-10-14 03:26:51 +0000 |
commit | 782d171cf0518cbb1d2611108121f4bd1584cccc (patch) | |
tree | b3e6fc0babf46763f41b5fcc147f51185f274136 /libguile/stacks.c | |
parent | 34019bd652658684b5fee9ba863a667f068c1d1e (diff) | |
download | guile-782d171cf0518cbb1d2611108121f4bd1584cccc.tar.gz |
* continuations.c, continuations.h, debug.c, gc.c, init.c, root.c,
stacks.c: Renamed regs --> scm_contregs.
* Makefile.in: Added entries for new files: backtrace.c,
backtrace.h, stacks.c and stacks.h.
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r-- | libguile/stacks.c | 578 |
1 files changed, 578 insertions, 0 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c new file mode 100644 index 000000000..e708a141b --- /dev/null +++ b/libguile/stacks.c @@ -0,0 +1,578 @@ +/* Representation of stack frame debug information + * Copyright (C) 1996 Mikael Djurfeldt + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + * The author can be reached at djurfeldt@nada.kth.se + * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN + */ + + +#include <stdio.h> +#include "_scm.h" +#include "debug.h" +#include "continuations.h" + +#include "stacks.h" + + +/* {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 an ordinary scheme vector. It is + * logically divided into sections of SCM values. Each section is an + * scm_info_frame struct. + * + * A frame is represented as a pair where the car contains a stack and + * the cdr an inum. The inum is an index to the first SCM value of + * the scm_info_frame struct. + * + * Stacks + * Constructor + * make-stack + * Selector + * stack-ref + * Inspector + * stack-length + * + * Frames + * Constructor + * last-stack-frame + * Selectors + * frame-number + * frame-source + * frame-procedure + * frame-arguments + * frame-previous + * frame-next + * Predicates + * frame-real? + * frame-procedure? + * frame-evaluating-args? + * frame-overflow? + */ + + + +/* Some auxiliary functions for reading debug frames off the stack. + */ + +/* 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 int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, int *maxp)); +static int +stack_depth (dframe, offset, maxp) + scm_debug_frame *dframe; + long offset; + int *maxp; +{ + int n, size; + int max_depth = SCM_BACKTRACE_MAXDEPTH; + scm_debug_info *info; + for (n = 0; + dframe && n < max_depth; + dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset)) + { + if (SCM_EVALFRAMEP (*dframe)) + { + size = dframe->status & SCM_MAX_FRAME_SIZE; + info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size]) + + offset); + n += (info - dframe->vect) / 2 + 1; + /* Data in the apply part of an eval info frame comes from previous + stack frame if the scm_debug_info vector is overflowed. */ + if ((((info - dframe->vect) & 1) == 0) + && SCM_OVERFLOWP (*dframe) + && !SCM_UNBNDP (info[1].a.proc)) + ++n; + } + else + ++n; + } + if (dframe) + *maxp = 1; + return n; +} + +/* Read debug info from DFRAME into IFRAME. + */ +static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe)); +static void +read_frame (dframe, offset, iframe) + scm_debug_frame *dframe; + long offset; + scm_info_frame *iframe; +{ + SCM flags = SCM_INUM0; + int size; + scm_debug_info *info; + if (SCM_EVALFRAMEP (*dframe)) + { + size = dframe->status & SCM_MAX_FRAME_SIZE; + info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size]) + + offset); + if ((info - dframe->vect) & 1) + { + /* Debug.vect ends with apply info. */ + --info; + if (info[1].a.proc != SCM_UNDEFINED) + { + 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; + } + } + iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env); + } + else + { + flags |= SCM_FRAMEF_PROC; + iframe->proc = dframe->vect[0].a.proc; + iframe->args = dframe->vect[0].a.args; + } + iframe->flags = flags; +} + +/* Fill the scm_info_frame vector IFRAME with data from N stack frames + * starting with the first stack frame represented by debug frame + * DFRAME. + */ +static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int skip, int n, scm_info_frame *iframes)); +static void +read_frames (dframe, offset, skip, n, iframes) + scm_debug_frame *dframe; + long offset; + int skip; + int n; + scm_info_frame *iframes; +{ + int size; + scm_info_frame *iframe = iframes; + scm_debug_info *info; + + for (; + dframe && n > 0; + dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset)) + { + read_frame (dframe, offset, iframe); + if (SCM_EVALFRAMEP (*dframe)) + { + size = dframe->status & SCM_MAX_FRAME_SIZE; + info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size]) + + offset); + if ((info - dframe->vect) & 1) + --info; + /* Data in the apply part of an eval info frame comes from + previous stack frame if the scm_debug_info vector is overflowed. */ + else if (SCM_OVERFLOWP (*dframe) + && !SCM_UNBNDP (info[1].a.proc)) + { + if (skip) + --skip; + else + { + ++iframe; + if (--n == 0) + goto quit; + } + iframe->flags = 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; + if (skip) + --skip; + else + { + ++iframe; + if (--n == 0) + goto quit; + } + while (info >= dframe->vect) + { + if (!SCM_UNBNDP (info[1].a.proc)) + { + iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC; + iframe->proc = info[1].a.proc; + iframe->args = info[1].a.args; + } + else + iframe->flags = SCM_INUM0; + iframe->source = scm_make_memoized (info[0].e.exp, + info[0].e.env); + info -= 2; + if (skip) + --skip; + else + { + ++iframe; + if (--n == 0) + goto quit; + } + } + } + else + { + if (skip) + --skip; + else + { + ++iframe; + --n; + } + } + quit: + if (iframe > iframes) + (iframe - 1) -> flags |= SCM_FRAMEF_REAL; + } +} + + + +/* Stacks + */ + +SCM_PROC (s_make_stack, "make-stack", 0, 3, 0, scm_make_stack); +SCM +scm_make_stack (obj, inner_cut, outer_cut) + SCM obj; + SCM inner_cut; + SCM outer_cut; +{ + int i, n, maxp = 0, size; + scm_debug_frame *dframe; + scm_info_frame *iframe; + long offset = 0; + SCM stack; + + if (SCM_UNBNDP (inner_cut)) + inner_cut = SCM_INUM0; + if (SCM_UNBNDP (outer_cut)) + outer_cut = SCM_INUM0; + SCM_ASSERT (SCM_INUMP (inner_cut), inner_cut, SCM_ARG2, s_make_stack); + SCM_ASSERT (SCM_INUMP (outer_cut), outer_cut, SCM_ARG3, s_make_stack); + + if (SCM_IMP (obj) + || (!SCM_DEBUGOBJP (obj) && (scm_tc7_contin != SCM_TYP7 (obj)))) + dframe = scm_last_debug_frame; + else + { + SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack); + if (SCM_DEBUGOBJP (obj)) + dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); + else if (scm_tc7_contin == SCM_TYP7 (obj)) + { + offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) + - SCM_BASE (obj)); +#ifndef STACK_GROWS_UP + offset += SCM_LENGTH (obj); +#endif + dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj) + + offset); + } + else scm_wta (obj, (char *) SCM_ARG1, s_make_stack); + } + + i = SCM_INUM (inner_cut); + n = stack_depth (dframe, offset, &maxp) - i - SCM_INUM (outer_cut); + if (n < 0) + n = 0; + size = n * SCM_FRAME_N_SLOTS; + + stack = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F, SCM_UNDEFINED); + iframe = (scm_info_frame *) SCM_VELTS (stack); + read_frames ((scm_debug_frame *) ((SCM_STACKITEM *) dframe + offset), + offset, + i, + n, + iframe); + + if (n > 0 && maxp) + iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; + + return stack; +} + +SCM_PROC(s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref); +SCM +scm_stack_ref (stack, i) + SCM stack; + SCM i; +{ + SCM_ASSERT (SCM_NIMP (stack) + && SCM_STACKP (stack), + stack, + SCM_ARG1, + s_stack_ref); + SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref); + SCM_ASSERT (SCM_INUM (i) >= 0 + && SCM_INUM (i) < SCM_STACK_LENGTH (stack), + i, + SCM_OUTOFRANGE, + s_stack_ref); + return scm_cons (stack, i); +} + +SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length); +SCM +scm_stack_length (stack) + SCM stack; +{ + SCM_ASSERT (SCM_NIMP (stack) + && SCM_STACKP (stack), + stack, + SCM_ARG1, + s_stack_length); + return SCM_MAKINUM (SCM_STACK_LENGTH (stack)); +} + +/* Frames + */ + +SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame); +SCM +scm_last_stack_frame (obj) + SCM obj; +{ + scm_debug_frame *dframe; + long offset = 0; + SCM fobj, v; + + SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame); + if (SCM_DEBUGOBJP (obj)) + dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); + else if (scm_tc7_contin == SCM_TYP7 (obj)) + { + offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) + - SCM_BASE (obj)); +#ifndef STACK_GROWS_UP + offset += SCM_LENGTH (obj); +#endif + dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj) + offset); + } + else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame); + + if (!dframe) + return SCM_BOOL_F; + + v = scm_make_vector (SCM_MAKINUM (SCM_FRAME_N_SLOTS), + SCM_BOOL_F, + SCM_UNDEFINED); + + SCM_NEWCELL (fobj); + SCM_DEFER_INTS; + SCM_SETCAR (fobj, v); + SCM_SETCDR (fobj, SCM_INUM0); + SCM_ALLOW_INTS; + + read_frame (dframe, offset, (scm_info_frame *) SCM_VELTS (v)); + + return fobj; +} + +SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number); +SCM +scm_frame_number (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_number); + return SCM_MAKINUM (SCM_FRAME_NUMBER (frame)); +} + +SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source); +SCM +scm_frame_source (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_source); + return SCM_FRAME_SOURCE (frame); +} + +SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure); +SCM +scm_frame_procedure (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_procedure); + return (SCM_FRAME_PROC_P (frame) + ? SCM_BOOL_F + : SCM_FRAME_PROC (frame)); +} + +SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments); +SCM +scm_frame_arguments (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_arguments); + return SCM_FRAME_ARGS (frame); +} + +SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous); +SCM +scm_frame_previous (frame) + SCM frame; +{ + int n; + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_previous); + n = SCM_INUM (SCM_CDR (frame)) + 1; + if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) + return SCM_BOOL_F; + else + return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); +} + +SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next); +SCM +scm_frame_next (frame) + SCM frame; +{ + int n; + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_next); + n = SCM_INUM (SCM_CDR (frame)) - 1; + if (n < 0) + return SCM_BOOL_F; + else + return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); +} + +SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p); +SCM +scm_frame_real_p (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_real_p); + return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p); +SCM +scm_frame_procedure_p (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_procedure_p); + return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p); +SCM +scm_frame_evaluating_args_p (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_evaluating_args_p); + return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p); +SCM +scm_frame_overflow_p (frame) + SCM frame; +{ + SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), + frame, + SCM_ARG1, + s_frame_overflow_p); + return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; +} + + + +void +scm_init_stacks () +{ +#include "stacks.x" +} |