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

abort-to-prompt uses an intrinsic

Browse source 
* libguile/control.h:
* libguile/control.c (scm_i_make_composable_continuation): Rename from
  make_partial_continuation and expose internally.
  (scm_abort_to_prompt_star): Adapt to scm_i_vm_abort name change.
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Define
  abort_to_prompt intrinsic.
* libguile/throw.c (abort_to_prompt): Adapt to scm_i_vm_abort name
  change.
* libguile/vm-engine.c (abort): Use abort_to_prompt intrinsic.
* libguile/vm.c (capture_delimited_continuation): Move here from
  control.c where it was named reify_partial_continuation.
  (scm_i_vm_abort): Move from control.c where it was named
  scm_c_abort (and only exposed internally).
  (abort_to_prompt): New intrinsic, replacing vm_abort.
* libguile/vm.h: Add setjmp include and scm_i_vm_abort decl.
This commit is contained in:
Andy Wingo 2018-06-26 16:19:16 +02:00
parent 03a9b71479
commit e7778c62aa
7 changed files with 138 additions and 135 deletions
Download patch file Download diff file Expand all files Collapse all files

110
libguile/control.c
View file

@ -74,8 +74,8 @@ static const uint32_t compose_continuation_code[] =
};
static SCM
make_partial_continuation (SCM vm_cont)
SCM
scm_i_make_composable_continuation (SCM vmcont)
{
scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
@ -83,113 +83,11 @@ make_partial_continuation (SCM vm_cont)
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont);
return ret;
}
static SCM
reify_partial_continuation (struct scm_vm *vp,
union scm_vm_stack_element *saved_fp,
union scm_vm_stack_element *saved_sp,
uint32_t *saved_ip,
jmp_buf *saved_registers,
scm_t_dynstack *dynstack,
jmp_buf *current_registers)
{
SCM vm_cont;
uint32_t flags;
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
of the abort, it means there are no intervening C frames on the
stack, and so the continuation can be relocated elsewhere on the
stack: it is rewindable. */
if (saved_registers && saved_registers == current_registers)
flags |= SCM_F_VM_CONT_REWINDABLE;
/* 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 (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 (base_fp) != saved_fp)
abort();
scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
/* 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);
}
void
scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
jmp_buf *current_registers)
{
SCM cont;
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
scm_t_bits *prompt;
scm_t_dynstack_prompt_flags flags;
ptrdiff_t fp_offset, sp_offset;
union scm_vm_stack_element *fp, *sp;
uint32_t *ip;
jmp_buf *registers;
size_t i;
prompt = scm_dynstack_find_prompt (dynstack, tag,
&flags, &fp_offset, &sp_offset, &ip,
&registers);
if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
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)
cont = SCM_BOOL_F;
else
{
scm_t_dynstack *captured;
captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
current_registers);
}
/* Unwind. */
scm_dynstack_unwind (dynstack, prompt);
/* Restore VM regs */
vp->fp = fp;
vp->sp = sp - n - 1;
vp->ip = ip;
/* Since we're jumping down, we should always have enough space. */
if (vp->sp < vp->stack_limit)
abort ();
/* Push vals */
vp->sp[n].as_scm = cont;
for (i = 0; i < n; i++)
vp->sp[n - i - 1].as_scm = argv[i];
/* Jump! */
longjmp (*registers, 1);
/* Shouldn't get here */
abort ();
}
SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
(SCM tag, SCM args),
"Abort to the nearest prompt with tag @var{tag}, yielding the\n"
@ -205,7 +103,7 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
for (i = 0; i < n; i++, args = scm_cdr (args))
argv[i] = scm_car (args);
scm_c_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL);
scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL);
/* Oh, what, you're still here? The abort must have been reinstated. Actually,
that's quite impossible, given that we're already in C-land here, so...

6
libguile/control.h
View file

@ -20,16 +20,14 @@
#ifndef SCM_CONTROL_H
#define SCM_CONTROL_H
#include <setjmp.h>
#include "libguile/scm.h"
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp,
ptrdiff_t saved_stack_depth);
SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
jmp_buf *registers) SCM_NORETURN;
SCM_INTERNAL SCM scm_i_make_composable_continuation (SCM vmcont);
SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN;

2
libguile/intrinsics.h
View file

@ -57,6 +57,7 @@ typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORET
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);
typedef int (*scm_t_int_from_scm_intrinsic) (SCM);
typedef void (*scm_t_thread_regs_intrinsic) (scm_thread*, jmp_buf*);
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
M(scm_from_scm_scm, add, "add", ADD) \
@ -111,6 +112,7 @@ typedef int (*scm_t_int_from_scm_intrinsic) (SCM);
M(scm_from_thread_regs, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \
M(thread_regs_scm, compose_continuation, "compose-continuation", COMPOSE_CONTINUATION) \
M(int_from_scm, rest_arg_length, "rest-arg-length", REST_ARG_LENGTH) \
M(thread_regs, abort_to_prompt, "abort-to-prompt", ABORT_TO_PROMPT) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic

2
libguile/throw.c
View file

@ -195,7 +195,7 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
for (i = 1; i < n; i++, args = scm_cdr (args))
argv[i] = scm_car (args);
scm_c_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL);
scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL);
/* Oh, what, you're still here? The abort must have been reinstated. Actually,
that's quite impossible, given that we're already in C-land here, so...

5
libguile/vm-engine.c
View file

@ -781,15 +781,12 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume)
*/
VM_DEFINE_OP (16, abort, "abort", OP1 (X32))
{
uint32_t nlocals = FRAME_LOCALS_COUNT ();
ASSERT (nlocals >= 2);
/* FIXME: Really we should capture the caller's registers. Until
then, manually advance the IP so that when the prompt resumes,
it continues with the next instruction. */
ip++;
SYNC_IP ();
vm_abort (VP, FP_REF (1), nlocals - 2, registers);
scm_vm_intrinsics.abort_to_prompt (thread, registers);
/* vm_abort should not return */
abort ();

144
libguile/vm.c
View file

@ -303,26 +303,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp)
vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
}
static void
vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
jmp_buf *current_registers) SCM_NORETURN;
static void
vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
jmp_buf *current_registers)
{
size_t i;
SCM *argv;
argv = alloca (nargs * sizeof (SCM));
for (i = 0; i < nargs; i++)
argv[i] = vp->sp[nargs - i - 1].as_scm;
vp->sp = vp->fp;
scm_c_abort (vp, tag, nargs, argv, current_registers);
}
/*
* VM Error Handling
@ -1314,6 +1294,129 @@ rest_arg_length (SCM x)
return len;
}
static SCM
capture_delimited_continuation (struct scm_vm *vp,
union scm_vm_stack_element *saved_fp,
union scm_vm_stack_element *saved_sp,
uint32_t *saved_ip,
jmp_buf *saved_registers,
scm_t_dynstack *dynstack,
jmp_buf *current_registers)
{
SCM vm_cont;
uint32_t flags;
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
of the abort, it means there are no intervening C frames on the
stack, and so the continuation can be relocated elsewhere on the
stack: it is rewindable. */
if (saved_registers && saved_registers == current_registers)
flags |= SCM_F_VM_CONT_REWINDABLE;
/* 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 (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 (base_fp) != saved_fp)
abort();
scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
/* 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 scm_i_make_composable_continuation (vm_cont);
}
void
scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
jmp_buf *current_registers)
{
SCM cont;
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
scm_t_bits *prompt;
scm_t_dynstack_prompt_flags flags;
ptrdiff_t fp_offset, sp_offset;
union scm_vm_stack_element *fp, *sp;
uint32_t *ip;
jmp_buf *registers;
size_t i;
prompt = scm_dynstack_find_prompt (dynstack, tag,
&flags, &fp_offset, &sp_offset, &ip,
&registers);
if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
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)
cont = SCM_BOOL_F;
else
{
scm_t_dynstack *captured;
captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
cont = capture_delimited_continuation (vp, fp, sp, ip, registers, captured,
current_registers);
}
/* Unwind. */
scm_dynstack_unwind (dynstack, prompt);
/* Restore VM regs */
vp->fp = fp;
vp->sp = sp - n - 1;
vp->ip = ip;
/* Since we're jumping down, we should always have enough space. */
if (vp->sp < vp->stack_limit)
abort ();
/* Push vals */
vp->sp[n].as_scm = cont;
for (i = 0; i < n; i++)
vp->sp[n - i - 1].as_scm = argv[i];
/* Jump! */
longjmp (*registers, 1);
/* Shouldn't get here */
abort ();
}
static void
abort_to_prompt (scm_thread *thread, jmp_buf *current_registers)
{
struct scm_vm *vp = &thread->vm;
SCM tag;
size_t nargs, i;
SCM *argv;
tag = SCM_FRAME_LOCAL (vp->fp, 1);
nargs = frame_locals_count (thread) - 2;
/* FIXME: Avoid this alloca. */
argv = alloca (nargs * sizeof (SCM));
for (i = 0; i < nargs; i++)
argv[i] = vp->sp[nargs - i - 1].as_scm;
vp->sp = vp->fp;
scm_i_vm_abort (vp, tag, nargs, argv, current_registers);
}
SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
@ -1661,6 +1764,7 @@ scm_bootstrap_vm (void)
scm_vm_intrinsics.capture_continuation = capture_continuation;
scm_vm_intrinsics.compose_continuation = compose_continuation;
scm_vm_intrinsics.rest_arg_length = rest_arg_length;
scm_vm_intrinsics.abort_to_prompt = abort_to_prompt;
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");

4
libguile/vm.h
View file

@ -20,6 +20,8 @@
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
#include <setjmp.h>
#include <libguile/gc.h>
#include <libguile/programs.h>
@ -120,6 +122,8 @@ SCM_INTERNAL SCM scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top,
uint32_t *ra,
scm_t_dynstack *dynstack,
uint32_t flags);
SCM_INTERNAL void scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
jmp_buf *registers) SCM_NORETURN;
SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame);
SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);