1 /* Representation of stack frame debug information
2 * Copyright (C) 1996 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 */
50 #include "continuations.h"
56 /* {Frames and stacks}
58 * The debugging evaluator creates debug frames on the stack. These
59 * are linked from the innermost frame and outwards. The last frame
60 * created can always be accessed as SCM_LAST_DEBUG_FRAME.
61 * Continuations contain a pointer to the innermost debug frame on the
64 * Each debug frame contains a set of flags and information about one
65 * or more stack frames. The case of multiple frames occurs due to
66 * tail recursion. The maximal number of stack frames which can be
67 * recorded in one debug frame can be set dynamically with the debug
70 * Stack frame information is of two types: eval information (the
71 * expression being evaluated and its environment) and apply
72 * information (the procedure being applied and its arguments). A
73 * stack frame normally corresponds to an eval/apply pair, but macros
74 * and special forms (which are implemented as macros in Guile) only
75 * have eval information and apply calls leads to apply only frames.
77 * Since we want to record the total stack information and later
78 * manipulate this data at the scheme level in the debugger, we need
79 * to transform it into a new representation. In the following code
80 * section you'll find the functions implementing this data type.
84 * The stack is represented as a struct with an id slot and a tail
85 * array of scm_info_frame structs.
87 * A frame is represented as a pair where the car contains a stack and
88 * the cdr an inum. The inum is an index to the first SCM value of
89 * the scm_info_frame struct.
113 * frame-evaluating-args?
118 /* Some auxiliary functions for reading debug frames off the stack.
121 /* Stacks often contain pointers to other items on the stack; for
122 example, each scm_debug_frame structure contains a pointer to the
123 next frame out. When we capture a continuation, we copy the stack
124 into the heap, and just leave all the pointers unchanged. This
125 makes it simple to restore the continuation --- just copy the stack
126 back! However, if we retrieve a pointer from the heap copy to
127 another item that was originally on the stack, we have to add an
128 offset to the pointer to discover the new referent.
130 If PTR is a pointer retrieved from a continuation, whose original
131 target was on the stack, and OFFSET is the appropriate offset from
132 the original stack to the continuation, then RELOC_MUMBLE (PTR,
133 OFFSET) is a pointer to the copy in the continuation of the
134 original referent, cast to an scm_debug_MUMBLE *. */
135 #define RELOC_INFO(ptr, offset) \
136 ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
137 #define RELOC_FRAME(ptr, offset) \
138 ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
141 /* Count number of debug info frames on a stack, beginning with
142 * DFRAME. OFFSET is used for relocation of pointers when the stack
143 * is read from a continuation.
145 static int stack_depth
SCM_P ((scm_debug_frame
*dframe
, long offset
, SCM
*id
, int *maxp
));
147 stack_depth (dframe
, offset
, id
, maxp
)
148 scm_debug_frame
*dframe
;
154 int max_depth
= SCM_BACKTRACE_MAXDEPTH
;
155 scm_debug_info
*info
;
157 dframe
&& !SCM_VOIDFRAMEP (*dframe
) && n
< max_depth
;
158 dframe
= RELOC_FRAME (dframe
->prev
, offset
))
160 if (SCM_EVALFRAMEP (*dframe
))
162 size
= dframe
->status
& SCM_MAX_FRAME_SIZE
;
163 info
= RELOC_INFO (dframe
->info
, offset
);
164 n
+= (info
- dframe
->vect
) / 2 + 1;
165 /* Data in the apply part of an eval info frame comes from previous
166 stack frame if the scm_debug_info vector is overflowed. */
167 if ((((info
- dframe
->vect
) & 1) == 0)
168 && SCM_OVERFLOWP (*dframe
)
169 && !SCM_UNBNDP (info
[1].a
.proc
))
175 if (dframe
&& SCM_VOIDFRAMEP (*dframe
))
176 *id
= dframe
->vect
[0].id
;
182 /* Read debug info from DFRAME into IFRAME.
184 static void read_frame
SCM_P ((scm_debug_frame
*dframe
, long offset
, scm_info_frame
*iframe
));
186 read_frame (dframe
, offset
, iframe
)
187 scm_debug_frame
*dframe
;
189 scm_info_frame
*iframe
;
191 SCM flags
= SCM_INUM0
;
193 scm_debug_info
*info
;
194 if (SCM_EVALFRAMEP (*dframe
))
196 size
= dframe
->status
& SCM_MAX_FRAME_SIZE
;
197 info
= RELOC_INFO (dframe
->info
, offset
);
198 if ((info
- dframe
->vect
) & 1)
200 /* Debug.vect ends with apply info. */
202 if (info
[1].a
.proc
!= SCM_UNDEFINED
)
204 flags
|= SCM_FRAMEF_PROC
;
205 iframe
->proc
= info
[1].a
.proc
;
206 iframe
->args
= info
[1].a
.args
;
207 if (!SCM_ARGS_READY_P (*dframe
))
208 flags
|= SCM_FRAMEF_EVAL_ARGS
;
211 iframe
->source
= scm_make_memoized (info
[0].e
.exp
, info
[0].e
.env
);
215 flags
|= SCM_FRAMEF_PROC
;
216 iframe
->proc
= dframe
->vect
[0].a
.proc
;
217 iframe
->args
= dframe
->vect
[0].a
.args
;
219 iframe
->flags
= flags
;
222 /* Fill the scm_info_frame vector IFRAME with data from N stack frames
223 * starting with the first stack frame represented by debug frame
227 #define NEXT_FRAME(iframe, n, quit) \
235 static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
237 read_frames (dframe
, offset
, n
, iframes
)
238 scm_debug_frame
*dframe
;
241 scm_info_frame
*iframes
;
244 scm_info_frame
*iframe
= iframes
;
245 scm_debug_info
*info
;
248 dframe
&& !SCM_VOIDFRAMEP (*dframe
) && n
> 0;
249 dframe
= RELOC_FRAME (dframe
->prev
, offset
))
251 read_frame (dframe
, offset
, iframe
);
252 if (SCM_EVALFRAMEP (*dframe
))
254 size
= dframe
->status
& SCM_MAX_FRAME_SIZE
;
255 info
= RELOC_INFO (dframe
->info
, offset
);
256 if ((info
- dframe
->vect
) & 1)
258 /* Data in the apply part of an eval info frame comes from
259 previous stack frame if the scm_debug_info vector is overflowed. */
260 else if (SCM_OVERFLOWP (*dframe
)
261 && !SCM_UNBNDP (info
[1].a
.proc
))
263 NEXT_FRAME (iframe
, n
, quit
);
264 iframe
->flags
= SCM_INUM0
| SCM_FRAMEF_PROC
;
265 iframe
->proc
= info
[1].a
.proc
;
266 iframe
->args
= info
[1].a
.args
;
268 if (SCM_OVERFLOWP (*dframe
))
269 iframe
->flags
|= SCM_FRAMEF_OVERFLOW
;
271 NEXT_FRAME (iframe
, n
, quit
);
272 while (info
>= dframe
->vect
)
274 if (!SCM_UNBNDP (info
[1].a
.proc
))
276 iframe
->flags
= SCM_INUM0
| SCM_FRAMEF_PROC
;
277 iframe
->proc
= info
[1].a
.proc
;
278 iframe
->args
= info
[1].a
.args
;
281 iframe
->flags
= SCM_INUM0
;
282 iframe
->source
= scm_make_memoized (info
[0].e
.exp
,
285 NEXT_FRAME (iframe
, n
, quit
);
290 NEXT_FRAME (iframe
, n
, quit
);
293 if (iframe
> iframes
)
294 (iframe
- 1) -> flags
|= SCM_FRAMEF_REAL
;
298 static void narrow_stack
SCM_P ((SCM stack
, int inner
, SCM inner_key
, int outer
, SCM outer_key
));
301 narrow_stack (stack
, inner
, inner_key
, outer
, outer_key
)
308 scm_stack
*s
= SCM_STACK (stack
);
312 /* Cut inner part. */
313 for (i
= 0; inner
; --inner
)
314 if (s
->frames
[i
++].proc
== inner_key
)
316 s
->frames
= &s
->frames
[i
];
319 /* Cut outer part. */
320 for (; n
&& outer
; --outer
)
321 if (s
->frames
[--n
].proc
== outer_key
)
334 SCM_PROC (s_stack_p
, "stack?", 1, 0, 0, scm_stack_p
);
339 return SCM_NIMP (obj
) && SCM_STACKP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
342 SCM_PROC (s_make_stack
, "make-stack", 0, 0, 1, scm_make_stack
);
344 scm_make_stack (args
)
348 scm_debug_frame
*dframe
;
349 scm_info_frame
*iframe
;
352 SCM obj
, inner_cut
, outer_cut
;
354 SCM_ASSERT (SCM_NIMP (args
) && SCM_CONSP (args
),
355 scm_makfrom0str (s_make_stack
),
358 obj
= SCM_CAR (args
);
359 args
= SCM_CDR (args
);
361 /* Extract a pointer to the innermost frame of whatever object
362 scm_make_stack was given. */
363 if (obj
== SCM_BOOL_T
)
364 dframe
= scm_last_debug_frame
;
367 SCM_ASSERT (SCM_NIMP (obj
), obj
, SCM_ARG1
, s_make_stack
);
368 if (SCM_DEBUGOBJP (obj
))
369 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (obj
);
370 else if (scm_tc7_contin
== SCM_TYP7 (obj
))
372 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (obj
) + sizeof (scm_contregs
))
374 #ifndef STACK_GROWS_UP
375 offset
+= SCM_LENGTH (obj
);
377 dframe
= RELOC_FRAME (SCM_DFRAME (obj
), offset
);
381 scm_wta (obj
, (char *) SCM_ARG1
, s_make_stack
);
386 /* Count number of frames. Also get stack id tag and check whether
387 there are more stackframes than we want to record
388 (SCM_BACKTRACE_MAXDEPTH). */
391 n
= stack_depth (dframe
, offset
, &id
, &maxp
);
392 size
= n
* SCM_FRAME_N_SLOTS
;
394 /* Make the stack object. */
395 stack
= scm_make_struct (scm_stack_type
, SCM_MAKINUM (size
), SCM_EOL
);
396 SCM_STACK (stack
) -> id
= id
;
397 SCM_STACK (stack
) -> length
= n
;
398 iframe
= &SCM_STACK (stack
) -> tail
[0];
399 SCM_STACK (stack
) -> frames
= iframe
;
401 /* Translate the current chain of stack frames into debugging information. */
402 read_frames (RELOC_FRAME (dframe
, offset
), offset
, n
, iframe
);
404 /* Narrow the stack according to the arguments given to scm_make_stack. */
405 while (n
> 0 && SCM_NIMP (args
) && SCM_CONSP (args
))
407 inner_cut
= SCM_CAR (args
);
408 args
= SCM_CDR (args
);
409 if (SCM_NIMP (args
) && SCM_CONSP (args
))
411 outer_cut
= SCM_CAR (args
);
412 args
= SCM_CDR (args
);
415 outer_cut
= SCM_INUM0
;
418 SCM_INUMP (inner_cut
) ? SCM_INUM (inner_cut
) : n
,
419 SCM_INUMP (inner_cut
) ? 0 : inner_cut
,
420 SCM_INUMP (outer_cut
) ? SCM_INUM (outer_cut
) : n
,
421 SCM_INUMP (outer_cut
) ? 0 : outer_cut
);
423 n
= SCM_STACK (stack
) -> length
;
429 iframe
[n
- 1].flags
|= SCM_FRAMEF_OVERFLOW
;
436 SCM_PROC (s_stack_id
, "stack-id", 1, 0, 0, scm_stack_id
);
441 scm_debug_frame
*dframe
;
443 if (stack
== SCM_BOOL_T
)
444 dframe
= scm_last_debug_frame
;
447 SCM_ASSERT (SCM_NIMP (stack
), stack
, SCM_ARG1
, s_make_stack
);
448 if (SCM_DEBUGOBJP (stack
))
449 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (stack
);
450 else if (scm_tc7_contin
== SCM_TYP7 (stack
))
452 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (stack
) + sizeof (scm_contregs
))
454 #ifndef STACK_GROWS_UP
455 offset
+= SCM_LENGTH (stack
);
457 dframe
= RELOC_FRAME (SCM_DFRAME (stack
), offset
);
459 else if (SCM_STACKP (stack
))
460 return SCM_STACK (stack
) -> id
;
461 else scm_wrong_type_arg (s_stack_id
, SCM_ARG1
, stack
);
463 while (dframe
&& !SCM_VOIDFRAMEP (*dframe
))
464 dframe
= RELOC_FRAME (dframe
->prev
, offset
);
465 if (dframe
&& SCM_VOIDFRAMEP (*dframe
))
466 return dframe
->vect
[0].id
;
470 SCM_PROC (s_stack_ref
, "stack-ref", 2, 0, 0, scm_stack_ref
);
472 scm_stack_ref (stack
, i
)
476 SCM_ASSERT (SCM_NIMP (stack
)
477 && SCM_STACKP (stack
),
481 SCM_ASSERT (SCM_INUMP (i
), i
, SCM_ARG2
, s_stack_ref
);
482 SCM_ASSERT (SCM_INUM (i
) >= 0
483 && SCM_INUM (i
) < SCM_STACK_LENGTH (stack
),
487 return scm_cons (stack
, i
);
490 SCM_PROC(s_stack_length
, "stack-length", 1, 0, 0, scm_stack_length
);
492 scm_stack_length (stack
)
495 SCM_ASSERT (SCM_NIMP (stack
)
496 && SCM_STACKP (stack
),
500 return SCM_MAKINUM (SCM_STACK_LENGTH (stack
));
506 SCM_PROC (s_frame_p
, "frame?", 1, 0, 0, scm_frame_p
);
511 return SCM_NIMP (obj
) && SCM_FRAMEP (obj
);
514 SCM_PROC(s_last_stack_frame
, "last-stack-frame", 1, 0, 0, scm_last_stack_frame
);
516 scm_last_stack_frame (obj
)
519 scm_debug_frame
*dframe
;
523 SCM_ASSERT (SCM_NIMP (obj
), obj
, SCM_ARG1
, s_last_stack_frame
);
524 if (SCM_DEBUGOBJP (obj
))
525 dframe
= (scm_debug_frame
*) SCM_DEBUGOBJ_FRAME (obj
);
526 else if (scm_tc7_contin
== SCM_TYP7 (obj
))
528 offset
= ((SCM_STACKITEM
*) (SCM_CHARS (obj
) + sizeof (scm_contregs
))
530 #ifndef STACK_GROWS_UP
531 offset
+= SCM_LENGTH (obj
);
533 dframe
= RELOC_FRAME (SCM_DFRAME (obj
), offset
);
537 scm_wta (obj
, (char *) SCM_ARG1
, s_last_stack_frame
);
541 if (!dframe
|| SCM_VOIDFRAMEP (*dframe
))
544 stack
= scm_make_struct (scm_stack_type
, SCM_MAKINUM (SCM_FRAME_N_SLOTS
),
546 SCM_STACK (stack
) -> length
= 1;
547 SCM_STACK (stack
) -> frames
= &SCM_STACK (stack
) -> tail
[0];
548 read_frame (dframe
, offset
,
549 (scm_info_frame
*) &SCM_STACK (stack
) -> frames
[0]);
551 return scm_cons (stack
, SCM_INUM0
);;
554 SCM_PROC(s_frame_number
, "frame-number", 1, 0, 0, scm_frame_number
);
556 scm_frame_number (frame
)
559 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
563 return SCM_MAKINUM (SCM_FRAME_NUMBER (frame
));
566 SCM_PROC(s_frame_source
, "frame-source", 1, 0, 0, scm_frame_source
);
568 scm_frame_source (frame
)
571 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
575 return SCM_FRAME_SOURCE (frame
);
578 SCM_PROC(s_frame_procedure
, "frame-procedure", 1, 0, 0, scm_frame_procedure
);
580 scm_frame_procedure (frame
)
583 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
587 return (SCM_FRAME_PROC_P (frame
)
588 ? SCM_FRAME_PROC (frame
)
592 SCM_PROC(s_frame_arguments
, "frame-arguments", 1, 0, 0, scm_frame_arguments
);
594 scm_frame_arguments (frame
)
597 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
601 return SCM_FRAME_ARGS (frame
);
604 SCM_PROC(s_frame_previous
, "frame-previous", 1, 0, 0, scm_frame_previous
);
606 scm_frame_previous (frame
)
610 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
614 n
= SCM_INUM (SCM_CDR (frame
)) + 1;
615 if (n
>= SCM_STACK_LENGTH (SCM_CAR (frame
)))
618 return scm_cons (SCM_CAR (frame
), SCM_MAKINUM (n
));
621 SCM_PROC(s_frame_next
, "frame-next", 1, 0, 0, scm_frame_next
);
623 scm_frame_next (frame
)
627 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
631 n
= SCM_INUM (SCM_CDR (frame
)) - 1;
635 return scm_cons (SCM_CAR (frame
), SCM_MAKINUM (n
));
638 SCM_PROC(s_frame_real_p
, "frame-real?", 1, 0, 0, scm_frame_real_p
);
640 scm_frame_real_p (frame
)
643 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
647 return SCM_FRAME_REAL_P (frame
) ? SCM_BOOL_T
: SCM_BOOL_F
;
650 SCM_PROC(s_frame_procedure_p
, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p
);
652 scm_frame_procedure_p (frame
)
655 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
658 s_frame_procedure_p
);
659 return SCM_FRAME_PROC_P (frame
) ? SCM_BOOL_T
: SCM_BOOL_F
;
662 SCM_PROC(s_frame_evaluating_args_p
, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p
);
664 scm_frame_evaluating_args_p (frame
)
667 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
670 s_frame_evaluating_args_p
);
671 return SCM_FRAME_EVAL_ARGS_P (frame
) ? SCM_BOOL_T
: SCM_BOOL_F
;
674 SCM_PROC(s_frame_overflow_p
, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p
);
676 scm_frame_overflow_p (frame
)
679 SCM_ASSERT (SCM_NIMP (frame
) && SCM_FRAMEP (frame
),
683 return SCM_FRAME_OVERFLOW_P (frame
) ? SCM_BOOL_T
: SCM_BOOL_F
;
692 SCM vtable_layout
= scm_make_struct_layout (scm_nullstr
);
694 = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT
));
695 vtable
= scm_make_vtable_vtable (vtable_layout
, SCM_INUM0
, SCM_EOL
);
697 = scm_permanent_object (scm_make_struct (vtable
, SCM_INUM0
,
698 scm_cons (stack_layout
,