/* Representation of stack frame debug information
- * Copyright (C) 1996 Mikael Djurfeldt
+ * Copyright (C) 1996,1997 Free Software Foundation
*
* 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
*
* 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.
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
* 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
- */
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
\f
#include <stdio.h>
#include "_scm.h"
+#include "eval.h"
#include "debug.h"
#include "continuations.h"
+#include "struct.h"
+#include "macros.h"
+#include "procprop.h"
+#include "modules.h"
#include "stacks.h"
*
* 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.
+ * The stack is represented as a struct with an id slot and a tail
+ * array of scm_info_frame structs.
*
* 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
* Stacks
* Constructor
* make-stack
- * Selector
+ * Selectors
+ * stack-id
* stack-ref
* Inspector
* stack-length
* frame-real?
* frame-procedure?
* frame-evaluating-args?
- * frame-overflow?
- */
+ * frame-overflow? */
\f
/* Some auxiliary functions for reading debug frames off the stack.
*/
+/* Stacks often contain pointers to other items on the stack; for
+ example, each scm_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_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
+#define RELOC_FRAME(ptr, offset) \
+ ((scm_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 int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, int *maxp));
+static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp));
static int
-stack_depth (dframe, offset, maxp)
+stack_depth (dframe, offset, id, maxp)
scm_debug_frame *dframe;
long offset;
+ SCM *id;
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))
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+ dframe = RELOC_FRAME (dframe->prev, offset))
{
if (SCM_EVALFRAMEP (*dframe))
{
size = dframe->status & SCM_MAX_FRAME_SIZE;
- info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
- + offset);
+ info = RELOC_INFO (dframe->info, 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. */
else
++n;
}
- if (dframe)
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ *id = dframe->vect[0].id;
+ else if (dframe)
*maxp = 1;
return n;
}
if (SCM_EVALFRAMEP (*dframe))
{
size = dframe->status & SCM_MAX_FRAME_SIZE;
- info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
- + offset);
+ info = RELOC_INFO (dframe->info, offset);
if ((info - dframe->vect) & 1)
{
/* Debug.vect ends with apply info. */
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 proc = SCM_CDR (scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F));
+ if (SCM_NIMP (proc) && SCM_CLOSUREP (proc))
+ return SCM_CADR (SCM_CODE (proc));
+ else
+ return SCM_UNDEFINED;
+}
+
+#define NEXT_FRAME(iframe, n, quit) \
+{ \
+ if (SCM_NIMP (iframe->source) \
+ && SCM_MEMOIZED_EXP (iframe->source) == applybody) \
+ { \
+ iframe->source = SCM_BOOL_F; \
+ if (SCM_FALSEP (iframe->proc)) \
+ { \
+ --iframe; \
+ ++n; \
+ } \
+ } \
+ ++iframe; \
+ if (--n == 0) \
+ goto quit; \
+} \
+
+
/* 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)
+
+static int read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
+static int
+read_frames (dframe, offset, 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;
+ 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 && n > 0;
- dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset))
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
+ dframe = RELOC_FRAME (dframe->prev, offset))
{
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;
+ }
size = dframe->status & SCM_MAX_FRAME_SIZE;
- info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
- + offset);
+ info = RELOC_INFO (dframe->info, offset);
if ((info - dframe->vect) & 1)
--info;
/* Data in the apply part of an eval info frame comes from
else if (SCM_OVERFLOWP (*dframe)
&& !SCM_UNBNDP (info[1].a.proc))
{
- if (skip)
- --skip;
- else
- {
- ++iframe;
- if (--n == 0)
- goto quit;
- }
+ NEXT_FRAME (iframe, n, 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;
- }
+ NEXT_FRAME (iframe, n, quit);
while (info >= dframe->vect)
{
if (!SCM_UNBNDP (info[1].a.proc))
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;
- }
+ NEXT_FRAME (iframe, n, quit);
}
}
+ else if (iframe->proc == scm_f_gsubr_apply)
+ /* Skip gsubr apply frames. */
+ continue;
else
{
- if (skip)
- --skip;
- else
- {
- ++iframe;
- --n;
- }
+ NEXT_FRAME (iframe, n, quit);
}
quit:
if (iframe > iframes)
(iframe - 1) -> flags |= SCM_FRAMEF_REAL;
}
+ return iframe - iframes; /* Number of frames actually read */
+}
+
+static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));
+
+/* Narrow STACK by cutting away stackframes (mutatingly).
+ *
+ * Inner frames (most recent) are cut by advancing the frames pointer.
+ * Outer frames are cut by decreasing the recorded length.
+ *
+ * Cut maximally INNER inner frames and OUTER outer frames using
+ * the keys INNER_KEY and OUTER_KEY.
+ *
+ * Frames are cut away starting at the end points and moving towards
+ * the center of the stack. The key is normally compared to the
+ * operator in application frames. Frames up to and including the key
+ * are cut.
+ *
+ * If INNER_KEY is #t a different scheme is used for inner frames:
+ *
+ * Frames up to but excluding the first source frame originating from
+ * a user module are cut, except for possible application frames
+ * between the user frame and the last system frame previously
+ * encountered.
+ */
+
+static void
+narrow_stack (stack, inner, inner_key, outer, outer_key)
+ SCM stack;
+ int inner;
+ SCM inner_key;
+ int outer;
+ SCM outer_key;
+{
+ scm_stack *s = SCM_STACK (stack);
+ int i;
+ int n = s->length;
+
+ /* Cut inner part. */
+ if (inner_key == SCM_BOOL_T)
+ /* Cut all frames up to user module code */
+ {
+ for (i = 0; inner; ++i, --inner)
+ {
+ SCM m = s->frames[i].source;
+ if (SCM_NIMP (m)
+ && SCM_MEMOIZEDP (m)
+ && SCM_NIMP (SCM_MEMOIZED_ENV (m))
+ && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
+ {
+ /* Back up in order to include any non-source frames */
+ while (i > 0
+ && !((SCM_NIMP (m = s->frames[i - 1].source)
+ && SCM_MEMOIZEDP (m))
+ || (SCM_NIMP (m = s->frames[i - 1].proc)
+ && SCM_NFALSEP (scm_procedure_p (m))
+ && SCM_NFALSEP (scm_procedure_property
+ (m, scm_sym_system_procedure)))))
+ {
+ --i;
+ ++inner;
+ }
+ break;
+ }
+ }
+ }
+ else
+ /* Use standard cutting procedure. */
+ {
+ for (i = 0; inner; --inner)
+ if (s->frames[i++].proc == inner_key)
+ break;
+ }
+ s->frames = &s->frames[i];
+ n -= i;
+
+ /* Cut outer part. */
+ for (; n && outer; --outer)
+ if (s->frames[--n].proc == outer_key)
+ break;
+
+ s->length = n;
}
\f
/* Stacks
*/
-SCM_PROC (s_make_stack, "make-stack", 0, 3, 0, scm_make_stack);
+SCM scm_stack_type;
+
+SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p);
SCM
-scm_make_stack (obj, inner_cut, outer_cut)
+scm_stack_p (obj)
SCM obj;
- SCM inner_cut;
- SCM outer_cut;
{
- int i, n, maxp = 0, size;
+ return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack);
+SCM
+scm_make_stack (args)
+ SCM args;
+{
+ int n, maxp, 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))))
+ SCM stack, id;
+ SCM obj, inner_cut, outer_cut;
+
+ SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args),
+ scm_makfrom0str (s_make_stack),
+ SCM_WNA,
+ NULL);
+ obj = SCM_CAR (args);
+ args = SCM_CDR (args);
+
+ /* Extract a pointer to the innermost frame of whatever object
+ scm_make_stack was given. */
+ if (obj == SCM_BOOL_T)
dframe = scm_last_debug_frame;
else
{
#ifndef STACK_GROWS_UP
offset += SCM_LENGTH (obj);
#endif
- dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj)
- + offset);
+ dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ }
+ else
+ {
+ scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
+ abort ();
}
- 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;
+ /* 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, &id, &maxp);
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);
+ /* Make the stack object. */
+ stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
+ SCM_STACK (stack) -> id = id;
+ iframe = &SCM_STACK (stack) -> tail[0];
+ SCM_STACK (stack) -> frames = iframe;
+
+ /* Translate the current chain of stack frames into debugging information. */
+ n = read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe);
+ SCM_STACK (stack) -> length = n;
- if (n > 0 && maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+ /* Narrow the stack according to the arguments given to scm_make_stack. */
+ while (n > 0 && SCM_NIMP (args) && SCM_CONSP (args))
+ {
+ inner_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ if (SCM_NIMP (args) && SCM_CONSP (args))
+ {
+ outer_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+ else
+ outer_cut = SCM_INUM0;
+
+ narrow_stack (stack,
+ SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n,
+ SCM_INUMP (inner_cut) ? 0 : inner_cut,
+ SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n,
+ SCM_INUMP (outer_cut) ? 0 : outer_cut);
+
+ n = SCM_STACK (stack) -> length;
+ }
- return stack;
+ if (n > 0)
+ {
+ if (maxp)
+ iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+ return stack;
+ }
+ else
+ return SCM_BOOL_F;
}
-SCM_PROC(s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
+SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
+SCM
+scm_stack_id (stack)
+ SCM stack;
+{
+ scm_debug_frame *dframe;
+ long offset = 0;
+ if (stack == SCM_BOOL_T)
+ dframe = scm_last_debug_frame;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
+ if (SCM_DEBUGOBJP (stack))
+ dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
+ else if (scm_tc7_contin == SCM_TYP7 (stack))
+ {
+ offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs))
+ - SCM_BASE (stack));
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (stack);
+#endif
+ dframe = RELOC_FRAME (SCM_DFRAME (stack), offset);
+ }
+ else if (SCM_STACKP (stack))
+ return SCM_STACK (stack) -> id;
+ else
+ scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
+ }
+ while (dframe && !SCM_VOIDFRAMEP (*dframe))
+ dframe = RELOC_FRAME (dframe->prev, offset);
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ return dframe->vect[0].id;
+ return SCM_BOOL_F;
+}
+
+SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
SCM
scm_stack_ref (stack, i)
SCM stack;
/* Frames
*/
+SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p);
+SCM
+scm_frame_p (obj)
+ SCM obj;
+{
+ return SCM_NIMP (obj) && SCM_FRAMEP (obj);
+}
+
SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
SCM
scm_last_stack_frame (obj)
{
scm_debug_frame *dframe;
long offset = 0;
- SCM fobj, v;
+ SCM stack;
SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
if (SCM_DEBUGOBJP (obj))
#ifndef STACK_GROWS_UP
offset += SCM_LENGTH (obj);
#endif
- dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj) + offset);
+ dframe = RELOC_FRAME (SCM_DFRAME (obj), offset);
+ }
+ else
+ {
+ scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
+ abort ();
}
- else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
- if (!dframe)
+ if (!dframe || SCM_VOIDFRAMEP (*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));
+ stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (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_info_frame *) &SCM_STACK (stack) -> frames[0]);
- return fobj;
+ return scm_cons (stack, SCM_INUM0);;
}
SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);
SCM_ARG1,
s_frame_procedure);
return (SCM_FRAME_PROC_P (frame)
- ? SCM_BOOL_F
- : SCM_FRAME_PROC (frame));
+ ? SCM_FRAME_PROC (frame)
+ : SCM_BOOL_F);
}
SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments);
void
scm_init_stacks ()
{
+ SCM vtable;
+ SCM vtable_layout = scm_make_struct_layout (scm_nullstr);
+ SCM stack_layout
+ = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT));
+ vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL);
+ scm_stack_type
+ = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0,
+ scm_cons (stack_layout,
+ SCM_EOL)));
+ scm_set_struct_vtable_name_x (scm_stack_type,
+ SCM_CAR (scm_intern0 ("stack")));
#include "stacks.x"
}
HCoop / bpt / guile.git / blobdiff