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

VM stack grows downward

Browse source 
Adapt VM stack to grow downward.  This will make native compilation look
more like the VM code, as we will be able to use native CALL
instructions, taking proper advantage of the return address buffer.

* libguile/continuations.c (scm_i_continuation_to_frame): Record offsets
  from stack top.

* libguile/control.c (scm_i_prompt_pop_abort_args_x): Adapt for reversed
  order of arguments, and instead of relying on the abort to push on the
  number of arguments, make the caller save the stack depth, which
  allows us to compute the number of arguments ourselves.
  (reify_partial_continuation, scm_c_abort): Adapt to reversed stack
  order.

* libguile/dynstack.c (scm_dynstack_wind_prompt): Since we wind the
  stack in a downward direction, subtract the reloc instead of adding
  it.

* libguile/dynstack.h (SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY): Remove flag;
  instead rely on prompt-establishing code to save the stack depth.

* libguile/eval.c (eval): Remove extraneous "volatile" declarations for
  variables that are not re-set between the setjmp and any longjmp.
  Adapt to save stack depth before instating the prompt.

* libguile/foreign.c (scm_i_foreign_call): Adapt to receive arguments in
  reverse order.

* libguile/frames.c (frame_stack_top, scm_i_frame_stack_top): Adapt to
  compute stack top instead of stack bottom.
  (scm_c_frame_closure): Adapt to stack growth change.
  (scm_frame_num_locals, scm_frame_local_ref, scm_frame_set_x): Use
  union data type to access stack.
  (RELOC): Reformat.
  (scm_c_frame_previous): Adapt to stack growth change.

* libguile/frames.h: Adapt stack diagram to indicate that the stack
  grows up.
  (union scm_vm_stack_element): New data type used to access items on
  the stack.
  (SCM_FRAME_PREVIOUS_SP)
  (SCM_FRAME_RETURN_ADDRESS, SCM_FRAME_SET_RETURN_ADDRESS)
  (SCM_FRAME_DYNAMIC_LINK, SCM_FRAME_SET_DYNAMIC_LINK)
  (SCM_FRAME_LOCAL, SCM_FRAME_NUM_LOCALS): Adapt to stack representation
  change.
  (SCM_FRAME_SLOT): New helper.
  (SCM_VM_FRAME_FP, SCM_VM_FRAME_SP): Adapt to stack growth change.

* libguile/stacks.c (scm_make_stack): Record offsets from top of stack.

* libguile/throw.c (catch): Adapt to scm_i_prompt_pop_abort_args_x
  change.

* libguile/vm-engine.c (ALLOC_FRAME, RESET_FRAME):
  (FRAME_LOCALS_COUNT_FROM): Adapt to stack growth change.
  (LOCAL_ADDRESS): Use SCM_FRAME_SLOT to get the address as the proper
  data type.
  (RETURN_ONE_VALUE, RETURN_VALUE_LIST): Adapt to stack growth change.
  (apply): Shuffling up the SMOB apply args can cause the stack to
  expand, so use ALLOC_FRAME instead of RESET_FRAME.
  (vm_engine): Adapt for stack growth change.

* libguile/vm.c (vm_increase_sp, vm_push_sp, vm_restore_sp): Adapt to
  stack representation change.
  (scm_i_vm_cont_to_frame): Adapt to take offsets from the top.
  (scm_i_vm_capture_stack): Adapt to capture from the top.
  (vm_return_to_continuation_inner): Adapt for data type changes.
  (vm_return_to_continuation): Likewise, and instead of looping, just
  splat the saved arguments on with memcpy.
  (vm_dispatch_hook): Adapt to receive arguments in the reverse order.
  Adapt callers.
  (vm_abort): There is never a tail argument.  Adapt to stack
  representation change.
  (vm_reinstate_partial_continuation)
  (vm_reinstate_partial_continuation_inner): Adapt to stack growth
  change.
  (allocate_stack, free_stack): Adapt to data type change.
  (expand_stack): Don't try to mremap(), as you can't grow a mapping
  from the bottom.  Without knowing that there's a free mapping space
  right below the old stack, which there usually isn't on Linux, we have
  to copy.  We can't use MAP_GROWSDOWN because Linux is buggy.
  (make_vm): Adapt to stack representation changes.
  (return_unused_stack_to_os): Round down instead of up, as the stack
  grows down.
  (scm_i_vm_mark_stack): Adapt to walk up the stack.
  (scm_i_vm_free_stack): Adapt to scm_vm changes.
  (vm_expand_stack_inner, reset_stack_limit, vm_expand_stack): Adapt to
  the stack growing down.
  (scm_call_n): Adapt to the stack growing down.  Don't allow argv to
  point into the stack.

* libguile/vm.h (struct scm_vm, struct scm_vm_cont): Adapt to hold the
  stack top and bottom.
This commit is contained in:
Andy Wingo 2015-09-22 10:24:30 +00:00
parent d7199da8c9
commit 0007507340
15 changed files with 400 additions and 392 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/continuations.c
View file

