1 /* Representation of stack frame debug information
2 * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 #include "libguile/_scm.h"
26 #include "libguile/eval.h"
27 #include "libguile/debug.h"
28 #include "libguile/continuations.h"
29 #include "libguile/struct.h"
30 #include "libguile/macros.h"
31 #include "libguile/procprop.h"
32 #include "libguile/modules.h"
33 #include "libguile/root.h"
34 #include "libguile/strings.h"
36 #include "libguile/validate.h"
37 #include "libguile/stacks.h"
40 /* {Frames and stacks}
42 * The debugging evaluator creates debug frames on the stack. These
43 * are linked from the innermost frame and outwards. The last frame
44 * created can always be accessed as SCM_LAST_DEBUG_FRAME.
45 * Continuations contain a pointer to the innermost debug frame on the
48 * Each debug frame contains a set of flags and information about one
49 * or more stack frames. The case of multiple frames occurs due to
50 * tail recursion. The maximal number of stack frames which can be
51 * recorded in one debug frame can be set dynamically with the debug
54 * Stack frame information is of two types: eval information (the
55 * expression being evaluated and its environment) and apply
56 * information (the procedure being applied and its arguments). A
57 * stack frame normally corresponds to an eval/apply pair, but macros
58 * and special forms (which are implemented as macros in Guile) only
59 * have eval information and apply calls leads to apply only frames.
61 * Since we want to record the total stack information and later
62 * manipulate this data at the scheme level in the debugger, we need
63 * to transform it into a new representation. In the following code
64 * section you'll find the functions implementing this data type.
68 * The stack is represented as a struct with an id slot and a tail
69 * array of scm_t_info_frame structs.
71 * A frame is represented as a pair where the car contains a stack and
72 * the cdr an inum. The inum is an index to the first SCM value of
73 * the scm_t_info_frame struct.
97 * frame-evaluating-args?
102 /* Some auxiliary functions for reading debug frames off the stack.
105 /* Stacks often contain pointers to other items on the stack; for
106 example, each scm_t_debug_frame structure contains a pointer to the
107 next frame out. When we capture a continuation, we copy the stack
108 into the heap, and just leave all the pointers unchanged. This
109 makes it simple to restore the continuation --- just copy the stack
110 back! However, if we retrieve a pointer from the heap copy to
111 another item that was originally on the stack, we have to add an
112 offset to the pointer to discover the new referent.
114 If PTR is a pointer retrieved from a continuation, whose original
115 target was on the stack, and OFFSET is the appropriate offset from
116 the original stack to the continuation, then RELOC_MUMBLE (PTR,
117 OFFSET) is a pointer to the copy in the continuation of the
118 original referent, cast to an scm_debug_MUMBLE *. */
119 #define RELOC_INFO(ptr, offset) \
120 ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
121 #define RELOC_FRAME(ptr, offset) \
122 ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
125 /* Count number of debug info frames on a stack, beginning with
126 * DFRAME. OFFSET is used for relocation of pointers when the stack
127 * is read from a continuation.
130 stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
134 long max_depth = SCM_BACKTRACE_MAXDEPTH;
136 dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
137 dframe = RELOC_FRAME (dframe->prev, offset))
139 if (SCM_EVALFRAMEP (*dframe))
141 scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
142 scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
143 n += (info - vect) / 2 + 1;
144 /* Data in the apply part of an eval info frame comes from previous
145 stack frame if the scm_t_debug_info vector is overflowed. */
146 if ((((info - vect) & 1) == 0)
147 && SCM_OVERFLOWP (*dframe)
148 && !SCM_UNBNDP (info[1].a.proc))
154 if (dframe && SCM_VOIDFRAMEP (*dframe))
155 *id = RELOC_INFO(dframe->vect, offset)[0].id;
161 /* Read debug info from DFRAME into IFRAME.
164 read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
165 scm_t_info_frame *iframe)
167 scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
168 if (SCM_EVALFRAMEP (*dframe))
170 scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
171 scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
172 if ((info - vect) & 1)
174 /* Debug.vect ends with apply info. */
176 if (!SCM_UNBNDP (info[1].a.proc))
178 flags |= SCM_FRAMEF_PROC;
179 iframe->proc = info[1].a.proc;
180 iframe->args = info[1].a.args;
181 if (!SCM_ARGS_READY_P (*dframe))
182 flags |= SCM_FRAMEF_EVAL_ARGS;
185 iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
189 scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
190 flags |= SCM_FRAMEF_PROC;
191 iframe->proc = vect[0].a.proc;
192 iframe->args = vect[0].a.args;
194 iframe->flags = flags;
197 /* Look up the first body form of the apply closure. We'll use this
198 below to prevent it from being displayed.
203 SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
204 if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
205 return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
207 return SCM_UNDEFINED;
210 #define NEXT_FRAME(iframe, n, quit) \
212 if (SCM_MEMOIZEDP (iframe->source) \
213 && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
215 iframe->source = SCM_BOOL_F; \
216 if (scm_is_false (iframe->proc)) \
228 /* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
229 * starting with the first stack frame represented by debug frame
234 read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
235 long n, scm_t_info_frame *iframes)
237 scm_t_info_frame *iframe = iframes;
238 scm_t_debug_info *info, *vect;
239 static SCM applybody = SCM_UNDEFINED;
241 /* The value of applybody has to be setup after r4rs.scm has executed. */
242 if (SCM_UNBNDP (applybody))
243 applybody = get_applybody ();
245 dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
246 dframe = RELOC_FRAME (dframe->prev, offset))
248 read_frame (dframe, offset, iframe);
249 if (SCM_EVALFRAMEP (*dframe))
251 /* If current frame is a macro during expansion, we should
252 skip the previously recorded macro transformer
253 application frame. */
254 if (SCM_MACROEXPP (*dframe) && iframe > iframes)
256 *(iframe - 1) = *iframe;
259 info = RELOC_INFO (dframe->info, offset);
260 vect = RELOC_INFO (dframe->vect, offset);
261 if ((info - vect) & 1)
263 /* Data in the apply part of an eval info frame comes from
264 previous stack frame if the scm_t_debug_info vector is
266 else if (SCM_OVERFLOWP (*dframe)
267 && !SCM_UNBNDP (info[1].a.proc))
269 NEXT_FRAME (iframe, n, quit);
270 iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
271 iframe->proc = info[1].a.proc;
272 iframe->args = info[1].a.args;
274 if (SCM_OVERFLOWP (*dframe))
275 iframe->flags |= SCM_FRAMEF_OVERFLOW;
277 NEXT_FRAME (iframe, n, quit);
280 if (!SCM_UNBNDP (info[1].a.proc))
282 iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
283 iframe->proc = info[1].a.proc;
284 iframe->args = info[1].a.args;
287 iframe->flags = SCM_UNPACK (SCM_INUM0);
288 iframe->source = scm_make_memoized (info[0].e.exp,
291 NEXT_FRAME (iframe, n, quit);
294 else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
295 /* Skip gsubr apply frames. */
299 NEXT_FRAME (iframe, n, quit);
302 if (iframe > iframes)
303 (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
305 return iframe - iframes; /* Number of frames actually read */
308 /* Narrow STACK by cutting away stackframes (mutatingly).
310 * Inner frames (most recent) are cut by advancing the frames pointer.
311 * Outer frames are cut by decreasing the recorded length.
313 * Cut maximally INNER inner frames and OUTER outer frames using
314 * the keys INNER_KEY and OUTER_KEY.
316 * Frames are cut away starting at the end points and moving towards
317 * the center of the stack. The key is normally compared to the
318 * operator in application frames. Frames up to and including the key
321 * If INNER_KEY is #t a different scheme is used for inner frames:
323 * Frames up to but excluding the first source frame originating from
324 * a user module are cut, except for possible application frames
325 * between the user frame and the last system frame previously
330 narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
332 scm_t_stack *s = SCM_STACK (stack);
336 /* Cut inner part. */
337 if (scm_is_eq (inner_key, SCM_BOOL_T))
339 /* Cut all frames up to user module code */
340 for (i = 0; inner; ++i, --inner)
342 SCM m = s->frames[i].source;
343 if (SCM_MEMOIZEDP (m)
344 && !SCM_IMP (SCM_MEMOIZED_ENV (m))
345 && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
347 /* Back up in order to include any non-source frames */
350 m = s->frames[i - 1].source;
351 if (SCM_MEMOIZEDP (m))
354 m = s->frames[i - 1].proc;
355 if (scm_is_true (scm_procedure_p (m))
356 && scm_is_true (scm_procedure_property
357 (m, scm_sym_system_procedure)))
368 /* Use standard cutting procedure. */
370 for (i = 0; inner; --inner)
371 if (scm_is_eq (s->frames[i++].proc, inner_key))
374 s->frames = &s->frames[i];
377 /* Cut outer part. */
378 for (; n && outer; --outer)
379 if (scm_is_eq (s->frames[--n].proc, outer_key))
392 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
394 "Return @code{#t} if @var{obj} is a calling stack.")
395 #define FUNC_NAME s_scm_stack_p
397 return scm_from_bool(SCM_STACKP (obj));
401 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
403 "Create a new stack. If @var{obj} is @code{#t}, the current\n"
404 "evaluation stack is used for creating the stack frames,\n"
405 "otherwise the frames are taken from @var{obj} (which must be\n"
406 "either a debug object or a continuation).\n\n"
407 "@var{args} should be a list containing any combination of\n"
408 "integer, procedure and @code{#t} values.\n\n"
409 "These values specify various ways of cutting away uninteresting\n"
410 "stack frames from the top and bottom of the stack that\n"
411 "@code{make-stack} returns. They come in pairs like this:\n"
412 "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
413 "@var{outer_cut_2} @dots{})}.\n\n"
414 "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
415 "procedure. @code{#t} means to cut away all frames up to but\n"
416 "excluding the first user module frame. An integer means to cut\n"
417 "away exactly that number of frames. A procedure means to cut\n"
418 "away all frames up to but excluding the application frame whose\n"
419 "procedure matches the specified one.\n\n"
420 "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
421 "integer means to cut away that number of frames. A procedure\n"
422 "means to cut away frames down to but excluding the application\n"
423 "frame whose procedure matches the specified one.\n\n"
424 "If the @var{outer_cut_N} of the last pair is missing, it is\n"
426 #define FUNC_NAME s_scm_make_stack
430 scm_t_debug_frame *dframe;
431 scm_t_info_frame *iframe;
434 SCM inner_cut, outer_cut;
436 /* Extract a pointer to the innermost frame of whatever object
437 scm_make_stack was given. */
438 if (scm_is_eq (obj, SCM_BOOL_T))
440 dframe = scm_i_last_debug_frame ();
442 else if (SCM_DEBUGOBJP (obj))
444 dframe = SCM_DEBUGOBJ_FRAME (obj);
446 else if (SCM_CONTINUATIONP (obj))
448 scm_t_contregs *cont = SCM_CONTREGS (obj);
449 offset = cont->offset;
450 dframe = RELOC_FRAME (cont->dframe, offset);
454 SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
458 /* Count number of frames. Also get stack id tag and check whether
459 there are more stackframes than we want to record
460 (SCM_BACKTRACE_MAXDEPTH). */
463 n = stack_depth (dframe, offset, &id, &maxp);
464 size = n * SCM_FRAME_N_SLOTS;
466 /* Make the stack object. */
467 stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
468 SCM_STACK (stack) -> id = id;
469 iframe = &SCM_STACK (stack) -> tail[0];
470 SCM_STACK (stack) -> frames = iframe;
472 /* Translate the current chain of stack frames into debugging information. */
473 n = read_frames (dframe, offset, n, iframe);
474 SCM_STACK (stack) -> length = n;
476 /* Narrow the stack according to the arguments given to scm_make_stack. */
477 SCM_VALIDATE_REST_ARGUMENT (args);
478 while (n > 0 && !scm_is_null (args))
480 inner_cut = SCM_CAR (args);
481 args = SCM_CDR (args);
482 if (scm_is_null (args))
484 outer_cut = SCM_INUM0;
488 outer_cut = SCM_CAR (args);
489 args = SCM_CDR (args);
493 scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
494 scm_is_integer (inner_cut) ? 0 : inner_cut,
495 scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
496 scm_is_integer (outer_cut) ? 0 : outer_cut);
498 n = SCM_STACK (stack) -> length;
504 iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
512 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
514 "Return the identifier given to @var{stack} by @code{start-stack}.")
515 #define FUNC_NAME s_scm_stack_id
517 scm_t_debug_frame *dframe;
519 if (scm_is_eq (stack, SCM_BOOL_T))
521 dframe = scm_i_last_debug_frame ();
523 else if (SCM_DEBUGOBJP (stack))
525 dframe = SCM_DEBUGOBJ_FRAME (stack);
527 else if (SCM_CONTINUATIONP (stack))
529 scm_t_contregs *cont = SCM_CONTREGS (stack);
530 offset = cont->offset;
531 dframe = RELOC_FRAME (cont->dframe, offset);
533 else if (SCM_STACKP (stack))
535 return SCM_STACK (stack) -> id;
539 SCM_WRONG_TYPE_ARG (1, stack);
542 while (dframe && !SCM_VOIDFRAMEP (*dframe))
543 dframe = RELOC_FRAME (dframe->prev, offset);
544 if (dframe && SCM_VOIDFRAMEP (*dframe))
545 return RELOC_INFO (dframe->vect, offset)[0].id;
550 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
551 (SCM stack, SCM index),
552 "Return the @var{index}'th frame from @var{stack}.")
553 #define FUNC_NAME s_scm_stack_ref
555 unsigned long int c_index;
557 SCM_VALIDATE_STACK (1, stack);
558 c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
559 return scm_cons (stack, index);
563 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
565 "Return the length of @var{stack}.")
566 #define FUNC_NAME s_scm_stack_length
568 SCM_VALIDATE_STACK (1, stack);
569 return scm_from_int (SCM_STACK_LENGTH (stack));
576 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
578 "Return @code{#t} if @var{obj} is a stack frame.")
579 #define FUNC_NAME s_scm_frame_p
581 return scm_from_bool(SCM_FRAMEP (obj));
585 SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
587 "Return a stack which consists of a single frame, which is the\n"
588 "last stack frame for @var{obj}. @var{obj} must be either a\n"
589 "debug object or a continuation.")
590 #define FUNC_NAME s_scm_last_stack_frame
592 scm_t_debug_frame *dframe;
596 if (SCM_DEBUGOBJP (obj))
598 dframe = SCM_DEBUGOBJ_FRAME (obj);
600 else if (SCM_CONTINUATIONP (obj))
602 scm_t_contregs *cont = SCM_CONTREGS (obj);
603 offset = cont->offset;
604 dframe = RELOC_FRAME (cont->dframe, offset);
608 SCM_WRONG_TYPE_ARG (1, obj);
612 if (!dframe || SCM_VOIDFRAMEP (*dframe))
615 stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
617 SCM_STACK (stack) -> length = 1;
618 SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
619 read_frame (dframe, offset,
620 (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
622 return scm_cons (stack, SCM_INUM0);
626 SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
628 "Return the frame number of @var{frame}.")
629 #define FUNC_NAME s_scm_frame_number
631 SCM_VALIDATE_FRAME (1, frame);
632 return scm_from_int (SCM_FRAME_NUMBER (frame));
636 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
638 "Return the source of @var{frame}.")
639 #define FUNC_NAME s_scm_frame_source
641 SCM_VALIDATE_FRAME (1, frame);
642 return SCM_FRAME_SOURCE (frame);
646 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
648 "Return the procedure for @var{frame}, or @code{#f} if no\n"
649 "procedure is associated with @var{frame}.")
650 #define FUNC_NAME s_scm_frame_procedure
652 SCM_VALIDATE_FRAME (1, frame);
653 return (SCM_FRAME_PROC_P (frame)
654 ? SCM_FRAME_PROC (frame)
659 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
661 "Return the arguments of @var{frame}.")
662 #define FUNC_NAME s_scm_frame_arguments
664 SCM_VALIDATE_FRAME (1, frame);
665 return SCM_FRAME_ARGS (frame);
669 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
671 "Return the previous frame of @var{frame}, or @code{#f} if\n"
672 "@var{frame} is the first frame in its stack.")
673 #define FUNC_NAME s_scm_frame_previous
676 SCM_VALIDATE_FRAME (1, frame);
677 n = scm_to_ulong (SCM_CDR (frame)) + 1;
678 if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
681 return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
685 SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
687 "Return the next frame of @var{frame}, or @code{#f} if\n"
688 "@var{frame} is the last frame in its stack.")
689 #define FUNC_NAME s_scm_frame_next
692 SCM_VALIDATE_FRAME (1, frame);
693 n = scm_to_ulong (SCM_CDR (frame));
697 return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
701 SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
703 "Return @code{#t} if @var{frame} is a real frame.")
704 #define FUNC_NAME s_scm_frame_real_p
706 SCM_VALIDATE_FRAME (1, frame);
707 return scm_from_bool(SCM_FRAME_REAL_P (frame));
711 SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
713 "Return @code{#t} if a procedure is associated with @var{frame}.")
714 #define FUNC_NAME s_scm_frame_procedure_p
716 SCM_VALIDATE_FRAME (1, frame);
717 return scm_from_bool(SCM_FRAME_PROC_P (frame));
721 SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
723 "Return @code{#t} if @var{frame} contains evaluated arguments.")
724 #define FUNC_NAME s_scm_frame_evaluating_args_p
726 SCM_VALIDATE_FRAME (1, frame);
727 return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
731 SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
733 "Return @code{#t} if @var{frame} is an overflow frame.")
734 #define FUNC_NAME s_scm_frame_overflow_p
736 SCM_VALIDATE_FRAME (1, frame);
737 return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
748 (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
750 scm_set_struct_vtable_name_x (scm_stack_type,
751 scm_from_locale_symbol ("stack"));
752 #include "libguile/stacks.x"