mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

replace frame implementation with VM frames

Browse source 
* libguile/stacks.h: Rework so that a stack doesn't copy information out
  of VM frames, it just holds onto a VM frame, along with the stack id
  and length. VM frames are now the only representation of frames in
  Guile.
  (scm_t_info_frame, SCM_FRAME_N_SLOTS, SCM_FRAME_REF, SCM_FRAME_NUMBER)
  (SCM_FRAME_FLAGS, SCM_FRAME_SOURCE, SCM_FRAME_PROC, SCM_FRAME_ARGS)
  (SCM_FRAME_PREV, SCM_FRAME_NEXT)
  (SCM_FRAMEF_VOID, SCM_FRAMEF_REAL, SCM_FRAMEF_PROC)
  (SCM_FRAMEF_EVAL_ARGS, SCM_FRAMEF_OVERFLOW)
  (SCM_FRAME_VOID_P, SCM_FRAME_REAL_P, SCM_FRAME_PROC_P)
  (SCM_FRAME_EVAL_ARGS_P, SCM_FRAME_OVERFLOW_P): Remove these macros
  corresponding to the old frame implementation.
  (scm_frame_p scm_frame_source, scm_frame_procedure)
  (scm_frame_arguments): These definitions are now in frames.h.
  (scm_last_stack_frame): Remove declaration of previously-removed
  constructor. Probably should re-instate it though.
  (scm_frame_number, scm_frame_previous, scm_frame_next)
  (scm_frame_real_p, scm_frame_procedure_p, scm_frame_evaluating_args_p)
  (scm_frame_overflow_p) : Remove these procedures corresponding to the
  old stack implementation.

* libguile/stacks.c: Update for new frames implementation.

* libguile/frames.h:
* libguile/frames.c: Rename functions operating on VM frames to have a
  scm_frame prefix, not scm_vm_frame -- because they really are the only
  frames we have. Rename corresponding Scheme functions too, from
  vm-frame-foo to frame-foo.

* libguile/deprecated.h: Remove scm_stack and scm_info_frame data types.

* libguile/vm.c (vm_dispatch_hook): Adapt to scm_c_make_frame name
  change.

* module/system/vm/frame.scm: No need to export functions provided
  frames.c now, as we load those procedures into the default environment
  now. Rename functions, and remove a couple of outdated, unused
  functions. The bottom half of this file is still bitrotten, though.

* libguile/backtrace.c: Rework to operate on the new frame
  representation. Also fix a bug displaying file names for compiled
  procedures.

* libguile/init.c: Load the VM much earlier, just because we can. Also
  it allows us to have frames.[ch] loaded in time for stacks to be
  initialized, so that scm_frame_arguments can do the right thing.
This commit is contained in:
Andy Wingo 2009-12-03 13:09:58 +01:00
parent 14aa25e410
commit aa3f69519f
9 changed files with 249 additions and 542 deletions
Download patch file Download diff file Expand all files Collapse all files

139
libguile/backtrace.c
View file

