diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 3cba0975..0afe3d7e 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -20,10 +20,6 @@ struct fullcont { size_t ci_offset; ptrdiff_t ci_len; - struct proc **xp_ptr; - size_t xp_offset; - ptrdiff_t xp_len; - struct code *ip; struct object **arena; @@ -41,7 +37,6 @@ cont_dtor(pic_state *pic, void *data) pic_free(pic, cont->stk_ptr); pic_free(pic, cont->st_ptr); pic_free(pic, cont->ci_ptr); - pic_free(pic, cont->xp_ptr); pic_free(pic, cont->arena); pic_free(pic, cont); } @@ -53,7 +48,6 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) struct checkpoint *cp; pic_value *stack; struct callinfo *ci; - struct proc **xp; size_t i; /* checkpoint */ @@ -78,11 +72,6 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value)) } } - /* exception handlers */ - for (xp = cont->xp_ptr; xp != cont->xp_ptr + cont->xp_offset; ++xp) { - mark(pic, pic_obj_value(*xp)); - } - /* arena */ for (i = 0; i < cont->arena_idx; ++i) { mark(pic, pic_obj_value(cont->arena[i])); @@ -139,11 +128,6 @@ save_cont(pic_state *pic, struct fullcont **c) cont->ci_ptr = pic_malloc(pic, sizeof(struct callinfo) * cont->ci_len); memcpy(cont->ci_ptr, pic->cibase, sizeof(struct callinfo) * cont->ci_len); - cont->xp_offset = pic->xp - pic->xpbase; - cont->xp_len = pic->xpend - pic->xpbase; - cont->xp_ptr = pic_malloc(pic, sizeof(struct proc *) * cont->xp_len); - memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct proc *) * cont->xp_len); - cont->ip = pic->ip; cont->arena_idx = pic->arena_idx; @@ -190,11 +174,6 @@ restore_cont(pic_state *pic, struct fullcont *cont) pic->ci = pic->cibase + cont->ci_offset; pic->ciend = pic->cibase + cont->ci_len; - assert(pic->xpend - pic->xpbase >= cont->xp_len); - memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct proc *) * cont->xp_len); - pic->xp = pic->xpbase + cont->xp_offset; - pic->xpend = pic->xpbase + cont->xp_len; - pic->ip = cont->ip; assert(pic->arena_size >= cont->arena_size); diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index dc34f2a2..3ddbf7db 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -14,7 +14,6 @@ struct pic_cont { struct checkpoint *cp; ptrdiff_t sp_offset; ptrdiff_t ci_offset; - ptrdiff_t xp_offset; size_t arena_idx; struct code *ip; @@ -35,7 +34,6 @@ pic_save_point(pic_state *pic, struct pic_cont *cont, PIC_JMPBUF *jmp) cont->cp = pic->cp; cont->sp_offset = pic->sp - pic->stbase; cont->ci_offset = pic->ci - pic->cibase; - cont->xp_offset = pic->xp - pic->xpbase; cont->arena_idx = pic->arena_idx; cont->ip = pic->ip; cont->prev = pic->cc; @@ -55,7 +53,6 @@ pic_load_point(pic_state *pic, struct pic_cont *cont) pic->cp = cont->cp; pic->sp = pic->stbase + cont->sp_offset; pic->ci = pic->cibase + cont->ci_offset; - pic->xp = pic->xpbase + cont->xp_offset; pic->arena_idx = cont->arena_idx; pic->ip = cont->ip; pic->cc = cont->prev; @@ -89,8 +86,6 @@ pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out) struct checkpoint *here; pic_value val; - assert(pic_proc_p(pic, thunk)); - pic_call(pic, in, 0); /* enter */ here = pic->cp; diff --git a/extlib/benz/error.c b/extlib/benz/error.c index 0105215f..fea8a857 100644 --- a/extlib/benz/error.c +++ b/extlib/benz/error.c @@ -37,46 +37,6 @@ pic_warnf(pic_state *pic, const char *fmt, ...) xfprintf(pic, file, "warn: %s\n", pic_str(pic, err)); } -void -pic_error(pic_state *pic, const char *msg, int n, ...) -{ - va_list ap; - pic_value irrs; - - va_start(ap, n); - irrs = pic_vlist(pic, n, ap); - va_end(ap); - - pic_raise(pic, pic_make_error(pic, "", msg, irrs)); -} - -void -pic_push_handler(pic_state *pic, pic_value handler) -{ - size_t xp_len; - ptrdiff_t xp_offset; - - if (pic->xp >= pic->xpend) { - xp_len = (size_t)(pic->xpend - pic->xpbase) * 2; - xp_offset = pic->xp - pic->xpbase; - pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct proc *) * xp_len); - pic->xp = pic->xpbase + xp_offset; - pic->xpend = pic->xpbase + xp_len; - } - - *pic->xp++ = pic_proc_ptr(pic, handler); -} - -pic_value -pic_pop_handler(pic_state *pic) -{ - if (pic->xp == pic->xpbase) { - pic_panic(pic, "no exception handler registered"); - } - - return pic_obj_value(*--pic->xp); -} - static pic_value native_exception_handler(pic_state *pic) { @@ -91,14 +51,70 @@ native_exception_handler(pic_state *pic) PIC_UNREACHABLE(); } -void -pic_push_native_handler(pic_state *pic, struct pic_cont *cont) +static pic_value +dynamic_set(pic_state *pic) { - pic_value handler; + pic_value var, val; + pic_get_args(pic, ""); + + var = pic_closure_ref(pic, 0); + val = pic_closure_ref(pic, 1); + + pic_proc_ptr(pic, var)->locals[0] = val; + + return pic_undef_value(pic); +} + +pic_value +pic_start_try(pic_state *pic, PIC_JMPBUF *jmp) +{ + struct pic_cont *cont; + pic_value handler; + pic_value var, old_val, new_val; + pic_value in, out; + struct checkpoint *here; + + /* call/cc */ + + cont = pic_alloca_cont(pic); + pic_save_point(pic, cont, jmp); handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont)); - pic_push_handler(pic, handler); + /* with-exception-handler */ + + var = pic_ref(pic, "picrin.base", "current-exception-handlers"); + old_val = pic_call(pic, var, 0); + new_val = pic_cons(pic, handler, old_val); + + in = pic_lambda(pic, dynamic_set, 2, var, new_val); + out = pic_lambda(pic, dynamic_set, 2, var, old_val); + + /* dynamic-wind */ + + pic_call(pic, in, 0); /* enter */ + + here = pic->cp; + pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); + pic->cp->prev = here; + pic->cp->depth = here->depth + 1; + pic->cp->in = pic_proc_ptr(pic, in); + pic->cp->out = pic_proc_ptr(pic, out); + + return pic_cons(pic, pic_obj_value(here), out); +} + +void +pic_end_try(pic_state *pic, pic_value cookie) +{ + struct checkpoint *here = (struct checkpoint *)pic_obj_ptr(pic_car(pic, cookie)); + pic_value out = pic_cdr(pic, cookie); + + pic->cp = here; + + pic_call(pic, out, 0); /* exit */ + + pic_exit_point(pic); } pic_value @@ -124,48 +140,72 @@ pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs return pic_obj_value(e); } -pic_value -pic_raise_continuable(pic_state *pic, pic_value err) +pic_value pic_raise_continuable(pic_state *, pic_value err); + +void +pic_error(pic_state *pic, const char *msg, int n, ...) { - pic_value handler, v; + va_list ap; + pic_value irrs; - handler = pic_pop_handler(pic); + va_start(ap, n); + irrs = pic_vlist(pic, n, ap); + va_end(ap); - pic_protect(pic, handler); + pic_raise(pic, pic_make_error(pic, "", msg, irrs)); +} - v = pic_call(pic, handler, 1, err); +static pic_value +raise(pic_state *pic) +{ + pic_get_args(pic, ""); - pic_push_handler(pic, handler); + pic_call(pic, pic_closure_ref(pic, 0), 1, pic_closure_ref(pic, 1)); - return v; + pic_error(pic, "handler returned", 2, pic_closure_ref(pic, 0), pic_closure_ref(pic, 1)); } void pic_raise(pic_state *pic, pic_value err) { - pic_value val; + pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); - val = pic_raise_continuable(pic, err); + stack = pic_call(pic, exc, 0); - pic_pop_handler(pic); + pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise, 2, pic_car(pic, stack), err)); - pic_error(pic, "error handler returned", 2, val, err); + PIC_UNREACHABLE(); +} + +static pic_value +raise_continuable(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_call(pic, pic_closure_ref(pic, 0), 1, pic_closure_ref(pic, 1)); +} + +pic_value +pic_raise_continuable(pic_state *pic, pic_value err) +{ + pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); + + stack = pic_call(pic, exc, 0); + + return pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise_continuable, 2, pic_car(pic, stack), err)); } static pic_value pic_error_with_exception_handler(pic_state *pic) { - pic_value handler, thunk, val; + pic_value handler, thunk; + pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); pic_get_args(pic, "ll", &handler, &thunk); - pic_push_handler(pic, handler); + stack = pic_call(pic, exc, 0); - val = pic_call(pic, thunk, 0); - - pic_pop_handler(pic); - - return val; + return pic_dynamic_bind(pic, exc, pic_cons(pic, handler, stack), thunk); } static pic_value @@ -249,6 +289,7 @@ pic_error_error_object_type(pic_state *pic) void pic_init_error(pic_state *pic) { + pic_defvar(pic, "current-exception-handlers", pic_nil_value(pic), pic_false_value(pic)); pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); pic_defun(pic, "raise", pic_error_raise); pic_defun(pic, "raise-continuable", pic_error_raise_continuable); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 9bbec745..0f0bc6f2 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -413,7 +413,6 @@ gc_mark_phase(pic_state *pic) { pic_value *stack; struct callinfo *ci; - struct proc **xhandler; struct list_head *list; int it; size_t j; @@ -437,11 +436,6 @@ gc_mark_phase(pic_state *pic) } } - /* exception handlers */ - for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) { - gc_mark_object(pic, (struct object *)*xhandler); - } - /* arena */ for (j = 0; j < pic->arena_idx; ++j) { gc_mark_object(pic, (struct object *)pic->arena[j]); diff --git a/extlib/benz/include/picrin/extra.h b/extlib/benz/include/picrin/extra.h index e574e24c..ffe1c3d7 100644 --- a/extlib/benz/include/picrin/extra.h +++ b/extlib/benz/include/picrin/extra.h @@ -78,26 +78,17 @@ xFILE *xfopen_null(pic_state *, const char *mode); pic_in_library(pic, lib); \ } while (0) -/* for pic_try & pic_catch macros */ -struct pic_cont *pic_alloca_cont(pic_state *); -pic_value pic_make_cont(pic_state *, struct pic_cont *); -void pic_push_native_handler(pic_state *, struct pic_cont *); -pic_value pic_pop_handler(pic_state *); -void pic_save_point(pic_state *, struct pic_cont *, PIC_JMPBUF *); -void pic_exit_point(pic_state *); - #define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp)) #define pic_try_(cont, jmp) \ do { \ + extern pic_value pic_start_try(pic_state *, PIC_JMPBUF *); \ + extern void pic_end_try(pic_state *, pic_value); \ PIC_JMPBUF jmp; \ - struct pic_cont *cont = pic_alloca_cont(pic); \ if (PIC_SETJMP(pic, jmp) == 0) { \ - pic_save_point(pic, cont, &jmp); \ - pic_push_native_handler(pic, cont); + pic_value pic_try_cookie_ = pic_start_try(pic, &jmp); #define pic_catch pic_catch_(PIC_GENSYM(label)) #define pic_catch_(label) \ - pic_pop_handler(pic); \ - pic_exit_point(pic); \ + pic_end_try(pic, pic_try_cookie_); \ } else { \ goto label; \ } \ diff --git a/extlib/benz/include/picrin/private/object.h b/extlib/benz/include/picrin/private/object.h index f92db235..9d157a4f 100644 --- a/extlib/benz/include/picrin/private/object.h +++ b/extlib/benz/include/picrin/private/object.h @@ -188,9 +188,14 @@ void pic_rope_decref(pic_state *, struct rope *); #define pic_func_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_FUNC) #define pic_irep_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_IREP) +struct pic_cont *pic_alloca_cont(pic_state *); +pic_value pic_make_cont(pic_state *, struct pic_cont *); +void pic_save_point(pic_state *, struct pic_cont *, PIC_JMPBUF *); +void pic_exit_point(pic_state *); void pic_wind(pic_state *, struct checkpoint *, struct checkpoint *); pic_value pic_dynamic_wind(pic_state *, pic_value in, pic_value thunk, pic_value out); +pic_value pic_dynamic_bind(pic_state *, pic_value var, pic_value val, pic_value thunk); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/private/state.h b/extlib/benz/include/picrin/private/state.h index 9a59574d..92f26679 100644 --- a/extlib/benz/include/picrin/private/state.h +++ b/extlib/benz/include/picrin/private/state.h @@ -49,9 +49,6 @@ struct pic_state { struct callinfo *ci; struct callinfo *cibase, *ciend; - struct proc **xp; - struct proc **xpbase, **xpend; - struct code *ip; struct lib *lib; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 95918308..b5f97b31 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -229,14 +229,6 @@ pic_open(pic_allocf allocf, void *userdata) goto EXIT_CI; } - /* exception handler */ - pic->xpbase = pic->xp = allocf(userdata, NULL, PIC_RESCUE_SIZE * sizeof(struct proc *)); - pic->xpend = pic->xpbase + PIC_RESCUE_SIZE; - - if (! pic->xp) { - goto EXIT_XP; - } - /* GC arena */ pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *)); pic->arena_size = PIC_ARENA_SIZE; @@ -317,8 +309,6 @@ pic_open(pic_allocf allocf, void *userdata) return pic; EXIT_ARENA: - allocf(userdata, pic->xp, 0); - EXIT_XP: allocf(userdata, pic->ci, 0); EXIT_CI: allocf(userdata, pic->sp, 0); @@ -336,7 +326,6 @@ pic_close(pic_state *pic) /* clear out root objects */ pic->sp = pic->stbase; pic->ci = pic->cibase; - pic->xp = pic->xpbase; pic->arena_idx = 0; pic->err = pic_invalid_value(pic); pic->globals = pic_invalid_value(pic); @@ -358,7 +347,6 @@ pic_close(pic_state *pic) /* free runtime context */ allocf(pic->userdata, pic->stbase, 0); allocf(pic->userdata, pic->cibase, 0); - allocf(pic->userdata, pic->xpbase, 0); /* free global stacks */ kh_destroy(oblist, &pic->oblist);