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

Add proxy-able continuation mark keys and proxies

Browse Source 
(with much help from Matthew on the JIT side)
This commit is contained in:
Asumu Takikawa 2012-06-12 16:18:41 -04:00
parent 1e115e2963
commit db6c37df92
20 changed files with 1147 additions and 776 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
collects/tests/racket/contmark.rktl
View File

@ -915,6 +915,87 @@
pt))))) pt)))))
pt))) pt)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test proxy-able continuation marks
(let ()
(define my-mark (make-continuation-mark-key 'my-mark))
(wcm-test '(secret)
(lambda ()
(with-continuation-mark my-mark 'secret
(extract-current-continuation-marks my-mark))))
(wcm-test '()
(lambda ()
(with-continuation-mark my-mark 'secret
(extract-current-continuation-marks 'my-mark))))
(define my-mark-2 (make-continuation-mark-key 'my-mark))
(wcm-test '()
(lambda ()
(with-continuation-mark my-mark 'secret
(extract-current-continuation-marks my-mark-2)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tests for continuation mark proxies
(let ()
(define imp-mark
(impersonate-continuation-mark-key
(make-continuation-mark-key)
(lambda (x) (* x 2))
(lambda (x) (+ x 1))))
(define cha-mark
(chaperone-continuation-mark-key
(make-continuation-mark-key)
(lambda (x) (if (number? x) x (error "fail")))
(lambda (x) x)))
(define bad-mark
(chaperone-continuation-mark-key
(make-continuation-mark-key)
(lambda (x) 42)
(lambda (x) x)))
(define bad-mark-2
(chaperone-continuation-mark-key
(make-continuation-mark-key)
(lambda (x) x)
(lambda (x) 42)))
(define (do-test mark val)
(with-continuation-mark mark val
(extract-current-continuation-marks mark)))
(define (do-test* mark val)
(with-continuation-mark mark val
(continuation-mark-set->list*
(current-continuation-marks)
(list mark))))
(define (do-test/first mark val)
(with-continuation-mark mark val
(continuation-mark-set-first (current-continuation-marks) mark)))
(define (do-test/immediate mark val)
(with-continuation-mark mark val
(call-with-immediate-continuation-mark mark
(lambda (v) v))))
(wcm-test '(12) (lambda () (do-test imp-mark 5)))
(wcm-test '(#(12)) (lambda () (do-test* imp-mark 5)))
(wcm-test 12 (lambda () (do-test/first imp-mark 5)))
(wcm-test 12 (lambda () (do-test/immediate imp-mark 5)))
(wcm-test '(5) (lambda () (do-test cha-mark 5)))
(wcm-test '(#(5)) (lambda () (do-test* cha-mark 5)))
(wcm-test 5 (lambda () (do-test/first cha-mark 5)))
(wcm-test 5 (lambda () (do-test/immediate cha-mark 5)))
(err/rt-test (do-test cha-mark "fail") exn:fail?)
(err/rt-test (do-test bad-mark 5) exn:fail?))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

5
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,8 @@
Version 5.3.0.12
racket/base: added impersonate-continuation-mark-key,
chaperone-continuation-mark-key, make-continuation-mark-key,
continuation-mark-key?
Version 5.3.0.11 Version 5.3.0.11
Changed contract on date second field to disallow 61, since Changed contract on date second field to disallow 61, since
leap seconds never appear more than once per minute leap seconds never appear more than once per minute

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

@ -451,6 +451,7 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_IMMUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(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_PROMPT_TAGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
#define SCHEME_CONTINUATION_MARK_KEYP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_continuation_mark_key_type)
#define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_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_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)

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

File diff suppressed because it is too large Load Diff

6
src/racket/src/eval.c
View File

@ -3559,6 +3559,12 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
if (SCHEME_TYPE(val) < _scheme_values_types_) if (SCHEME_TYPE(val) < _scheme_values_types_)
val = _scheme_eval_linked_expr_wp(val, p); val = _scheme_eval_linked_expr_wp(val, p);
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
val = scheme_chaperone_do_continuation_mark("with-continuation-mark", 0, key, val);
key = SCHEME_CHAPERONE_VAL(key);
}
scheme_set_cont_mark(key, val); scheme_set_cont_mark(key, val);
obj = wcm->body; obj = wcm->body;

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

@ -143,6 +143,10 @@ 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 *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 (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_continuation_mark_key (int argc, Scheme_Object *argv[]);
static Scheme_Object *continuation_mark_key_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_continuation_mark_key (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_continuation_mark_key (int argc, Scheme_Object *argv[]);
static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]); static Scheme_Object *cc_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]); static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]); static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
@ -395,6 +399,27 @@ scheme_init_fun (Scheme_Env *env)
0, -1), 0, -1),
env); env);
scheme_add_global_constant("make-continuation-mark-key",
scheme_make_prim_w_arity(make_continuation_mark_key,
"make-continuation-mark-key",
0, 1),
env);
scheme_add_global_constant("continuation-mark-key?",
scheme_make_prim_w_arity(continuation_mark_key_p,
"continuation-mark-key?",
1, 1),
env);
scheme_add_global_constant("impersonate-continuation-mark-key",
scheme_make_prim_w_arity(impersonate_continuation_mark_key,
"impersonate-continuation-mark-key",
3, -1),
env);
scheme_add_global_constant("chaperone-continuation-mark-key",
scheme_make_prim_w_arity(chaperone_continuation_mark_key,
"chaperone-continuation-mark-key",
3, -1),
env);
scheme_add_global_constant("current-continuation-marks", scheme_add_global_constant("current-continuation-marks",
scheme_make_prim_w_arity(cc_marks, scheme_make_prim_w_arity(cc_marks,
"current-continuation-marks", "current-continuation-marks",
@ -3742,6 +3767,100 @@ int scheme_escape_continuation_ok(Scheme_Object *ec)
return 0; return 0;
} }
static Scheme_Object *make_continuation_mark_key (int argc, Scheme_Object *argv[])
{
Scheme_Object *o;
if (argc && !SCHEME_SYMBOLP(argv[0]))
scheme_wrong_contract("make-continuation-mark-key", "symbol?", 0, argc, argv);
o = scheme_alloc_small_object();
o->type = scheme_continuation_mark_key_type;
SCHEME_PTR_VAL(o) = (argc ? argv[0] : NULL);
return o;
}
static Scheme_Object *continuation_mark_key_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_CHAPERONE_CONTINUATION_MARK_KEYP(argv[0])
? scheme_true
: scheme_false);
}
Scheme_Object *scheme_chaperone_do_continuation_mark (const char *name, int is_get, Scheme_Object *key, Scheme_Object *val)
{
Scheme_Chaperone *px;
Scheme_Object *proc;
Scheme_Object *a[1];
while (1) {
if (SCHEME_CONTINUATION_MARK_KEYP(key)) {
return val;
} else {
px = (Scheme_Chaperone *)key;
key = px->prev;
if (is_get)
proc = SCHEME_CAR(px->redirects);
else
proc = SCHEME_CDR(px->redirects);
a[0] = val;
val = _scheme_apply(proc, 1, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
if (!scheme_chaperone_of(val, a[0]))
scheme_wrong_chaperoned(name, "value", a[0], val);
}
}
}
}
Scheme_Object *do_chaperone_continuation_mark_key (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_CONTINUATION_MARK_KEYP(val))
scheme_wrong_contract(name, "continuation-mark-key?", 0, argc, argv);
scheme_check_proc_arity(name, 1, 1, argc, argv);
scheme_check_proc_arity(name, 1, 2, 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_continuation_mark_key(int argc, Scheme_Object **argv)
{
return do_chaperone_continuation_mark_key("chaperone-continuation-mark-key", 0, argc, argv);
}
static Scheme_Object *impersonate_continuation_mark_key(int argc, Scheme_Object **argv)
{
return do_chaperone_continuation_mark_key("impersonate-continuation-mark-key", 1, argc, argv);
}
static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]) static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
@ -3751,6 +3870,10 @@ static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv
scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv); scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);
key = argv[0]; key = argv[0];
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key)))
key = SCHEME_CHAPERONE_VAL(key);
if (argc > 2) if (argc > 2)
a[0] = argv[2]; a[0] = argv[2];
else else
@ -3768,7 +3891,16 @@ static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv
break; break;
} else { } else {
if (find->key == key) { if (find->key == key) {
a[0] = find->val; /*
* If not equal, it was a chaperone since we unwrapped the key
*/
if (argv[0] != key) {
Scheme_Object *val;
val = scheme_chaperone_do_continuation_mark("call-with-immediate-continuation-mark",
1, argv[0], find->val);
a[0] = val;
} else
a[0] = find->val;
break; break;
} }
} }
@ -7093,7 +7225,9 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
{ {
Scheme_Cont_Mark_Chain *chain; Scheme_Cont_Mark_Chain *chain;
Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag; Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag;
Scheme_Object *v;
Scheme_Object *pr; Scheme_Object *pr;
int is_chaperoned = 0;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) { if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
scheme_wrong_contract("continuation-mark-set->list", "continuation-mark-set?", 0, argc, argv); scheme_wrong_contract("continuation-mark-set->list", "continuation-mark-set?", 0, argc, argv);
@ -7124,11 +7258,22 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
return NULL; return NULL;
} }
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
is_chaperoned = 1;
key = SCHEME_CHAPERONE_VAL(key);
}
prompt_tag = SCHEME_PTR_VAL(prompt_tag); prompt_tag = SCHEME_PTR_VAL(prompt_tag);
while (chain) { while (chain) {
if (chain->key == key) { if (chain->key == key) {
pr = scheme_make_pair(chain->val, scheme_null); if (is_chaperoned)
v = scheme_chaperone_do_continuation_mark("continuation-mark-set->list",
1, argv[1], chain->val);
else
v = chain->val;
pr = scheme_make_pair(v, scheme_null);
if (last) if (last)
SCHEME_CDR(last) = pr; SCHEME_CDR(last) = pr;
else else
@ -7198,8 +7343,17 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
while (chain) { while (chain) {
for (i = 0; i < len; i++) { for (i = 0; i < len; i++) {
int is_chaperoned = 0;
Scheme_Object *orig_key, *val;
if (SCHEME_MARK_CHAIN_FLAG(chain) & 0x1) if (SCHEME_MARK_CHAIN_FLAG(chain) & 0x1)
last_pos = -1; last_pos = -1;
if (SCHEME_NP_CHAPERONEP(keys[i])
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(keys[i]))) {
is_chaperoned = 1;
orig_key = keys[i];
keys[i] = SCHEME_CHAPERONE_VAL(orig_key);
}
if (SAME_OBJ(chain->key, keys[i])) { if (SAME_OBJ(chain->key, keys[i])) {
intptr_t pos; intptr_t pos;
pos = (intptr_t)chain->pos; pos = (intptr_t)chain->pos;
@ -7214,7 +7368,12 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
last = pr; last = pr;
} else } else
vals = SCHEME_CAR(last); vals = SCHEME_CAR(last);
SCHEME_VEC_ELS(vals)[i] = chain->val; if (is_chaperoned) {
val = scheme_chaperone_do_continuation_mark("continuation-mark-set->list*",
1, orig_key, chain->val);
SCHEME_VEC_ELS(vals)[i] = val;
} else
SCHEME_VEC_ELS(vals)[i] = chain->val;
} }
} }
@ -7324,16 +7483,30 @@ extract_cc_proc_marks(int argc, Scheme_Object *argv[])
} }
static Scheme_Object * static Scheme_Object *
scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key_arg,
Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta, Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
MZ_MARK_POS_TYPE *_vpos) MZ_MARK_POS_TYPE *_vpos)
{ {
Scheme_Object *key = key_arg;
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
key = SCHEME_CHAPERONE_VAL(key);
}
if (mark_set) { if (mark_set) {
Scheme_Cont_Mark_Chain *chain; Scheme_Cont_Mark_Chain *chain;
chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain; chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain;
while (chain) { while (chain) {
if (chain->key == key) if (chain->key == key)
return chain->val; if (key_arg != key)
/*
* TODO: is this the only name that this procedure is called as
* publicly?
*/
return scheme_chaperone_do_continuation_mark("continuation-mark-set-first",
1, key_arg, chain->val);
else
return chain->val;
else if (SAME_OBJ(chain->key, prompt_tag)) else if (SAME_OBJ(chain->key, prompt_tag))
break; break;
else else
@ -7450,6 +7623,8 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key
} else } else
cht = NULL; cht = NULL;
if (key_arg != key)
val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val);
if (!cache || !SCHEME_VECTORP(cache)) { if (!cache || !SCHEME_VECTORP(cache)) {
/* No cache so far, so map one key */ /* No cache so far, so map one key */
cache = scheme_make_vector(4, NULL); cache = scheme_make_vector(4, NULL);

5
src/racket/src/gen-jit-ts.rkt
View File

@ -60,7 +60,7 @@
XFORM_SKIP_PROC \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ if (scheme_use_rtcall) \
@|return| scheme_rtcall_@|t|("[" #id "]", src_type, id, @(string-join arg-names ", ")); \ @|return| scheme_rtcall_@|t|("[" #id "]", src_type, @(string-join (cons "id" arg-names) ", ")); \
else \ else \
@|return| id(@(string-join arg-names ", ")); \ @|return| id(@(string-join arg-names ", ")); \
}}) }})
@ -196,7 +196,8 @@
sis_v sis_v
ss_i ss_i
iSp_v iSp_v
sss_s)) sss_s
_v))
(with-output-to-file "jit_ts_def.c" (with-output-to-file "jit_ts_def.c"
#:exists 'replace #:exists 'replace

17
src/racket/src/jit.c
View File

@ -2857,6 +2857,23 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
/* Key and value are on runstack */ /* Key and value are on runstack */
mz_rs_sync(); mz_rs_sync();
if (SCHEME_TYPE(wcm->key) < _scheme_values_types_) {
/* Check whether the key is chaperoned: */
GC_CAN_IGNORE jit_insn *ref, *ref2;
mz_rs_ldxi(JIT_R0, 1);
__START_TINY_JUMPS__(1);
ref = jit_bmsi_i(jit_forward(), JIT_R0, 0x1);
ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_chaperone_type, JIT_R1);
__END_TINY_JUMPS__(1);
(void)jit_calli(sjc.wcm_chaperone); /* adjusts values on the runstack */
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
mz_patch_branch(ref2);
__END_TINY_JUMPS__(1);
}
/* Key and value are (still) on runstack */
if (!wcm_may_replace) { if (!wcm_may_replace) {
(void)jit_calli(sjc.wcm_nontail_code); (void)jit_calli(sjc.wcm_nontail_code);
wcm_may_replace = 1; wcm_may_replace = 1;

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

@ -268,7 +268,7 @@ struct scheme_jit_common_record {
void *module_run_start_code, *module_exprun_start_code, *module_start_start_code; void *module_run_start_code, *module_exprun_start_code, *module_start_start_code;
void *box_flonum_from_stack_code, *box_flonum_from_reg_code; void *box_flonum_from_stack_code, *box_flonum_from_reg_code;
void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2]; void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2];
void *wcm_code, *wcm_nontail_code; void *wcm_code, *wcm_nontail_code, *wcm_chaperone;
void *apply_to_list_tail_code, *apply_to_list_code, *apply_to_list_multi_ok_code; void *apply_to_list_tail_code, *apply_to_list_code, *apply_to_list_multi_ok_code;
void *eqv_code, *eqv_branch_code; void *eqv_code, *eqv_branch_code;
void *proc_arity_includes_code; void *proc_arity_includes_code;

2
src/racket/src/jit_ts.c
View File

@ -91,6 +91,7 @@ define_ts_iS_s(scheme_checked_list_tail, FSRC_MARKS)
define_ts_iSs_s(scheme_struct_getter, FSRC_MARKS) define_ts_iSs_s(scheme_struct_getter, FSRC_MARKS)
define_ts_iSs_s(scheme_struct_setter, FSRC_MARKS) define_ts_iSs_s(scheme_struct_setter, FSRC_MARKS)
define_ts_iS_s(scheme_box_cas, FSRC_MARKS) define_ts_iS_s(scheme_box_cas, FSRC_MARKS)
define_ts__v(chaperone_set_mark, FSRC_MARKS)
#endif #endif
#ifdef JITCALL_TS_PROCS #ifdef JITCALL_TS_PROCS
@ -178,6 +179,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_unbox scheme_unbox # define ts_scheme_unbox scheme_unbox
# define ts_scheme_set_box scheme_set_box # define ts_scheme_set_box scheme_set_box
# define ts_scheme_box_cas scheme_box_cas # define ts_scheme_box_cas scheme_box_cas
# define ts_chaperone_set_mark chaperone_set_mark
# define ts_scheme_vector_length scheme_vector_length # define ts_scheme_vector_length scheme_vector_length
# define ts_scheme_flvector_length scheme_flvector_length # define ts_scheme_flvector_length scheme_flvector_length
# define ts_scheme_fxvector_length scheme_fxvector_length # define ts_scheme_fxvector_length scheme_fxvector_length

11
src/racket/src/jit_ts_def.c
View File

@ -39,7 +39,7 @@ static Scheme_Object* ts_ ## id() \
XFORM_SKIP_PROC \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ if (scheme_use_rtcall) \
return scheme_rtcall__s("[" #id "]", src_type, id, ); \ return scheme_rtcall__s("[" #id "]", src_type, id); \
else \ else \
return id(); \ return id(); \
} }
@ -241,3 +241,12 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g59, Scheme_Object* g60, Scheme_O
else \ else \
return id(g59, g60, g61); \ return id(g59, g60, g61); \
} }
#define define_ts__v(id, src_type) \
static void ts_ ## id() \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall__v("[" #id "]", src_type, id); \
else \
id(); \
}