@ -43,6 +43,7 @@
#include "libguile/ports.h" #include "libguile/ports.h"
#include "libguile/strings.h" #include "libguile/strings.h"
#include "libguile/dynwind.h" #include "libguile/dynwind.h"
#include "libguile/frames.h"
#include "libguile/validate.h" #include "libguile/validate.h"
#include "libguile/lang.h" #include "libguile/lang.h"
@ -157,11 +158,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM port)
pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH; pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
if (scm_is_symbol (pname) || scm_is_string (pname)) if (scm_is_symbol (pname) || scm_is_string (pname))
{ {
if (SCM_FRAMEP (frame) scm_puts ("In procedure ", port);
&& SCM_FRAME_EVAL_ARGS_P (frame))
scm_puts ("While evaluating arguments to ", port);
else
scm_puts ("In procedure ", port);
scm_iprin1 (pname, port, pstate); scm_iprin1 (pname, port, pstate);
} }
scm_puts (":\n", port); scm_puts (":\n", port);
@ -354,14 +351,14 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S
static void static void
display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate) display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{ {
SCM proc = SCM_FRAME_PROC (frame); SCM proc = scm_frame_procedure (frame);
SCM name = (scm_is_true (scm_procedure_p (proc)) SCM name = (scm_is_true (scm_procedure_p (proc))
? scm_procedure_name (proc) ? scm_procedure_name (proc)
: SCM_BOOL_F); : SCM_BOOL_F);
display_frame_expr ("[", display_frame_expr ("[",
scm_cons (scm_is_true (name) ? name : proc, scm_cons (scm_is_true (name) ? name : proc,
SCM_FRAME_ARGS (frame)), scm_frame_arguments (frame)),
SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]", "]",
indentation, indentation,
sport, sport,
port, port,
@ -383,30 +380,27 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
if (SCM_UNBNDP (indent)) if (SCM_UNBNDP (indent))
indent = SCM_INUM0; indent = SCM_INUM0;
if (SCM_FRAME_PROC_P (frame)) /* Display an application. */
/* Display an application. */ {
{ SCM sport, print_state;
SCM sport, print_state; scm_print_state *pstate;
scm_print_state *pstate;
/* Create a string port used for adaptation of printing parameters. */ /* Create a string port used for adaptation of printing parameters. */
sport = scm_mkstrport (SCM_INUM0, sport = scm_mkstrport (SCM_INUM0,
scm_make_string (scm_from_int (240), scm_make_string (scm_from_int (240),
SCM_UNDEFINED), SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG, SCM_OPN | SCM_WRTNG,
FUNC_NAME); FUNC_NAME);
/* Create a print state for printing of frames. */ /* Create a print state for printing of frames. */
print_state = scm_make_print_state (); print_state = scm_make_print_state ();
pstate = SCM_PRINT_STATE (print_state); pstate = SCM_PRINT_STATE (print_state);
pstate->writingp = 1; pstate->writingp = 1;
pstate->fancyp = 1; pstate->fancyp = 1;
display_application (frame, scm_to_int (indent), sport, port, pstate); display_application (frame, scm_to_int (indent), sport, port, pstate);
return SCM_BOOL_T; return SCM_BOOL_T;
} }
else
return SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -415,7 +409,7 @@ SCM_SYMBOL (sym_base, "base");
static void static void
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line) display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{ {
SCM source = SCM_FRAME_SOURCE (frame); SCM source = scm_frame_source (frame);
*file = *line = SCM_BOOL_F; *file = *line = SCM_BOOL_F;
if (scm_is_pair (source) if (scm_is_pair (source)
&& scm_is_pair (scm_cdr (source)) && scm_is_pair (scm_cdr (source))
@ -439,7 +433,7 @@ display_backtrace_file (frame, last_file, port, pstate)
display_backtrace_get_file_line (frame, &file, &line); display_backtrace_get_file_line (frame, &file, &line);
if (scm_is_eq (file, *last_file)) if (scm_is_true (scm_equal_p (file, *last_file)))
return; return;
*last_file = file; *last_file = file;
@ -506,23 +500,16 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
} }
static void static void
display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate) display_frame (SCM frame, int n, int nfield, int indentation,
SCM sport, SCM port, scm_print_state *pstate)
{ {
int n, i, j; int i, j;
/* Announce missing frames? */
if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{
indent (nfield + 1 + indentation, port);
scm_puts ("...\n", port);
}
/* display file name and line number */ /* display file name and line number */
if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME))) if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
display_backtrace_file_and_line (frame, port, pstate); display_backtrace_file_and_line (frame, port, pstate);
/* Check size of frame number. */ /* Check size of frame number. */
n = SCM_FRAME_NUMBER (frame);
for (i = 0, j = n; j > 0; ++i) j /= 10; for (i = 0, j = n; j > 0; ++i) j /= 10;
/* Number indentation. */ /* Number indentation. */
@ -531,38 +518,12 @@ display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_
/* Frame number. */ /* Frame number. */
scm_iprin1 (scm_from_int (n), port, pstate); scm_iprin1 (scm_from_int (n), port, pstate);
/* Real frame marker */
scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
/* Indentation. */ /* Indentation. */
indent (indentation, port); indent (indentation, port);
if (SCM_FRAME_PROC_P (frame)) /* Display an application. */
/* Display an application. */ display_application (frame, nfield + 1 + indentation, sport, port, pstate);
display_application (frame, nfield + 1 + indentation, sport, port, pstate);
else
/* Display a special form. */
{
SCM source = SCM_FRAME_SOURCE (frame);
SCM copy = (scm_is_pair (source)
? scm_source_property (source, scm_sym_copy)
: SCM_BOOL_F);
display_frame_expr ("(",
copy,
")",
nfield + 1 + indentation,
sport,
port,
pstate);
}
scm_putc ('\n', port); scm_putc ('\n', port);
/* Announce missing frames? */
if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{
indent (nfield + 1 + indentation, port);
scm_puts ("...\n", port);
}
} }
struct display_backtrace_args { struct display_backtrace_args {
@ -633,48 +594,26 @@ display_backtrace_body (struct display_backtrace_args *a)
pstate->highlight_objects = a->highlight_objects; pstate->highlight_objects = a->highlight_objects;
/* First find out if it's reasonable to do indentation. */ /* First find out if it's reasonable to do indentation. */
if (SCM_BACKWARDS_P) indent_p = 0;
indent_p = 0;
else
{
unsigned int j;
indent_p = 1;
frame = scm_stack_ref (a->stack, scm_from_int (beg));
for (i = 0, j = 0; i < n; ++i)
{
if (SCM_FRAME_REAL_P (frame))
++j;
if (j > SCM_BACKTRACE_INDENT)
{
indent_p = 0;
break;
}
frame = (SCM_BACKWARDS_P
? SCM_FRAME_PREV (frame)
: SCM_FRAME_NEXT (frame));
}
}
/* Determine size of frame number field. */ /* Determine size of frame number field. */
j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end))); j = end;
for (i = 0; j > 0; ++i) j /= 10; for (i = 0; j > 0; ++i) j /= 10;
nfield = i ? i : 1; nfield = i ? i : 1;
/* Print frames. */ /* Print frames. */
frame = scm_stack_ref (a->stack, scm_from_int (beg));
indentation = 1; indentation = 1;
last_file = SCM_UNDEFINED; last_file = SCM_UNDEFINED;
for (i = 0; i < n; ++i) if (SCM_BACKWARDS_P)
end++;
else
end--;
for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i)
{ {
frame = scm_stack_ref (a->stack, scm_from_int (i));
if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
display_backtrace_file (frame, &last_file, a->port, pstate); display_backtrace_file (frame, &last_file, a->port, pstate);
display_frame (frame, i, nfield, indentation, sport, a->port, pstate);
display_frame (frame, nfield, indentation, sport, a->port, pstate);
if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
++indentation;
frame = (SCM_BACKWARDS_P ?
SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
} }
scm_remember_upto_here_1 (print_state); scm_remember_upto_here_1 (print_state);

2
libguile/deprecated.h
View file

@ -240,8 +240,6 @@ SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define scm_option scm_t_option #define scm_option scm_t_option
#define scm_srcprops scm_t_srcprops #define scm_srcprops scm_t_srcprops
#define scm_srcprops_chunk scm_t_srcprops_chunk #define scm_srcprops_chunk scm_t_srcprops_chunk
#define scm_info_frame scm_t_info_frame
#define scm_stack scm_t_stack
#define scm_array scm_t_array #define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim #define scm_array_dim scm_t_array_dim
#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS #define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS

89
libguile/frames.c
View file

@ -27,31 +27,31 @@
#include "frames.h" #include "frames.h"
scm_t_bits scm_tc16_vm_frame; scm_t_bits scm_tc16_frame;
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame)) #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM SCM
scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_t_uint8 *ip, scm_t_ptrdiff offset) scm_t_uint8 *ip, scm_t_ptrdiff offset)
{ {
struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame), struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
"vmframe"); "vmframe");
p->stack_holder = stack_holder; p->stack_holder = stack_holder;
p->fp = fp; p->fp = fp;
p->sp = sp; p->sp = sp;
p->ip = ip; p->ip = ip;
p->offset = offset; p->offset = offset;
SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p); SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
} }
static int static int
vm_frame_print (SCM frame, SCM port, scm_print_state *pstate) frame_print (SCM frame, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<vm-frame ", port); scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port); scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_putc (' ', port); scm_putc (' ', port);
scm_write (scm_vm_frame_program (frame), port); scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */ /* don't write args, they can get us into trouble. */
scm_puts (">", port); scm_puts (">", port);
@ -61,28 +61,29 @@ vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
/* Scheme interface */ /* Scheme interface */
SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0, SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj), (SCM obj),
"") "")
#define FUNC_NAME s_scm_vm_frame_p #define FUNC_NAME s_scm_frame_p
{ {
return scm_from_bool (SCM_VM_FRAME_P (obj)); return scm_from_bool (SCM_VM_FRAME_P (obj));
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0, SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_program #define FUNC_NAME s_scm_frame_procedure
{ {
SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame)); return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
scm_vm_frame_arguments (SCM frame) (SCM frame),
#define FUNC_NAME "vm-frame-arguments" "")
#define FUNC_NAME s_scm_frame_arguments
{ {
static SCM var = SCM_BOOL_F; static SCM var = SCM_BOOL_F;
@ -90,16 +91,16 @@ scm_vm_frame_arguments (SCM frame)
if (scm_is_false (var)) if (scm_is_false (var))
var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"), var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
"vm-frame-arguments"); "frame-arguments");
return scm_call_1 (SCM_VARIABLE_REF (var), frame); return scm_call_1 (SCM_VARIABLE_REF (var), frame);
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0, SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_source #define FUNC_NAME s_scm_frame_source
{ {
SCM *fp; SCM *fp;
struct scm_objcode *bp; struct scm_objcode *bp;
@ -118,11 +119,11 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
the presence of not-yet-active frames on the stack. So we have a cheap the presence of not-yet-active frames on the stack. So we have a cheap
heuristic to detect not-yet-active frames, and skip over them. Perhaps we heuristic to detect not-yet-active frames, and skip over them. Perhaps we
should represent them more usefully. should represent them more usefully.
*/ */
SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0, SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_num_locals #define FUNC_NAME s_scm_frame_num_locals
{ {
SCM *sp, *p; SCM *sp, *p;
unsigned int n = 0; unsigned int n = 0;
@ -146,11 +147,11 @@ SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
/* Need same not-yet-active frame logic here as in vm-frame-num-locals */ /* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0, SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
(SCM frame, SCM index), (SCM frame, SCM index),
"") "")
#define FUNC_NAME s_scm_vm_frame_local_ref #define FUNC_NAME s_scm_frame_local_ref
{ {
SCM *sp, *p; SCM *sp, *p;
unsigned int n = 0; unsigned int n = 0;
@ -178,11 +179,11 @@ SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
/* Need same not-yet-active frame logic here as in vm-frame-num-locals */ /* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0, SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val), (SCM frame, SCM index, SCM val),
"") "")
#define FUNC_NAME s_scm_vm_frame_local_set_x #define FUNC_NAME s_scm_frame_local_set_x
{ {
SCM *sp, *p; SCM *sp, *p;
unsigned int n = 0; unsigned int n = 0;
@ -213,22 +214,22 @@ SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer", 1, 0, 0, SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_instruction_pointer #define FUNC_NAME s_scm_frame_instruction_pointer
{ {
SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long) return scm_from_ulong ((unsigned long)
(SCM_VM_FRAME_IP (frame) (SCM_VM_FRAME_IP (frame)
- SCM_PROGRAM_DATA (scm_vm_frame_program (frame))->base)); - SCM_PROGRAM_DATA (scm_frame_procedure (frame))->base));
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0, SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_return_address #define FUNC_NAME s_scm_frame_return_address
{ {
SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long) return scm_from_ulong ((unsigned long)
@ -237,10 +238,10 @@ SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0, SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_mv_return_address #define FUNC_NAME s_scm_frame_mv_return_address
{ {
SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long) return scm_from_ulong ((unsigned long)
@ -249,10 +250,10 @@ SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0, SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_vm_frame_dynamic_link #define FUNC_NAME s_scm_frame_dynamic_link
{ {
SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */ /* fixme: munge fp if holder is a continuation */
@ -264,7 +265,7 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
extern SCM extern SCM
scm_c_vm_frame_prev (SCM frame) scm_c_frame_prev (SCM frame)
{ {
SCM *this_fp, *new_fp, *new_sp; SCM *this_fp, *new_fp, *new_sp;
this_fp = SCM_VM_FRAME_FP (frame); this_fp = SCM_VM_FRAME_FP (frame);
@ -272,10 +273,10 @@ scm_c_vm_frame_prev (SCM frame)
if (new_fp) if (new_fp)
{ new_fp = RELOC (frame, new_fp); { new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1; new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame), return scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
new_fp, new_sp, new_fp, new_sp,
SCM_FRAME_RETURN_ADDRESS (this_fp), SCM_FRAME_RETURN_ADDRESS (this_fp),
SCM_VM_FRAME_OFFSET (frame)); SCM_VM_FRAME_OFFSET (frame));
} }
else else
return SCM_BOOL_F; return SCM_BOOL_F;
@ -285,8 +286,8 @@ scm_c_vm_frame_prev (SCM frame)
void void
scm_bootstrap_frames (void) scm_bootstrap_frames (void)
{ {
scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0); scm_tc16_frame = scm_make_smob_type ("frame", 0);
scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print); scm_set_smob_print (scm_tc16_frame, frame_print);
scm_c_register_extension ("libguile", "scm_init_frames", scm_c_register_extension ("libguile", "scm_init_frames",
(scm_t_extension_init_func)scm_init_frames, NULL); (scm_t_extension_init_func)scm_init_frames, NULL);
} }

46
libguile/frames.h
View file

@ -27,6 +27,16 @@
* VM frames * VM frames
*/ */
/*
* It's a little confusing, but there are two representations of frames in this
* file: frame pointers and Scheme objects wrapping those frame pointers. The
* former uses the SCM_FRAME_... macro prefix, the latter SCM_VM_FRAME_..
* prefix.
*
* The confusing thing is that only Scheme frame objects have functions that use
* them, and they use the scm_frame_.. prefix. Hysterical raisins.
*/
/* VM Frame Layout /* VM Frame Layout
--------------- ---------------
@ -77,9 +87,9 @@
* Heap frames * Heap frames
*/ */
SCM_API scm_t_bits scm_tc16_vm_frame; SCM_API scm_t_bits scm_tc16_frame;
struct scm_vm_frame struct scm_frame
{ {
SCM stack_holder; SCM stack_holder;
SCM *fp; SCM *fp;
@ -88,8 +98,8 @@ struct scm_vm_frame
scm_t_ptrdiff offset; scm_t_ptrdiff offset;
}; };
#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x) #define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x)) #define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder #define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp #define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp #define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
@ -97,21 +107,21 @@ struct scm_vm_frame
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset #define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_t_uint8 *ip, scm_t_ptrdiff offset); scm_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_vm_frame_p (SCM obj); SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame); SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_vm_frame_source (SCM frame); SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_vm_frame_num_locals (SCM frame); SCM_API SCM scm_frame_num_locals (SCM frame);
SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index); SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
SCM_API SCM scm_vm_frame_instruction_pointer (SCM frame); SCM_API SCM scm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_vm_frame_return_address (SCM frame); SCM_API SCM scm_frame_return_address (SCM frame);
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); SCM_API SCM scm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); SCM_API SCM scm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_c_vm_frame_prev (SCM frame); SCM_API SCM scm_c_frame_prev (SCM frame);
SCM_INTERNAL void scm_bootstrap_frames (void); SCM_INTERNAL void scm_bootstrap_frames (void);
SCM_INTERNAL void scm_init_frames (void); SCM_INTERNAL void scm_init_frames (void);