@ -180,10 +180,13 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
if (scm_is_true (cont->vm_cont))
{
struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
union scm_vm_stack_element *stack_top;
/* FIXME vm_cont should hold fp/sp offsets */
stack_top = data->stack_bottom + data->stack_size;
frame->stack_holder = data;
frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
frame->fp_offset = stack_top - (data->fp + data->reloc);
frame->sp_offset = stack_top - (data->sp + data->reloc);
frame->ip = data->ra;
return 1;

63
libguile/control.c
View file

@ -39,19 +39,22 @@
/* Only to be called if the SCM_I_SETJMP returns 1 */
SCM
scm_i_prompt_pop_abort_args_x (struct scm_vm *vp)
scm_i_prompt_pop_abort_args_x (struct scm_vm *vp,
scm_t_ptrdiff saved_stack_depth)
{
size_t i, n;
scm_t_ptrdiff stack_depth;
SCM vals = SCM_EOL;
n = scm_to_size_t (vp->sp[0]);
for (i = 0; i < n; i++)
vals = scm_cons (vp->sp[-(i + 1)], vals);
stack_depth = vp->stack_top - vp->sp;
if (stack_depth < saved_stack_depth)
abort ();
n = stack_depth - saved_stack_depth;
/* The abort did reset the VM's registers, but then these values
were pushed on; so we need to pop them ourselves. */
vp->sp -= n + 1;
/* FIXME NULLSTACK */
for (i = 0; i < n; i++)
vals = scm_cons (vp->sp[i].scm, vals);
vp->sp += n;
return vals;
}
@ -79,8 +82,8 @@ make_partial_continuation (SCM vm_cont)
static SCM
reify_partial_continuation (struct scm_vm *vp,
SCM *saved_fp,
SCM *saved_sp,
union scm_vm_stack_element *saved_fp,
union scm_vm_stack_element *saved_sp,
scm_t_uint32 *saved_ip,
scm_i_jmp_buf *saved_registers,
scm_t_dynstack *dynstack,
@ -88,7 +91,7 @@ reify_partial_continuation (struct scm_vm *vp,
{
SCM vm_cont;
scm_t_uint32 flags;
SCM *bottom_fp;
union scm_vm_stack_element *base_fp;
flags = SCM_F_VM_CONT_PARTIAL;
/* If we are aborting to a prompt that has the same registers as those
@ -98,24 +101,20 @@ reify_partial_continuation (struct scm_vm *vp,
if (saved_registers && saved_registers == current_registers)
flags |= SCM_F_VM_CONT_REWINDABLE;
/* Walk the stack down until we find the first frame after saved_fp.
We will save the stack down to that frame. It used to be that we
could determine the stack bottom in O(1) time, but that's no longer
/* Walk the stack until we find the first frame newer than saved_fp.
We will save the stack until that frame. It used to be that we
could determine the stack base in O(1) time, but that's no longer
the case, since the thunk application doesn't occur where the
prompt is saved. */
for (bottom_fp = vp->fp;
SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
for (base_fp = vp->fp;
SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp;
base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp));
if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp)
if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp)
abort();
/* Capture from the top of the thunk application frame up to the end. */
vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0),
vp->fp,
vp->sp,
vp->ip,
dynstack,
/* Capture from the base_fp to the top thunk application frame. */
vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack,
flags);
return make_partial_continuation (vm_cont);
@ -130,7 +129,7 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
scm_t_bits *prompt;
scm_t_dynstack_prompt_flags flags;
scm_t_ptrdiff fp_offset, sp_offset;
SCM *fp, *sp;
union scm_vm_stack_element *fp, *sp;
scm_t_uint32 *ip;
scm_i_jmp_buf *registers;
size_t i;
@ -142,8 +141,8 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
fp = vp->stack_base + fp_offset;
sp = vp->stack_base + sp_offset;
fp = vp->stack_top - fp_offset;
sp = vp->stack_top - sp_offset;
/* Only reify if the continuation referenced in the handler. */
if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
@ -162,19 +161,17 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
/* Restore VM regs */
vp->fp = fp;
vp->sp = sp;
vp->sp = sp - n - 1;
vp->ip = ip;
/* Since we're jumping down, we should always have enough space. */
if (vp->sp + n + 1 >= vp->stack_limit)
if (vp->sp < vp->stack_limit)
abort ();
/* Push vals */
*(++(vp->sp)) = cont;
vp->sp[n].scm = cont;
for (i = 0; i < n; i++)
*(++(vp->sp)) = argv[i];
if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
*(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
vp->sp[n - i - 1].scm = argv[i];
/* Jump! */
SCM_I_LONGJMP (*registers, 1);

3
libguile/control.h
View file

@ -22,7 +22,8 @@
#include "libguile/vm.h"
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp);
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp,
scm_t_ptrdiff saved_stack_depth);
SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
scm_i_jmp_buf *registers) SCM_NORETURN;

4
libguile/dynstack.c
View file

@ -484,8 +484,8 @@ scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item,
scm_dynstack_push_prompt (dynstack,
SCM_DYNSTACK_TAG_FLAGS (tag),
PROMPT_KEY (item),
PROMPT_FP (item) + reloc,
PROMPT_SP (item) + reloc,
PROMPT_FP (item) - reloc,
PROMPT_SP (item) - reloc,
PROMPT_IP (item),
registers);
}

3
libguile/dynstack.h
View file

@ -129,8 +129,7 @@ typedef enum {
} scm_t_dynstack_winder_flags;
typedef enum {
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT),
SCM_F_DYNSTACK_PROMPT_PUSH_NARGS = (2 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
} scm_t_dynstack_prompt_flags;
typedef void (*scm_t_guard) (void *);

18
libguile/eval.c
View file

@ -424,23 +424,22 @@ eval (SCM x, SCM env)
case SCM_M_CALL_WITH_PROMPT:
{
struct scm_vm *vp;
SCM k, res;
SCM k, handler, res;
scm_i_jmp_buf registers;
/* We need the handler after nonlocal return to the setjmp, so
make sure it is volatile. */
volatile SCM handler;
scm_t_ptrdiff saved_stack_depth;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vp = scm_the_vm ();
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
| SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
vp->fp - vp->stack_base,
vp->sp - vp->stack_base,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
&registers);
@ -449,8 +448,7 @@ eval (SCM x, SCM env)
/* The prompt exited nonlocally. */
scm_gc_after_nonlocal_exit ();
proc = handler;
vp = scm_the_vm ();
args = scm_i_prompt_pop_abort_args_x (vp);
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
goto apply_proc;
}

4
libguile/foreign.c
View file

@ -977,7 +977,7 @@ pack (const ffi_type * type, const void *loc, int return_value_p)
SCM
scm_i_foreign_call (SCM foreign, const SCM *argv)
scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
{
/* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
objtable. */
@ -1016,7 +1016,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
cif->arg_types[i]->alignment);
assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
unpack (cif->arg_types[i], args[i], argv[i], 0);
unpack (cif->arg_types[i], args[i], argv[cif->nargs - i - 1].scm, 0);
}
/* Prepare space for the return value. On some platforms, such as

5
libguile/foreign.h
View file

@ -93,11 +93,14 @@ SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer, SCM length, SCM encoding);
arguments.
*/
union scm_vm_stack_element;
SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign,
const union scm_vm_stack_element *argv);
SCM_INTERNAL int scm_i_foreign_arity (SCM foreign,
int *req, int *opt, int *rest);

