summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-09-22 10:24:30 +0000
committerAndy Wingo <wingo@pobox.com>2015-10-21 11:49:20 +0200
commit0007507340b10754cb307763cbc8eeb064853926 (patch)
treeffce65ab7dd195fa2f45360bef7d9db62760ce67
parentd7199da8c9d287b9602e053d470d0a822b4f7cec (diff)
VM stack grows downward
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.
-rw-r--r--libguile/continuations.c7
-rw-r--r--libguile/control.c61
-rw-r--r--libguile/control.h3
-rw-r--r--libguile/dynstack.c4
-rw-r--r--libguile/dynstack.h3
-rw-r--r--libguile/eval.c18
-rw-r--r--libguile/foreign.c4
-rw-r--r--libguile/foreign.h5
-rw-r--r--libguile/frames.c62
-rw-r--r--libguile/frames.h76
-rw-r--r--libguile/stacks.c7
-rw-r--r--libguile/throw.c9
-rw-r--r--libguile/vm-engine.c112
-rw-r--r--libguile/vm.c394
-rw-r--r--libguile/vm.h25
15 files changed, 399 insertions, 391 deletions
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 8dca62e2d..7cc3cea10 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -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;
diff --git a/libguile/control.c b/libguile/control.c
index 347d69715..a3457342b 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -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]);
+ stack_depth = vp->stack_top - vp->sp;
+ if (stack_depth < saved_stack_depth)
+ abort ();
+ n = stack_depth - saved_stack_depth;
+
for (i = 0; i < n; i++)
- vals = scm_cons (vp->sp[-(i + 1)], vals);
+ vals = scm_cons (vp->sp[i].scm, vals);
- /* 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 */
+ 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);
diff --git a/libguile/control.h b/libguile/control.h
index 4b76591aa..84990ab10 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -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;
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index 9235ec495..bda1a16b5 100644
--- a/libguile/dynstack.c
+++ b/libguile/dynstack.c
@@ -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);
}
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index 7b31acedf..853f0684d 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -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 *);
diff --git a/libguile/eval.c b/libguile/eval.c
index 735e6c0b3..09fa71df4 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -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;
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 0cab6b8b0..3ac06591d 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -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
diff --git a/libguile/foreign.h b/libguile/foreign.h
index fbb97640b..53f39d5c7 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -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);
diff --git a/libguile/frames.c b/libguile/frames.c
index 2162f49ce..f89b0fd5b 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -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;
+ case SCM_VM_FRAME_KIND_CONT:
+ {
+ 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);
{
diff --git a/libguile/frames.h b/libguile/frames.h
index 31f86345f..c2f1e57db 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -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 */
-};
-
-#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)
+ union scm_vm_stack_element *fp;
+ scm_t_uint32 *ip;
+ SCM scm;
-#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])
+ /* For GC purposes. */
+ void *ptr;
+ scm_t_bits bits;
+};
-#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. */
diff --git a/libguile/stacks.c b/libguile/stacks.c
index a09c3b9a3..ec3ec789f 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -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))
diff --git a/libguile/throw.c b/libguile/throw.c
index bbde5e009..773ac2783 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7e752dd14..f6cb0c49c 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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);
diff --git a/libguile/vm.c b/libguile/vm.c
index 0e5983575..d5a72727f 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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)
- return NULL;
+ if ((size_t)old_bottom < extension_size * sizeof (union scm_vm_stack_element))
+ abort ();
- return (SCM *) new_stack;
-#else
- SCM *new_stack;
+ new_bottom = allocate_stack (new_size);
- new_stack = allocate_stack (new_size);
- if (!new_stack)
+ if (!new_bottom)
return NULL;
- memcpy (new_stack, old_stack, old_size * sizeof (SCM));
- free_stack (old_stack, old_size);
+ memcpy (new_bottom + extension_size,
+ old_bottom,
+ old_size * sizeof (union scm_vm_stack_element));
+ free_stack (old_bottom, 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;
-
- /* 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];
-
- /* 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];
+ /* 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();
+
+ /* 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;
+
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);
diff --git a/libguile/vm.h b/libguile/vm.h
index 8f88d0cd4..adac08593 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -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);