mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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/strings.h"
#include "libguile/dynwind.h"
#include "libguile/frames.h"
#include "libguile/validate.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;
if (scm_is_symbol (pname) || scm_is_string (pname))
{
if (SCM_FRAMEP (frame)
&& SCM_FRAME_EVAL_ARGS_P (frame))
scm_puts ("While evaluating arguments to ", port);
else
scm_puts ("In procedure ", port);
scm_puts ("In procedure ", port);
scm_iprin1 (pname, port, pstate);
}
scm_puts (":\n", port);
@ -354,14 +351,14 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S
static void
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_procedure_name (proc)
: SCM_BOOL_F);
display_frame_expr ("[",
scm_cons (scm_is_true (name) ? name : proc,
SCM_FRAME_ARGS (frame)),
SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
scm_frame_arguments (frame)),
"]",
indentation,
sport,
port,
@ -383,30 +380,27 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
if (SCM_UNBNDP (indent))
indent = SCM_INUM0;
if (SCM_FRAME_PROC_P (frame))
/* Display an application. */
{
SCM sport, print_state;
scm_print_state *pstate;
/* Display an application. */
{
SCM sport, print_state;
scm_print_state *pstate;
/* Create a string port used for adaptation of printing parameters. */
sport = scm_mkstrport (SCM_INUM0,
scm_make_string (scm_from_int (240),
SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
/* Create a string port used for adaptation of printing parameters. */
sport = scm_mkstrport (SCM_INUM0,
scm_make_string (scm_from_int (240),
SCM_UNDEFINED),
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
/* Create a print state for printing of frames. */
print_state = scm_make_print_state ();
pstate = SCM_PRINT_STATE (print_state);
pstate->writingp = 1;
pstate->fancyp = 1;
/* Create a print state for printing of frames. */
print_state = scm_make_print_state ();
pstate = SCM_PRINT_STATE (print_state);
pstate->writingp = 1;
pstate->fancyp = 1;
display_application (frame, scm_to_int (indent), sport, port, pstate);
return SCM_BOOL_T;
}
else
return SCM_BOOL_F;
display_application (frame, scm_to_int (indent), sport, port, pstate);
return SCM_BOOL_T;
}
}
#undef FUNC_NAME
@ -415,7 +409,7 @@ SCM_SYMBOL (sym_base, "base");
static void
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;
if (scm_is_pair (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);
if (scm_is_eq (file, *last_file))
if (scm_is_true (scm_equal_p (file, *last_file)))
return;
*last_file = file;
@ -506,23 +500,16 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
}
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;
/* Announce missing frames? */
if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
{
indent (nfield + 1 + indentation, port);
scm_puts ("...\n", port);
}
int i, j;
/* display file name and line number */
if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
display_backtrace_file_and_line (frame, port, pstate);
/* Check size of frame number. */
n = SCM_FRAME_NUMBER (frame);
for (i = 0, j = n; j > 0; ++i) j /= 10;
/* Number indentation. */
@ -531,38 +518,12 @@ display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_
/* Frame number. */
scm_iprin1 (scm_from_int (n), port, pstate);
/* Real frame marker */
scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
/* Indentation. */
indent (indentation, port);
if (SCM_FRAME_PROC_P (frame))
/* Display an application. */
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);
}
/* Display an application. */
display_application (frame, nfield + 1 + indentation, sport, port, pstate);
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 {
@ -633,48 +594,26 @@ display_backtrace_body (struct display_backtrace_args *a)
pstate->highlight_objects = a->highlight_objects;
/* First find out if it's reasonable to do indentation. */
if (SCM_BACKWARDS_P)
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));
}
}
indent_p = 0;
/* 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;
nfield = i ? i : 1;
/* Print frames. */
frame = scm_stack_ref (a->stack, scm_from_int (beg));
indentation = 1;
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))
display_backtrace_file (frame, &last_file, 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));
display_frame (frame, i, nfield, indentation, sport, a->port, pstate);
}
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_srcprops scm_t_srcprops
#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_dim scm_t_array_dim
#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS

89
libguile/frames.c
View file