60
libguile/frames.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -25,14 +25,6 @@
#include "_scm.h"
#include "frames.h"
#include "vm.h"
#include <verify.h>
/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
verify (sizeof (SCM) == sizeof (SCM *));
verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM));
verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
SCM
scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
@ -57,16 +49,19 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
scm_puts_unlocked (">", port);
}
static SCM*
frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
static union scm_vm_stack_element*
frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
switch (kind)
{
case SCM_VM_FRAME_KIND_CONT:
return ((struct scm_vm_cont *) frame->stack_holder)->stack_base;
{
struct scm_vm_cont *cont = frame->stack_holder;
return cont->stack_bottom + cont->stack_size;
}
case SCM_VM_FRAME_KIND_VM:
return ((struct scm_vm *) frame->stack_holder)->stack_base;
return ((struct scm_vm *) frame->stack_holder)->stack_top;
default:
abort ();
@ -89,14 +84,14 @@ frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
}
}
SCM*
scm_i_frame_stack_base (SCM frame)
#define FUNC_NAME "frame-stack-base"
union scm_vm_stack_element*
scm_i_frame_stack_top (SCM frame)
#define FUNC_NAME "frame-stack-top"
{
SCM_VALIDATE_VM_FRAME (1, frame);
return frame_stack_base (SCM_VM_FRAME_KIND (frame),
SCM_VM_FRAME_DATA (frame));
return frame_stack_top (SCM_VM_FRAME_KIND (frame),
SCM_VM_FRAME_DATA (frame));
}
#undef FUNC_NAME
@ -130,10 +125,10 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
SCM
scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
SCM *fp, *sp;
union scm_vm_stack_element *fp, *sp;
fp = frame_stack_base (kind, frame) + frame->fp_offset;
sp = frame_stack_base (kind, frame) + frame->sp_offset;
fp = frame_stack_top (kind, frame) - frame->fp_offset;
sp = frame_stack_top (kind, frame) - frame->sp_offset;
if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
return SCM_FRAME_LOCAL (fp, 0);
@ -214,7 +209,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_num_locals
{
SCM *fp, *sp;
union scm_vm_stack_element *fp, *sp;
SCM_VALIDATE_VM_FRAME (1, frame);
@ -230,7 +225,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
"")
#define FUNC_NAME s_scm_frame_local_ref
{
SCM *fp, *sp;
union scm_vm_stack_element *fp, *sp;
unsigned int i;
SCM_VALIDATE_VM_FRAME (1, frame);
@ -252,7 +247,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
"")
#define FUNC_NAME s_scm_frame_local_set_x
{
SCM *fp, *sp;
union scm_vm_stack_element *fp, *sp;
unsigned int i;
SCM_VALIDATE_VM_FRAME (1, frame);
@ -314,8 +309,7 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
}
#undef FUNC_NAME
#define RELOC(kind, frame, val) \
(((SCM *) (val)) + frame_offset (kind, frame))
#define RELOC(kind, frame, val) ((val) + frame_offset (kind, frame))
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
@ -334,13 +328,13 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
int
scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
{
SCM *this_fp, *new_fp, *new_sp;
SCM *stack_base = frame_stack_base (kind, frame);
union scm_vm_stack_element *this_fp, *new_fp, *new_sp;
union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame);
again:
this_fp = frame->fp_offset + stack_base;
this_fp = stack_top - frame->fp_offset;
if (this_fp == stack_base)
if (this_fp == stack_top)
return 0;
new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
@ -350,12 +344,12 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
new_fp = RELOC (kind, frame, new_fp);
if (new_fp < stack_base)
if (new_fp > stack_top)
return 0;
new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
frame->fp_offset = new_fp - stack_base;
frame->sp_offset = new_sp - stack_base;
frame->fp_offset = stack_top - new_fp;
frame->sp_offset = stack_top - new_sp;
frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
{

76
libguile/frames.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -38,24 +38,29 @@
Stack frame layout
------------------
/------------------\
| Local N-1 | <- sp
| ... |
| Local 1 |
| Local 0 | <- fp = SCM_FRAME_LOCALS_ADDRESS (fp)
+==================+
+==================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp)
| Dynamic link |
+------------------+
| Return address |
| Dynamic link | <- fp - 2 = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
| | <- fp - 3 = SCM_FRAME_PREVIOUS_SP (fp)
+==================+ <- fp
| Local 0 |
+------------------+
| Local 1 |
+------------------+
| ... |
+------------------+
| Local N-1 |
\------------------/ <- sp
The stack grows down.
The calling convention is that a caller prepares a stack frame
consisting of the saved FP and the return address, followed by the
procedure and then the arguments to the call, in order. Thus in the
beginning of a call, the procedure being called is in slot 0, the
first argument is in slot 1, and the SP points to the last argument.
The number of arguments, including the procedure, is thus SP - FP +
1.
The number of arguments, including the procedure, is thus FP - SP.
After ensuring that the correct number of arguments have been passed,
a function will set the stack pointer to point to the last local
@ -80,35 +85,26 @@
/* This structure maps to the contents of a VM stack frame. It can
alias a frame directly. */
struct scm_vm_frame
/* Each element on the stack occupies the same amount of space. */
union scm_vm_stack_element
{
SCM *dynamic_link;
scm_t_uint32 *return_address;
SCM locals[1]; /* Variable-length */
union scm_vm_stack_element *fp;
scm_t_uint32 *ip;
SCM scm;
/* For GC purposes. */
void *ptr;
scm_t_bits bits;
};
#define SCM_FRAME_LOWER_ADDRESS(fp) (((SCM *) (fp)) - 2)
#define SCM_FRAME_STRUCT(fp) \
((struct scm_vm_frame *) SCM_FRAME_LOWER_ADDRESS (fp))
#define SCM_FRAME_LOCALS_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->locals)
#define SCM_FRAME_PREVIOUS_SP(fp) (((SCM *) (fp)) - 3)
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_STRUCT (fp)->return_address)
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
SCM_FRAME_STRUCT (fp)->return_address = (ra)
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STRUCT (fp)->dynamic_link)
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
SCM_FRAME_DYNAMIC_LINK (fp) = (dl)
#define SCM_FRAME_LOCAL(fp,i) \
(SCM_FRAME_STRUCT (fp)->locals[i])
#define SCM_FRAME_NUM_LOCALS(fp, sp) \
((sp) + 1 - &SCM_FRAME_LOCAL (fp, 0))
#define SCM_FRAME_PREVIOUS_SP(fp_) ((fp_) + 2)
#define SCM_FRAME_RETURN_ADDRESS(fp_) ((fp_)[0].ip)
#define SCM_FRAME_SET_RETURN_ADDRESS(fp_, ra) ((fp_)[0].ip = (ra))
#define SCM_FRAME_DYNAMIC_LINK(fp_) ((fp_)[1].fp)
#define SCM_FRAME_SET_DYNAMIC_LINK(fp_, dl) ((fp_)[1].fp = (dl))
#define SCM_FRAME_SLOT(fp_,i) ((fp_) - (i) - 1)
#define SCM_FRAME_LOCAL(fp_,i) (SCM_FRAME_SLOT (fp_, i)->scm)
#define SCM_FRAME_NUM_LOCALS(fp_, sp) ((fp_) - (sp))
/*
@ -137,13 +133,13 @@ enum scm_vm_frame_kind
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA (f)->stack_holder
#define SCM_VM_FRAME_FP_OFFSET(f) SCM_VM_FRAME_DATA (f)->fp_offset
#define SCM_VM_FRAME_SP_OFFSET(f) SCM_VM_FRAME_DATA (f)->sp_offset
#define SCM_VM_FRAME_FP(f) (SCM_VM_FRAME_FP_OFFSET (f) + scm_i_frame_stack_base (f))
#define SCM_VM_FRAME_SP(f) (SCM_VM_FRAME_SP_OFFSET (f) + scm_i_frame_stack_base (f))
#define SCM_VM_FRAME_FP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_FP_OFFSET (f))
#define SCM_VM_FRAME_SP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_SP_OFFSET (f))
#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA (f)->ip
#define SCM_VM_FRAME_OFFSET(f) scm_i_frame_offset (f)
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame);
SCM_INTERNAL union scm_vm_stack_element* scm_i_frame_stack_top (SCM frame);
SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame);
/* See notes in frames.c before using this. */

7
libguile/stacks.c
View file

@ -320,14 +320,17 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
{
SCM cont;
struct scm_vm_cont *c;
union scm_vm_stack_element *stack_top;
cont = scm_i_capture_current_stack ();
c = SCM_VM_CONT_DATA (cont);
/* FIXME vm_cont should hold fp/sp offsets */
stack_top = c->stack_bottom + c->stack_size;
kind = SCM_VM_FRAME_KIND_CONT;
frame.stack_holder = c;
frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
frame.fp_offset = stack_top - (c->fp + c->reloc);
frame.sp_offset = stack_top - (c->sp + c->reloc);
frame.ip = c->ra;
}
else if (SCM_VM_FRAME_P (obj))

9
libguile/throw.c
View file

@ -102,14 +102,13 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
scm_c_vector_set_x (eh, 3, pre_unwind_handler);
vp = scm_the_vm ();
saved_stack_depth = vp->sp - vp->stack_base;
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt and exception handler onto the dynamic stack. */
scm_dynstack_push_prompt (dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
| SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
prompt_tag,
vp->fp - vp->stack_base,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
&registers);
@ -125,7 +124,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
/* FIXME: We know where the args will be on the stack; we could
avoid consing them. */
args = scm_i_prompt_pop_abort_args_x (vp);
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
/* Cdr past the continuation. */
args = scm_cdr (args);

