suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Prototype implementation of control proxies

Browse Source
This commit is contained in:
Asumu Takikawa 2012-06-08 02:28:58 -04:00
parent 82943df351
commit d527426cac
7 changed files with 847 additions and 658 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/tests/racket/prompt.rktl
View File

@ -159,5 +159,38 @@
(test (void) overflow-prompt-go))
;; ----------------------------------------
;; control proxies
(define imp-tag
(impersonate-prompt-tag
(make-continuation-prompt-tag)
(lambda (x) (* x 2))
(lambda (x) (+ x 1))))
(define cha-tag
(chaperone-prompt-tag
(make-continuation-prompt-tag)
(lambda (x) (if (number? x) x (error "fail")))
(lambda (x) x)))
(define bad-tag
(chaperone-prompt-tag
(make-continuation-prompt-tag)
(lambda (x) 42)
(lambda (x) x)))
(define (do-test tag v)
(call-with-continuation-prompt
(lambda ()
(abort-current-continuation tag v))
tag
(lambda (x) x)))
(test 12 do-test imp-tag 5)
(test 5 do-test cha-tag 5)
(err/rt-test (do-test cha-tag "bad") exn:fail?)
(err/rt-test (do-test bad-tag 5) exn:fail?)
;;----------------------------------------
(report-errs)

2
src/racket/include/scheme.h
View File

@ -450,6 +450,8 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_MUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_PROMPT_TAGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
#define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
#define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
#define SCHEME_HASHTRP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_tree_type)

1284
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

164
src/racket/src/fun.c
View File

