diff options
-rw-r--r-- | doc/ref/vm.texi | 6 | ||||
-rw-r--r-- | gdbinit | 18 | ||||
-rw-r--r-- | libguile/frames.c | 230 | ||||
-rw-r--r-- | libguile/frames.h | 65 | ||||
-rw-r--r-- | libguile/stacks.c | 104 | ||||
-rw-r--r-- | libguile/vm-engine.c | 1 | ||||
-rw-r--r-- | libguile/vm-engine.h | 83 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 31 | ||||
-rw-r--r-- | libguile/vm.c | 213 | ||||
-rw-r--r-- | libguile/vm.h | 24 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 14 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 33 |
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 @@ -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)) |