112
libguile/vm-engine.c
View file

@ -134,10 +134,10 @@
/* Virtual Machine
The VM has three state bits: the instruction pointer (IP), the frame
pointer (FP), and the top-of-stack pointer (SP). We cache the first
two of these in machine registers, local to the VM, because they are
used extensively by the VM. As the SP is used more by code outside
the VM than by the VM itself, we don't bother caching it locally.
pointer (FP), and the stack pointer (SP). We cache the first two of
these in machine registers, local to the VM, because they are used
extensively by the VM. As the SP is used more by code outside the VM
than by the VM itself, we don't bother caching it locally.
Since the FP changes infrequently, relative to the IP, we keep vp->fp
in sync with the local FP. This would be a big lose for the IP,
@ -172,17 +172,17 @@
FP is valid across an ALLOC_FRAME call. Be careful! */
#define ALLOC_FRAME(n) \
do { \
SCM *new_sp = LOCAL_ADDRESS (n - 1); \
if (new_sp > vp->sp_max_since_gc) \
union scm_vm_stack_element *new_sp = LOCAL_ADDRESS (n - 1); \
if (new_sp < vp->sp_min_since_gc) \
{ \
if (SCM_UNLIKELY (new_sp >= vp->stack_limit)) \
if (SCM_UNLIKELY (new_sp < vp->stack_limit)) \
{ \
SYNC_IP (); \
vm_expand_stack (vp, new_sp); \
CACHE_FP (); \
} \
else \
vp->sp_max_since_gc = vp->sp = new_sp; \
vp->sp_min_since_gc = vp->sp = new_sp; \
} \
else \
vp->sp = new_sp; \
@ -193,15 +193,15 @@
#define RESET_FRAME(n) \
do { \
vp->sp = LOCAL_ADDRESS (n - 1); \
if (vp->sp > vp->sp_max_since_gc) \
vp->sp_max_since_gc = vp->sp; \
if (vp->sp < vp->sp_min_since_gc) \
vp->sp_min_since_gc = vp->sp; \
} while (0)
/* Compute the number of locals in the frame. At a call, this is equal
to the number of actual arguments when a function is first called,
plus one for the function. */
#define FRAME_LOCALS_COUNT_FROM(slot) \
(vp->sp + 1 - LOCAL_ADDRESS (slot))
(LOCAL_ADDRESS (slot) + 1 - vp->sp)
#define FRAME_LOCALS_COUNT() \
FRAME_LOCALS_COUNT_FROM (0)
@ -246,7 +246,7 @@
case opcode:
#endif
#define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
#define LOCAL_ADDRESS(i) SCM_FRAME_SLOT (fp, i)
#define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
@ -257,18 +257,18 @@
#define RETURN_ONE_VALUE(ret) \
do { \
SCM val = ret; \
SCM *old_fp; \
union scm_vm_stack_element *old_fp; \
VM_HANDLE_INTERRUPTS; \
ALLOC_FRAME (2); \
old_fp = fp; \
ip = SCM_FRAME_RETURN_ADDRESS (fp); \
fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
/* Clear frame. */ \
old_fp[-1] = SCM_BOOL_F; \
old_fp[-2] = SCM_BOOL_F; \
old_fp[0].scm = SCM_BOOL_F; \
old_fp[1].scm = SCM_BOOL_F; \
/* Leave proc. */ \
SCM_FRAME_LOCAL (old_fp, 1) = val; \
vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
vp->sp = SCM_FRAME_SLOT (old_fp, 1); \
POP_CONTINUATION_HOOK (old_fp); \
NEXT (0); \
} while (0)
@ -279,10 +279,10 @@
do { \
SCM vals = vals_; \
VM_HANDLE_INTERRUPTS; \
ALLOC_FRAME (3); \
fp[0] = vm_builtin_apply; \
fp[1] = vm_builtin_values; \
fp[2] = vals; \
ALLOC_FRAME (3); \
SCM_FRAME_LOCAL (fp, 0) = vm_builtin_apply; \
SCM_FRAME_LOCAL (fp, 1) = vm_builtin_values; \
SCM_FRAME_LOCAL (fp, 2) = vals; \
ip = (scm_t_uint32 *) vm_builtin_apply_code; \
goto op_tail_apply; \
} while (0)
@ -429,7 +429,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
/* Frame pointer: A pointer into the stack, off of which we index
arguments and local variables. Pushed at function calls, popped on
returns. */
register SCM *fp FP_REG;
register union scm_vm_stack_element *fp FP_REG;
/* Current opcode: A cache of *ip. */
register scm_t_uint32 op;
@ -472,8 +472,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
{
scm_t_uint32 n = FRAME_LOCALS_COUNT();
/* Shuffle args up. */
RESET_FRAME (n + 1);
/* Shuffle args up. (FIXME: no real need to shuffle; just set
IP and go. ) */
ALLOC_FRAME (n + 1);
while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n));
@ -546,7 +547,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
{
scm_t_uint32 proc, nlocals;
SCM *old_fp;
union scm_vm_stack_element *old_fp;
UNPACK_24 (op, proc);
UNPACK_24 (ip[1], nlocals);
@ -556,7 +557,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
PUSH_CONTINUATION_HOOK ();
old_fp = fp;
fp = vp->fp = old_fp + proc;
fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2);
@ -586,7 +587,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
{
scm_t_uint32 proc, nlocals;
scm_t_int32 label;
SCM *old_fp;
union scm_vm_stack_element *old_fp;
UNPACK_24 (op, proc);
UNPACK_24 (ip[1], nlocals);
@ -597,7 +598,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
PUSH_CONTINUATION_HOOK ();
old_fp = fp;
fp = vp->fp = old_fp + proc;
fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 3);
@ -754,7 +755,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*/
VM_DEFINE_OP (9, return_values, "return-values", OP1 (U8_X24))
{
SCM *old_fp;
union scm_vm_stack_element *old_fp;
VM_HANDLE_INTERRUPTS;
@ -763,8 +764,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Clear stack frame. */
old_fp[-1] = SCM_BOOL_F;
old_fp[-2] = SCM_BOOL_F;
old_fp[0].scm = SCM_BOOL_F;
old_fp[1].scm = SCM_BOOL_F;
POP_CONTINUATION_HOOK (old_fp);
@ -804,34 +805,46 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
ret = subr ();
break;
case 1:
ret = subr (fp[1]);
ret = subr (LOCAL_REF (1));
break;
case 2:
ret = subr (fp[1], fp[2]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2));
break;
case 3:
ret = subr (fp[1], fp[2], fp[3]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3));
break;
case 4:
ret = subr (fp[1], fp[2], fp[3], fp[4]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4));
break;
case 5:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5));
break;
case 6:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6));
break;
case 7:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6),
LOCAL_REF (7));
break;
case 8:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6),
LOCAL_REF (7), LOCAL_REF (8));
break;
case 9:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6),
LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9));
break;
case 10:
ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9], fp[10]);
ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3),
LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6),
LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9),
LOCAL_REF (10));
break;
default:
abort ();
@ -869,7 +882,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
// FIXME: separate args
ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer),
LOCAL_ADDRESS (1));
vp->sp);
CACHE_FP ();
@ -903,7 +916,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
vm_return_to_continuation (scm_i_contregs_vp (contregs),
scm_i_contregs_vm_cont (contregs),
FRAME_LOCALS_COUNT_FROM (1),
LOCAL_ADDRESS (1));
vp->sp);
scm_i_reinstate_continuation (contregs);
/* no NEXT */
@ -912,7 +925,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
/* compose-continuation cont:24
*
* Compose a partial continution with the current continuation. The
* Compose a partial continuation with the current continuation. The
* arguments to the continuation are taken from the stack. CONT is a
* free variable containing the reified continuation. This
* instruction is part of the implementation of partial continuations,
@ -930,9 +943,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
vm_error_continuation_not_rewindable (vmcont));
vm_reinstate_partial_continuation (vp, vmcont, FRAME_LOCALS_COUNT_FROM (1),
LOCAL_ADDRESS (1),
&thread->dynstack,
registers);
&thread->dynstack, registers);
CACHE_REGISTER ();
NEXT (0);
}
@ -999,7 +1010,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
SYNC_IP ();
dynstack = scm_dynstack_capture_all (&thread->dynstack);
vm_cont = scm_i_vm_capture_stack (vp->stack_base,
vm_cont = scm_i_vm_capture_stack (vp->stack_top,
SCM_FRAME_DYNAMIC_LINK (fp),
SCM_FRAME_PREVIOUS_SP (fp),
SCM_FRAME_RETURN_ADDRESS (fp),
@ -1051,8 +1062,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
it continues with the next instruction. */
ip++;
SYNC_IP ();
vm_abort (vp, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2),
SCM_EOL, LOCAL_ADDRESS (0), registers);
vm_abort (vp, LOCAL_REF (1), nlocals - 2, registers);
/* vm_abort should not return */
abort ();
@ -2065,8 +2075,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
scm_dynstack_push_prompt (&thread->dynstack, flags,
LOCAL_REF (tag),
fp - vp->stack_base,
LOCAL_ADDRESS (proc_slot) - vp->stack_base,
vp->stack_top - fp,
vp->stack_top - LOCAL_ADDRESS (proc_slot),
ip + offset,
registers);
NEXT (3);