@ -139,6 +139,8 @@ static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[]);
static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *argv[]);
static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[]);
static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_prompt_tag (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_prompt_tag (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_sema (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]);
@ -369,6 +371,16 @@ scheme_init_fun (Scheme_Env *env)
"continuation-prompt-tag?",
1, 1, 1),
env);
scheme_add_global_constant("impersonate-prompt-tag",
scheme_make_prim_w_arity(impersonate_prompt_tag,
"impersonate-prompt-tag",
3, -1),
env);
scheme_add_global_constant("chaperone-prompt-tag",
scheme_make_prim_w_arity(chaperone_prompt_tag,
"chaperone-prompt-tag",
3, -1),
env);
scheme_add_global_constant("call-with-semaphore",
scheme_make_prim_w_arity2(call_with_sema,
@ -5542,11 +5554,53 @@ static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[])
static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[])
{
return (SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))
return (SCHEME_CHAPERONE_PROMPT_TAGP(argv[0])
? scheme_true
: scheme_false);
}
Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_PROMPT_TAGP(val))
scheme_wrong_contract(name, "prompt-tag?", 0, argc, argv);
scheme_check_proc_arity(name, 1, 1, argc, argv);
scheme_check_proc_arity(name, 1, 1, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]);
props = scheme_parse_chaperone_props(name, 3, argc, argv);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = argv[0];
px->props = props;
px->redirects = redirects;
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px;
}
static Scheme_Object *chaperone_prompt_tag(int argc, Scheme_Object **argv)
{
return do_chaperone_prompt_tag("chaperone-prompt-tag", 0, argc, argv);
}
static Scheme_Object *impersonate_prompt_tag(int argc, Scheme_Object **argv)
{
return do_chaperone_prompt_tag("impersonate-prompt-tag", 1, argc, argv);
}
Scheme_Overflow *scheme_get_thread_end_overflow(void)
{
Scheme_Overflow *overflow;
@ -5951,6 +6005,39 @@ static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
prompt_unwind_dw(prompt_tag);
}
static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object *argv[])
{
Scheme_Chaperone *px;
Scheme_Object *a[1];
Scheme_Object *v;
Scheme_Object **vals;
vals = MALLOC_N(Scheme_Object *, argc);
while (1) {
int i;
if (SCHEME_PROMPT_TAGP(obj)) {
return vals;
} else {
px = (Scheme_Chaperone *)obj;
obj = px->prev;
for (i = 0; i < argc; i++) {
a[0] = argv[i];
v = _scheme_apply(SCHEME_CAR(px->redirects), 1, a);
vals[i] = v;
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
for (i = 0; i < argc; i++) {
if (!scheme_chaperone_of(vals[i], argv[i]))
scheme_wrong_chaperoned("call-with-continuation-prompt", "value", argv[i], vals[i]);
}
}
}
}
}
static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
{
Scheme_Object *v;
@ -5963,6 +6050,7 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
Scheme_Cont_Frame_Data cframe;
Scheme_Dynamic_Wind *prompt_dw;
int cc_count = scheme_cont_capture_count;
int is_chaperoned = 0;
argc = in_argc - 3;
if (argc <= 0) {
@ -5981,10 +6069,16 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
if (in_argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) {
if (!SCHEME_PROMPT_TAGP(in_argv[1])) {
if (SCHEME_NP_CHAPERONEP(in_argv[1])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) {
is_chaperoned = 1;
prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
}
else
scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
1, in_argc, in_argv);
}
} else
prompt_tag = in_argv[1];
} else
prompt_tag = scheme_default_prompt_tag;
@ -6134,6 +6228,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
} else
argv = (Scheme_Object **)p->cjs.val;
if (is_chaperoned) {
argv = chaperone_do_prompt_handler(in_argv[1], argc, argv);
}
reset_cjs(&p->cjs);
if (SAME_OBJ(handler, scheme_values_func)) {
@ -6369,17 +6467,61 @@ Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Sch
return value;
}
static Scheme_Object *chaperone_do_abort_one(Scheme_Object *obj, Scheme_Object *v)
{
Scheme_Chaperone *px;
Scheme_Object *a[1];
while (1) {
if (SCHEME_PROMPT_TAGP(obj)) {
return v;
} else {
px = (Scheme_Chaperone *)obj;
obj = px->prev;
a[0] = v;
v = _scheme_apply(SCHEME_CDR(px->redirects), 1, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[0]))
scheme_wrong_chaperoned("abort-current-continuation", "value", a[0], v);
}
}
}
static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int num_args, Scheme_Object *args[])
{
Scheme_Object **vals;
Scheme_Object *v;
int i;
vals = MALLOC_N(Scheme_Object *, num_args);
for (i = 0; i < num_args; i++) {
v = chaperone_do_abort_one(obj, args[i]);
vals[i] = v;
}
return vals;
}
static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
{
Scheme_Object *prompt_tag;
Scheme_Prompt *prompt;
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *val;
int is_chaperoned = 0;
prompt_tag = argv[0];
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
if (!SCHEME_PROMPT_TAGP(argv[0])) {
if (SCHEME_NP_CHAPERONEP(argv[0])
&& SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) {
is_chaperoned = 1;
prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
}
else
scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
0, argc, argv);
}
} else
prompt_tag = argv[0];
prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
@ -6395,7 +6537,12 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
if (argc == 2) {
p->cjs.num_vals = 1;
if (!is_chaperoned)
p->cjs.val = argv[1];
else {
val = chaperone_do_abort_one(argv[0], argv[1]);
p->cjs.val = val;
}
} else {
Scheme_Object **vals;
int i;
@ -6404,7 +6551,12 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
vals[i-1] = argv[i];
}
p->cjs.num_vals = argc - 1;
if (!is_chaperoned)
p->cjs.val = (Scheme_Object *)vals;
else {
val = chaperone_do_abort(argv[0], argc - 1, vals);
p->cjs.val = val;
}
}
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.alt_full_continuation = NULL;

2
src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1058
#define EXPECTED_PRIM_COUNT 1060
#define EXPECTED_UNSAFE_COUNT 79
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_FUTURES_COUNT 13

2
src/racket/src/schpriv.h
View File

@ -883,6 +883,8 @@ typedef struct Scheme_Chaperone {
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_BUCKTP(obj) (SCHEME_BUCKTP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_PROMPT_TAGP(obj) (SCHEME_PROMPT_TAGP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(obj))))
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.0.10"
#define MZSCHEME_VERSION "5.3.0.11"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)