mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

remove heap links in VM frames, incorporate vm frames into normal backtraces

Browse source 
* doc/ref/vm.texi (Stack Layout): Update to remove references to the
  "heap link".

* gdbinit: Update for "heap link" removal.

* libguile/frames.c:
* libguile/frames.h: Update macros and diagram for removal of "heap
  link". As part of this, we also remove "heap frames", replacing them
  with "vm frames", which are much like the interpreter's debug objects,
  but for VM stacks. That is to say, they don't actually hold the stack
  themselves, just the pointers into stack that's held by a continuation
  (either captured or current).

* libguile/stacks.c (stack_depth, read_frames): Since a "stack" object is
  really a copy of information that comes from somewhere else, it makes
  sense to copy over info from the VM, just as `make-stack' does from the
  evaluator. The tricky bit is to figure out how to interleave VM and
  interpreter frames. We do that by starting in the interpreter, and
  whenever the current frame's procedure is actually a program, we switch
  to the VM stack, switching back when we reach a "bootstrap frame". The
  last bit is hacky, but it does work...
  (is_vm_bootstrap_frame): Hacky predicate to see if a VM frame is a
  bootstrap frame.
  (scm_make_stack): Accept a VM frame in addition to debug frames.
  Probably has some bugs in this case. But in the case that the arg is
  #t (a common case), do the right thing, capturing the top VM frame as
  well, and interleaving those frames appropriately on the stack.

  As an accident, we lost the ability to limit the number of frames in
  the backtrace. We could add that back, but personally I always want
  *all* frames in the trace... Narrowing still works fine, though there
  are some hiccups sometimes -- e.g. an outer cut to a procedure that
  does a tail-call in VM code will never find the cut, as it no longer
  exists in the continuation.

* libguile/vm.h (struct scm_vm): So! Now that we have switched to save
  stacks in the normal make-stack, there's no more need for `this_frame'
  or `last_frame'. On the other hand, we can take this opportunity to fix
  tracing: when we're in a trace hook, we set `trace_frame' on the VM,
  so we know not to fire hooks when we're already in a hook.
  (struct scm_vm_cont): Expose this, as make-stack needs it to make VM
  frames from VM continuations.

* libguile/vm.c (scm_vm_trace_frame): New function, gets the current
  trace frame.
  (vm_mark, make_vm): Hook up the trace frame.
  (vm_dispatch_hook): New hook dispatcher, with a dynwind so it does the
  right thing if the hook exits nonlocally.

* libguile/vm-engine.c (vm_run): No more this_frame in the wind data.

* libguile/vm-engine.h (RUN_HOOK): Run hooks through the dispatcher.
  (ALIGN_AS_NON_IMMEDIATE, POP_LIST_ON_STACK): Remove unused code.
  (NEW_FRAME): Adapt for no HL in the frame.

* libguile/vm-i-system.c (goto/args, mv-call, return, return/values):
  Adapt for no HL in the frame.

* module/system/vm/frame.scm:
* module/system/vm/vm.scm: Beginnings of some reworkings, needs more
  thought.
This commit is contained in:
Andy Wingo 2008-12-26 17:59:46 +01:00
parent 9f0e9918f4
commit b1b942b74c
12 changed files with 379 additions and 439 deletions
Download patch file Download diff file Expand all files Collapse all files

6
doc/ref/vm.texi
View file

@ -154,12 +154,11 @@ The structure of the fixed part of an application frame is as follows:
@example @example
Stack Stack
| | <- fp + bp->nargs + bp->nlocs + 5 | | <- fp + bp->nargs + bp->nlocs + 4
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address | | Return address |
| MV return address| | MV return address|
| Dynamic link | | Dynamic link |
| Heap link |
| External link | <- fp + bp->nargs + bp->nlocs | External link | <- fp + bp->nargs + bp->nlocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs | 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 effect, this and the return address are the registers that are always
``saved''. ``saved''.
@item Heap link
This field is unused and needs to be removed ASAP.
@item External link @item External link
This field is a reference to the list of heap-allocated variables This field is a reference to the list of heap-allocated variables
associated with this frame. A discussion of heap versus stack associated with this frame. A discussion of heap versus stack