25
src/racket/src/jit_ts_future_glue.c
View File

@ -701,4 +701,29 @@
future->retval_s = 0; future->retval_s = 0;
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; return retval;
}
void scheme_rtcall__v(const char *who, int src_type, prim__v f )
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
future_t *future;
double tm;
future = fts->thread->current_ft;
future->prim_protocol = SIG__v;
future->prim_func = f;
tm = get_future_timestamp();
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
future = fts->thread->current_ft;
} }

3
src/racket/src/jit_ts_protos.h
View File

@ -79,3 +79,6 @@ void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g221,
#define SIG_sss_s 36 #define SIG_sss_s 36
typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*); typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*);
Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g224, Scheme_Object* g225, Scheme_Object* g226); Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g224, Scheme_Object* g225, Scheme_Object* g226);
#define SIG__v 37
typedef void (*prim__v)();
void scheme_rtcall__v(const char *who, int src_type, prim__v f );

14
src/racket/src/jit_ts_runtime_glue.c
View File

@ -374,5 +374,19 @@ case SIG_sss_s:
f(arg_s0, arg_s1, arg_s2); f(arg_s0, arg_s1, arg_s2);
future->retval_s = retval; future->retval_s = retval;
send_special_result(future, retval); send_special_result(future, retval);
break;
}
case SIG__v:
{
prim__v f = (prim__v)future->prim_func;
f();
break; break;
} }

