[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-79-gaa3
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-79-gaa3f695 |
|
Date: |
Thu, 03 Dec 2009 13:42:33 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=aa3f69519f1af3fcf31cf36be33776db3fedf65a
The branch, master has been updated
via aa3f69519f1af3fcf31cf36be33776db3fedf65a (commit)
via 14aa25e410d49586c8ff9b4a80d2b6046b769905 (commit)
from b2b554efd3fee1bd110cb286a1b185042db0a27f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit aa3f69519f1af3fcf31cf36be33776db3fedf65a
Author: Andy Wingo <address@hidden>
Date: Thu Dec 3 13:09:58 2009 +0100
replace frame implementation with VM frames
* 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.
commit 14aa25e410d49586c8ff9b4a80d2b6046b769905
Author: Andy Wingo <address@hidden>
Date: Thu Dec 3 11:03:39 2009 +0100
remove debug frames
* libguile/debug.h (scm_t_debug_frame): Remove this type, as it was
internal to the old evaluator.
(SCM_EVALFRAME, SCM_APPLYFRAME, SCM_VOIDFRAME, SCM_MACROEXPF)
(SCM_TAILREC, SCM_TRACED_FRAME, SCM_ARGS_READY, SCM_DOVERFLOW)
(SCM_MAX_FRAME_SIZE, SCM_FRAMETYPE)
(SCM_EVALFRAMEP, SCM_APPLYFRAMEP, SCM_VOIDFRAMEP, SCM_MACROEXPFP)
(SCM_TAILRECP, SCM_TRACED_FRAME_P, SCM_ARGS_READY_P, SCM_OVERFLOWP)
(SCM_SET_MACROEXP, SCM_SET_TAILREC, SCM_SET_TRACED_FRAME)
(SCM_SET_ARGSREADY, SCM_SET_OVERFLOW)
(SCM_CLEAR_MACROEXP, SCM_CLEAR_TRACED_FRAME, SCM_CLEAR_ARGSREADY):
Remove macro accessors to scm_t_debug_frame.
(SCM_DEBUGOBJP, SCM_DEBUGOBJ_FRAME, SCM_SET_DEBUGOBJ_FRAME):
(scm_debug_object_p, scm_make_debugobj): Remove debugobj accessors.
(scm_i_unmemoize_expr): Remove unused declaration.
* libguile/debug.c (scm_debug_options): No more max limit on frame
sizes.
(scm_start_stack): Just call out to scm_vm_call_with_new_stack.
(scm_debug_object_p, scm_make_debugobj, scm_init_debug): No more
debugobj smob type.
* libguile/deprecated.h:
* libguile/deprecated.c (scm_i_deprecated_last_debug_frame)
(scm_last_debug_frame): Remove deprecated debug-frame bits.
* libguile/stacks.c (scm_make_stack): Rework this function and its
dependents to only walk VM frames.
(scm_stack_id): Call out to the holder of the VM frame in question,
which should be a VM or a VM continuation, for the stack ID. Currently
this bit is stubbed out.
(scm_last_stack_frame): Removed. It seems this is mainly useful for a
debugger, and we need to rewrite the debugger to work on the Scheme
level.
* test-suite/tests/continuations.test ("continuations"): Remove test for
last-stack-frame.
* libguile/continuations.h (struct scm_t_contregs):
* libguile/continuations.c (scm_make_continuation):
(copy_stack_and_call, scm_i_with_continuation_barrier): No need to
save and restore debug frames.
* libguile/threads.h (scm_i_thread): Don't track debug frames.
(scm_i_last_debug_frame, scm_i_set_last_debug_frame): Remove macro
accessors.
* libguile/threads.c (guilify_self_1): Don't track debug frames.
* libguile/throw.c: No need to track debug frames in a jmpbuf.
* libguile/vm-engine.c (vm_engine, VM_PUSH_DEBUG_FRAMES): Don't push
debug frames.
* libguile/vm.h:
* libguile/vm.c (scm_vm_call_with_new_stack): New function. Currently
stubbed out though.
-----------------------------------------------------------------------
Summary of changes:
libguile/backtrace.c | 141 +++------
libguile/continuations.c | 9 +-
libguile/continuations.h | 7 +-
libguile/debug.c | 50 +---
libguile/debug.h | 67 ----
libguile/deprecated.c | 8 -
libguile/deprecated.h | 4 -
libguile/frames.c | 89 +++---
libguile/frames.h | 48 ++-
libguile/init.c | 6 +-
libguile/stacks.c | 664 +++++++----------------------------
libguile/stacks.h | 78 +----
libguile/threads.c | 1 -
libguile/threads.h | 4 -
libguile/throw.c | 4 -
libguile/vm-engine.c | 21 --
libguile/vm.c | 8 +-
libguile/vm.h | 1 +
module/system/vm/frame.scm | 88 ++---
test-suite/tests/continuations.test | 7 +-
20 files changed, 300 insertions(+), 1005 deletions(-)
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 58fe0cf..9d56ea2 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -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 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 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;
- 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);
diff --git a/libguile/continuations.c b/libguile/continuations.c
index a0e2f6d..7013e3d 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -84,7 +84,6 @@ scm_make_continuation (int *first)
continuation->dynenv = scm_i_dynwinds ();
continuation->throw_value = SCM_EOL;
continuation->root = thread->continuation_root;
- continuation->dframe = scm_i_last_debug_frame ();
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
src -= stack_size;
@@ -190,8 +189,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- scm_i_set_last_debug_frame (continuation->dframe);
-
continuation->throw_value = val;
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
@@ -276,17 +273,14 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM old_controot;
SCM_STACKITEM *old_contbase;
- scm_t_debug_frame *old_lastframe;
SCM result;
/* Establish a fresh continuation root.
*/
old_controot = thread->continuation_root;
old_contbase = thread->continuation_base;
- old_lastframe = thread->last_debug_frame;
thread->continuation_root = scm_cons (thread->handle, old_controot);
thread->continuation_base = &stack_item;
- thread->last_debug_frame = NULL;
/* Call FUNC inside a catch all. This is now guaranteed to return
directly and exactly once.
@@ -298,7 +292,6 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
/* Return to old continuation root.
*/
- thread->last_debug_frame = old_lastframe;
thread->continuation_base = old_contbase;
thread->continuation_root = old_controot;
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 82cf178..8f7e38e 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -64,11 +64,6 @@ typedef struct
*/
scm_t_ptrdiff offset;
- /* The most recently created debug frame on the live stack, before
- it was saved. This needs to be adjusted with OFFSET, above.
- */
- struct scm_t_debug_frame *dframe;
-
SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
} scm_t_contregs;
diff --git a/libguile/debug.c b/libguile/debug.c
index f0dd29a..91eef16 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -49,6 +49,7 @@
#include "libguile/fluids.h"
#include "libguile/programs.h"
#include "libguile/memoize.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
@@ -73,7 +74,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0,
1, 0,
scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
- if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
+ if (SCM_N_FRAMES < 1)
{
scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
@@ -246,52 +247,10 @@ SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
"Call @var{thunk} on an evaluator stack tagged with @var{id}.")
#define FUNC_NAME s_scm_sys_start_stack
{
- SCM answer;
- scm_t_debug_frame vframe;
- scm_t_debug_info vframe_vect_body;
- vframe.prev = scm_i_last_debug_frame ();
- vframe.status = SCM_VOIDFRAME;
- vframe.vect = &vframe_vect_body;
- vframe.vect[0].id = id;
- scm_i_set_last_debug_frame (&vframe);
- answer = scm_call_0 (thunk);
- scm_i_set_last_debug_frame (vframe.prev);
- return answer;
+ return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
}
#undef FUNC_NAME
-/* {Debug Objects}
- *
- * The debugging evaluator throws these on frame traps.
- */
-
-scm_t_bits scm_tc16_debugobj;
-
-static int
-debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<debug-object ", port);
- scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a debug object.")
-#define FUNC_NAME s_scm_debug_object_p
-{
- return scm_from_bool(SCM_DEBUGOBJP (obj));
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_make_debugobj (scm_t_debug_frame *frame)
-{
- return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
-}
-
/* Undocumented debugging procedure */
@@ -337,9 +296,6 @@ scm_init_debug ()
init_stack_limit ();
scm_init_opts (scm_debug_options, scm_debug_opts);
- scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
- scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
-
scm_add_feature ("debug-extensions");
#include "libguile/debug.x"
diff --git a/libguile/debug.h b/libguile/debug.h
index 24c6b9e..2ca0b52 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -29,22 +29,6 @@
#include "libguile/options.h"
-/*
- * Here comes some definitions for the debugging machinery.
- * It might seem strange to represent debug flags as ints,
- * but consider that any particular piece of code is normally
- * only interested in one flag at a time. This is then
- * the most efficient representation.
- */
-
-/* {Options}
- */
-
-/* scm_debug_opts is defined in eval.c.
- */
-
-
-
/* {Evaluator}
*/
@@ -55,57 +39,8 @@ typedef union scm_t_debug_info
SCM id;
} scm_t_debug_info;
-typedef struct scm_t_debug_frame
-{
- struct scm_t_debug_frame *prev;
- long status;
- scm_t_debug_info *vect;
- scm_t_debug_info *info;
-} scm_t_debug_frame;
-
-#define SCM_EVALFRAME (0L << 11)
-#define SCM_APPLYFRAME (1L << 11)
-#define SCM_VOIDFRAME (3L << 11)
-#define SCM_MACROEXPF (1L << 10)
-#define SCM_TAILREC (1L << 9)
-#define SCM_TRACED_FRAME (1L << 8)
-#define SCM_ARGS_READY (1L << 7)
-#define SCM_DOVERFLOW (1L << 6)
-#define SCM_MAX_FRAME_SIZE 63
-
-#define SCM_FRAMETYPE (3L << 11)
-
-#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME)
-#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME)
-#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME)
-#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
-#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
-#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
-#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
-#define SCM_MACROEXPP(x) (((x).status & SCM_MACROEXPF) != 0)
-#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
-#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
-#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
-#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
-#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
-#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
-#define SCM_SET_MACROEXP(x) ((x).status |= SCM_MACROEXPF)
-#define SCM_CLEAR_MACROEXP(x) ((x).status &= ~SCM_MACROEXPF)
-
-/* {Debug Objects}
- */
-
-SCM_API scm_t_bits scm_tc16_debugobj;
-
-#define SCM_DEBUGOBJP(x) \
- SCM_TYP16_PREDICATE (scm_tc16_debugobj, x)
-#define SCM_DEBUGOBJ_FRAME(x) \
- ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
-#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
-
-SCM_API SCM scm_debug_object_p (SCM obj);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_module (SCM proc);
@@ -114,9 +49,7 @@ SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);
-SCM_API SCM scm_make_debugobj (scm_t_debug_frame *debug);
-SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized);
SCM_INTERNAL void scm_init_debug (void);
#ifdef GUILE_DEBUG
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 1f35d2a..8b1fce8 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -1416,14 +1416,6 @@ scm_i_deprecated_dynwinds (void)
return scm_i_dynwinds ();
}
-scm_t_debug_frame *
-scm_i_deprecated_last_debug_frame (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_last_debug_frame is deprecated. Do not use it.");
- return scm_i_last_debug_frame ();
-}
-
SCM_STACKITEM *
scm_i_stack_base (void)
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 5570a43..f20e47c 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -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
@@ -499,7 +497,6 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define scm_cur_loadp scm_i_cur_loadp ()
#define scm_progargs scm_i_progargs ()
#define scm_dynwinds scm_i_deprecated_dynwinds ()
-#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
#define scm_stack_base scm_i_stack_base ()
SCM_DEPRECATED SCM scm_i_cur_inp (void);
@@ -508,7 +505,6 @@ SCM_DEPRECATED SCM scm_i_cur_errp (void);
SCM_DEPRECATED SCM scm_i_cur_loadp (void);
SCM_DEPRECATED SCM scm_i_progargs (void);
SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void);
-SCM_DEPRECATED scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void);
/* Deprecated because it evaluates its argument twice.
diff --git a/libguile/frames.c b/libguile/frames.c
index c0d7d61..e38fc00 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -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);
}
diff --git a/libguile/frames.h b/libguile/frames.h
index f744c2b..45ade5a 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -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_vm_frame_prev (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_frame_prev (SCM frame);
SCM_INTERNAL void scm_bootstrap_frames (void);
SCM_INTERNAL void scm_init_frames (void);
diff --git a/libguile/init.c b/libguile/init.c
index 3712a9a..2180e45 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -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 ();
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 79fe2bd..21c288f 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -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,40 +42,10 @@
-/* {Frames and stacks}
+/* {Stacks}
*
- * The debugging evaluator creates debug frames on the stack. These
- * are linked from the innermost frame and outwards. The last frame
- * created can always be accessed as SCM_LAST_DEBUG_FRAME.
- * Continuations contain a pointer to the innermost debug frame on the
- * continuation stack.
- *
- * Each debug frame contains a set of flags and information about one
- * or more stack frames. The case of multiple frames occurs due to
- * tail recursion. The maximal number of stack frames which can be
- * recorded in one debug frame can be set dynamically with the debug
- * option FRAMES.
- *
- * Stack frame information is of two types: eval information (the
- * expression being evaluated and its environment) and apply
- * information (the procedure being applied and its arguments). A
- * stack frame normally corresponds to an eval/apply pair, but macros
- * and special forms (which are implemented as macros in Guile) only
- * have eval information and apply calls leads to apply only frames.
- *
- * Since we want to record the total stack information and later
- * manipulate this data at the scheme level in the debugger, we need
- * to transform it into a new representation. In the following code
- * section you'll find the functions implementing this data type.
- *
- * Representation:
- *
- * 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
@@ -85,271 +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? */
+ */
-/* Some auxiliary functions for reading debug frames off the stack.
- */
+static SCM stack_id_with_fp (SCM frame, SCM **fp);
-/* Stacks often contain pointers to other items on the stack; for
- example, each scm_t_debug_frame structure contains a pointer to the
- next frame out. When we capture a continuation, we copy the stack
- into the heap, and just leave all the pointers unchanged. This
- makes it simple to restore the continuation --- just copy the stack
- back! However, if we retrieve a pointer from the heap copy to
- another item that was originally on the stack, we have to add an
- offset to the pointer to discover the new referent.
-
- If PTR is a pointer retrieved from a continuation, whose original
- target was on the stack, and OFFSET is the appropriate offset from
- the original stack to the continuation, then RELOC_MUMBLE (PTR,
- OFFSET) is a pointer to the copy in the continuation of the
- original referent, cast to an scm_debug_MUMBLE *. */
-#define RELOC_INFO(ptr, offset) \
- ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
-#define RELOC_FRAME(ptr, offset) \
- ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
-
-/* Count number of debug info frames on a stack, beginning with
- * DFRAME. OFFSET is used for relocation of pointers when the stack
- * is read from a continuation.
+/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
- SCM *id)
+stack_depth (SCM frame, SCM *fp)
{
long n;
- for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe);
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && n > 0)
- --n;
- n += (info - vect) / 2 + 1;
- /* Data in the apply part of an eval info frame comes from previous
- stack frame if the scm_t_debug_info vector is overflowed. */
- if ((((info - vect) & 1) == 0)
- && SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- ++n;
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if (SCM_PROGRAM_P (vect[0].a.proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
- /* Programs can end up in the debug stack via deval; but we
just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- /* count vmframe back to previous boot frame */
- for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev
(vmframe))
- {
- if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
- ++n;
- else
- { /* skip boot frame, cut out of the vm backtrace */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- }
- }
- else
- ++n; /* increment for non-program apply frame */
- }
- }
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- *id = RELOC_INFO(dframe->vect, offset)[0].id;
+ /* 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;
}
-/* Read debug info from DFRAME into IFRAME.
- */
-static void
-read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- scm_t_info_frame *iframe)
-{
- scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- {
- /* Debug.vect ends with apply info. */
- --info;
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- if (!SCM_ARGS_READY_P (*dframe))
- flags |= SCM_FRAMEF_EVAL_ARGS;
- }
- }
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = vect[0].a.proc;
- iframe->args = vect[0].a.args;
- }
- iframe->flags = flags;
-}
-
-/* Look up the first body form of the apply closure. We'll use this
- below to prevent it from being displayed.
-*/
-static SCM
-get_applybody ()
-{
- SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
- return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
- else
- return SCM_UNDEFINED;
-}
-
-#define NEXT_FRAME(iframe, n, quit) \
-do { \
- ++iframe; \
- if (--n == 0) \
- goto quit; \
-} while (0)
-
-
-/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
- * starting with the first stack frame represented by debug frame
- * DFRAME.
- */
-
-static scm_t_bits
-read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM vmframe, long n, scm_t_info_frame *iframes)
-{
- scm_t_info_frame *iframe = iframes;
- scm_t_debug_info *info, *vect;
- static SCM applybody = SCM_UNDEFINED;
-
- /* The value of applybody has to be setup after r4rs.scm has executed. */
- if (SCM_UNBNDP (applybody))
- applybody = get_applybody ();
- for (;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- read_frame (dframe, offset, iframe);
- if (SCM_EVALFRAMEP (*dframe))
- {
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && iframe > iframes)
- {
- *(iframe - 1) = *iframe;
- --iframe;
- ++n;
- }
- info = RELOC_INFO (dframe->info, offset);
- vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- --info;
- /* Data in the apply part of an eval info frame comes from
- previous stack frame if the scm_t_debug_info vector is
- overflowed. */
- else if (SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- {
- NEXT_FRAME (iframe, n, quit);
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- if (SCM_OVERFLOWP (*dframe))
- iframe->flags |= SCM_FRAMEF_OVERFLOW;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- while (info >= vect)
- {
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- else
- iframe->flags = SCM_UNPACK (SCM_INUM0);
- iframe->source = SCM_BOOL_F;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- }
- }
- else if (SCM_PROGRAM_P (iframe->proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (iframe->proc))
- /* Programs can end up in the debug stack via deval; but we just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- 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, back to interpreted frames */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- 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)
- goto quit;
- }
- }
- }
- else
- {
- NEXT_FRAME (iframe, n, quit);
- }
- quit:
- if (iframe > iframes)
- (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
- }
- 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.
@@ -374,33 +99,48 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff
offset,
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);
}
@@ -446,50 +186,44 @@ 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_debug_frame *dframe;
- scm_t_info_frame *iframe;
- SCM vmframe;
- long offset = 0;
- SCM stack, id;
+ SCM frame;
+ SCM stack;
+ SCM id, *id_fp;
SCM inner_cut, outer_cut;
/* Extract a pointer to the innermost frame of whatever object
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- dframe = scm_i_last_debug_frame ();
- vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
- }
- else if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- vmframe = SCM_BOOL_F;
+ 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))
- {
- dframe = NULL;
- vmframe = obj;
- }
+ frame = obj;
else if (SCM_CONTINUATIONP (obj))
{
scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
if (!scm_is_null (cont->vm_conts))
{ SCM vm_cont;
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
{
@@ -497,30 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* not reached */
}
+ if (scm_is_false (frame))
+ return SCM_BOOL_F;
+
+ /* Get ID of the stack corresponding to the given frame. */
+ 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 (dframe, offset, vmframe, &id);
- /* 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 (dframe, offset, 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))
@@ -543,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
@@ -561,49 +287,76 @@ 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_t_debug_frame *dframe;
- long offset = 0;
+ SCM frame, *id_fp;
+
if (scm_is_eq (stack, SCM_BOOL_T))
{
- dframe = scm_i_last_debug_frame ();
- }
- else if (SCM_DEBUGOBJP (stack))
- {
- dframe = SCM_DEBUGOBJ_FRAME (stack);
+ struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
+ frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
}
+ else if (SCM_VM_FRAME_P (stack))
+ frame = stack;
else if (SCM_CONTINUATIONP (stack))
{
scm_t_contregs *cont = SCM_CONTREGS (stack);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else if (SCM_STACKP (stack))
- {
- return SCM_STACK (stack) -> id;
+ if (!scm_is_null (cont->vm_conts))
+ { SCM vm_cont;
+ struct scm_vm_cont *data;
+ vm_cont = scm_cdr (scm_car (cont->vm_conts));
+ data = SCM_VM_CONT_DATA (vm_cont);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
+ } else
+ frame = SCM_BOOL_F;
}
else
{
- SCM_WRONG_TYPE_ARG (1, stack);
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
+ /* not reached */
}
- while (dframe && !SCM_VOIDFRAMEP (*dframe))
- dframe = RELOC_FRAME (dframe->prev, offset);
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- return RELOC_INFO (dframe->vect, offset)[0].id;
- return SCM_BOOL_F;
+ return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
+static SCM
+stack_id_with_fp (SCM frame, SCM **fp)
+{
+ SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ if (SCM_VM_CONT_P (holder))
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+}
+
SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM index),
"Return the @var{index}'th frame from @var{stack}.")
#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
@@ -613,174 +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_last_stack_frame, "last-stack-frame", 1, 0, 0,
- (SCM obj),
- "Return the last (innermost) frame of @var{obj}, which must be\n"
- "either a debug object or a continuation.")
-#define FUNC_NAME s_scm_last_stack_frame
-{
- scm_t_debug_frame *dframe;
- long offset = 0;
- SCM stack;
-
- if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- }
- else if (SCM_CONTINUATIONP (obj))
- {
- scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else
- {
- SCM_WRONG_TYPE_ARG (1, obj);
- /* not reached */
- }
-
- if (!dframe || SCM_VOIDFRAMEP (*dframe))
- return SCM_BOOL_F;
-
- stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
- SCM_EOL);
- SCM_STACK (stack) -> length = 1;
- SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
- read_frame (dframe, offset,
- (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
-
- return scm_cons (stack, SCM_INUM0);
-}
-#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
diff --git a/libguile/stacks.h b/libguile/stacks.h
index 20735ef..ba97e08 100644
--- a/libguile/stacks.h
+++ b/libguile/stacks.h
@@ -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_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_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_STACK_LAYOUT \
+ "pw" /* len */ \
+ "pw" /* id */ \
+ "pw" /* frame */
-#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_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE
(obj), scm_stack_type))
+#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_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_FRAMEP(obj) (SCM_VM_FRAME_P (obj))
-#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 */
diff --git a/libguile/threads.c b/libguile/threads.c
index 1527e01..bf2fdb2 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -338,7 +338,6 @@ guilify_self_1 (SCM_STACKITEM *base)
t->block_asyncs = 1;
t->pending_asyncs = 1;
t->critical_section_level = 0;
- t->last_debug_frame = NULL;
t->base = base;
#ifdef __ia64__
/* Calculate and store off the base of this thread's register
diff --git a/libguile/threads.h b/libguile/threads.h
index 5afe45f..4b06590 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -79,7 +79,6 @@ typedef struct scm_i_thread {
/* Other thread local things.
*/
SCM dynamic_state;
- scm_t_debug_frame *last_debug_frame;
SCM dynwinds;
/* For system asyncs.
@@ -209,9 +208,6 @@ SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key;
# define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
# define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
-# define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
-# define scm_i_set_last_debug_frame(f) \
- (SCM_I_CURRENT_THREAD->last_debug_frame =
(f))
#endif /* BUILDING_LIBGUILE */
diff --git a/libguile/throw.c b/libguile/throw.c
index 14153cf..051f6d3 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -62,8 +62,6 @@ static scm_t_bits tc16_jmpbuffer;
#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
-#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3
(x))
#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
@@ -187,7 +185,6 @@ scm_c_catch (SCM tag,
answer = SCM_EOL;
scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
SETJBJMPBUF(jmpbuf, &jbr.buf);
- SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
pre_unwind.handler = pre_unwind_handler;
pre_unwind.handler_data = pre_unwind_handler_data;
@@ -888,7 +885,6 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
- scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
}
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 03993ec..2f3320c 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -23,13 +23,11 @@
#define VM_USE_CLOCK 0 /* Bogoclock */
#define VM_CHECK_OBJECT 1 /* Check object table */
#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
-#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator
debug stack */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
#define VM_USE_CLOCK 1
#define VM_CHECK_OBJECT 1
#define VM_CHECK_FREE_VARIABLES 1
-#define VM_PUSH_DEBUG_FRAMES 1
#else
#error unknown debug engine VM_ENGINE
#endif
@@ -66,12 +64,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
static void **jump_table = NULL;
#endif
-#if VM_PUSH_DEBUG_FRAMES
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.status = SCM_VOIDFRAME;
-#endif
-
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table))
{
@@ -95,15 +87,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* Boot program */
program = vm_make_boot_program (nargs);
-#if VM_PUSH_DEBUG_FRAMES
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = program; /* the boot program */
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-#endif
-
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
@@ -147,9 +130,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
vm_done:
SYNC_ALL ();
-#if VM_PUSH_DEBUG_FRAMES
- scm_i_set_last_debug_frame (debug.prev);
-#endif
return finish_args;
/* Errors */
@@ -278,7 +258,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
#undef VM_USE_CLOCK
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE
-#undef VM_PUSH_DEBUG_FRAMES
/*
Local Variables:
diff --git a/libguile/vm.c b/libguile/vm.c
index 247bb7d..51426a5 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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);
@@ -531,6 +531,12 @@ scm_vm_apply (SCM vm, SCM program, SCM args)
}
#undef FUNC_NAME
+SCM
+scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
+{
+ return scm_c_vm_run (vm, thunk, NULL, 0);
+}
+
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
diff --git a/libguile/vm.h b/libguile/vm.h
index eace1cb..8ec2682 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -65,6 +65,7 @@ SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 628a0ed..5aa5962 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -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))))
diff --git a/test-suite/tests/continuations.test
b/test-suite/tests/continuations.test
index d96274e..f6db40e 100644
--- a/test-suite/tests/continuations.test
+++ b/test-suite/tests/continuations.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -87,9 +87,6 @@
(pass-if "get a continuation's stack ID"
(let ((id (call-with-current-continuation stack-id)))
- (or (boolean? id) (symbol? id))))
-
- (pass-if "get a continuation's innermost frame"
- (pair? (call-with-current-continuation last-stack-frame))))
+ (or (boolean? id) (symbol? id)))))
)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-79-gaa3f695,
Andy Wingo <=