Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-04 19:56:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial trampoling support for CPS from C code.

Browse source
This commit is contained in:
Alex Shinn 2012-04-22 17:14:06 +09:00
parent ec76df5146
commit 04210ff14a
2 changed files with 32 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
include/chibi/sexp.h
View file

@ -437,9 +437,10 @@ struct sexp_struct {
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
#define SEXP_STRING_OPORT SEXP_MAKE_IMMEDIATE(8) /* internal use */
#define SEXP_STRING_OPORT SEXP_MAKE_IMMEDIATE(8) /* internal use */
#define SEXP_TRAMPOLINE SEXP_MAKE_IMMEDIATE(9) /* internal use */
#if SEXP_USE_OBJECT_BRACE_LITERALS
#define SEXP_CLOSE_BRACE SEXP_MAKE_IMMEDIATE(9) /* internal use */
#define SEXP_CLOSE_BRACE SEXP_MAKE_IMMEDIATE(10) /* internal use */
#endif
#if SEXP_USE_LIMITED_MALLOC
@ -878,6 +879,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure))
#define sexp_exception_source(x) (sexp_field(x, exception, SEXP_EXCEPTION, source))
#define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE)
#define sexp_trampoline_procedure(x) sexp_exception_procedure(x)
#define sexp_trampoline_args(x) sexp_exception_irritants(x)
#define sexp_cpointer_freep(x) (sexp_freep(x))
#define sexp_cpointer_length(x) (sexp_cpointer_field(x, length))
#define sexp_cpointer_body(x) (sexp_cpointer_field(x, body))
@ -1194,7 +1199,6 @@ enum sexp_context_globals {
#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p)))
#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
#define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
#else
@ -1293,6 +1297,7 @@ SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp
SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args);
SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
SEXP_API void sexp_init(void);

38
vm.c
View file

@ -662,6 +662,10 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
/*********************** the virtual machine **************************/
sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
return sexp_make_exception(ctx, SEXP_TRAMPOLINE, SEXP_FALSE, args, proc, SEXP_FALSE);
}
#if SEXP_USE_GROW_STACK
static int sexp_grow_stack (sexp ctx, int min_size) {
sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
@ -772,20 +776,20 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
}
#if SEXP_USE_GREEN_THREADS
#define sexp_fcall_return(x, i) \
if (sexp_exceptionp(x)) { \
if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) { \
fuel = 0; ip--; goto loop; \
} else { \
top -= i; \
_ARG1 = x; \
ip += sizeof(sexp); \
goto call_error_handler; \
} \
} else { \
top -= i; \
_ARG1 = x; \
ip += sizeof(sexp); \
#define sexp_fcall_return(x, i) \
if (sexp_exceptionp(x)) { \
if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) { \
fuel = 0; ip--; goto loop; \
} else { \
top -= i; \
_ARG1 = x; \
ip += sizeof(sexp); \
goto call_error_handler; \
} \
} else { \
top -= i; \
_ARG1 = x; \
ip += sizeof(sexp); \
}
#else
#define sexp_fcall_return(x, i) \
@ -912,6 +916,12 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp_exception_procedure(_ARG1) = self;
case SEXP_OP_RAISE:
sexp_context_top(ctx) = top;
if (sexp_trampolinep(_ARG1)) {
tmp1 = sexp_trampoline_procedure(_ARG1);
tmp2 = sexp_trampoline_args(_ARG1);
top--;
goto apply1;
}
tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER));
sexp_context_last_fp(ctx) = fp;
if (! sexp_procedurep(tmp1))