summaryrefslogtreecommitdiff
path: root/libguile/stacks.c
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-14 03:26:51 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1996-10-14 03:26:51 +0000
commit782d171cf0518cbb1d2611108121f4bd1584cccc (patch)
treeb3e6fc0babf46763f41b5fcc147f51185f274136 /libguile/stacks.c
parent34019bd652658684b5fee9ba863a667f068c1d1e (diff)
downloadguile-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.c578
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"
+}