10
gdbinit
View file

@ -146,11 +146,6 @@ define nextframe
output $vmdl output $vmdl
newline newline
set $vmsp=$vmsp-1 set $vmsp=$vmsp-1
sputs "hl:\t"
output $vmsp
sputs "\t"
gwrite *$vmsp
set $vmsp=$vmsp-1
sputs "el:\t" sputs "el:\t"
output $vmsp output $vmsp
sputs "\t" sputs "\t"
@ -184,14 +179,13 @@ define nextframe
gwrite *$vmsp gwrite *$vmsp
set $vmsp=$vmsp-1 set $vmsp=$vmsp-1
newline newline
if !$vmdl if $vmdl
loop_break
end
set $vmfp=$vmdl set $vmfp=$vmdl
set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1]) set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1])
set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4 set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4
set $vmframe=$vmframe+1 set $vmframe=$vmframe+1
newline newline
end
end end
define vmstack define vmstack

230
libguile/frames.c
View file

@ -48,148 +48,240 @@
#include "frames.h" #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
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; struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp); "vmframe");
SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp); p->stack_holder = stack_holder;
size_t size = sizeof (SCM) * (upper - lower + 1); p->fp = fp;
SCM *p = scm_gc_malloc (size, "frame"); p->sp = sp;
p->ip = ip;
SCM_NEWSMOB (frame, scm_tc16_heap_frame, p); p->offset = offset;
p[0] = frame; /* self link */ SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
memcpy (p + 1, lower, size - sizeof (SCM));
return frame;
} }
static SCM static SCM
heap_frame_mark (SCM obj) vm_frame_mark (SCM obj)
{ {
SCM *sp; return SCM_VM_FRAME_STACK_HOLDER (obj);
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;
} }
static scm_sizet static scm_sizet
heap_frame_free (SCM obj) vm_frame_free (SCM obj)
{ {
SCM *fp = SCM_HEAP_FRAME_POINTER (obj); struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp); scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
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");
return 0; return 0;
} }
/* Scheme interface */ /* 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), (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 #undef FUNC_NAME
SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
(SCM frame), (SCM frame),
"") "")
#define FUNC_NAME s_scm_frame_program #define FUNC_NAME s_scm_vm_frame_program
{ {
SCM_VALIDATE_HEAP_FRAME (1, frame); SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame)); return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, 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_vm_frame_source, "vm-frame-source", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_vm_frame_source
{
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_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index), (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 *fp;
SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */ unsigned int i;
return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), struct scm_program *bp;
SCM_I_INUM (index));
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 #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), (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 *fp;
SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */ unsigned int i;
SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), struct scm_program *bp;
SCM_I_INUM (index)) = val;
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; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #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), (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) return scm_from_ulong ((unsigned long)
(SCM_FRAME_RETURN_ADDRESS (SCM_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_POINTER (frame)))); (SCM_VM_FRAME_FP (frame))));
} }
#undef FUNC_NAME #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), (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) return scm_from_ulong ((unsigned long)
(SCM_FRAME_MV_RETURN_ADDRESS (SCM_FRAME_MV_RETURN_ADDRESS
(SCM_HEAP_FRAME_POINTER (frame)))); (SCM_VM_FRAME_FP (frame))));
} }
#undef FUNC_NAME #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), (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); SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (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 #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), (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); SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame)); return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
} }
#undef FUNC_NAME #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 void
scm_bootstrap_frames (void) scm_bootstrap_frames (void)
{ {
scm_tc16_heap_frame = scm_make_smob_type ("frame", 0); scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark); scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free); scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
} }
void void

61
libguile/frames.h
View file

