1 /* Representation of stack frame debug information
2 * Copyright (C) 1996,1997 Free Software Foundation
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2, or (at your option)
9 * This program 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
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this software; see the file COPYING. If not, write to
16 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
17 * Boston, MA 02111-1307 USA
19 * As a special exception, the Free Software Foundation gives permission
20 * for additional uses of the text contained in its release of GUILE.
22 * The exception is that, if you link the GUILE library with other files
23 * to produce an executable, this does not by itself cause the
24 * resulting executable to be covered by the GNU General Public License.
25 * Your use of that executable is in no way restricted on account of
26 * linking the GUILE library code into it.
28 * This exception does not however invalidate any other reasons why
29 * the executable file might be covered by the GNU General Public License.
31 * This exception applies only to the code released by the
32 * Free Software Foundation under the name GUILE. If you copy
33 * code from other Free Software Foundation releases into a copy of
34 * GUILE, as the General Public License permits, the exception does
35 * not apply to the code that you add in this way. To avoid misleading
36 * anyone as to the status of such modified files, you must delete
37 * this exception notice from them.
39 * If you write modifications of your own for GUILE, it is your choice
40 * whether to permit this exception to apply to your modifications.
41 * If you do not wish that, delete this exception notice.
43 * The author can be reached at djurfeldt@nada.kth.se
44 * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
46 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
47 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
52 #include "libguile/_scm.h"
53 #include "libguile/eval.h"
54 #include "libguile/debug.h"
55 #include "libguile/continuations.h"
56 #include "libguile/struct.h"
57 #include "libguile/macros.h"
58 #include "libguile/procprop.h"
59 #include "libguile/modules.h"
60 #include "libguile/root.h"
61 #include "libguile/strings.h"
63 #include "libguile/validate.h"
64 #include "libguile/stacks.h"
67 /* {Frames and stacks}
69 * The debugging evaluator creates debug frames on the stack. These
70 * are linked from the innermost frame and outwards. The last frame
71 * created can always be accessed as SCM_LAST_DEBUG_FRAME.
72 * Continuations contain a pointer to the innermost debug frame on the
75 * Each debug frame contains a set of flags and information about one
76 * or more stack frames. The case of multiple frames occurs due to
77 * tail recursion. The maximal number of stack frames which can be
78 * recorded in one debug frame can be set dynamically with the debug
81 * Stack frame information is of two types: eval information (the
82 * expression being evaluated and its environment) and apply
83 * information (the procedure being applied and its arguments). A
84 * stack frame normally corresponds to an eval/apply pair, but macros
85 * and special forms (which are implemented as macros in Guile) only
86 * have eval information and apply calls leads to apply only frames.
88 * Since we want to record the total stack information and later
89 * manipulate this data at the scheme level in the debugger, we need
90 * to transform it into a new representation. In the following code
91 * section you'll find the functions implementing this data type.
95 * The stack is represented as a struct with an id slot and a tail
96 * array of scm_info_frame structs.
98 * A frame is represented as a pair where the car contains a stack and
99 * the cdr an inum. The inum is an index to the first SCM value of
100 * the scm_info_frame struct.
124 * frame-evaluating-args?
129 /* Some auxiliary functions for reading debug frames off the stack.
132 /* Stacks often contain pointers to other items on the stack; for
133 example, each scm_debug_frame structure contains a pointer to the
134 next frame out. When we capture a continuation, we copy the stack
135 into the heap, and just leave all the pointers unchanged. This
136 makes it simple to restore the continuation --- just copy the stack
137 back! However, if we retrieve a pointer from the heap copy to
138 another item that was originally on the stack, we have to add an
139 offset to the pointer to discover the new referent.
141 If PTR is a pointer retrieved from a continuation, whose original
142 target was on the stack, and OFFSET is the appropriate offset from
143 the original stack to the continuation, then RELOC_MUMBLE (PTR,
144 OFFSET) is a pointer to the copy in the continuation of the
145 original referent, cast to an scm_debug_MUMBLE *. */
146 #define RELOC_INFO(ptr, offset) \
147 ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
148 #define RELOC_FRAME(ptr, offset) \
149 ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
152 /* Count number of debug info frames on a stack, beginning with
153 * DFRAME. OFFSET is used for relocation of pointers when the stack
154 * is read from a continuation.
157 stack_depth (scm_debug_frame
*dframe
,long offset
,SCM
*id
,int *maxp
)
160 int max_depth
= SCM_BACKTRACE_MAXDEPTH
;
162 dframe
&& !SCM_VOIDFRAMEP (*dframe
) && n
< max_depth
;
163 dframe
= RELOC_FRAME (dframe
->prev
, offset
))
165 if (SCM_EVALFRAMEP (*dframe
))
167 scm_debug_info
* info
= RELOC_INFO (dframe
->info
, offset
);
168 n
+= (info
- dframe
->vect
) / 2 + 1;
169 /* Data in the apply part of an eval info frame comes from previous
170 stack frame if the scm_debug_info vector is overflowed. */
171 if ((((info
- dframe
->vect
) & 1) == 0)
172 && SCM_OVERFLOWP (*dframe
)
173 && !SCM_UNBNDP (info
[1].a
.proc
))
179 if (dframe
&& SCM_VOIDFRAMEP (*dframe
))
180 *id
= dframe
->vect
[0].id
;
186 /* Read debug info from DFRAME into IFRAME.
189 read_frame (scm_debug_frame
*dframe
,long offset
,scm_info_frame
*iframe
)
191 scm_bits_t flags
= SCM_UNPACK (SCM_INUM0
); /* UGh. */
192 if (SCM_EVALFRAMEP (*dframe
))
194 scm_debug_info
* info
= RELOC_INFO (dframe
->info
, offset
);
195 if ((info
- dframe
->vect
) & 1)
197 /* Debug.vect ends with apply info. */
199 if (!SCM_UNBNDP (info
[1].a
.proc
))
201 flags
|= SCM_FRAMEF_PROC
;
202 iframe
->proc
= info
[1].a
.proc
;
203 iframe
->args
= info
[1].a
.args
;
204 if (!SCM_ARGS_READY_P (*dframe
))
205 flags
|= SCM_FRAMEF_EVAL_ARGS
;
208 iframe
->source
= scm_make_memoized (info
[0].e
.exp
, info
[0].e
.env
);
212 flags
|= SCM_FRAMEF_PROC
;
213 iframe
->proc
= dframe
->vect
[0].a
.proc
;
214 iframe
->args
= dframe
->vect
[0].a
.args
;
216 iframe
->flags
= flags
;
219 /* Look up the first body form of the apply closure. We'll use this
220 below to prevent it from being displayed.
225 SCM proc
= SCM_CDR (scm_sym2vcell (scm_sym_apply
, SCM_BOOL_F
, SCM_BOOL_F
));
226 if (SCM_CLOSUREP (proc
))
227 return SCM_CADR (SCM_CODE (proc
));
229 return SCM_UNDEFINED
;
232 #define NEXT_FRAME(iframe, n, quit) \
234 if (SCM_NIMP (iframe->source) \
235 && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
237 iframe->source = SCM_BOOL_F; \
238 if (SCM_FALSEP (iframe->proc)) \
250 /* Fill the scm_info_frame vector IFRAME with data from N stack frames
251 * starting with the first stack frame represented by debug frame
256 read_frames (scm_debug_frame
*dframe
,long offset
,int n
,scm_info_frame
*iframes
)
258 scm_info_frame
*iframe
= iframes
;
259 scm_debug_info
*info
;
260 static SCM applybody
= SCM_UNDEFINED
;
262 /* The value of applybody has to be setup after r4rs.scm has executed. */
263 if (SCM_UNBNDP (applybody
))
264 applybody
= get_applybody ();
266 dframe
&& !SCM_VOIDFRAMEP (*dframe
) && n
> 0;
267 dframe
= RELOC_FRAME (dframe
->prev
, offset
))
269 read_frame (dframe
, offset
, iframe
);
270 if (SCM_EVALFRAMEP (*dframe
))
272 /* If current frame is a macro during expansion, we should
273 skip the previously recorded macro transformer
274 application frame. */
275 if (SCM_MACROEXPP (*dframe
) && iframe
> iframes
)
277 *(iframe
- 1) = *iframe
;
280 info
= RELOC_INFO (dframe
->info
, offset
);
281 if ((info
- dframe
->vect
) & 1)
283 /* Data in the apply part of an eval info frame comes from
284 previous stack frame if the scm_debug_info vector is overflowed. */
285 else if (SCM_OVERFLOWP (*dframe
)
286 && !SCM_UNBNDP (info
[1].a
.proc
))
288 NEXT_FRAME (iframe
, n
, quit
);
289 iframe
->flags
= SCM_UNPACK(SCM_INUM0
) | SCM_FRAMEF_PROC
;
290 iframe
->proc
= info
[1].a
.proc
;
291 iframe
->args
= info
[1].a
.args
;
293 if (SCM_OVERFLOWP (*dframe
))
294 iframe
->flags
|= SCM_FRAMEF_OVERFLOW
;
296 NEXT_FRAME (iframe
, n
, quit
);
297 while (info
>= dframe
->vect
)
299 if (!SCM_UNBNDP (info
[1].a
.proc
))
301 iframe
->flags
= SCM_UNPACK(SCM_INUM0
) | SCM_FRAMEF_PROC
;
302 iframe
->proc
= info
[1].a
.proc
;
303 iframe
->args
= info
[1].a
.args
;
306 iframe
->flags
= SCM_UNPACK (SCM_INUM0
);
307 iframe
->source
= scm_make_memoized (info
[0].e
.exp
,
310 NEXT_FRAME (iframe
, n
, quit
);
313 else if (SCM_EQ_P (iframe
->proc
, scm_f_gsubr_apply
))
314 /* Skip gsubr apply frames. */
318 NEXT_FRAME (iframe
, n
, quit
);
321 if (iframe
> iframes
)
322 (iframe
- 1) -> flags
|= SCM_FRAMEF_REAL
;
324 return iframe
- iframes
; /* Number of frames actually read */
327 /* Narrow STACK by cutting away stackframes (mutatingly).
329 * Inner frames (most recent) are cut by advancing the frames pointer.
330 * Outer frames are cut by decreasing the recorded length.
332 * Cut maximally INNER inner frames and OUTER outer frames using
333 * the keys INNER_KEY and OUTER_KEY.
335 * Frames are cut away starting at the end points and moving towards
336 * the center of the stack. The key is normally compared to the
337 * operator in application frames. Frames up to and including the key
340 * If INNER_KEY is #t a different scheme is used for inner frames:
342 * Frames up to but excluding the first source frame originating from
343 * a user module are cut, except for possible application frames
344 * between the user frame and the last system frame previously
349 narrow_stack (SCM stack
,int inner
,SCM inner_key
,int outer
,SCM outer_key
)
351 scm_stack
*s
= SCM_STACK (stack
);
355 /* Cut inner part. */
356 if (SCM_TRUE_P (inner_key
))
357 /* Cut all frames up to user module code */
359 for (i
= 0; inner
; ++i
, --inner
)
361 SCM m
= s
->frames
[i
].source
;
362 if ( SCM_MEMOIZEDP (m
)
363 && SCM_NIMP (SCM_MEMOIZED_ENV (m
))
364 && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m
))))
366 /* Back up in order to include any non-source frames */
368 && !((m
= s
->frames
[i
- 1].source
, SCM_MEMOIZEDP (m
))
369 || (SCM_NIMP (m
= s
->frames
[i
- 1].proc
)
370 && SCM_NFALSEP (scm_procedure_p (m
))
371 && SCM_NFALSEP (scm_procedure_property
372 (m
, scm_sym_system_procedure
)))))
382 /* Use standard cutting procedure. */
384 for (i
= 0; inner
; --inner
)
385 if (SCM_EQ_P (s
->frames
[i
++].proc
, inner_key
))
388 s
->frames
= &s
->frames
[i
];
391 /* Cut outer part. */
392 for (; n
&& outer
; --outer
)
393 if (SCM_EQ_P (s
->frames
[--n
].proc
, outer_key
))
406 SCM_DEFINE (scm_stack_p
, "stack?", 1, 0, 0,
408 "Return @code{#t} if @var{obj} is a calling stack.")
409 #define FUNC_NAME s_scm_stack_p
411 return SCM_BOOL(SCM_STACKP (obj
));
415 SCM_DEFINE (scm_make_stack
, "make-stack", 1, 0, 1,
418 #define FUNC_NAME s_scm_make_stack
421 scm_debug_frame
*dframe
= scm_last_debug_frame
;
422 scm_info_frame
*iframe
;
425 SCM inner_cut
, outer_cut
;
427 /* Extract a pointer to the innermost frame of whatever object
428 scm_make_stack was given. */
429 /* just use dframe == scm_last_debug_frame
430 (from initialization of dframe, above) if obj is #t */
431 if (!SCM_TRUE_P (obj
))
433 SCM_ASSERT (SCM_NIMP (obj
), obj
, SCM_ARG1
, FUNC_NAME
);
434 if (SCM_DEBUGOBJP (obj
))
435 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (obj
);
436 else if (scm_tc7_contin
== SCM_TYP7 (obj
))
438 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (obj
) + sizeof (scm_contregs
))
440 #ifndef STACK_GROWS_UP
441 offset
+= SCM_LENGTH (obj
);
443 dframe
= RELOC_FRAME (SCM_DFRAME (obj
), offset
);
447 SCM_WTA (SCM_ARG1
, obj
);
452 /* Count number of frames. Also get stack id tag and check whether
453 there are more stackframes than we want to record
454 (SCM_BACKTRACE_MAXDEPTH). */
457 n
= stack_depth (dframe
, offset
, &id
, &maxp
);
458 size
= n
* SCM_FRAME_N_SLOTS
;
460 /* Make the stack object. */
461 stack
= scm_make_struct (scm_stack_type
, SCM_MAKINUM (size
), SCM_EOL
);
462 SCM_STACK (stack
) -> id
= id
;
463 iframe
= &SCM_STACK (stack
) -> tail
[0];
464 SCM_STACK (stack
) -> frames
= iframe
;
466 /* Translate the current chain of stack frames into debugging information. */
467 n
= read_frames (RELOC_FRAME (dframe
, offset
), offset
, n
, iframe
);
468 SCM_STACK (stack
) -> length
= n
;
470 /* Narrow the stack according to the arguments given to scm_make_stack. */
471 SCM_VALIDATE_REST_ARGUMENT (args
);
472 while (n
> 0 && !SCM_NULLP (args
))
474 inner_cut
= SCM_CAR (args
);
475 args
= SCM_CDR (args
);
476 if (SCM_NULLP (args
))
478 outer_cut
= SCM_INUM0
;
482 outer_cut
= SCM_CAR (args
);
483 args
= SCM_CDR (args
);
487 SCM_INUMP (inner_cut
) ? SCM_INUM (inner_cut
) : n
,
488 SCM_INUMP (inner_cut
) ? 0 : inner_cut
,
489 SCM_INUMP (outer_cut
) ? SCM_INUM (outer_cut
) : n
,
490 SCM_INUMP (outer_cut
) ? 0 : outer_cut
);
492 n
= SCM_STACK (stack
) -> length
;
498 iframe
[n
- 1].flags
|= SCM_FRAMEF_OVERFLOW
;
506 SCM_DEFINE (scm_stack_id
, "stack-id", 1, 0, 0,
508 "Return the identifier given to @var{stack} by @code{start-stack}.")
509 #define FUNC_NAME s_scm_stack_id
511 scm_debug_frame
*dframe
;
513 if (SCM_TRUE_P (stack
))
514 dframe
= scm_last_debug_frame
;
517 SCM_VALIDATE_NIM (1,stack
);
518 if (SCM_DEBUGOBJP (stack
))
519 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (stack
);
520 else if (scm_tc7_contin
== SCM_TYP7 (stack
))
522 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (stack
) + sizeof (scm_contregs
))
524 #ifndef STACK_GROWS_UP
525 offset
+= SCM_LENGTH (stack
);
527 dframe
= RELOC_FRAME (SCM_DFRAME (stack
), offset
);
529 else if (SCM_STACKP (stack
))
530 return SCM_STACK (stack
) -> id
;
532 SCM_WRONG_TYPE_ARG (1, stack
);
534 while (dframe
&& !SCM_VOIDFRAMEP (*dframe
))
535 dframe
= RELOC_FRAME (dframe
->prev
, offset
);
536 if (dframe
&& SCM_VOIDFRAMEP (*dframe
))
537 return dframe
->vect
[0].id
;
542 SCM_DEFINE (scm_stack_ref
, "stack-ref", 2, 0, 0,
545 #define FUNC_NAME s_scm_stack_ref
547 SCM_VALIDATE_STACK (1,stack
);
548 SCM_VALIDATE_INUM (2,i
);
549 SCM_ASSERT_RANGE (1,i
,
551 SCM_INUM (i
) < SCM_STACK_LENGTH (stack
));
552 return scm_cons (stack
, i
);
556 SCM_DEFINE (scm_stack_length
, "stack-length", 1, 0, 0,
559 #define FUNC_NAME s_scm_stack_length
561 SCM_VALIDATE_STACK (1,stack
);
562 return SCM_MAKINUM (SCM_STACK_LENGTH (stack
));
569 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
572 #define FUNC_NAME s_scm_frame_p
574 return SCM_BOOL(SCM_FRAMEP (obj
));
578 SCM_DEFINE (scm_last_stack_frame
, "last-stack-frame", 1, 0, 0,
581 #define FUNC_NAME s_scm_last_stack_frame
583 scm_debug_frame
*dframe
;
587 SCM_VALIDATE_NIM (1,obj
);
588 if (SCM_DEBUGOBJP (obj
))
589 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (obj
);
590 else if (scm_tc7_contin
== SCM_TYP7 (obj
))
592 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (obj
) + sizeof (scm_contregs
))
594 #ifndef STACK_GROWS_UP
595 offset
+= SCM_LENGTH (obj
);
597 dframe
= RELOC_FRAME (SCM_DFRAME (obj
), offset
);
605 if (!dframe
|| SCM_VOIDFRAMEP (*dframe
))
608 stack
= scm_make_struct (scm_stack_type
, SCM_MAKINUM (SCM_FRAME_N_SLOTS
),
610 SCM_STACK (stack
) -> length
= 1;
611 SCM_STACK (stack
) -> frames
= &SCM_STACK (stack
) -> tail
[0];
612 read_frame (dframe
, offset
,
613 (scm_info_frame
*) &SCM_STACK (stack
) -> frames
[0]);
615 return scm_cons (stack
, SCM_INUM0
);;
619 SCM_DEFINE (scm_frame_number
, "frame-number", 1, 0, 0,
622 #define FUNC_NAME s_scm_frame_number
624 SCM_VALIDATE_FRAME (1,frame
);
625 return SCM_MAKINUM (SCM_FRAME_NUMBER (frame
));
629 SCM_DEFINE (scm_frame_source
, "frame-source", 1, 0, 0,
632 #define FUNC_NAME s_scm_frame_source
634 SCM_VALIDATE_FRAME (1,frame
);
635 return SCM_FRAME_SOURCE (frame
);
639 SCM_DEFINE (scm_frame_procedure
, "frame-procedure", 1, 0, 0,
642 #define FUNC_NAME s_scm_frame_procedure
644 SCM_VALIDATE_FRAME (1,frame
);
645 return (SCM_FRAME_PROC_P (frame
)
646 ? SCM_FRAME_PROC (frame
)
651 SCM_DEFINE (scm_frame_arguments
, "frame-arguments", 1, 0, 0,
654 #define FUNC_NAME s_scm_frame_arguments
656 SCM_VALIDATE_FRAME (1,frame
);
657 return SCM_FRAME_ARGS (frame
);
661 SCM_DEFINE (scm_frame_previous
, "frame-previous", 1, 0, 0,
664 #define FUNC_NAME s_scm_frame_previous
667 SCM_VALIDATE_FRAME (1,frame
);
668 n
= SCM_INUM (SCM_CDR (frame
)) + 1;
669 if (n
>= SCM_STACK_LENGTH (SCM_CAR (frame
)))
672 return scm_cons (SCM_CAR (frame
), SCM_MAKINUM (n
));
676 SCM_DEFINE (scm_frame_next
, "frame-next", 1, 0, 0,
679 #define FUNC_NAME s_scm_frame_next
682 SCM_VALIDATE_FRAME (1,frame
);
683 n
= SCM_INUM (SCM_CDR (frame
)) - 1;
687 return scm_cons (SCM_CAR (frame
), SCM_MAKINUM (n
));
691 SCM_DEFINE (scm_frame_real_p
, "frame-real?", 1, 0, 0,
694 #define FUNC_NAME s_scm_frame_real_p
696 SCM_VALIDATE_FRAME (1,frame
);
697 return SCM_BOOL(SCM_FRAME_REAL_P (frame
));
701 SCM_DEFINE (scm_frame_procedure_p
, "frame-procedure?", 1, 0, 0,
704 #define FUNC_NAME s_scm_frame_procedure_p
706 SCM_VALIDATE_FRAME (1,frame
);
707 return SCM_BOOL(SCM_FRAME_PROC_P (frame
));
711 SCM_DEFINE (scm_frame_evaluating_args_p
, "frame-evaluating-args?", 1, 0, 0,
714 #define FUNC_NAME s_scm_frame_evaluating_args_p
716 SCM_VALIDATE_FRAME (1,frame
);
717 return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame
));
721 SCM_DEFINE (scm_frame_overflow_p
, "frame-overflow?", 1, 0, 0,
724 #define FUNC_NAME s_scm_frame_overflow_p
726 SCM_VALIDATE_FRAME (1,frame
);
727 return SCM_BOOL(SCM_FRAME_OVERFLOW_P (frame
));
737 SCM vtable_layout
= scm_make_struct_layout (scm_nullstr
);
739 = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT
));
740 vtable
= scm_make_vtable_vtable (vtable_layout
, SCM_INUM0
, SCM_EOL
);
742 = scm_permanent_object (scm_make_struct (vtable
, SCM_INUM0
,
743 scm_cons (stack_layout
,
745 scm_set_struct_vtable_name_x (scm_stack_type
,
746 SCM_CAR (scm_intern0 ("stack")));
747 #include "libguile/stacks.x"