6
libguile/init.c
View file

@ -533,9 +533,12 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_arrays (); scm_init_arrays ();
scm_init_array_map (); scm_init_array_map ();
scm_bootstrap_vm ();
scm_init_strings (); /* Requires array-handle */ scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */ scm_init_struct (); /* Requires strings */
scm_init_stacks (); /* Requires strings, struct */ scm_init_frames ();
scm_init_stacks (); /* Requires strings, struct, frames */
scm_init_symbols (); scm_init_symbols ();
scm_init_values (); /* Requires struct */ scm_init_values (); /* Requires struct */
scm_init_load (); /* Requires strings */ scm_init_load (); /* Requires strings */
@ -552,7 +555,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_guardians (); scm_init_guardians ();
scm_init_vports (); scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */ scm_init_standard_ports (); /* Requires fports */
scm_bootstrap_vm ();
scm_init_memoize (); scm_init_memoize ();
scm_init_eval (); scm_init_eval ();
scm_init_load_path (); scm_init_load_path ();

345
libguile/stacks.c
View file

@ -1,4 +1,4 @@
/* Representation of stack frame debug information /* A stack holds a frame chain
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -42,14 +42,10 @@
/* {Frames and stacks} /* {Stacks}
* *
* The stack is represented as a struct with an id slot and a tail * The stack is represented as a struct that holds a frame. The frame itself is
* array of scm_t_info_frame structs. * linked to the next frame, or #f.
*
* 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_t_info_frame struct.
* *
* Stacks * Stacks
* Constructor * Constructor
@ -59,71 +55,26 @@
* stack-ref * stack-ref
* Inspector * Inspector
* stack-length * 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? */
static SCM stack_id_with_fp (SCM vmframe, SCM **fp); static SCM stack_id_with_fp (SCM frame, SCM **fp);
/* Count number of debug info frames on a stack, beginning with VMFRAME. /* Count number of debug info frames on a stack, beginning with FRAME.
*/ */
static long static long
stack_depth (SCM vmframe, SCM *fp) stack_depth (SCM frame, SCM *fp)
{ {
long n; long n;
/* count vmframes, skipping boot frames */ /* count frames, skipping boot frames */
for (; scm_is_true (vmframe) && SCM_VM_FRAME_FP (vmframe) > fp; for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
vmframe = scm_c_vm_frame_prev (vmframe)) frame = scm_c_frame_prev (frame))
if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
++n; ++n;
return n; return n;
} }
/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
* starting with the first stack frame represented by VMFRAME.
*/
static scm_t_bits
read_frames (SCM vmframe, long n, scm_t_info_frame *iframes)
{
scm_t_info_frame *iframe = iframes;
for (; scm_is_true (vmframe);
vmframe = scm_c_vm_frame_prev (vmframe))
{
if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
/* skip boot frame */
continue;
else
{
/* Oh dear, oh dear, oh dear. */
iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
iframe->source = scm_vm_frame_source (vmframe);
iframe->proc = scm_vm_frame_program (vmframe);
iframe->args = scm_vm_frame_arguments (vmframe);
++iframe;
if (--n == 0)
break;
}
}
return iframe - iframes; /* Number of frames actually read */
}
/* Narrow STACK by cutting away stackframes (mutatingly). /* Narrow STACK by cutting away stackframes (mutatingly).
* *
* Inner frames (most recent) are cut by advancing the frames pointer. * Inner frames (most recent) are cut by advancing the frames pointer.
@ -148,33 +99,48 @@ read_frames (SCM vmframe, long n, scm_t_info_frame *iframes)
static void static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{ {
scm_t_stack *s = SCM_STACK (stack); unsigned long int len;
unsigned long int i; SCM frame;
long n = s->length;
len = SCM_STACK_LENGTH (stack);
frame = SCM_STACK_FRAME (stack);
/* Cut inner part. */ /* Cut inner part. */
if (scm_is_eq (inner_key, SCM_BOOL_T)) if (scm_is_eq (inner_key, SCM_BOOL_T))
{ {
/* Cut all frames up to user module code */ /* Cut specified number of frames. */
for (i = 0; inner; ++i, --inner) for (; inner && len; --inner)
; {
len--;
frame = scm_c_frame_prev (frame);
}
} }
else else
/* Use standard cutting procedure. */
{ {
for (i = 0; inner; --inner) /* Cut until the given procedure is seen. */
if (scm_is_eq (s->frames[i++].proc, inner_key)) for (; inner && len ; --inner)
break; {
SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_c_frame_prev (frame);
if (scm_is_eq (proc, inner_key))
break;
}
} }
s->frames = &s->frames[i];
n -= i; SCM_SET_STACK_LENGTH (stack, len);
SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */ /* Cut outer part. */
for (; n && outer; --outer) for (; outer && len ; --outer)
if (scm_is_eq (s->frames[--n].proc, outer_key)) {
break; frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
if (scm_is_eq (scm_frame_procedure (frame), outer_key))
break;
}
s->length = n; SCM_SET_STACK_LENGTH (stack, len);
} }
@ -220,10 +186,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"taken as 0.") "taken as 0.")
#define FUNC_NAME s_scm_make_stack #define FUNC_NAME s_scm_make_stack
{ {
long n, size; long n;
int maxp; int maxp;
scm_t_info_frame *iframe; SCM frame;
SCM vmframe;
SCM stack; SCM stack;
SCM id, *id_fp; SCM id, *id_fp;
SCM inner_cut, outer_cut; SCM inner_cut, outer_cut;
@ -232,11 +197,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_make_stack was given. */ scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T)) if (scm_is_eq (obj, SCM_BOOL_T))
{ {
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); SCM cont;
vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); struct scm_vm_cont *c;
cont = scm_cdar (scm_vm_capture_continuations ());
c = SCM_VM_CONT_DATA (cont);
frame = scm_c_make_frame (cont, c->fp + c->reloc,
c->sp + c->reloc, c->ip,
c->reloc);
} }
else if (SCM_VM_FRAME_P (obj)) else if (SCM_VM_FRAME_P (obj))
vmframe = obj; frame = obj;
else if (SCM_CONTINUATIONP (obj)) else if (SCM_CONTINUATIONP (obj))
{ {
scm_t_contregs *cont = SCM_CONTREGS (obj); scm_t_contregs *cont = SCM_CONTREGS (obj);
@ -245,13 +217,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
struct scm_vm_cont *data; struct scm_vm_cont *data;
vm_cont = scm_cdr (scm_car (cont->vm_conts)); vm_cont = scm_cdr (scm_car (cont->vm_conts));
data = SCM_VM_CONT_DATA (vm_cont); data = SCM_VM_CONT_DATA (vm_cont);
vmframe = scm_c_make_vm_frame (vm_cont, frame = scm_c_make_frame (vm_cont,
data->fp + data->reloc, data->fp + data->reloc,
data->sp + data->reloc, data->sp + data->reloc,
data->ip, data->ip,
data->reloc); data->reloc);
} else } else
vmframe = SCM_BOOL_F; frame = SCM_BOOL_F;
} }
else else
{ {
@ -259,36 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* not reached */ /* not reached */
} }
if (scm_is_false (vmframe)) if (scm_is_false (frame))
return SCM_BOOL_F; return SCM_BOOL_F;
/* Get ID of the stack corresponding to the given frame. */ /* Get ID of the stack corresponding to the given frame. */
id = stack_id_with_fp (vmframe, &id_fp); id = stack_id_with_fp (frame, &id_fp);
/* Count number of frames. Also get stack id tag and check whether /* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */ (SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F; id = SCM_BOOL_F;
maxp = 0; maxp = 0;
n = stack_depth (vmframe, id_fp); n = stack_depth (frame, id_fp);
/* FIXME: redo maxp? */
size = n * SCM_FRAME_N_SLOTS;
/* Make the stack object. */ /* Make the stack object. */
stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL); stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM_STACK (stack) -> id = id; SCM_SET_STACK_LENGTH (stack, n);
iframe = &SCM_STACK (stack) -> tail[0]; SCM_SET_STACK_ID (stack, id);
SCM_STACK (stack) -> frames = iframe; SCM_SET_STACK_FRAME (stack, frame);
SCM_STACK (stack) -> length = n;
/* Translate the current chain of stack frames into debugging information. */
n = read_frames (vmframe, n, iframe);
if (n != SCM_STACK (stack)->length)
{
scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ());
SCM_STACK (stack)->length = n;
}
/* Narrow the stack according to the arguments given to scm_make_stack. */ /* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
while (n > 0 && !scm_is_null (args)) while (n > 0 && !scm_is_null (args))
@ -311,12 +272,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
scm_is_integer (outer_cut) ? 0 : outer_cut); scm_is_integer (outer_cut) ? 0 : outer_cut);
n = SCM_STACK (stack) -> length; n = SCM_STACK_LENGTH (stack);
} }
if (n > 0 && maxp)
iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
if (n > 0) if (n > 0)
return stack; return stack;
else else
@ -329,15 +287,15 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
"Return the identifier given to @var{stack} by @code{start-stack}.") "Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id #define FUNC_NAME s_scm_stack_id
{ {
SCM vmframe, *id_fp; SCM frame, *id_fp;
if (scm_is_eq (stack, SCM_BOOL_T)) if (scm_is_eq (stack, SCM_BOOL_T))
{ {
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
} }
else if (SCM_VM_FRAME_P (stack)) else if (SCM_VM_FRAME_P (stack))
vmframe = stack; frame = stack;
else if (SCM_CONTINUATIONP (stack)) else if (SCM_CONTINUATIONP (stack))
{ {
scm_t_contregs *cont = SCM_CONTREGS (stack); scm_t_contregs *cont = SCM_CONTREGS (stack);
@ -346,13 +304,13 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
struct scm_vm_cont *data; struct scm_vm_cont *data;
vm_cont = scm_cdr (scm_car (cont->vm_conts)); vm_cont = scm_cdr (scm_car (cont->vm_conts));
data = SCM_VM_CONT_DATA (vm_cont); data = SCM_VM_CONT_DATA (vm_cont);
vmframe = scm_c_make_vm_frame (vm_cont, frame = scm_c_make_frame (vm_cont,
data->fp + data->reloc, data->fp + data->reloc,
data->sp + data->reloc, data->sp + data->reloc,
data->ip, data->ip,
data->reloc); data->reloc);
} else } else
vmframe = SCM_BOOL_F; frame = SCM_BOOL_F;
} }
else else
{ {
@ -360,14 +318,14 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
/* not reached */ /* not reached */
} }
return stack_id_with_fp (vmframe, &id_fp); return stack_id_with_fp (frame, &id_fp);
} }
#undef FUNC_NAME #undef FUNC_NAME
static SCM static SCM
stack_id_with_fp (SCM vmframe, SCM **fp) stack_id_with_fp (SCM frame, SCM **fp)
{ {
SCM holder = SCM_VM_FRAME_STACK_HOLDER (vmframe); SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
if (SCM_VM_CONT_P (holder)) if (SCM_VM_CONT_P (holder))
{ {
@ -387,10 +345,18 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
#define FUNC_NAME s_scm_stack_ref #define FUNC_NAME s_scm_stack_ref
{ {
unsigned long int c_index; unsigned long int c_index;
SCM frame;
SCM_VALIDATE_STACK (1, stack); SCM_VALIDATE_STACK (1, stack);
c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
return scm_cons (stack, index); frame = SCM_STACK_FRAME (stack);
while (c_index--)
{
frame = scm_c_frame_prev (frame);
while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
frame = scm_c_frame_prev (frame);
}
return frame;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -400,134 +366,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
#define FUNC_NAME s_scm_stack_length #define FUNC_NAME s_scm_stack_length
{ {
SCM_VALIDATE_STACK (1, stack); SCM_VALIDATE_STACK (1, stack);
return scm_from_int (SCM_STACK_LENGTH (stack)); return scm_from_long (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME
/* Frames
*/
SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a stack frame.")
#define FUNC_NAME s_scm_frame_p
{
return scm_from_bool(SCM_FRAMEP (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
(SCM frame),
"Return the frame number of @var{frame}.")
#define FUNC_NAME s_scm_frame_number
{
SCM_VALIDATE_FRAME (1, frame);
return scm_from_int (SCM_FRAME_NUMBER (frame));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame),
"Return the source of @var{frame}.")
#define FUNC_NAME s_scm_frame_source
{
SCM_VALIDATE_FRAME (1, frame);
return SCM_FRAME_SOURCE (frame);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"Return the procedure for @var{frame}, or @code{#f} if no\n"
"procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_FRAME (1, frame);
return (SCM_FRAME_PROC_P (frame)
? SCM_FRAME_PROC (frame)
: SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
(SCM frame),
"Return the arguments of @var{frame}.")
#define FUNC_NAME s_scm_frame_arguments
{
SCM_VALIDATE_FRAME (1, frame);
return SCM_FRAME_ARGS (frame);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
(SCM frame),
"Return the previous frame of @var{frame}, or @code{#f} if\n"
"@var{frame} is the first frame in its stack.")
#define FUNC_NAME s_scm_frame_previous
{
unsigned long int n;
SCM_VALIDATE_FRAME (1, frame);
n = scm_to_ulong (SCM_CDR (frame)) + 1;
if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
return SCM_BOOL_F;
else
return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
(SCM frame),
"Return the next frame of @var{frame}, or @code{#f} if\n"
"@var{frame} is the last frame in its stack.")
#define FUNC_NAME s_scm_frame_next
{
unsigned long int n;
SCM_VALIDATE_FRAME (1, frame);
n = scm_to_ulong (SCM_CDR (frame));
if (n == 0)
return SCM_BOOL_F;
else
return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
(SCM frame),
"Return @code{#t} if @var{frame} is a real frame.")
#define FUNC_NAME s_scm_frame_real_p
{
SCM_VALIDATE_FRAME (1, frame);
return scm_from_bool(SCM_FRAME_REAL_P (frame));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
(SCM frame),
"Return @code{#t} if a procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure_p
{
SCM_VALIDATE_FRAME (1, frame);
return scm_from_bool(SCM_FRAME_PROC_P (frame));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
(SCM frame),
"Return @code{#t} if @var{frame} contains evaluated arguments.")
#define FUNC_NAME s_scm_frame_evaluating_args_p
{
SCM_VALIDATE_FRAME (1, frame);
return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
(SCM frame),
"Return @code{#t} if @var{frame} is an overflow frame.")
#define FUNC_NAME s_scm_frame_overflow_p
{
SCM_VALIDATE_FRAME (1, frame);
return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
} }
#undef FUNC_NAME #undef FUNC_NAME

78
libguile/stacks.h
View file

@ -24,67 +24,28 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
#include "libguile/frames.h"
/* {Frames and stacks} /* {Frames and stacks}
*/ */
typedef struct scm_t_info_frame {
/* SCM flags; */
scm_t_bits flags;
SCM source;
SCM proc;
SCM args;
} scm_t_info_frame;
#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM))
#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj))
#define SCM_STACK_LAYOUT "pwuourpW"
typedef struct scm_t_stack {
SCM id; /* Stack id */
scm_t_info_frame *frames; /* Info frames */
unsigned long length; /* Stack length */
unsigned long tail_length;
scm_t_info_frame tail[1];
} scm_t_stack;
SCM_API SCM scm_stack_type; SCM_API SCM scm_stack_type;
#define SCM_STACK_LAYOUT \
"pw" /* len */ \
"pw" /* id */ \
"pw" /* frame */
#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type)) #define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type))
#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) #define SCM_STACK_LENGTH(obj) (scm_to_long (SCM_STRUCT_SLOT_REF (obj,0)))
#define SCM_SET_STACK_LENGTH(obj,f) (SCM_STRUCT_SLOT_SET (obj,0,scm_from_long (f)))
#define SCM_STACK_ID(obj) (SCM_STRUCT_SLOT_REF (obj,1))
#define SCM_SET_STACK_ID(obj,f) (SCM_STRUCT_SLOT_SET (obj,1,f))
#define SCM_STACK_FRAME(obj) (SCM_STRUCT_SLOT_REF (obj,2))
#define SCM_SET_STACK_FRAME(obj,f) (SCM_STRUCT_SLOT_SET (obj,2,f))
#define SCM_FRAMEP(obj) \ #define SCM_FRAMEP(obj) (SCM_VM_FRAME_P (obj))
(scm_is_pair (obj) && SCM_STACKP (SCM_CAR (obj)) \
&& scm_is_unsigned_integer (SCM_CDR (obj), \
0, SCM_STACK_LENGTH (SCM_CAR (obj))-1))
#define SCM_FRAME_REF(frame, slot) \
(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot)
#define SCM_FRAME_NUMBER(frame) \
(SCM_BACKWARDS_P \
? scm_to_size_t (SCM_CDR (frame)) \
: (SCM_STACK_LENGTH (SCM_CAR (frame)) \
- scm_to_size_t (SCM_CDR (frame)) \
- 1)) \
#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
#define SCM_FRAMEF_VOID (1L << 2)
#define SCM_FRAMEF_REAL (1L << 3)
#define SCM_FRAMEF_PROC (1L << 4)
#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
#define SCM_FRAMEF_OVERFLOW (1L << 6)
#define SCM_FRAME_VOID_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_VOID)
#define SCM_FRAME_REAL_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_REAL)
#define SCM_FRAME_PROC_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_PROC)
#define SCM_FRAME_EVAL_ARGS_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_EVAL_ARGS)
#define SCM_FRAME_OVERFLOW_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_OVERFLOW)
@ -94,19 +55,6 @@ SCM_API SCM scm_stack_id (SCM stack);
SCM_API SCM scm_stack_ref (SCM stack, SCM i); SCM_API SCM scm_stack_ref (SCM stack, SCM i);
SCM_API SCM scm_stack_length (SCM stack); SCM_API SCM scm_stack_length (SCM stack);
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_last_stack_frame (SCM obj);
SCM_API SCM scm_frame_number (SCM frame);
SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);
SCM_API SCM scm_frame_next (SCM frame);
SCM_API SCM scm_frame_real_p (SCM frame);
SCM_API SCM scm_frame_procedure_p (SCM frame);
SCM_API SCM scm_frame_evaluating_args_p (SCM frame);
SCM_API SCM scm_frame_overflow_p (SCM frame);
SCM_INTERNAL void scm_init_stacks (void); SCM_INTERNAL void scm_init_stacks (void);
#endif /* SCM_STACKS_H */ #endif /* SCM_STACKS_H */

2
libguile/vm.c
View file

@ -159,7 +159,7 @@ vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
scm_dynwind_begin (0); scm_dynwind_begin (0);
/* FIXME, stack holder should be the vm */ /* FIXME, stack holder should be the vm */
vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0); vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY); scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
scm_c_run_hook (hook, hook_args); scm_c_run_hook (hook, hook_args);

84
module/system/vm/frame.scm
View file

@ -24,21 +24,19 @@
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module (system vm objcode) #:use-module (system vm objcode)
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:export (vm-frame? #:export (frame-local-ref frame-local-set!
vm-frame-program frame-instruction-pointer
vm-frame-local-ref vm-frame-local-set! frame-return-address frame-mv-return-address
vm-frame-instruction-pointer frame-dynamic-link
vm-frame-return-address vm-frame-mv-return-address frame-num-locals
vm-frame-dynamic-link
vm-frame-num-locals
vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set! frame-bindings frame-binding-ref frame-binding-set!
vm-frame-arguments ; frame-arguments
vm-frame-number vm-frame-address frame-number frame-address
make-frame-chain make-frame-chain
print-frame print-frame-chain-as-backtrace print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-local-variables
frame-environment frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set! frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name frame-object-name
@ -48,22 +46,22 @@
(load-extension "libguile" "scm_init_frames") (load-extension "libguile" "scm_init_frames")
(define (vm-frame-bindings frame) (define (frame-bindings frame)
(map (lambda (b) (map (lambda (b)
(cons (binding:name b) (binding:index b))) (cons (binding:name b) (binding:index b)))
(program-bindings-for-ip (vm-frame-program frame) (program-bindings-for-ip (frame-procedure frame)
(vm-frame-instruction-pointer frame)))) (frame-instruction-pointer frame))))
(define (vm-frame-binding-set! frame var val) (define (frame-binding-set! frame var val)
(let ((i (assq-ref (vm-frame-bindings frame) var))) (let ((i (assq-ref (frame-bindings frame) var)))
(if i (if i
(vm-frame-local-set! frame i val) (frame-local-set! frame i val)
(error "variable not bound in frame" var frame)))) (error "variable not bound in frame" var frame))))
(define (vm-frame-binding-ref frame var) (define (frame-binding-ref frame var)
(let ((i (assq-ref (vm-frame-bindings frame) var))) (let ((i (assq-ref (frame-bindings frame) var)))
(if i (if i
(vm-frame-local-ref frame i) (frame-local-ref frame i)
(error "variable not bound in frame" var frame)))) (error "variable not bound in frame" var frame))))
;; Basically there are two cases to deal with here: ;; Basically there are two cases to deal with here:
@ -80,37 +78,37 @@
;; number of arguments, or perhaps we're doing a typed dispatch and ;; number of arguments, or perhaps we're doing a typed dispatch and
;; the types don't match. In that case the arguments are all on the ;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack. ;; stack, and nothing else is on the stack.
(define (vm-frame-arguments frame) (define (frame-arguments frame)
(cond (cond
((program-lambda-list (vm-frame-program frame) ((program-lambda-list (frame-procedure frame)
(vm-frame-instruction-pointer frame)) (frame-instruction-pointer frame))
;; case 1 ;; case 1
=> (lambda (formals) => (lambda (formals)
(let lp ((formals formals)) (let lp ((formals formals))
(pmatch formals (pmatch formals
(() '()) (() '())
((,x . ,rest) (guard (symbol? x)) ((,x . ,rest) (guard (symbol? x))
(cons (vm-frame-binding-ref frame x) (lp rest))) (cons (frame-binding-ref frame x) (lp rest)))
((,x . ,rest) ((,x . ,rest)
;; could be a keyword ;; could be a keyword
(cons x (lp rest))) (cons x (lp rest)))
(,rest (guard (symbol? rest)) (,rest (guard (symbol? rest))
(vm-frame-binding-ref frame rest)) (frame-binding-ref frame rest))
;; let's not error here, as we are called during ;; let's not error here, as we are called during
;; backtraces... ;; backtraces...
(else '???))))) (else '???)))))
(else (else
;; case 2 ;; case 2
(map (lambda (i) (map (lambda (i)
(vm-frame-local-ref frame i)) (frame-local-ref frame i))
(iota (vm-frame-num-locals frame)))))) (iota (frame-num-locals frame))))))
;;; ;;;
;;; Frame chain ;;; Frame chain
;;; ;;;
(define vm-frame-number (make-object-property)) (define frame-number (make-object-property))
(define vm-frame-address (make-object-property)) (define frame-address (make-object-property))
;; FIXME: the header. ;; FIXME: the header.
(define (bootstrap-frame? frame) (define (bootstrap-frame? frame)
@ -201,17 +199,9 @@
prog (module-obarray (current-module)))))) prog (module-obarray (current-module))))))
;;;
;;; Frames ;;; Frames
;;; ;;;
(define (frame-arguments frame)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
(do ((n (+ (arity:nargs arity) -1) (1- n))
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
(define (frame-local-variables frame) (define (frame-local-variables frame)
(let* ((prog (frame-program frame)) (let* ((prog (frame-program frame))
(arity (program-arity prog))) (arity (program-arity prog)))
@ -219,26 +209,6 @@
(l '() (cons (frame-local-ref frame n) l))) (l '() (cons (frame-local-ref frame n) l)))
((< n 0) l)))) ((< n 0) l))))
(define (frame-binding-ref frame binding)
(let ((x (frame-local-ref frame (binding:index binding))))
(if (and (binding:boxed? binding) (variable? x))
(variable-ref x)
x)))
(define (frame-binding-set! frame binding val)
(if (binding:boxed? binding)
(let ((v (frame-local-ref frame binding)))
(if (variable? v)
(variable-set! v val)
(frame-local-set! frame binding (make-variable val))))
(frame-local-set! frame binding val)))
;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr)
(filter (lambda (b) (and (>= addr (binding:start b))
(<= addr (binding:end b))))
(program-bindings (frame-program frame))))
(define (frame-lookup-binding frame addr sym) (define (frame-lookup-binding frame addr sym)
(assq sym (reverse (frame-bindings frame addr)))) (assq sym (reverse (frame-bindings frame addr))))