@ -58,7 +58,6 @@
| Return address | | Return address |
| MV return address| | MV return address|
| Dynamic link | | Dynamic link |
| Heap link |
| External link | <- fp + bp->nargs + bp->nlocs | External link | <- fp + bp->nargs + bp->nlocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs | Local variable 0 | <- fp + bp->nargs
@ -75,21 +74,20 @@
#define SCM_FRAME_DATA_ADDRESS(fp) \ #define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs) + 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_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x)) #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_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \ #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])) (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) \ #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) \ #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl); ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1])
#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0]) #define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
#define SCM_FRAME_VARIABLE(fp,i) fp[i] #define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1] #define SCM_FRAME_PROGRAM(fp) fp[-1]
@ -99,24 +97,43 @@
* Heap frames * Heap frames
*/ */
extern scm_t_bits scm_tc16_heap_frame; extern scm_t_bits scm_tc16_vm_frame;
#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x) struct scm_vm_frame
#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f)) {
#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0) SCM stack_holder;
#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2) SCM *fp;
#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P) SCM *sp;
scm_byte_t *ip;
scm_t_ptrdiff offset;
};
extern SCM scm_heap_frame_p (SCM obj); #define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
extern SCM scm_frame_program (SCM frame); #define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x))
extern SCM scm_frame_local_ref (SCM frame, SCM index); #define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
extern SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val); #define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
extern SCM scm_frame_return_address (SCM frame); #define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
extern SCM scm_frame_mv_return_address (SCM frame); #define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA(f)->ip
extern SCM scm_frame_dynamic_link (SCM frame); #define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
extern SCM scm_frame_external_link (SCM frame); #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_bootstrap_frames (void);
extern void scm_init_frames (void); extern void scm_init_frames (void);

100
libguile/stacks.c
View file