24
src/racket/src/jitcommon.c
View File

@ -165,6 +165,15 @@ static void ts_allocate_values(int count, Scheme_Thread *p) XFORM_SKIP_PROC
# define ts_allocate_values allocate_values # define ts_allocate_values allocate_values
#endif #endif
static void chaperone_set_mark()
/* arguments are on runstack; result goes there, too */
{
Scheme_Object *v;
v = scheme_chaperone_do_continuation_mark("with-continuation-mark", 0, MZ_RUNSTACK[1], MZ_RUNSTACK[0]);
MZ_RUNSTACK[0] = v;
MZ_RUNSTACK[1] = SCHEME_CHAPERONE_VAL(MZ_RUNSTACK[1]);
}
#define JITCOMMON_TS_PROCS #define JITCOMMON_TS_PROCS
#define JIT_APPLY_TS_PROCS #define JIT_APPLY_TS_PROCS
#include "jit_ts.c" #include "jit_ts.c"
@ -2258,6 +2267,21 @@ static int common6(mz_jit_state *jitter, void *_data)
scheme_jit_register_sub_func(jitter, sjc.wcm_code, scheme_false); scheme_jit_register_sub_func(jitter, sjc.wcm_code, scheme_false);
} }
/* wcm_chaperone */
/* key and value are on runstack and are updated there */
{
GC_CAN_IGNORE jit_insn *ref2;
sjc.wcm_chaperone = jit_get_ip().ptr;
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(0);
(void)mz_finish_lwe(ts_chaperone_set_mark, ref2);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.wcm_chaperone, scheme_false);
}
return 1; return 1;
} }

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

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

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

