mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

compose-continuation uses an intrinsic

Browse source 
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add
  compose-continuation intrinsic.
* libguile/vm-engine.c (compose-continuation): Call compose-continuation
  intrinsic.
* libguile/vm.c (compose_continuation_inner, compose_continuation): Move
  down and rename from vm_reinstate_partial_continuation, and make into
  a form that works as an intrinsic.
This commit is contained in:
Andy Wingo 2018-06-26 15:10:58 +02:00
parent ba23bc12fd
commit b4553dbb02
3 changed files with 82 additions and 84 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/intrinsics.h
View file

@ -55,6 +55,7 @@ typedef SCM (*scm_t_scm_from_scm_scm_scmp_sp_intrinsic) (SCM, SCM, SCM*,
const union scm_vm_stack_element*);
typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORETURN;
typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*);
typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM);
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
M(scm_from_scm_scm, add, "add", ADD) \
@ -107,6 +108,7 @@ typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*);
M(scm_from_scm_scm_scmp_sp, foreign_call, "foreign-call", FOREIGN_CALL) \
M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", REINSTATE_CONTINUATION_X) \
M(scm_from_thread_regs, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \
M(thread_regs_scm, compose_continuation, "compose-continuation", COMPOSE_CONTINUATION) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic

5
libguile/vm-engine.c
View file

@ -696,10 +696,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume)
vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), cont_idx);
SYNC_IP ();
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),
&thread->dynstack, registers);
scm_vm_intrinsics.compose_continuation (thread, registers, vmcont);
CACHE_REGISTER ();
NEXT (0);
}

159
libguile/vm.c
View file

@ -323,78 +323,6 @@ vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
scm_c_abort (vp, tag, nargs, argv, current_registers);
}
struct vm_reinstate_partial_continuation_data
{
struct scm_vm *vp;
struct scm_vm_cont *cp;
};
static void *
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;
memcpy (vp->fp - cp->stack_size,
cp->stack_bottom,
cp->stack_size * sizeof (*cp->stack_bottom));
vp->fp -= cp->fp_offset;
vp->ip = cp->ra;
return NULL;
}
static void
vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs,
scm_t_dynstack *dynstack,
jmp_buf *registers)
{
struct vm_reinstate_partial_continuation_data data;
struct scm_vm_cont *cp;
union scm_vm_stack_element *args;
ptrdiff_t old_fp_offset;
args = alloca (nargs * sizeof (*args));
memcpy (args, vp->sp, nargs * sizeof (*args));
cp = SCM_VM_CONT_DATA (cont);
old_fp_offset = vp->stack_top - vp->fp;
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);
/* 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].as_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
relocate any prompts that we see along the way. */
{
scm_t_bits *walk;
for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
SCM_DYNSTACK_TAG (walk);
walk = SCM_DYNSTACK_NEXT (walk))
{
scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
scm_dynstack_wind_prompt (dynstack, walk, old_fp_offset, registers);
else
scm_dynstack_wind_1 (dynstack, walk);
}
}
}
/*
* VM Error Handling
@ -412,7 +340,6 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_wrong_number_of_values (uint32_t expected) SCM_NORETURN SCM_NOINLINE;
static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
static void
vm_throw (SCM key, SCM args)
@ -503,12 +430,6 @@ vm_error_wrong_number_of_values (uint32_t expected)
scm_from_uint32 (expected));
}
static void
vm_error_continuation_not_rewindable (SCM cont)
{
vm_error ("Unrewindable partial continuation", cont);
}
@ -1274,7 +1195,7 @@ reinstate_continuation_x (scm_thread *thread, SCM cont)
"invoking continuation would cross continuation barrier: ~A",
scm_list_1 (cont));
n = frame_locals_count (thread) - 1,
n = frame_locals_count (thread) - 1;
argv = alloca (n * sizeof (*argv));
memcpy (argv, vp->sp, n * sizeof (*argv));
@ -1312,6 +1233,83 @@ capture_continuation (scm_thread *thread, jmp_buf *registers)
return scm_i_make_continuation (registers, thread, vm_cont);
}
struct compose_continuation_data
{
struct scm_vm *vp;
struct scm_vm_cont *cp;
};
static void *
compose_continuation_inner (void *data_ptr)
{
struct compose_continuation_data *data = data_ptr;
struct scm_vm *vp = data->vp;
struct scm_vm_cont *cp = data->cp;
memcpy (vp->fp - cp->stack_size,
cp->stack_bottom,
cp->stack_size * sizeof (*cp->stack_bottom));
vp->fp -= cp->fp_offset;
vp->ip = cp->ra;
return NULL;
}
static void
compose_continuation (scm_thread *thread, jmp_buf *registers, SCM cont)
{
struct scm_vm *vp = &thread->vm;
size_t nargs;
struct compose_continuation_data data;
struct scm_vm_cont *cp;
union scm_vm_stack_element *args;
ptrdiff_t old_fp_offset;
if (SCM_UNLIKELY (! SCM_VM_CONT_REWINDABLE_P (cont)))
vm_error ("Unrewindable partial continuation", cont);
nargs = frame_locals_count (thread) - 1;
args = alloca (nargs * sizeof (*args));
memcpy (args, vp->sp, nargs * sizeof (*args));
cp = SCM_VM_CONT_DATA (cont);
old_fp_offset = vp->stack_top - vp->fp;
vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1));
data.vp = vp;
data.cp = cp;
GC_call_with_alloc_lock (compose_continuation_inner, &data);
/* The resumed 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].as_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
relocate any prompts that we see along the way. */
{
scm_t_bits *walk;
for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
SCM_DYNSTACK_TAG (walk);
walk = SCM_DYNSTACK_NEXT (walk))
{
scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
scm_dynstack_wind_prompt (&thread->dynstack, walk, old_fp_offset,
registers);
else
scm_dynstack_wind_1 (&thread->dynstack, walk);
}
}
}
SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
@ -1657,6 +1655,7 @@ scm_bootstrap_vm (void)
scm_vm_intrinsics.push_interrupt_frame = push_interrupt_frame;
scm_vm_intrinsics.reinstate_continuation_x = reinstate_continuation_x;
scm_vm_intrinsics.capture_continuation = capture_continuation;
scm_vm_intrinsics.compose_continuation = compose_continuation;
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");