@ -32,6 +32,9 @@
#include "libguile/modules.h" #include "libguile/modules.h"
#include "libguile/root.h" #include "libguile/root.h"
#include "libguile/strings.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/validate.h"
#include "libguile/stacks.h" #include "libguile/stacks.h"
@ -123,19 +126,24 @@
#define RELOC_FRAME(ptr, offset) \ #define RELOC_FRAME(ptr, offset) \
((scm_t_debug_frame *) ((SCM_STACKITEM *) (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 /* Count number of debug info frames on a stack, beginning with
* DFRAME. OFFSET is used for relocation of pointers when the stack * DFRAME. OFFSET is used for relocation of pointers when the stack
* is read from a continuation. * is read from a continuation.
*/ */
static scm_t_bits static long
stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
SCM *id, int *maxp) SCM *id)
{ {
long n; long n;
long max_depth = SCM_BACKTRACE_MAXDEPTH;
for (n = 0; for (n = 0;
dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; dframe && !SCM_VOIDFRAMEP (*dframe);
dframe = RELOC_FRAME (dframe->prev, offset)) dframe = RELOC_FRAME (dframe->prev, offset))
{ {
if (SCM_EVALFRAMEP (*dframe)) if (SCM_EVALFRAMEP (*dframe))
@ -150,13 +158,30 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
&& !SCM_UNBNDP (info[1].a.proc)) && !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 else
++n; ++n;
} }
if (dframe && SCM_VOIDFRAMEP (*dframe)) if (dframe && SCM_VOIDFRAMEP (*dframe))
*id = RELOC_INFO(dframe->vect, offset)[0].id; *id = RELOC_INFO(dframe->vect, offset)[0].id;
else if (dframe)
*maxp = 1;
return n; return n;
} }
@ -234,7 +259,7 @@ do { \
static scm_t_bits static scm_t_bits
read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, 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_info_frame *iframe = iframes;
scm_t_debug_info *info, *vect; scm_t_debug_info *info, *vect;
@ -298,6 +323,32 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
continue; continue;
else 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); NEXT_FRAME (iframe, n, quit);
} }
quit: quit:
@ -431,6 +482,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
int maxp; int maxp;
scm_t_debug_frame *dframe; scm_t_debug_frame *dframe;
scm_t_info_frame *iframe; scm_t_info_frame *iframe;
SCM vmframe;
long offset = 0; long offset = 0;
SCM stack, id; SCM stack, id;
SCM inner_cut, outer_cut; SCM inner_cut, outer_cut;
@ -439,17 +491,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_make_stack was given. */ scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T)) if (scm_is_eq (obj, SCM_BOOL_T))
{ {
struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
dframe = scm_i_last_debug_frame (); 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)) else if (SCM_DEBUGOBJP (obj))
{ {
dframe = SCM_DEBUGOBJ_FRAME (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)) else if (SCM_CONTINUATIONP (obj))
{ {
scm_t_contregs *cont = SCM_CONTREGS (obj); scm_t_contregs *cont = SCM_CONTREGS (obj);
offset = cont->offset; offset = cont->offset;
dframe = RELOC_FRAME (cont->dframe, 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 else
{ {
@ -462,7 +534,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
(SCM_BACKTRACE_MAXDEPTH). */ (SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F; id = SCM_BOOL_F;
maxp = 0; 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; size = n * SCM_FRAME_N_SLOTS;
/* Make the stack object. */ /* Make the stack object. */
@ -472,7 +545,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
SCM_STACK (stack) -> frames = iframe; SCM_STACK (stack) -> frames = iframe;
/* Translate the current chain of stack frames into debugging information. */ /* 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; SCM_STACK (stack) -> length = n;
/* Narrow the stack according to the arguments given to scm_make_stack. */ /* Narrow the stack according to the arguments given to scm_make_stack. */
@ -500,12 +573,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
n = SCM_STACK (stack) -> length; n = SCM_STACK (stack) -> length;
} }
if (n > 0) if (n > 0 && maxp)
{
if (maxp)
iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
if (n > 0)
return stack; return stack;
}
else else
return SCM_BOOL_F; return SCM_BOOL_F;
} }

1
libguile/vm-engine.c
View file

@ -80,7 +80,6 @@ vm_run (SCM vm, SCM program, SCM args)
wind_data.vp = vp; wind_data.vp = vp;
wind_data.sp = vp->sp; wind_data.sp = vp->sp;
wind_data.fp = vp->fp; wind_data.fp = vp->fp;
wind_data.this_frame = vp->this_frame;
scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0); 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 /* could do this if we reified all vm stacks -- for now, don't bother changing

83
libguile/vm-engine.h
View file

@ -217,11 +217,10 @@
#if VM_USE_HOOKS #if VM_USE_HOOKS
#define RUN_HOOK(h) \ #define RUN_HOOK(h) \
{ \ { \
if (!SCM_FALSEP (vp->hooks[h])) \ if (SCM_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\
{ \ { \
SYNC_REGISTER (); \ SYNC_REGISTER (); \
vm_heapify_frames (vm); \ vm_dispatch_hook (vm, vp->hooks[h], hook_args); \
scm_c_run_hook (vp->hooks[h], hook_args); \
CACHE_REGISTER (); \ CACHE_REGISTER (); \
} \ } \
} }
@ -311,75 +310,6 @@ do \
} \ } \
} while (0) } 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() \ #define POP_LIST_MARK() \
do { \ do { \
@ -476,7 +406,7 @@ do { \
/* New registers */ \ /* New registers */ \
fp = sp - bp->nargs + 1; \ fp = sp - bp->nargs + 1; \
data = SCM_FRAME_DATA_ADDRESS (fp); \ data = SCM_FRAME_DATA_ADDRESS (fp); \
sp = data + 4; \ sp = data + 3; \
CHECK_OVERFLOW (); \ CHECK_OVERFLOW (); \
stack_base = sp; \ stack_base = sp; \
ip = bp->base; \ ip = bp->base; \
@ -486,10 +416,9 @@ do { \
data[-i] = SCM_UNDEFINED; \ data[-i] = SCM_UNDEFINED; \
\ \
/* Set frame data */ \ /* Set frame data */ \
data[4] = (SCM)ra; \ data[3] = (SCM)ra; \
data[3] = 0x0; \ data[2] = 0x0; \
data[2] = (SCM)dl; \ data[1] = (SCM)dl; \
data[1] = SCM_BOOL_F; \
\ \
/* Postpone initializing external vars, \ /* Postpone initializing external vars, \
because if the CONS causes a GC, we \ because if the CONS causes a GC, we \

31
libguile/vm-i-system.c
View file

@ -688,7 +688,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
sure we have space for the locals now */ sure we have space for the locals now */
data = SCM_FRAME_DATA_ADDRESS (fp); data = SCM_FRAME_DATA_ADDRESS (fp);
ip = bp->base; ip = bp->base;
stack_base = data + 4; stack_base = data + 3;
sp = stack_base; sp = stack_base;
CHECK_OVERFLOW (); CHECK_OVERFLOW ();
@ -703,10 +703,9 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
data[-i] = SCM_UNDEFINED; data[-i] = SCM_UNDEFINED;
/* Set frame data */ /* Set frame data */
data[4] = (SCM)ra; data[3] = (SCM)ra;
data[3] = (SCM)mvra; data[2] = (SCM)mvra;
data[2] = (SCM)dl; data[1] = (SCM)dl;
data[1] = SCM_BOOL_F;
/* Postpone initializing external vars, because if the CONS causes a GC, /* Postpone initializing external vars, because if the CONS causes a GC,
we want the stack marker to see the data array formatted as expected. */ 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 (); CACHE_PROGRAM ();
INIT_ARGS (); INIT_ARGS ();
NEW_FRAME (); 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 (); ENTER_HOOK ();
APPLY_HOOK (); APPLY_HOOK ();
NEXT; NEXT;
@ -996,12 +995,12 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
POP (ret); POP (ret);
ASSERT (sp == stack_base); ASSERT (sp == stack_base);
ASSERT (stack_base == data + 4); ASSERT (stack_base == data + 3);
/* Restore registers */ /* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp); sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_BYTE_CAST (data[4]); ip = SCM_FRAME_BYTE_CAST (data[3]);
fp = SCM_FRAME_STACK_CAST (data[2]); fp = SCM_FRAME_STACK_CAST (data[1]);
{ {
#ifdef VM_ENABLE_STACK_NULLING #ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp; int nullcount = stack_base - sp;
@ -1034,16 +1033,16 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
RETURN_HOOK (); RETURN_HOOK ();
data = SCM_FRAME_DATA_ADDRESS (fp); data = SCM_FRAME_DATA_ADDRESS (fp);
ASSERT (stack_base == data + 4); ASSERT (stack_base == data + 3);
/* data[3] is the mv return address */ /* data[2] is the mv return address */
if (nvalues != 1 && data[3]) if (nvalues != 1 && data[2])
{ {
int i; int i;
/* Restore registers */ /* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */ ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
fp = SCM_FRAME_STACK_CAST (data[2]); fp = SCM_FRAME_STACK_CAST (data[1]);
/* Push return values, and the number of values */ /* Push return values, and the number of values */
for (i = 0; i < nvalues; i++) for (i = 0; i < nvalues; i++)
@ -1062,8 +1061,8 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
continuation.) */ continuation.) */
/* Restore registers */ /* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */ ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
fp = SCM_FRAME_STACK_CAST (data[2]); fp = SCM_FRAME_STACK_CAST (data[1]);
/* Push first value */ /* Push first value */
*++sp = stack_base[1]; *++sp = stack_base[1];

213
libguile/vm.c
View file

@ -79,19 +79,6 @@
scm_t_bits scm_tc16_vm_cont; 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 static void
vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc) 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 */ /* update fp from the dynamic link */
fp = (SCM*)*sp-- + reloc; 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--) for (; sp >= lower; sp--)
if (*sp && SCM_NIMP (*sp)) if (*sp && SCM_NIMP (*sp))
scm_gc_mark (*sp); scm_gc_mark (*sp);
@ -222,7 +209,6 @@ struct vm_unwind_data
struct scm_vm *vp; struct scm_vm *vp;
SCM *sp; SCM *sp;
SCM *fp; SCM *fp;
SCM this_frame;
}; };
static void static void
@ -233,12 +219,34 @@ vm_reset_stack (void *data)
vp->sp = w->sp; vp->sp = w->sp;
vp->fp = w->fp; vp->fp = w->fp;
vp->this_frame = w->this_frame;
#ifdef VM_ENABLE_STACK_NULLING #ifdef VM_ENABLE_STACK_NULLING
memset (vp->sp + 1, 0, (vp->stack_size - (vp->sp + 1 - vp->stack_base)) * sizeof(SCM)); memset (vp->sp + 1, 0, (vp->stack_size - (vp->sp + 1 - vp->stack_base)) * sizeof(SCM));
#endif #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 * VM Internal functions
@ -272,68 +280,6 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
return ip; 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 * VM
@ -380,11 +326,9 @@ make_vm (void)
vp->time = 0; vp->time = 0;
vp->clock = 0; vp->clock = 0;
vp->options = SCM_EOL; 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++) for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F; vp->hooks[i] = SCM_BOOL_F;
vp->trace_frame = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -407,8 +351,9 @@ vm_mark (SCM obj)
/* mark other objects */ /* mark other objects */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++) for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vp->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; return vp->options;
} }
@ -630,109 +575,13 @@ SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
#define VM_CHECK_RUNNING(vm) \ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
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), (SCM vm),
"") "")
#define FUNC_NAME s_scm_vm_this_frame #define FUNC_NAME s_scm_vm_trace_frame
{ {
SCM_VALIDATE_VM (1, vm); SCM_VALIDATE_VM (1, vm);
return SCM_VM_DATA (vm)->this_frame; return SCM_VM_DATA (vm)->trace_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 vm),
"")
#define FUNC_NAME s_scm_vm_fetch_stack
{
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;
} }
#undef FUNC_NAME #undef FUNC_NAME