@ -885,6 +885,9 @@ typedef struct Scheme_Chaperone {
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj)))) || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_PROMPT_TAGP(obj) (SCHEME_PROMPT_TAGP(obj) \ #define SCHEME_CHAPERONE_PROMPT_TAGP(obj) (SCHEME_PROMPT_TAGP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(obj)))) || (SCHEME_NP_CHAPERONEP(obj) && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(obj))))
#define SCHEME_CHAPERONE_CONTINUATION_MARK_KEYP(obj) (SCHEME_CONTINUATION_MARK_KEYP(obj) \
|| (SCHEME_NP_CHAPERONEP(obj) \
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(obj))))
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i); Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v); void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);
@ -1675,6 +1678,8 @@ Scheme_Object *scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int n
Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
Scheme_Object **old_runstack, int can_ec); Scheme_Object **old_runstack, int can_ec);
Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_get, Scheme_Object *key, Scheme_Object *val);
/*========================================================================*/ /*========================================================================*/
/* semaphores and locks */ /* semaphores and locks */
/*========================================================================*/ /*========================================================================*/

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

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

199
src/racket/src/stypes.h
View File

@ -172,109 +172,110 @@ enum {
scheme_raw_pair_type, /* 152 */ scheme_raw_pair_type, /* 152 */
scheme_prompt_type, /* 153 */ scheme_prompt_type, /* 153 */
scheme_prompt_tag_type, /* 154 */ scheme_prompt_tag_type, /* 154 */
scheme_expanded_syntax_type, /* 155 */ scheme_continuation_mark_key_type, /* 155 */
scheme_delay_syntax_type, /* 156 */ scheme_expanded_syntax_type, /* 156 */
scheme_cust_box_type, /* 157 */ scheme_delay_syntax_type, /* 157 */
scheme_resolved_module_path_type, /* 158 */ scheme_cust_box_type, /* 158 */
scheme_module_phase_exports_type, /* 159 */ scheme_resolved_module_path_type, /* 159 */
scheme_logger_type, /* 160 */ scheme_module_phase_exports_type, /* 160 */
scheme_log_reader_type, /* 161 */ scheme_logger_type, /* 161 */
scheme_free_id_info_type, /* 162 */ scheme_log_reader_type, /* 162 */
scheme_rib_delimiter_type, /* 163 */ scheme_free_id_info_type, /* 163 */
scheme_noninline_proc_type, /* 164 */ scheme_rib_delimiter_type, /* 164 */
scheme_prune_context_type, /* 165 */ scheme_noninline_proc_type, /* 165 */
scheme_future_type, /* 166 */ scheme_prune_context_type, /* 166 */
scheme_flvector_type, /* 167 */ scheme_future_type, /* 167 */
scheme_fxvector_type, /* 168 */ scheme_flvector_type, /* 168 */
scheme_place_type, /* 169 */ scheme_fxvector_type, /* 169 */
scheme_place_object_type, /* 170 */ scheme_place_type, /* 170 */
scheme_place_async_channel_type, /* 171 */ scheme_place_object_type, /* 171 */
scheme_place_bi_channel_type, /* 172 */ scheme_place_async_channel_type, /* 172 */
scheme_once_used_type, /* 173 */ scheme_place_bi_channel_type, /* 173 */
scheme_serialized_symbol_type, /* 174 */ scheme_once_used_type, /* 174 */
scheme_serialized_structure_type, /* 175 */ scheme_serialized_symbol_type, /* 175 */
scheme_fsemaphore_type, /* 176 */ scheme_serialized_structure_type, /* 176 */
scheme_serialized_tcp_fd_type, /* 177 */ scheme_fsemaphore_type, /* 177 */
scheme_serialized_file_fd_type, /* 178 */ scheme_serialized_tcp_fd_type, /* 178 */
scheme_port_closed_evt_type, /* 179 */ scheme_serialized_file_fd_type, /* 179 */
scheme_port_closed_evt_type, /* 180 */
#ifdef MZTAG_REQUIRED #ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 180 */ _scheme_last_normal_type_, /* 181 */
scheme_rt_weak_array, /* 181 */ scheme_rt_weak_array, /* 182 */
scheme_rt_comp_env, /* 182 */ scheme_rt_comp_env, /* 183 */
scheme_rt_constant_binding, /* 183 */ scheme_rt_constant_binding, /* 184 */
scheme_rt_resolve_info, /* 184 */ scheme_rt_resolve_info, /* 185 */
scheme_rt_unresolve_info, /* 185 */ scheme_rt_unresolve_info, /* 186 */
scheme_rt_optimize_info, /* 186 */ scheme_rt_optimize_info, /* 187 */
scheme_rt_compile_info, /* 187 */ scheme_rt_compile_info, /* 188 */
scheme_rt_cont_mark, /* 188 */ scheme_rt_cont_mark, /* 189 */
scheme_rt_saved_stack, /* 189 */ scheme_rt_saved_stack, /* 190 */
scheme_rt_reply_item, /* 190 */ scheme_rt_reply_item, /* 191 */
scheme_rt_closure_info, /* 191 */ scheme_rt_closure_info, /* 192 */
scheme_rt_overflow, /* 192 */ scheme_rt_overflow, /* 193 */
scheme_rt_overflow_jmp, /* 193 */ scheme_rt_overflow_jmp, /* 194 */
scheme_rt_meta_cont, /* 194 */ scheme_rt_meta_cont, /* 195 */
scheme_rt_dyn_wind_cell, /* 195 */ scheme_rt_dyn_wind_cell, /* 196 */
scheme_rt_dyn_wind_info, /* 196 */ scheme_rt_dyn_wind_info, /* 197 */
scheme_rt_dyn_wind, /* 197 */ scheme_rt_dyn_wind, /* 198 */
scheme_rt_dup_check, /* 198 */ scheme_rt_dup_check, /* 199 */
scheme_rt_thread_memory, /* 199 */ scheme_rt_thread_memory, /* 200 */
scheme_rt_input_file, /* 200 */ scheme_rt_input_file, /* 201 */
scheme_rt_input_fd, /* 201 */ scheme_rt_input_fd, /* 202 */
scheme_rt_oskit_console_input, /* 202 */ scheme_rt_oskit_console_input, /* 203 */
scheme_rt_tested_input_file, /* 203 */ scheme_rt_tested_input_file, /* 204 */
scheme_rt_tested_output_file, /* 204 */ scheme_rt_tested_output_file, /* 205 */
scheme_rt_indexed_string, /* 205 */ scheme_rt_indexed_string, /* 206 */
scheme_rt_output_file, /* 206 */ scheme_rt_output_file, /* 207 */
scheme_rt_load_handler_data, /* 207 */ scheme_rt_load_handler_data, /* 208 */
scheme_rt_pipe, /* 208 */ scheme_rt_pipe, /* 209 */
scheme_rt_beos_process, /* 209 */ scheme_rt_beos_process, /* 210 */
scheme_rt_system_child, /* 210 */ scheme_rt_system_child, /* 211 */
scheme_rt_tcp, /* 211 */ scheme_rt_tcp, /* 212 */
scheme_rt_write_data, /* 212 */ scheme_rt_write_data, /* 213 */
scheme_rt_tcp_select_info, /* 213 */ scheme_rt_tcp_select_info, /* 214 */
scheme_rt_param_data, /* 214 */ scheme_rt_param_data, /* 215 */
scheme_rt_will, /* 215 */ scheme_rt_will, /* 216 */
scheme_rt_struct_proc_info, /* 216 */ scheme_rt_struct_proc_info, /* 217 */
scheme_rt_linker_name, /* 217 */ scheme_rt_linker_name, /* 218 */
scheme_rt_param_map, /* 218 */ scheme_rt_param_map, /* 219 */
scheme_rt_finalization, /* 219 */ scheme_rt_finalization, /* 220 */
scheme_rt_finalizations, /* 220 */ scheme_rt_finalizations, /* 221 */
scheme_rt_cpp_object, /* 221 */ scheme_rt_cpp_object, /* 222 */
scheme_rt_cpp_array_object, /* 222 */ scheme_rt_cpp_array_object, /* 223 */
scheme_rt_stack_object, /* 223 */ scheme_rt_stack_object, /* 224 */
scheme_rt_preallocated_object, /* 224 */ scheme_rt_preallocated_object, /* 225 */
scheme_thread_hop_type, /* 225 */ scheme_thread_hop_type, /* 226 */
scheme_rt_srcloc, /* 226 */ scheme_rt_srcloc, /* 227 */
scheme_rt_evt, /* 227 */ scheme_rt_evt, /* 228 */
scheme_rt_syncing, /* 228 */ scheme_rt_syncing, /* 229 */
scheme_rt_comp_prefix, /* 229 */ scheme_rt_comp_prefix, /* 230 */
scheme_rt_user_input, /* 230 */ scheme_rt_user_input, /* 231 */
scheme_rt_user_output, /* 231 */ scheme_rt_user_output, /* 232 */
scheme_rt_compact_port, /* 232 */ scheme_rt_compact_port, /* 233 */
scheme_rt_read_special_dw, /* 233 */ scheme_rt_read_special_dw, /* 234 */
scheme_rt_regwork, /* 234 */ scheme_rt_regwork, /* 235 */
scheme_rt_rx_lazy_string, /* 235 */ scheme_rt_rx_lazy_string, /* 236 */
scheme_rt_buf_holder, /* 236 */ scheme_rt_buf_holder, /* 237 */
scheme_rt_parameterization, /* 237 */ scheme_rt_parameterization, /* 238 */
scheme_rt_print_params, /* 238 */ scheme_rt_print_params, /* 239 */
scheme_rt_read_params, /* 239 */ scheme_rt_read_params, /* 240 */
scheme_rt_native_code, /* 240 */ scheme_rt_native_code, /* 241 */
scheme_rt_native_code_plus_case, /* 241 */ scheme_rt_native_code_plus_case, /* 242 */
scheme_rt_jitter_data, /* 242 */ scheme_rt_jitter_data, /* 243 */
scheme_rt_module_exports, /* 243 */ scheme_rt_module_exports, /* 244 */
scheme_rt_delay_load_info, /* 244 */ scheme_rt_delay_load_info, /* 245 */
scheme_rt_marshal_info, /* 245 */ scheme_rt_marshal_info, /* 246 */
scheme_rt_unmarshal_info, /* 246 */ scheme_rt_unmarshal_info, /* 247 */
scheme_rt_runstack, /* 247 */ scheme_rt_runstack, /* 248 */
scheme_rt_sfs_info, /* 248 */ scheme_rt_sfs_info, /* 249 */
scheme_rt_validate_clearing, /* 249 */ scheme_rt_validate_clearing, /* 250 */
scheme_rt_avl_node, /* 250 */ scheme_rt_avl_node, /* 251 */
scheme_rt_lightweight_cont, /* 251 */ scheme_rt_lightweight_cont, /* 252 */
scheme_rt_export_info, /* 252 */ scheme_rt_export_info, /* 253 */
scheme_rt_cont_jmp, /* 253 */ scheme_rt_cont_jmp, /* 254 */
#endif #endif
_scheme_last_type_ _scheme_last_type_

2
src/racket/src/type.c
View File

@ -274,6 +274,7 @@ scheme_init_type ()
set_name(scheme_thread_cell_values_type, "<thread-cell-values>"); set_name(scheme_thread_cell_values_type, "<thread-cell-values>");
set_name(scheme_prompt_tag_type, "<continuation-prompt-tag>"); set_name(scheme_prompt_tag_type, "<continuation-prompt-tag>");
set_name(scheme_continuation_mark_key_type, "<continuation-mark-key>");
set_name(scheme_string_converter_type, "<string-converter>"); set_name(scheme_string_converter_type, "<string-converter>");
@ -632,6 +633,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_thread_type, thread_val); GC_REG_TRAV(scheme_thread_type, thread_val);
GC_REG_TRAV(scheme_prompt_type, prompt_val); GC_REG_TRAV(scheme_prompt_type, prompt_val);
GC_REG_TRAV(scheme_prompt_tag_type, cons_cell); GC_REG_TRAV(scheme_prompt_tag_type, cons_cell);
GC_REG_TRAV(scheme_continuation_mark_key_type, small_object);
GC_REG_TRAV(scheme_cont_mark_set_type, cont_mark_set_val); GC_REG_TRAV(scheme_cont_mark_set_type, cont_mark_set_val);
GC_REG_TRAV(scheme_sema_type, sema_val); GC_REG_TRAV(scheme_sema_type, sema_val);
GC_REG_TRAV(scheme_channel_type, channel_val); GC_REG_TRAV(scheme_channel_type, channel_val);