@ -27,31 +27,31 @@
#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))
SCM
scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_t_uint8 *ip, scm_t_ptrdiff offset)
scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
"vmframe");
struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
"vmframe");
p->stack_holder = stack_holder;
p->fp = fp;
p->sp = sp;
p->ip = ip;
p->offset = offset;
SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
}
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_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. */
scm_puts (">", port);
@ -61,28 +61,29 @@ vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
/* Scheme interface */
SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(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));
}
#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),
"")
#define FUNC_NAME s_scm_vm_frame_program
#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
SCM
scm_vm_frame_arguments (SCM frame)
#define FUNC_NAME "vm-frame-arguments"
SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_arguments
{
static SCM var = SCM_BOOL_F;
@ -90,16 +91,16 @@ scm_vm_frame_arguments (SCM frame)
if (scm_is_false (var))
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);
}
#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),
"")
#define FUNC_NAME s_scm_vm_frame_source
#define FUNC_NAME s_scm_frame_source
{
SCM *fp;
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
heuristic to detect not-yet-active frames, and skip over them. Perhaps we
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),
"")
#define FUNC_NAME s_scm_vm_frame_num_locals
#define FUNC_NAME s_scm_frame_num_locals
{
SCM *sp, *p;
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
/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
/* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_vm_frame_local_ref
#define FUNC_NAME s_scm_frame_local_ref
{
SCM *sp, *p;
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
/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
/* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(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;
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
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),
"")
#define FUNC_NAME s_scm_vm_frame_instruction_pointer
#define FUNC_NAME s_scm_frame_instruction_pointer
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
(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
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),
"")
#define FUNC_NAME s_scm_vm_frame_return_address
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
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
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),
"")
#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);
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
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),
"")
#define FUNC_NAME s_scm_vm_frame_dynamic_link
#define FUNC_NAME s_scm_frame_dynamic_link
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* 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
extern SCM
scm_c_vm_frame_prev (SCM frame)
scm_c_frame_prev (SCM frame)
{
SCM *this_fp, *new_fp, *new_sp;
this_fp = SCM_VM_FRAME_FP (frame);
@ -272,10 +273,10 @@ scm_c_vm_frame_prev (SCM frame)
if (new_fp)
{ new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
new_fp, new_sp,
SCM_FRAME_RETURN_ADDRESS (this_fp),
SCM_VM_FRAME_OFFSET (frame));
return scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
new_fp, new_sp,
SCM_FRAME_RETURN_ADDRESS (this_fp),
SCM_VM_FRAME_OFFSET (frame));
}
else
return SCM_BOOL_F;
@ -285,8 +286,8 @@ scm_c_vm_frame_prev (SCM frame)
void
scm_bootstrap_frames (void)
{
scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
scm_tc16_frame = scm_make_smob_type ("frame", 0);
scm_set_smob_print (scm_tc16_frame, frame_print);
scm_c_register_extension ("libguile", "scm_init_frames",
(scm_t_extension_init_func)scm_init_frames, NULL);
}

46
libguile/frames.h
View file

@ -27,6 +27,16 @@
* 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
---------------
@ -77,9 +87,9 @@
* 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 *fp;
@ -88,8 +98,8 @@ struct scm_vm_frame
scm_t_ptrdiff offset;
};
#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x))
#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, 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_FP(f) SCM_VM_FRAME_DATA(f)->fp
#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_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_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_vm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);
SCM_API SCM scm_vm_frame_source (SCM frame);
SCM_API SCM scm_vm_frame_num_locals (SCM frame);
SCM_API SCM scm_vm_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_vm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_vm_frame_return_address (SCM frame);
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_num_locals (SCM frame);
SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
SCM_API SCM scm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_frame_return_address (SCM frame);
SCM_API SCM scm_frame_mv_return_address (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_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_array_map ();
scm_bootstrap_vm ();
scm_init_strings (); /* Requires array-handle */
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_values (); /* Requires struct */
scm_init_load (); /* Requires strings */
@ -552,7 +555,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_guardians ();
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
scm_bootstrap_vm ();
scm_init_memoize ();
scm_init_eval ();
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
*
* 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
* array of scm_t_info_frame structs.
*
* A frame is represented as a pair where the car contains a stack and
* the cdr an inum. The inum is an index to the first SCM value of
* the scm_t_info_frame struct.
* The stack is represented as a struct that holds a frame. The frame itself is
* linked to the next frame, or #f.
*
* Stacks
* Constructor
@ -59,71 +55,26 @@
* stack-ref
* Inspector
* 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
stack_depth (SCM vmframe, SCM *fp)
stack_depth (SCM frame, SCM *fp)
{
long n;
/* count vmframes, skipping boot frames */
for (; scm_is_true (vmframe) && SCM_VM_FRAME_FP (vmframe) > fp;
vmframe = scm_c_vm_frame_prev (vmframe))
if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
/* count frames, skipping boot frames */
for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
frame = scm_c_frame_prev (frame))
if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
++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).
*
* 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
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
scm_t_stack *s = SCM_STACK (stack);
unsigned long int i;
long n = s->length;
unsigned long int len;
SCM frame;
len = SCM_STACK_LENGTH (stack);
frame = SCM_STACK_FRAME (stack);
/* Cut inner part. */
if (scm_is_eq (inner_key, SCM_BOOL_T))
{
/* Cut all frames up to user module code */
for (i = 0; inner; ++i, --inner)
;
/* Cut specified number of frames. */
for (; inner && len; --inner)
{
len--;
frame = scm_c_frame_prev (frame);
}
}
else
/* Use standard cutting procedure. */
{
for (i = 0; inner; --inner)
if (scm_is_eq (s->frames[i++].proc, inner_key))
break;
/* Cut until the given procedure is seen. */
for (; inner && len ; --inner)
{
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. */
for (; n && outer; --outer)
if (scm_is_eq (s->frames[--n].proc, outer_key))
break;
for (; outer && len ; --outer)
{
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.")
#define FUNC_NAME s_scm_make_stack
{
long n, size;
long n;
int maxp;
scm_t_info_frame *iframe;
SCM vmframe;
SCM frame;
SCM stack;
SCM id, *id_fp;
SCM inner_cut, outer_cut;
@ -232,11 +197,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
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);
SCM cont;
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))
vmframe = obj;
frame = obj;
else if (SCM_CONTINUATIONP (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;
vm_cont = scm_cdr (scm_car (cont->vm_conts));
data = SCM_VM_CONT_DATA (vm_cont);
vmframe = scm_c_make_vm_frame (vm_cont,
data->fp + data->reloc,
data->sp + data->reloc,
data->ip,
data->reloc);
frame = scm_c_make_frame (vm_cont,
data->fp + data->reloc,
data->sp + data->reloc,
data->ip,
data->reloc);
} else
vmframe = SCM_BOOL_F;
frame = SCM_BOOL_F;
}
else
{
@ -259,36 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* not reached */
}
if (scm_is_false (vmframe))
if (scm_is_false (frame))
return SCM_BOOL_F;
/* 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
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F;
maxp = 0;
n = stack_depth (vmframe, id_fp);
/* FIXME: redo maxp? */
size = n * SCM_FRAME_N_SLOTS;
n = stack_depth (frame, id_fp);
/* Make the stack object. */
stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
SCM_STACK (stack) -> id = id;
iframe = &SCM_STACK (stack) -> tail[0];
SCM_STACK (stack) -> frames = iframe;
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;
}
stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM_SET_STACK_LENGTH (stack, n);
SCM_SET_STACK_ID (stack, id);
SCM_SET_STACK_FRAME (stack, frame);
/* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (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) ? 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)
return stack;
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}.")
#define FUNC_NAME s_scm_stack_id
{
SCM vmframe, *id_fp;
SCM frame, *id_fp;
if (scm_is_eq (stack, SCM_BOOL_T))
{
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))
vmframe = stack;
frame = stack;
else if (SCM_CONTINUATIONP (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;
vm_cont = scm_cdr (scm_car (cont->vm_conts));
data = SCM_VM_CONT_DATA (vm_cont);
vmframe = scm_c_make_vm_frame (vm_cont,
data->fp + data->reloc,
data->sp + data->reloc,
data->ip,
data->reloc);
frame = scm_c_make_frame (vm_cont,
data->fp + data->reloc,
data->sp + data->reloc,
data->ip,
data->reloc);
} else
vmframe = SCM_BOOL_F;
frame = SCM_BOOL_F;
}
else
{
@ -360,14 +318,14 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
/* not reached */
}
return stack_id_with_fp (vmframe, &id_fp);
return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
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))
{
@ -387,10 +345,18 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
#define FUNC_NAME s_scm_stack_ref
{
unsigned long int c_index;
SCM frame;
SCM_VALIDATE_STACK (1, stack);
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
@ -400,134 +366,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
#define FUNC_NAME s_scm_stack_length
{
SCM_VALIDATE_STACK (1, stack);
return scm_from_int (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));
return scm_from_long (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME

78
libguile/stacks.h
View file

@ -24,67 +24,28 @@
#include "libguile/__scm.h"
#include "libguile/frames.h"
/* {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;
#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_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) \
(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_FRAMEP(obj) (SCM_VM_FRAME_P (obj))
#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_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);
#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);
/* 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_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 objcode)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (vm-frame?
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
vm-frame-instruction-pointer
vm-frame-return-address vm-frame-mv-return-address
vm-frame-dynamic-link
vm-frame-num-locals
#:export (frame-local-ref frame-local-set!
frame-instruction-pointer
frame-return-address frame-mv-return-address
frame-dynamic-link
frame-num-locals
vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set!
vm-frame-arguments
frame-bindings frame-binding-ref frame-binding-set!
; frame-arguments
vm-frame-number vm-frame-address
frame-number frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables
frame-local-variables
frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name
@ -48,22 +46,22 @@
(load-extension "libguile" "scm_init_frames")
(define (vm-frame-bindings frame)
(define (frame-bindings frame)
(map (lambda (b)
(cons (binding:name b) (binding:index b)))
(program-bindings-for-ip (vm-frame-program frame)
(vm-frame-instruction-pointer frame))))
(program-bindings-for-ip (frame-procedure frame)
(frame-instruction-pointer frame))))
(define (vm-frame-binding-set! frame var val)
(let ((i (assq-ref (vm-frame-bindings frame) var)))
(define (frame-binding-set! frame var val)
(let ((i (assq-ref (frame-bindings frame) var)))
(if i
(vm-frame-local-set! frame i val)
(frame-local-set! frame i val)
(error "variable not bound in frame" var frame))))
(define (vm-frame-binding-ref frame var)
(let ((i (assq-ref (vm-frame-bindings frame) var)))
(define (frame-binding-ref frame var)
(let ((i (assq-ref (frame-bindings frame) var)))
(if i
(vm-frame-local-ref frame i)
(frame-local-ref frame i)
(error "variable not bound in frame" var frame))))
;; 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
;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack.
(define (vm-frame-arguments frame)
(define (frame-arguments frame)
(cond
((program-lambda-list (vm-frame-program frame)
(vm-frame-instruction-pointer frame))
((program-lambda-list (frame-procedure frame)
(frame-instruction-pointer frame))
;; case 1
=> (lambda (formals)
(let lp ((formals formals))
(pmatch formals
(() '())
((,x . ,rest) (guard (symbol? x))
(cons (vm-frame-binding-ref frame x) (lp rest)))
(cons (frame-binding-ref frame x) (lp rest)))
((,x . ,rest)
;; could be a keyword
(cons x (lp 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
;; backtraces...
(else '???)))))
(else
;; case 2
(map (lambda (i)
(vm-frame-local-ref frame i))
(iota (vm-frame-num-locals frame))))))
(frame-local-ref frame i))
(iota (frame-num-locals frame))))))
;;;
;;; Frame chain
;;;
(define vm-frame-number (make-object-property))
(define vm-frame-address (make-object-property))
(define frame-number (make-object-property))
(define frame-address (make-object-property))
;; FIXME: the header.
(define (bootstrap-frame? frame)
@ -201,17 +199,9 @@
prog (module-obarray (current-module))))))
;;;
;;; 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)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
@ -219,26 +209,6 @@
(l '() (cons (frame-local-ref frame n) 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)
(assq sym (reverse (frame-bindings frame addr))))