394
libguile/vm.c
View file

@ -16,9 +16,6 @@
* 02110-1301 USA
*/
/* For mremap(2) on GNU/Linux systems. */
#define _GNU_SOURCE
#if HAVE_CONFIG_H
# include <config.h>
#endif
@ -65,7 +62,8 @@ static size_t page_size;
necessary, but might be if you think you found a bug in the VM. */
/* #define VM_ENABLE_ASSERTIONS */
static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE;
static void vm_expand_stack (struct scm_vm *vp,
union scm_vm_stack_element *new_sp) SCM_NOINLINE;
/* RESTORE is for the case where we know we have done a PUSH of equal or
greater stack size in the past. Otherwise PUSH is the thing, which
@ -73,28 +71,29 @@ static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE;
enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE };
static inline void
vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind)
vm_increase_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp,
enum vm_increase_sp_kind kind)
{
if (new_sp <= vp->sp_max_since_gc)
if (new_sp >= vp->sp_min_since_gc)
{
vp->sp = new_sp;
return;
}
if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit)
if (kind == VM_SP_PUSH && new_sp < vp->stack_limit)
vm_expand_stack (vp, new_sp);
else
vp->sp_max_since_gc = vp->sp = new_sp;
vp->sp_min_since_gc = vp->sp = new_sp;
}
static inline void
vm_push_sp (struct scm_vm *vp, SCM *new_sp)
vm_push_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
{
vm_increase_sp (vp, new_sp, VM_SP_PUSH);
}
static inline void
vm_restore_sp (struct scm_vm *vp, SCM *new_sp)
vm_restore_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
{
vm_increase_sp (vp, new_sp, VM_SP_RESTORE);
}
@ -116,10 +115,12 @@ int
scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
{
struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
union scm_vm_stack_element *stack_top;
stack_top = data->stack_bottom + data->stack_size;
frame->stack_holder = data;
frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
frame->fp_offset = stack_top - (data->fp + data->reloc);
frame->sp_offset = stack_top - (data->sp + data->reloc);
frame->ip = data->ra;
return 1;
@ -129,23 +130,25 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
is inside VM code, and call/cc was invoked within that same call to
vm_run. That's currently not implemented. */
SCM
scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top,
union scm_vm_stack_element *fp,
union scm_vm_stack_element *sp, scm_t_uint32 *ra,
scm_t_dynstack *dynstack, scm_t_uint32 flags)
{
struct scm_vm_cont *p;
p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
p->stack_size = stack_top - sp;
p->stack_bottom = scm_gc_malloc (p->stack_size * sizeof (*p->stack_bottom),
"capture_vm_cont");
p->ra = ra;
p->sp = sp;
p->fp = fp;
memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
p->reloc = p->stack_base - stack_base;
memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom));
p->reloc = (p->stack_bottom + p->stack_size) - stack_top;
p->dynstack = dynstack;
p->flags = flags;
return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p);
}
struct return_to_continuation_data
@ -162,23 +165,27 @@ vm_return_to_continuation_inner (void *data_ptr)
struct return_to_continuation_data *data = data_ptr;
struct scm_vm *vp = data->vp;
struct scm_vm_cont *cp = data->cp;
union scm_vm_stack_element *cp_stack_top;
scm_t_ptrdiff reloc;
/* We know that there is enough space for the continuation, because we
captured it in the past. However there may have been an expansion
since the capture, so we may have to re-link the frame
pointers. */
reloc = (vp->stack_base - (cp->stack_base - cp->reloc));
cp_stack_top = cp->stack_bottom + cp->stack_size;
reloc = (vp->stack_top - (cp_stack_top - cp->reloc));
vp->fp = cp->fp + reloc;
memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
memcpy (vp->stack_top - cp->stack_size,
cp->stack_bottom,
cp->stack_size * sizeof (*cp->stack_bottom));
vm_restore_sp (vp, cp->sp + reloc);
if (reloc)
{
SCM *fp = vp->fp;
union scm_vm_stack_element *fp = vp->fp;
while (fp)
{
SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
if (next_fp)
{
next_fp += reloc;
@ -192,14 +199,15 @@ vm_return_to_continuation_inner (void *data_ptr)
}
static void
vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n,
union scm_vm_stack_element *argv)
{
struct scm_vm_cont *cp;
SCM *argv_copy;
union scm_vm_stack_element *argv_copy;
struct return_to_continuation_data data;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
argv_copy = alloca (n * sizeof (*argv));
memcpy (argv_copy, argv, n * sizeof (*argv));
cp = SCM_VM_CONT_DATA (cont);
@ -208,22 +216,13 @@ vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data);
/* Now we have the continuation properly copied over. We just need to
copy the arguments. It is not guaranteed that there is actually
space for the arguments, though, so we have to bump the SP first. */
vm_push_sp (vp, vp->sp + 3 + n);
/* Now copy on an empty frame and the return values, as the
continuation expects. */
{
SCM *base = vp->sp + 1 - 3 - n;
size_t i;
for (i = 0; i < 3; i++)
base[i] = SCM_BOOL_F;
for (i = 0; i < n; i++)
base[i + 3] = argv_copy[i];
}
copy on an empty frame and the return values, as the continuation
expects. */
vm_push_sp (vp, vp->sp - 3 - n);
vp->sp[n+2].scm = SCM_BOOL_F;
vp->sp[n+1].scm = SCM_BOOL_F;
vp->sp[n].scm = SCM_BOOL_F;
memcpy(vp->sp, argv_copy, n * sizeof (union scm_vm_stack_element));
vp->ip = cp->ra;
}
@ -238,19 +237,21 @@ scm_i_capture_current_stack (void)
thread = SCM_I_CURRENT_THREAD;
vp = thread_vm (thread);
return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip,
return scm_i_vm_capture_stack (vp->stack_top, vp->fp, vp->sp, vp->ip,
scm_dynstack_capture_all (&thread->dynstack),
0);
}
static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE;
static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE;
static void vm_dispatch_pop_continuation_hook
(struct scm_vm *vp, union scm_vm_stack_element *old_fp) SCM_NOINLINE;
static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE;
static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE;
static void
vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
vm_dispatch_hook (struct scm_vm *vp, int hook_num,
union scm_vm_stack_element *argv, int n)
{
SCM hook;
struct scm_frame c_frame;
@ -275,8 +276,8 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
seems reasonable to limit the lifetime of frame objects. */
c_frame.stack_holder = vp;
c_frame.fp_offset = vp->fp - vp->stack_base;
c_frame.sp_offset = vp->sp - vp->stack_base;
c_frame.fp_offset = vp->stack_top - vp->fp;
c_frame.sp_offset = vp->stack_top - vp->sp;
c_frame.ip = vp->ip;
/* Arrange for FRAME to be 8-byte aligned, like any other cell. */
@ -298,15 +299,16 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
SCM args[2];
args[0] = SCM_PACK_POINTER (frame);
args[1] = argv[0];
args[1] = argv[0].scm;
scm_c_run_hookn (hook, args, 2);
}
else
{
SCM args = SCM_EOL;
int i;
while (n--)
args = scm_cons (argv[n], args);
for (i = 0; i < n; i++)
args = scm_cons (argv[i].scm, args);
scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
}
@ -322,11 +324,11 @@ static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
{
return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
}
static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp,
union scm_vm_stack_element *old_fp)
{
return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK,
&SCM_FRAME_LOCAL (old_fp, 1),
SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
vp->sp, SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
}
static void vm_dispatch_next_hook (struct scm_vm *vp)
{
@ -335,38 +337,27 @@ static void vm_dispatch_next_hook (struct scm_vm *vp)
static void vm_dispatch_abort_hook (struct scm_vm *vp)
{
return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK,
&SCM_FRAME_LOCAL (vp->fp, 1),
SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
}
static void
vm_abort (struct scm_vm *vp, SCM tag,
size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
scm_i_jmp_buf *current_registers) SCM_NORETURN;
static void
vm_abort (struct scm_vm *vp, SCM tag,
size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
scm_i_jmp_buf *current_registers)
{
size_t i;
ssize_t tail_len;
SCM *argv;
tail_len = scm_ilength (tail);
if (tail_len < 0)
scm_misc_error ("vm-engine", "tail values to abort should be a list",
scm_list_1 (tail));
argv = alloca (nargs * sizeof (SCM));
for (i = 0; i < nargs; i++)
argv[i] = vp->sp[nargs - i - 1].scm;
argv = alloca ((nstack + tail_len) * sizeof (SCM));
for (i = 0; i < nstack; i++)
argv[i] = stack_args[i];
for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
argv[i] = scm_car (tail);
vp->sp = vp->fp;
vp->sp = sp;
scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
scm_c_abort (vp, tag, nargs, argv, current_registers);
}
struct vm_reinstate_partial_continuation_data
@ -382,23 +373,23 @@ vm_reinstate_partial_continuation_inner (void *data_ptr)
struct vm_reinstate_partial_continuation_data *data = data_ptr;
struct scm_vm *vp = data->vp;
struct scm_vm_cont *cp = data->cp;
SCM *base;
union scm_vm_stack_element *base_fp;
scm_t_ptrdiff reloc;
base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
reloc = cp->reloc + (base - cp->stack_base);
base_fp = vp->fp;
reloc = cp->reloc + (base_fp - (cp->stack_bottom + cp->stack_size));
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
memcpy (base_fp - cp->stack_size,
cp->stack_bottom,
cp->stack_size * sizeof (*cp->stack_bottom));
vp->fp = cp->fp + reloc;
vp->ip = cp->ra;
/* now relocate frame pointers */
{
SCM *fp;
for (fp = vp->fp;
SCM_FRAME_LOWER_ADDRESS (fp) >= base;
fp = SCM_FRAME_DYNAMIC_LINK (fp))
union scm_vm_stack_element *fp;
for (fp = vp->fp; fp < base_fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc);
}
@ -408,32 +399,32 @@ vm_reinstate_partial_continuation_inner (void *data_ptr)
}
static void
vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
size_t n, SCM *argv,
vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs,
scm_t_dynstack *dynstack,
scm_i_jmp_buf *registers)
{
struct vm_reinstate_partial_continuation_data data;
struct scm_vm_cont *cp;
SCM *argv_copy;
union scm_vm_stack_element *args;
scm_t_ptrdiff reloc;
size_t i;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
args = alloca (nargs * sizeof (*args));
memcpy (args, vp->sp, nargs * sizeof (*args));
cp = SCM_VM_CONT_DATA (cont);
vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1);
vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1));
data.vp = vp;
data.cp = cp;
GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data);
reloc = data.reloc;
/* Push the arguments. */
for (i = 0; i < n; i++)
vp->sp[i + 1 - n] = argv_copy[i];
/* The resume continuation will expect ARGS on the stack as if from a
multiple-value return. Fill in the closure slot with #f, and copy
the arguments into place. */
vp->sp[nargs].scm = SCM_BOOL_F;
memcpy (vp->sp, args, nargs * sizeof (*args));
/* The prompt captured a slice of the dynamic stack. Here we wind
those entries onto the current thread's stack. We also have to
@ -789,20 +780,22 @@ typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp,
static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
{ vm_regular_engine, vm_debug_engine };
static SCM*
static union scm_vm_stack_element*
allocate_stack (size_t size)
#define FUNC_NAME "make_vm"
{
void *ret;
if (size >= ((size_t) -1) / sizeof (SCM))
if (size >= ((size_t) -1) / sizeof (union scm_vm_stack_element))
abort ();
size *= sizeof (SCM);
size *= sizeof (union scm_vm_stack_element);
#if HAVE_SYS_MMAN_H
ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
if (ret == NULL)
/* Shouldn't happen. */
abort ();
if (ret == MAP_FAILED)
ret = NULL;
#else
@ -810,19 +803,15 @@ allocate_stack (size_t size)
#endif
if (!ret)
{
perror ("allocate_stack failed");
return NULL;
}
perror ("allocate_stack failed");
return (SCM *) ret;
return (union scm_vm_stack_element *) ret;
}
#undef FUNC_NAME
static void
free_stack (SCM *stack, size_t size)
free_stack (union scm_vm_stack_element *stack, size_t size)
{
size *= sizeof (SCM);
size *= sizeof (*stack);
#if HAVE_SYS_MMAN_H
munmap (stack, size);
@ -831,36 +820,38 @@ free_stack (SCM *stack, size_t size)
#endif
}
static SCM*
expand_stack (SCM *old_stack, size_t old_size, size_t new_size)
/* Ideally what we would like is an mremap or a realloc that grows at
the bottom, not the top. Oh well; mmap and memcpy are fast enough,
considering that they run very infrequently. */
static union scm_vm_stack_element*
expand_stack (union scm_vm_stack_element *old_bottom, size_t old_size,
size_t new_size)
#define FUNC_NAME "expand_stack"
{
#if defined MREMAP_MAYMOVE
void *new_stack;
union scm_vm_stack_element *new_bottom;
size_t extension_size;
if (new_size >= ((size_t) -1) / sizeof (SCM))
if (new_size >= ((size_t) -1) / sizeof (union scm_vm_stack_element))
abort ();
if (new_size <= old_size)
abort ();
old_size *= sizeof (SCM);
new_size *= sizeof (SCM);
extension_size = new_size - old_size;
new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
if (new_stack == MAP_FAILED)
if ((size_t)old_bottom < extension_size * sizeof (union scm_vm_stack_element))
abort ();
new_bottom = allocate_stack (new_size);
if (!new_bottom)
return NULL;
return (SCM *) new_stack;
#else
SCM *new_stack;
memcpy (new_bottom + extension_size,
old_bottom,
old_size * sizeof (union scm_vm_stack_element));
free_stack (old_bottom, old_size);
new_stack = allocate_stack (new_size);
if (!new_stack)
return NULL;
memcpy (new_stack, old_stack, old_size * sizeof (SCM));
free_stack (old_stack, old_size);
return new_stack;
#endif
return new_bottom;
}
#undef FUNC_NAME
@ -873,19 +864,21 @@ make_vm (void)
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = page_size / sizeof (SCM);
vp->stack_base = allocate_stack (vp->stack_size);
if (!vp->stack_base)
vp->stack_size = page_size / sizeof (union scm_vm_stack_element);
vp->stack_bottom = allocate_stack (vp->stack_size);
if (!vp->stack_bottom)
/* As in expand_stack, we don't have any way to throw an exception
if we can't allocate one measely page -- there's no stack to
handle it. For now, abort. */
abort ();
vp->stack_limit = vp->stack_base + vp->stack_size;
vp->stack_top = vp->stack_bottom + vp->stack_size;
vp->stack_limit = vp->stack_bottom;
vp->overflow_handler_stack = SCM_EOL;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->engine = vm_default_engine;
vp->ip = NULL;
vp->sp = vp->stack_top;
vp->sp_min_since_gc = vp->sp;
vp->fp = NULL;
vp->engine = vm_default_engine;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
@ -898,30 +891,30 @@ static void
return_unused_stack_to_os (struct scm_vm *vp)
{
#if HAVE_SYS_MMAN_H
scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1);
scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit;
scm_t_uintptr lo = (scm_t_uintptr) vp->stack_bottom;
scm_t_uintptr hi = (scm_t_uintptr) vp->sp;
/* The second condition is needed to protect against wrap-around. */
if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc)
end = (scm_t_uintptr) (vp->sp_max_since_gc + 1);
if (vp->sp_min_since_gc >= vp->stack_bottom && vp->sp >= vp->sp_min_since_gc)
lo = (scm_t_uintptr) vp->sp_min_since_gc;
start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */
end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */
lo &= ~(page_size - 1U); /* round down */
hi &= ~(page_size - 1U); /* round down */
/* Return these pages to the OS. The next time they are paged in,
they will be zeroed. */
if (start < end)
if (lo < hi)
{
int ret = 0;
do
ret = madvise ((void *) start, end - start, MADV_DONTNEED);
ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED);
while (ret && errno == -EAGAIN);
if (ret)
perror ("madvise failed");
}
vp->sp_max_since_gc = vp->sp;
vp->sp_min_since_gc = vp->sp;
#endif
}
@ -957,45 +950,44 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
return map;
}
/* Mark the VM stack region between its base and its current top. */
/* Mark the active VM stack region. */
struct GC_ms_entry *
scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit)
{
SCM *sp, *fp;
union scm_vm_stack_element *sp, *fp;
/* The first frame will be marked conservatively (without a dead
slot map). This is because GC can happen at any point within the
hottest activation, due to multiple threads or per-instruction
hooks, and providing dead slot maps for all points in a program
would take a prohibitive amount of space. */
const scm_t_uint8 *dead_slots = NULL;
scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr;
scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr;
void *upper = (void *) GC_greatest_plausible_heap_addr;
void *lower = (void *) GC_least_plausible_heap_addr;
struct dead_slot_map_cache cache;
memset (&cache, 0, sizeof (cache));
for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
{
for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--)
scm_t_ptrdiff nlocals = SCM_FRAME_NUM_LOCALS (fp, sp);
size_t slot = nlocals - 1;
for (slot = nlocals - 1; sp < fp; sp++, slot--)
{
SCM elt = *sp;
if (SCM_NIMP (elt)
&& SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper)
if (SCM_NIMP (sp->scm) && sp->ptr >= lower && sp->ptr <= upper)
{
if (dead_slots)
{
size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0);
if (dead_slots[slot / 8U] & (1U << (slot % 8U)))
{
/* This value may become dead as a result of GC,
so we can't just leave it on the stack. */
*sp = SCM_UNSPECIFIED;
sp->scm = SCM_UNSPECIFIED;
continue;
}
}
mark_stack_ptr = GC_mark_and_push ((void *) elt,
mark_stack_ptr = GC_mark_and_push (sp->ptr,
mark_stack_ptr,
mark_stack_limit,
NULL);
@ -1018,8 +1010,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
void
scm_i_vm_free_stack (struct scm_vm *vp)
{
free_stack (vp->stack_base, vp->stack_size);
vp->stack_base = vp->stack_limit = NULL;
free_stack (vp->stack_bottom, vp->stack_size);
vp->stack_bottom = vp->stack_top = vp->stack_limit = NULL;
vp->stack_size = 0;
}
@ -1027,7 +1019,7 @@ struct vm_expand_stack_data
{
struct scm_vm *vp;
size_t stack_size;
SCM *new_sp;
union scm_vm_stack_element *new_sp;
};
static void *
@ -1036,34 +1028,35 @@ vm_expand_stack_inner (void *data_ptr)
struct vm_expand_stack_data *data = data_ptr;
struct scm_vm *vp = data->vp;
SCM *old_stack, *new_stack;
union scm_vm_stack_element *old_top, *new_bottom;
size_t new_size;
scm_t_ptrdiff reloc;
old_top = vp->stack_top;
new_size = vp->stack_size;
while (new_size < data->stack_size)
new_size *= 2;
old_stack = vp->stack_base;
new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
if (!new_stack)
new_bottom = expand_stack (vp->stack_bottom, vp->stack_size, new_size);
if (!new_bottom)
return NULL;
vp->stack_base = new_stack;
vp->stack_bottom = new_bottom;
vp->stack_size = new_size;
vp->stack_limit = vp->stack_base + new_size;
reloc = vp->stack_base - old_stack;
vp->stack_top = vp->stack_bottom + new_size;
vp->stack_limit = vp->stack_bottom;
reloc = vp->stack_top - old_top;
if (reloc)
{
SCM *fp;
union scm_vm_stack_element *fp;
if (vp->fp)
vp->fp += reloc;
data->new_sp += reloc;
fp = vp->fp;
while (fp)
{
SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
if (next_fp)
{
next_fp += reloc;
@ -1073,7 +1066,7 @@ vm_expand_stack_inner (void *data_ptr)
}
}
return new_stack;
return new_bottom;
}
static scm_t_ptrdiff
@ -1095,9 +1088,9 @@ static void
reset_stack_limit (struct scm_vm *vp)
{
if (should_handle_stack_overflow (vp, vp->stack_size))
vp->stack_limit = vp->stack_base + current_overflow_size (vp);
vp->stack_limit = vp->stack_top - current_overflow_size (vp);
else
vp->stack_limit = vp->stack_base + vp->stack_size;
vp->stack_limit = vp->stack_bottom;
}
struct overflow_handler_data
@ -1127,9 +1120,9 @@ unwind_overflow_handler (void *ptr)
}
static void
vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
vm_expand_stack (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
{
scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base;
scm_t_ptrdiff stack_size = vp->stack_top - new_sp;
if (stack_size > vp->stack_size)
{
@ -1146,7 +1139,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
new_sp = data.new_sp;
}
vp->sp_max_since_gc = vp->sp = new_sp;
vp->sp_min_since_gc = vp->sp = new_sp;
if (should_handle_stack_overflow (vp, stack_size))
{
@ -1184,7 +1177,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
scm_dynwind_end ();
/* Recurse */
/* Recurse. */
return vm_expand_stack (vp, new_sp);
}
}
@ -1209,10 +1202,13 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
scm_i_thread *thread;
struct scm_vm *vp;
SCM *base;
ptrdiff_t base_frame_size;
/* Cached variables. */
scm_i_jmp_buf registers; /* used for prompts */
union scm_vm_stack_element *return_fp, *call_fp;
/* Since nargs can only describe the length of a valid argv array in
elements and each element is at least 4 bytes, nargs will not be
greater than INTMAX/2 and therefore we don't have to check for
overflow here or below. */
size_t return_nlocals = 1, call_nlocals = nargs + 1, frame_size = 2;
scm_t_ptrdiff stack_reserve_words;
size_t i;
thread = SCM_I_CURRENT_THREAD;
@ -1220,32 +1216,36 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
SCM_CHECK_STACK;
/* Check that we have enough space: 3 words for the boot continuation,
and 3 + nargs for the procedure application. */
base_frame_size = 3 + 3 + nargs;
vm_push_sp (vp, vp->sp + base_frame_size);
base = vp->sp + 1 - base_frame_size;
/* It's not valid for argv to point into the stack already. */
if ((void *) argv < (void *) vp->stack_top &&
(void *) argv >= (void *) vp->sp)
abort();
/* Since it's possible to receive the arguments on the stack itself,
shuffle up the arguments first. */
for (i = nargs; i > 0; i--)
base[6 + i - 1] = argv[i - 1];
/* Check that we have enough space for the two stack frames: the
innermost one that makes the call, and its continuation which
receives the resulting value(s) and returns from the engine
call. */
stack_reserve_words = call_nlocals + frame_size + return_nlocals + frame_size;
vm_push_sp (vp, vp->sp - stack_reserve_words);
call_fp = vp->sp + call_nlocals;
return_fp = call_fp + frame_size + return_nlocals;
SCM_FRAME_SET_RETURN_ADDRESS (return_fp, vp->ip);
SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp);
SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation;
/* Push the boot continuation, which calls PROC and returns its
result(s). */
base[0] = SCM_PACK (vp->fp); /* dynamic link */
base[1] = SCM_PACK (vp->ip); /* ra */
base[2] = vm_boot_continuation;
vp->fp = &base[2];
vp->ip = (scm_t_uint32 *) vm_boot_continuation_code;
vp->fp = call_fp;
/* The pending call to PROC. */
base[3] = SCM_PACK (vp->fp); /* dynamic link */
base[4] = SCM_PACK (vp->ip); /* ra */
base[5] = proc;
vp->fp = &base[5];
SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip);
SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp);
SCM_FRAME_LOCAL (call_fp, 0) = proc;
for (i = 0; i < nargs; i++)
SCM_FRAME_LOCAL (call_fp, i + 1) = argv[i];
{
scm_i_jmp_buf registers;
int resume = SCM_I_SETJMP (registers);
if (SCM_UNLIKELY (resume))
@ -1449,7 +1449,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler,
SCM new_limit, ret;
vp = scm_the_vm ();
stack_size = vp->sp - vp->stack_base;
stack_size = vp->stack_top - vp->sp;
c_limit = scm_to_ptrdiff_t (limit);
if (c_limit <= 0)
@ -1474,7 +1474,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler,
scm_dynwind_unwind_handler (unwind_overflow_handler, &data,
SCM_F_WIND_EXPLICITLY);
/* Reset vp->sp_max_since_gc so that the VM checks actually
/* Reset vp->sp_min_since_gc so that the VM checks actually
trigger. */
return_unused_stack_to_os (vp);

25
libguile/vm.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -37,13 +37,14 @@ enum {
struct scm_vm {
scm_t_uint32 *ip; /* instruction pointer */
SCM *sp; /* stack pointer */
SCM *fp; /* frame pointer */
SCM *stack_limit; /* stack limit address */
union scm_vm_stack_element *sp; /* stack pointer */
union scm_vm_stack_element *fp; /* frame pointer */
union scm_vm_stack_element *stack_limit; /* stack limit address */
int trace_level; /* traces enabled if trace_level > 0 */
SCM *sp_max_since_gc; /* highest sp since last gc */
union scm_vm_stack_element *sp_min_since_gc; /* deepest sp since last gc */
size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */
union scm_vm_stack_element *stack_bottom; /* lowest address in allocated stack */
union scm_vm_stack_element *stack_top; /* highest address in allocated stack */
SCM overflow_handler_stack; /* alist of max-stack-size -> thunk */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
int engine; /* which vm engine we're using */
@ -78,11 +79,13 @@ SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp);
#define SCM_F_VM_CONT_REWINDABLE 0x2
struct scm_vm_cont {
SCM *sp;
SCM *fp;
/* FIXME: sp isn't needed, it's effectively the same as
stack_bottom */
union scm_vm_stack_element *sp;
union scm_vm_stack_element *fp;
scm_t_uint32 *ra;
scm_t_ptrdiff stack_size;
SCM *stack_base;
union scm_vm_stack_element *stack_bottom;
scm_t_ptrdiff reloc;
scm_t_dynstack *dynstack;
scm_t_uint32 flags;
@ -97,7 +100,9 @@ SCM_API SCM scm_load_compiled_with_vm (SCM file);
SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
SCM_INTERNAL SCM scm_i_capture_current_stack (void);
SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
SCM_INTERNAL SCM scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top,
union scm_vm_stack_element *fp,
union scm_vm_stack_element *sp,
scm_t_uint32 *ra,
scm_t_dynstack *dynstack,
scm_t_uint32 flags);