summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/vm.texi6
-rw-r--r--gdbinit18
-rw-r--r--libguile/frames.c230
-rw-r--r--libguile/frames.h65
-rw-r--r--libguile/stacks.c104
-rw-r--r--libguile/vm-engine.c1
-rw-r--r--libguile/vm-engine.h83
-rw-r--r--libguile/vm-i-system.c31
-rw-r--r--libguile/vm.c213
-rw-r--r--libguile/vm.h24
-rw-r--r--module/system/vm/frame.scm14
-rw-r--r--module/system/vm/vm.scm33
12 files changed, 381 insertions, 441 deletions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 3eec91635..0829106fd 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -154,12 +154,11 @@ The structure of the fixed part of an application frame is as follows:
@example
Stack
- | | <- fp + bp->nargs + bp->nlocs + 5
+ | | <- fp + bp->nargs + bp->nlocs + 4
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| MV return address|
| Dynamic link |
- | Heap link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
@@ -199,9 +198,6 @@ This is the @code{fp} in effect before this program was applied. In
effect, this and the return address are the registers that are always
``saved''.
-@item Heap link
-This field is unused and needs to be removed ASAP.
-
@item External link
This field is a reference to the list of heap-allocated variables
associated with this frame. A discussion of heap versus stack
diff --git a/gdbinit b/gdbinit
index cd3add5fb..7c1b216a8 100644
--- a/gdbinit
+++ b/gdbinit
@@ -146,11 +146,6 @@ define nextframe
output $vmdl
newline
set $vmsp=$vmsp-1
- sputs "hl:\t"
- output $vmsp
- sputs "\t"
- gwrite *$vmsp
- set $vmsp=$vmsp-1
sputs "el:\t"
output $vmsp
sputs "\t"
@@ -184,14 +179,13 @@ define nextframe
gwrite *$vmsp
set $vmsp=$vmsp-1
newline
- if !$vmdl
- loop_break
+ if $vmdl
+ set $vmfp=$vmdl
+ set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1])
+ set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4
+ set $vmframe=$vmframe+1
+ newline
end
- set $vmfp=$vmdl
- set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1])
- set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4
- set $vmframe=$vmframe+1
- newline
end
define vmstack
diff --git a/libguile/frames.c b/libguile/frames.c
index 36f057f7e..fa1c54f59 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -48,148 +48,240 @@
#include "frames.h"
-scm_t_bits scm_tc16_heap_frame;
+scm_t_bits scm_tc16_vm_frame;
+
+#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_heap_frame (SCM *fp)
+scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_byte_t *ip, scm_t_ptrdiff offset)
{
- SCM frame;
- SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
- SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
- size_t size = sizeof (SCM) * (upper - lower + 1);
- SCM *p = scm_gc_malloc (size, "frame");
-
- SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
- p[0] = frame; /* self link */
- memcpy (p + 1, lower, size - sizeof (SCM));
-
- return frame;
+ struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_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);
}
static SCM
-heap_frame_mark (SCM obj)
+vm_frame_mark (SCM obj)
{
- SCM *sp;
- SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
- SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
-
- for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++)
- if (SCM_NIMP (*sp))
- scm_gc_mark (*sp);
-
- return SCM_BOOL_F;
+ return SCM_VM_FRAME_STACK_HOLDER (obj);
}
static scm_sizet
-heap_frame_free (SCM obj)
+vm_frame_free (SCM obj)
{
- SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
- SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
- SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
- size_t size = sizeof (SCM) * (upper - lower + 1);
-
- scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
-
+ struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
+ scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
return 0;
}
/* Scheme interface */
-SCM_DEFINE (scm_heap_frame_p, "heap-frame?", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
(SCM obj),
"")
-#define FUNC_NAME s_scm_heap_frame_p
+#define FUNC_NAME s_scm_vm_frame_p
{
- return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
+ return SCM_BOOL (SCM_VM_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_program
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_arguments
+{
+ SCM *fp;
+ int i;
+ struct scm_program *bp;
+ SCM ret;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ if (!bp->nargs)
+ return SCM_EOL;
+ else if (bp->nrest)
+ ret = fp[bp->nargs - 1];
+ else
+ ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
+
+ for (i = bp->nargs - 2; i >= 0; i--)
+ ret = scm_cons (fp[i], ret);
+
+ return ret;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_frame_program
+#define FUNC_NAME s_scm_vm_frame_source
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
- return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame));
+ SCM *fp;
+ struct scm_program *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ return scm_c_program_source (bp, SCM_VM_FRAME_IP (frame) - bp->base);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
+SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
-#define FUNC_NAME s_scm_frame_local_ref
+#define FUNC_NAME s_scm_vm_frame_local_ref
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
- SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
- return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
- SCM_I_INUM (index));
+ SCM *fp;
+ unsigned int i;
+ struct scm_program *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ SCM_VALIDATE_UINT_COPY (2, index, i);
+ SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+ return SCM_FRAME_VARIABLE (fp, i);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
+SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
-#define FUNC_NAME s_scm_frame_local_set_x
+#define FUNC_NAME s_scm_vm_frame_local_set_x
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
- SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
- SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
- SCM_I_INUM (index)) = val;
+ SCM *fp;
+ unsigned int i;
+ struct scm_program *bp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ fp = SCM_VM_FRAME_FP (frame);
+ bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+ SCM_VALIDATE_UINT_COPY (2, index, i);
+ SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+ SCM_FRAME_VARIABLE (fp, i) = val;
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_frame_return_address
+#define FUNC_NAME s_scm_vm_frame_return_address
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
(SCM_FRAME_RETURN_ADDRESS
- (SCM_HEAP_FRAME_POINTER (frame))));
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_frame_mv_return_address
+#define FUNC_NAME s_scm_vm_frame_mv_return_address
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
(SCM_FRAME_MV_RETURN_ADDRESS
- (SCM_HEAP_FRAME_POINTER (frame))));
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_frame_dynamic_link
+#define FUNC_NAME s_scm_vm_frame_dynamic_link
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
- return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame));
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ /* fixme: munge fp if holder is a continuation */
+ return scm_from_ulong
+ ((unsigned long)
+ RELOC (frame,
+ SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_frame_external_link
+#define FUNC_NAME s_scm_vm_frame_external_link
{
- SCM_VALIDATE_HEAP_FRAME (1, frame);
- return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
+SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_stack
+{
+ SCM *top, *bottom, ret = SCM_EOL;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ top = SCM_VM_FRAME_SP (frame);
+ bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (bottom <= top)
+ ret = scm_cons (*bottom++, ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+extern SCM
+scm_c_vm_frame_prev (SCM frame)
+{
+ SCM *this_fp, *new_fp, *new_sp;
+ this_fp = SCM_VM_FRAME_FP (frame);
+ new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
+ 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));
+ }
+ else
+ return SCM_BOOL_F;
+}
+
void
scm_bootstrap_frames (void)
{
- scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
- scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
- scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
+ scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
+ scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
+ scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
}
void
diff --git a/libguile/frames.h b/libguile/frames.h
index f5323f712..836763700 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -58,7 +58,6 @@
| Return address |
| MV return address|
| Dynamic link |
- | Heap link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
@@ -75,21 +74,20 @@
#define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 5)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \
- (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[4]))
-#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
+#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_DYNAMIC_LINK(fp) \
- (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
- ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
-#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1])
+ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
@@ -99,24 +97,43 @@
* Heap frames
*/
-extern scm_t_bits scm_tc16_heap_frame;
-
-#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
-#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f))
-#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0)
-#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2)
-#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
-
-extern SCM scm_heap_frame_p (SCM obj);
-extern SCM scm_frame_program (SCM frame);
-extern SCM scm_frame_local_ref (SCM frame, SCM index);
-extern SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
-extern SCM scm_frame_return_address (SCM frame);
-extern SCM scm_frame_mv_return_address (SCM frame);
-extern SCM scm_frame_dynamic_link (SCM frame);
-extern SCM scm_frame_external_link (SCM frame);
+extern scm_t_bits scm_tc16_vm_frame;
+
+struct scm_vm_frame
+{
+ SCM stack_holder;
+ SCM *fp;
+ SCM *sp;
+ scm_byte_t *ip;
+ 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_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
+#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA(f)->ip
+#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)
+
+/* FIXME rename scm_byte_t */
+extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_byte_t *ip, scm_t_ptrdiff offset);
+extern SCM scm_vm_frame_p (SCM obj);
+extern SCM scm_vm_frame_program (SCM frame);
+extern SCM scm_vm_frame_arguments (SCM frame);
+extern SCM scm_vm_frame_source (SCM frame);
+extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+extern SCM scm_vm_frame_return_address (SCM frame);
+extern SCM scm_vm_frame_mv_return_address (SCM frame);
+extern SCM scm_vm_frame_dynamic_link (SCM frame);
+extern SCM scm_vm_frame_external_link (SCM frame);
+extern SCM scm_vm_frame_stack (SCM frame);
+
+extern SCM scm_c_vm_frame_prev (SCM frame);
-extern SCM scm_c_make_heap_frame (SCM *fp);
extern void scm_bootstrap_frames (void);
extern void scm_init_frames (void);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 4b97a1827..85527bd6a 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -32,6 +32,9 @@
#include "libguile/modules.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/vm.h" /* to capture vm stacks */
+#include "libguile/frames.h" /* vm frames */
+#include "libguile/instructions.h" /* scm_op_halt */
#include "libguile/validate.h"
#include "libguile/stacks.h"
@@ -123,19 +126,24 @@
#define RELOC_FRAME(ptr, offset) \
((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
+/* FIXME: factor this out somewhere? */
+static int is_vm_bootstrap_frame (SCM f)
+{
+ struct scm_program *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
+ return bp->base[bp->size-1] == scm_op_halt;
+}
/* 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.
*/
-static scm_t_bits
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM *id, int *maxp)
+static long
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
+ SCM *id)
{
long n;
- long max_depth = SCM_BACKTRACE_MAXDEPTH;
for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+ dframe && !SCM_VOIDFRAMEP (*dframe);
dframe = RELOC_FRAME (dframe->prev, offset))
{
if (SCM_EVALFRAMEP (*dframe))
@@ -148,15 +156,32 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
if ((((info - vect) & 1) == 0)
&& SCM_OVERFLOWP (*dframe)
&& !SCM_UNBNDP (info[1].a.proc))
- ++n;
+ ++n;
}
+ else if (SCM_APPLYFRAMEP (*dframe))
+ {
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ if (SCM_PROGRAM_P (vect[0].a.proc))
+ {
+ /* count vmframe back to previous bootstrap frame */
+ for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
+ {
+ if (is_vm_bootstrap_frame (vmframe))
+ { /* skip bootstrap frame, cut out of the vm backtrace */
+ vmframe = scm_c_vm_frame_prev (vmframe);
+ break;
+ }
+ else
+ ++n;
+ }
+ }
+ ++n; /* increment for apply frame in any case */
+ }
else
++n;
}
if (dframe && SCM_VOIDFRAMEP (*dframe))
*id = RELOC_INFO(dframe->vect, offset)[0].id;
- else if (dframe)
- *maxp = 1;
return n;
}
@@ -234,7 +259,7 @@ do { \
static scm_t_bits
read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- long n, scm_t_info_frame *iframes)
+ SCM vmframe, long n, scm_t_info_frame *iframes)
{
scm_t_info_frame *iframe = iframes;
scm_t_debug_info *info, *vect;
@@ -298,6 +323,32 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
continue;
else
{
+ if (SCM_PROGRAM_P (iframe->proc))
+ {
+ scm_t_info_frame saved = *iframe;
+ for (; scm_is_true (vmframe);
+ vmframe = scm_c_vm_frame_prev (vmframe))
+ {
+ if (is_vm_bootstrap_frame (vmframe))
+ { /* skip bootstrap 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;
+ }
+ }
+ *iframe = saved;
+ }
+
NEXT_FRAME (iframe, n, quit);
}
quit:
@@ -431,6 +482,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
int maxp;
scm_t_debug_frame *dframe;
scm_t_info_frame *iframe;
+ SCM vmframe;
long offset = 0;
SCM stack, id;
SCM inner_cut, outer_cut;
@@ -439,17 +491,37 @@ 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 ());
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;
+ }
+ else if (SCM_VM_FRAME_P (obj))
+ {
+ dframe = NULL;
+ vmframe = 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->stack_base + data->fp,
+ data->stack_base + data->sp,
+ data->ip,
+ data->reloc);
+ } else
+ vmframe = SCM_BOOL_F;
}
else
{
@@ -462,7 +534,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
(SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F;
maxp = 0;
- n = stack_depth (dframe, offset, &id, &maxp);
+ n = stack_depth (dframe, offset, vmframe, &id);
+ /* FIXME: redo maxp? */
size = n * SCM_FRAME_N_SLOTS;
/* Make the stack object. */
@@ -472,7 +545,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
SCM_STACK (stack) -> frames = iframe;
/* Translate the current chain of stack frames into debugging information. */
- n = read_frames (dframe, offset, n, iframe);
+ n = read_frames (dframe, offset, vmframe, n, iframe);
SCM_STACK (stack) -> length = n;
/* Narrow the stack according to the arguments given to scm_make_stack. */
@@ -500,12 +573,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
n = SCM_STACK (stack) -> length;
}
+ if (n > 0 && maxp)
+ iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+
if (n > 0)
- {
- if (maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
- return stack;
- }
+ return stack;
else
return SCM_BOOL_F;
}
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 84af98c07..fcafd5151 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -80,7 +80,6 @@ vm_run (SCM vm, SCM program, SCM args)
wind_data.vp = vp;
wind_data.sp = vp->sp;
wind_data.fp = vp->fp;
- wind_data.this_frame = vp->this_frame;
scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0);
/* could do this if we reified all vm stacks -- for now, don't bother changing
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 215f630b1..217ad2e66 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -217,11 +217,10 @@
#if VM_USE_HOOKS
#define RUN_HOOK(h) \
{ \
- if (!SCM_FALSEP (vp->hooks[h])) \
+ if (SCM_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\
{ \
SYNC_REGISTER (); \
- vm_heapify_frames (vm); \
- scm_c_run_hook (vp->hooks[h], hook_args); \
+ vm_dispatch_hook (vm, vp->hooks[h], hook_args); \
CACHE_REGISTER (); \
} \
}
@@ -312,75 +311,6 @@ do \
} while (0)
-/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
- allocate cells on the stack. This is a significant improvement for
- programs which call a lot of procedures, since the procedure call
- mechanism uses POP_LIST which normally uses `scm_cons'.
-
- What it does is that it creates a list whose cells are allocated on the
- VM's stack instead of being allocated on the heap via `scm_cell'. This is
- much faster. However, if the callee does something like:
-
- (lambda (. args)
- (set! the-args args))
-
- then terrible things may happen since the list of arguments may be
- overwritten later on. */
-
-
-/* Awful hack that aligns PTR so that it can be considered as a non-immediate
- value by Guile. */
-#define ALIGN_AS_NON_IMMEDIATE(_ptr) \
-{ \
- if ((scm_t_bits)(_ptr) & 6) \
- { \
- size_t _incr; \
- \
- _incr = (scm_t_bits)(_ptr) & 6; \
- _incr = (~_incr) & 7; \
- (_ptr) += _incr; \
- } \
-}
-
-#define POP_LIST_ON_STACK(n) \
-do \
-{ \
- int i; \
- if (n == 0) \
- { \
- sp -= n; \
- PUSH (SCM_EOL); \
- } \
- else \
- { \
- SCM *list_head, *list; \
- \
- list_head = sp + 1; \
- ALIGN_AS_NON_IMMEDIATE (list_head); \
- list = list_head; \
- \
- sp -= n; \
- for (i = 1; i <= n; i++) \
- { \
- /* The cell's car and cdr. */ \
- *(list) = sp[i]; \
- *(list + 1) = PTR2SCM (list + 2); \
- list += 2; \
- } \
- \
- /* The last pair's cdr is '(). */ \
- list--; \
- *list = SCM_EOL; \
- /* Push the SCM object that points */ \
- /* to the first cell. */ \
- PUSH (PTR2SCM (list_head)); \
- } \
-} \
-while (0)
-
-/* end of the experiment */
-
-
#define POP_LIST_MARK() \
do { \
SCM o; \
@@ -476,7 +406,7 @@ do { \
/* New registers */ \
fp = sp - bp->nargs + 1; \
data = SCM_FRAME_DATA_ADDRESS (fp); \
- sp = data + 4; \
+ sp = data + 3; \
CHECK_OVERFLOW (); \
stack_base = sp; \
ip = bp->base; \
@@ -486,10 +416,9 @@ do { \
data[-i] = SCM_UNDEFINED; \
\
/* Set frame data */ \
- data[4] = (SCM)ra; \
- data[3] = 0x0; \
- data[2] = (SCM)dl; \
- data[1] = SCM_BOOL_F; \
+ data[3] = (SCM)ra; \
+ data[2] = 0x0; \
+ data[1] = (SCM)dl; \
\
/* Postpone initializing external vars, \
because if the CONS causes a GC, we \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 4f24aae6e..831819db8 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -688,7 +688,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
sure we have space for the locals now */
data = SCM_FRAME_DATA_ADDRESS (fp);
ip = bp->base;
- stack_base = data + 4;
+ stack_base = data + 3;
sp = stack_base;
CHECK_OVERFLOW ();
@@ -703,10 +703,9 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
data[-i] = SCM_UNDEFINED;
/* Set frame data */
- data[4] = (SCM)ra;
- data[3] = (SCM)mvra;
- data[2] = (SCM)dl;
- data[1] = SCM_BOOL_F;
+ data[3] = (SCM)ra;
+ data[2] = (SCM)mvra;
+ data[1] = (SCM)dl;
/* Postpone initializing external vars, because if the CONS causes a GC,
we want the stack marker to see the data array formatted as expected. */
@@ -839,7 +838,7 @@ VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
CACHE_PROGRAM ();
INIT_ARGS ();
NEW_FRAME ();
- SCM_FRAME_DATA_ADDRESS (fp)[3] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+ SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -996,12 +995,12 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
POP (ret);
ASSERT (sp == stack_base);
- ASSERT (stack_base == data + 4);
+ ASSERT (stack_base == data + 3);
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_BYTE_CAST (data[4]);
- fp = SCM_FRAME_STACK_CAST (data[2]);
+ ip = SCM_FRAME_BYTE_CAST (data[3]);
+ fp = SCM_FRAME_STACK_CAST (data[1]);
{
#ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp;
@@ -1034,16 +1033,16 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
RETURN_HOOK ();
data = SCM_FRAME_DATA_ADDRESS (fp);
- ASSERT (stack_base == data + 4);
+ ASSERT (stack_base == data + 3);
- /* data[3] is the mv return address */
- if (nvalues != 1 && data[3])
+ /* data[2] is the mv return address */
+ if (nvalues != 1 && data[2])
{
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */
- fp = SCM_FRAME_STACK_CAST (data[2]);
+ ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
+ fp = SCM_FRAME_STACK_CAST (data[1]);
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
@@ -1062,8 +1061,8 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
continuation.) */
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */
- fp = SCM_FRAME_STACK_CAST (data[2]);
+ ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
+ fp = SCM_FRAME_STACK_CAST (data[1]);
/* Push first value */
*++sp = stack_base[1];
diff --git a/libguile/vm.c b/libguile/vm.c
index 08629f0b7..32fde6150 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -79,19 +79,6 @@
scm_t_bits scm_tc16_vm_cont;
-struct scm_vm_cont {
- scm_byte_t *ip;
- scm_t_ptrdiff sp;
- scm_t_ptrdiff fp;
- scm_t_ptrdiff stack_size;
- SCM *stack_base;
- scm_t_ptrdiff reloc;
-};
-
-
-#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-
static void
vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
{
@@ -119,7 +106,7 @@ vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
/* update fp from the dynamic link */
fp = (SCM*)*sp-- + reloc;
- /* mark from the hl down to the lower address */
+ /* mark from the el down to the lower address */
for (; sp >= lower; sp--)
if (*sp && SCM_NIMP (*sp))
scm_gc_mark (*sp);
@@ -222,7 +209,6 @@ struct vm_unwind_data
struct scm_vm *vp;
SCM *sp;
SCM *fp;
- SCM this_frame;
};
static void
@@ -233,12 +219,34 @@ vm_reset_stack (void *data)
vp->sp = w->sp;
vp->fp = w->fp;
- vp->this_frame = w->this_frame;
#ifdef VM_ENABLE_STACK_NULLING
memset (vp->sp + 1, 0, (vp->stack_size - (vp->sp + 1 - vp->stack_base)) * sizeof(SCM));
#endif
}
+static void enfalsen_frame (void *p)
+{
+ struct scm_vm *vp = p;
+ vp->trace_frame = SCM_BOOL_F;
+}
+
+static void
+vm_dispatch_hook (SCM vm, SCM hook, SCM hook_args)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+
+ if (!SCM_FALSEP (vp->trace_frame))
+ return;
+
+ scm_dynwind_begin (0);
+ vp->trace_frame = scm_c_make_vm_frame (vm, 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);
+
+ scm_dynwind_end ();
+}
+
/*
* VM Internal functions
@@ -272,68 +280,6 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
return ip;
}
-static SCM
-vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
-{
- SCM frame;
- SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
-#if 0
- SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
-#endif
- SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
-
- if (!dl)
- {
- /* The top frame */
- frame = scm_c_make_heap_frame (fp);
- fp = SCM_HEAP_FRAME_POINTER (frame);
- SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
- }
- else
- {
- /* Child frames */
- SCM link = SCM_FRAME_HEAP_LINK (dl);
- if (!SCM_FALSEP (link))
- link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
- else
- link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
- frame = scm_c_make_heap_frame (fp);
- fp = SCM_HEAP_FRAME_POINTER (frame);
- /* FIXME: I don't think we should be storing heap links on the stack. */
- SCM_FRAME_HEAP_LINK (fp) = link;
- SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
- }
-
- /* Apparently the intention here is to be able to have a frame on the heap,
- but data on the stack, so that you can push as much as you want on the
- stack; but I think that it's currently causing borkage with nonlocal exits
- and the unwind handler, which reinstates the sp and fp, but it's no longer
- pointing at a valid stack frame. So disable for now, we'll get back to
- this later. */
-#if 0
- /* Move stack data */
- for (; src <= sp; src++, dest++)
- *dest = *src;
- *destp = dest;
-#endif
-
- return frame;
-}
-
-static SCM
-vm_heapify_frames (SCM vm)
-{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
- {
- SCM *dest;
- vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
- vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
- vp->sp = dest - 1;
- }
- return vp->this_frame;
-}
-
/*
* VM
@@ -380,11 +326,9 @@ make_vm (void)
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
- vp->this_frame = SCM_BOOL_F;
- vp->last_frame = SCM_BOOL_F;
- vp->last_ip = NULL;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
+ vp->trace_frame = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
}
#undef FUNC_NAME
@@ -407,8 +351,9 @@ vm_mark (SCM obj)
/* mark other objects */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vp->hooks[i]);
- scm_gc_mark (vp->this_frame);
- scm_gc_mark (vp->last_frame);
+
+ scm_gc_mark (vp->trace_frame);
+
return vp->options;
}
@@ -630,109 +575,13 @@ SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
}
#undef FUNC_NAME
-#define VM_CHECK_RUNNING(vm) \
- if (!SCM_VM_DATA (vm)->ip) \
- SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
-
-SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_this_frame
-{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->this_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_last_frame
-{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->last_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_last_ip
-{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_save_stack
-{
- struct scm_vm *vp;
- SCM *dest;
- SCM_VALIDATE_VM (1, vm);
- vp = SCM_VM_DATA (vm);
-
- if (vp->fp)
- {
-#ifdef VM_ENABLE_STACK_NULLING
- if (vp->sp >= vp->stack_base)
- if (!vp->sp[0] || vp->sp[1])
- abort ();
-#endif
- vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
- vp->last_ip = vp->ip;
- }
- else
- {
- vp->last_frame = SCM_BOOL_F;
- }
-
-
- return vp->last_frame;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fetch_code
-{
- int i;
- SCM list;
- scm_byte_t *ip;
- struct scm_instruction *p;
-
- SCM_VALIDATE_VM (1, vm);
- VM_CHECK_RUNNING (vm);
-
- ip = SCM_VM_DATA (vm)->ip;
- p = SCM_INSTRUCTION (*ip);
-
- list = SCM_LIST1 (scm_str2symbol (p->name));
- for (i = 1; i <= p->len; i++)
- list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
- return scm_reverse_x (list, SCM_EOL);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
(SCM vm),
"")
-#define FUNC_NAME s_scm_vm_fetch_stack
+#define FUNC_NAME s_scm_vm_trace_frame
{
- SCM *sp;
- SCM ls = SCM_EOL;
- struct scm_vm *vp;
-
SCM_VALIDATE_VM (1, vm);
- VM_CHECK_RUNNING (vm);
-
- vp = SCM_VM_DATA (vm);
- for (sp = vp->stack_base; sp <= vp->sp; sp++)
- ls = scm_cons (*sp, ls);
- return ls;
+ return SCM_VM_DATA (vm)->trace_frame;
}
#undef FUNC_NAME
diff --git a/libguile/vm.h b/libguile/vm.h
index 7e6ae613b..90a28911d 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -62,13 +62,11 @@ struct scm_vm {
size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */
SCM *stack_limit; /* stack limit address */
- SCM this_frame; /* currrent frame */
- SCM last_frame; /* last frame */
- scm_byte_t *last_ip; /* ip when exception occured */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */
unsigned long time; /* time spent */
unsigned long clock; /* bogos clock */
+ SCM trace_frame; /* a frame being traced */
};
extern SCM scm_the_vm_fluid;
@@ -100,12 +98,20 @@ extern SCM scm_vm_return_hook (SCM vm);
extern SCM scm_vm_option (SCM vm, SCM key);
extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
extern SCM scm_vm_stats (SCM vm);
-extern SCM scm_vm_this_frame (SCM vm);
-extern SCM scm_vm_last_frame (SCM vm);
-extern SCM scm_vm_last_ip (SCM vm);
-extern SCM scm_vm_save_stack (SCM vm);
-extern SCM scm_vm_fetch_code (SCM vm);
-extern SCM scm_vm_fetch_stack (SCM vm);
+extern SCM scm_vm_trace_frame (SCM vm);
+
+struct scm_vm_cont {
+ scm_byte_t *ip;
+ scm_t_ptrdiff sp;
+ scm_t_ptrdiff fp;
+ scm_t_ptrdiff stack_size;
+ SCM *stack_base;
+ scm_t_ptrdiff reloc;
+};
+
+extern scm_t_bits scm_tc16_vm_cont;
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
extern SCM scm_vm_capture_continuations (void);
extern void scm_vm_reinstate_continuations (SCM conts);
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 2de0dde07..85a223e98 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -23,7 +23,15 @@
#:use-module (system vm program)
#:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold))
- #:export (frame-number frame-address
+ #:export (vm-frame?
+ vm-frame-program
+ vm-frame-local-ref vm-frame-local-set!
+ vm-frame-return-address vm-frame-mv-return-address
+ vm-frame-dynamic-link vm-frame-external-link
+ vm-frame-stack
+
+
+ vm-frame-number vm-frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-external-variables
@@ -41,8 +49,8 @@
;;; Frame chain
;;;
-(define frame-number (make-object-property))
-(define frame-address (make-object-property))
+(define vm-frame-number (make-object-property))
+(define vm-frame-address (make-object-property))
(define (bootstrap-frame? frame)
(let ((code (program-bytecode (frame-program frame))))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 725c1a281..a46b85213 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -23,38 +23,17 @@
#:use-module (system vm frame)
#:use-module (system vm objcode)
#:export (vm? the-vm make-vm vm-version
- vm:ip vm:sp vm:fp vm:last-ip
+ vm:ip vm:sp vm:fp vm:last-ip
- vm-load vm-return-value
+ vm-load vm-option set-vm-option! vm-version vm-stats
+ vms:time vms:clock
- vm-option set-vm-option! vm-version
-
- vm-fetch-locals vm-fetch-externals
- vm-last-frame vm-this-frame vm-fetch-stack vm-save-stack
- vm-current-frame-chain vm-last-frame-chain
-
- vm-stats vms:time vms:clock
-
- vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
- vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+ vm-trace-frame
+ vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
+ vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
(dynamic-call "scm_init_vm" (dynamic-link "libguile"))
-(define (vm-current-frame-chain vm)
- (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
-
-(define (vm-last-frame-chain vm)
- (make-frame-chain (vm-last-frame vm) (vm:last-ip vm)))
-
-(define (vm-fetch-locals vm)
- (frame-local-variables (vm-this-frame vm)))
-
-(define (vm-fetch-externals vm)
- (frame-external-variables (vm-this-frame vm)))
-
-(define (vm-return-value vm)
- (car (vm-fetch-stack vm)))
-
(define (vms:time stat) (vector-ref stat 0))
(define (vms:clock stat) (vector-ref stat 1))