24
libguile/vm.h
View file

@ -62,13 +62,11 @@ struct scm_vm {
size_t stack_size; /* stack size */ size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */ SCM *stack_base; /* stack base address */
SCM *stack_limit; /* stack limit 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 hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */ SCM options; /* options */
unsigned long time; /* time spent */ unsigned long time; /* time spent */
unsigned long clock; /* bogos clock */ unsigned long clock; /* bogos clock */
SCM trace_frame; /* a frame being traced */
}; };
extern SCM scm_the_vm_fluid; 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_vm_option (SCM vm, SCM key);
extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
extern SCM scm_vm_stats (SCM vm); extern SCM scm_vm_stats (SCM vm);
extern SCM scm_vm_this_frame (SCM vm); extern SCM scm_vm_trace_frame (SCM vm);
extern SCM scm_vm_last_frame (SCM vm);
extern SCM scm_vm_last_ip (SCM vm); struct scm_vm_cont {
extern SCM scm_vm_save_stack (SCM vm); scm_byte_t *ip;
extern SCM scm_vm_fetch_code (SCM vm); scm_t_ptrdiff sp;
extern SCM scm_vm_fetch_stack (SCM vm); 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 SCM scm_vm_capture_continuations (void);
extern void scm_vm_reinstate_continuations (SCM conts); extern void scm_vm_reinstate_continuations (SCM conts);

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

@ -23,7 +23,15 @@
#:use-module (system vm program) #:use-module (system vm program)
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold)) #: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 make-frame-chain
print-frame print-frame-chain-as-backtrace print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-external-variables frame-arguments frame-local-variables frame-external-variables
@ -41,8 +49,8 @@
;;; Frame chain ;;; Frame chain
;;; ;;;
(define frame-number (make-object-property)) (define vm-frame-number (make-object-property))
(define frame-address (make-object-property)) (define vm-frame-address (make-object-property))
(define (bootstrap-frame? frame) (define (bootstrap-frame? frame)
(let ((code (program-bytecode (frame-program frame)))) (let ((code (program-bytecode (frame-program frame))))

27
module/system/vm/vm.scm
View file

@ -25,36 +25,15 @@
#:export (vm? the-vm make-vm vm-version #: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-trace-frame
vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook 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-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
(dynamic-call "scm_init_vm" (dynamic-link "libguile")) (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:time stat) (vector-ref stat 0))
(define (vms:clock stat) (vector-ref stat 1)) (define (vms:clock stat) (vector-ref stat 1))