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

add with-immediate-continuation-mark bytecode form

Browse Source 
Specialize a
  (call-with-immediate-continuation-mark _key (lambda (_arg) _body) _def-val)
call to an internal
  (with-immediate-continuation-mark [_arg (#%immediate _key _def_val)] _body)
form, which avoids a closure allocation and more.

This optimization is useful for contracts, which use
`call-with-immediate-continuation-mark` to avoid redundant
contract checks.
This commit is contained in:
Matthew Flatt 2015-08-05 07:26:33 -06:00
parent c308915047
commit 0480f55f67
21 changed files with 718 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
racket/src/racket/src/compile.c
View File

@ -1915,6 +1915,20 @@ static Scheme_Object *shift_compiled_expression(Scheme_Object *v, int delta, int
v2 = shift_compiled_expression(SCHEME_PTR2_VAL(v), delta, skip);
SCHEME_PTR2_VAL(v) = v2;
return v;
}
case scheme_with_immed_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)v;
Scheme_Object *v2;
v2 = shift_compiled_expression(wcm->key, delta, skip);
wcm->key = v2;
v2 = shift_compiled_expression(wcm->val, delta, skip);
wcm->val = v2;
v2 = shift_compiled_expression(wcm->body, delta, skip+1);
wcm->body = v2;
return v;
}
case scheme_set_bang_type:
@ -5153,7 +5167,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env,
orig_rest_form = SCHEME_STX_CDR(form);
/* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */
/* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */
if (SCHEME_STX_SYMBOLP(name)) {
Scheme_Object *at_first, *at_second, *the_end;
at_first = SCHEME_STX_CDR(form);

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

@ -3827,6 +3827,35 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
v = apply_values_execute(obj);
break;
}
case scheme_with_immed_mark_type:
{
# define wcm ((Scheme_With_Continuation_Mark *)obj)
Scheme_Object *mark_key;
GC_CAN_IGNORE Scheme_Object *mark_val;
mark_key = wcm->key;
if (SCHEME_TYPE(mark_key) < _scheme_values_types_) {
UPDATE_THREAD_RSPTR();
mark_key = _scheme_eval_linked_expr_wp(mark_key, p);
}
mark_val = wcm->val;
if (SCHEME_TYPE(mark_val) < _scheme_values_types_) {
UPDATE_THREAD_RSPTR();
mark_val = _scheme_eval_linked_expr_wp(mark_val, p);
}
UPDATE_THREAD_RSPTR();
mark_val = scheme_chaperone_get_immediate_cc_mark(mark_key, mark_val);
PUSH_RUNSTACK(p, RUNSTACK, 1);
RUNSTACK_CHANGED();
RUNSTACK[0] = mark_val;
obj = wcm->body;
goto eval_top;
#undef wcm
}
case scheme_case_lambda_sequence_type:
{
UPDATE_THREAD_RSPTR();

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

@ -93,6 +93,7 @@ READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_apply_proc;
READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
READ_ONLY Scheme_Object *scheme_call_with_immed_mark_proc;
READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
READ_ONLY Scheme_Object *scheme_tail_call_waiting;
READ_ONLY Scheme_Object *scheme_default_prompt_tag;
@ -483,11 +484,13 @@ scheme_init_fun (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant("continuation-mark-set-first", o, env);
REGISTER_SO(scheme_call_with_immed_mark_proc);
scheme_call_with_immed_mark_proc = scheme_make_prim_w_arity2(call_with_immediate_cc_mark,
"call-with-immediate-continuation-mark",
2, 3,
0, -1);
scheme_add_global_constant("call-with-immediate-continuation-mark",
scheme_make_prim_w_arity2(call_with_immediate_cc_mark,
"call-with-immediate-continuation-mark",
2, 3,
0, -1),
scheme_call_with_immed_mark_proc,
env);
scheme_add_global_constant("continuation-mark-set?",
scheme_make_prim_w_arity(cc_marks_p,
@ -4351,24 +4354,10 @@ static Scheme_Object *impersonate_continuation_mark_key(int argc, Scheme_Object
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[])
Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
{
Scheme_Thread *p = scheme_current_thread;
intptr_t findpos, bottom;
Scheme_Object *a[1], *key;
scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);
key = argv[0];
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key)))
key = SCHEME_CHAPERONE_VAL(key);
if (argc > 2)
a[0] = argv[2];
else
a[0] = scheme_false;
if (p->cont_mark_stack_segments) {
findpos = (intptr_t)MZ_CONT_MARK_STACK;
@ -4381,23 +4370,40 @@ static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv
if ((intptr_t)find->pos < (intptr_t)MZ_CONT_MARK_POS) {
break;
} else {
if (find->key == key) {
/*
* 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;
}
if (find->key == key)
return find->val;
}
}
}
return def_val;
}
Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
{
Scheme_Object *val;
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
val = scheme_get_immediate_cc_mark(SCHEME_CHAPERONE_VAL(key), NULL);
if (val)
return scheme_chaperone_do_continuation_mark("call-with-immediate-continuation-mark",
1, key, val);
else
return def_val;
} else
return scheme_get_immediate_cc_mark(key, def_val);
}
static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
{
Scheme_Object *a[1], *val;
scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);
val = scheme_chaperone_get_immediate_cc_mark(argv[0], ((argc > 2) ? argv[2] : scheme_false));
a[0] = val;
return scheme_tail_apply(argv[1], 1, a);
}

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

@ -2445,6 +2445,36 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
return 1;
}
break;
case scheme_with_immed_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj;
START_JIT_DATA();
LOG_IT(("with-immediate-continuation-mark...\n"));
scheme_generate_two_args(wcm->key, wcm->val, jitter, 1, 0);
CHECK_LIMIT();
/* key is in JIT_R0, default value is in JIT_R1 */
mz_rs_sync();
(void)jit_calli(sjc.with_immed_mark_code);
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW();
mz_runstack_pushed(jitter, 1);
mz_rs_str(JIT_R0);
CHECK_LIMIT();
END_JIT_DATA(22);
LOG_IT(("...in\n"));
return scheme_generate(wcm->body, jitter, is_tail, wcm_may_replace,
multi_ok, orig_target, for_branch);
}
break;
case scheme_boxenv_type:
{
Scheme_Object *p, *v;

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

@ -356,6 +356,7 @@ struct scheme_jit_common_record {
void *box_extflonum_from_stack_code, *box_extflonum_from_reg_code;
#endif
void *wcm_code, *wcm_nontail_code, *wcm_chaperone;
void *with_immed_mark_code;
void *apply_to_list_tail_code, *apply_to_list_code, *apply_to_list_multi_ok_code;
void *eqv_code, *eqv_branch_code;
void *proc_arity_includes_code;

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

@ -103,6 +103,7 @@ define_ts_iSs_s(scheme_struct_getter, FSRC_MARKS)
define_ts_iSs_s(scheme_struct_setter, FSRC_MARKS)
define_ts_iS_s(scheme_box_cas, FSRC_MARKS)
define_ts__v(chaperone_set_mark, FSRC_MARKS)
define_ts_ss_s(scheme_chaperone_get_immediate_cc_mark, FSRC_MARKS)
define_ts_iS_s(scheme_checked_char_to_integer, FSRC_MARKS)
define_ts_iS_s(scheme_checked_integer_to_char, FSRC_MARKS)
# ifndef CAN_INLINE_ALLOC
@ -205,6 +206,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_set_box scheme_set_box
# define ts_scheme_box_cas scheme_box_cas
# define ts_chaperone_set_mark chaperone_set_mark
# define ts_scheme_chaperone_get_immediate_cc_mark scheme_chaperone_get_immediate_cc_mark
# define ts_scheme_vector_length scheme_vector_length
# define ts_scheme_flvector_length scheme_flvector_length
#ifdef MZ_LONG_DOUBLE

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

@ -2711,6 +2711,23 @@ static int common6(mz_jit_state *jitter, void *_data)
scheme_jit_register_sub_func(jitter, sjc.wcm_chaperone, scheme_false);
}
/* with_immed_mark_code */
{
GC_CAN_IGNORE jit_insn *ref2 USED_ONLY_FOR_FUTURES;
sjc.with_immed_mark_code = jit_get_ip();
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_chaperone_get_immediate_cc_mark, ref2);
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.with_immed_mark_code, scheme_false);
}
return 1;
}

28
racket/src/racket/src/jitinline.c
View File

@ -2130,24 +2130,36 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW();
mz_runstack_pushed(jitter, 1);
mz_rs_str(JIT_R0);
mz_runstack_skipped(jitter, skipped-1);
if (skipped) {
mz_runstack_pushed(jitter, 1);
mz_rs_str(JIT_R0);
mz_runstack_skipped(jitter, skipped-1);
} else {
mz_pushr_p(JIT_R0);
}
scheme_generate_non_tail(rand2, jitter, 0, 1, 0); /* no sync... */
CHECK_LIMIT();
if (order_matters) {
jit_movr_p(JIT_R1, JIT_R0);
mz_rs_ldr(JIT_R0);
if (!skipped)
mz_popr_p(JIT_R0);
else
mz_rs_ldr(JIT_R0);
} else {
mz_rs_ldr(JIT_R1);
if (!skipped)
mz_popr_p(JIT_R1);
else
mz_rs_ldr(JIT_R1);
direction = -1;
}
mz_runstack_unskipped(jitter, skipped-1);
mz_rs_inc(1);
mz_runstack_popped(jitter, 1);
if (skipped) {
mz_runstack_unskipped(jitter, skipped-1);
mz_rs_inc(1);
mz_runstack_popped(jitter, 1);
}
}
} else {
mz_runstack_skipped(jitter, skipped);

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

@ -379,6 +379,29 @@ static Scheme_Object *apply_values_jit(Scheme_Object *data)
}
}
static Scheme_Object *with_immed_mark_jit(Scheme_Object *o)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
k = scheme_jit_expr(wcm->key);
v = scheme_jit_expr(wcm->val);
b = scheme_jit_expr(wcm->body);
if (SAME_OBJ(wcm->key, k)
&& SAME_OBJ(wcm->val, v)
&& SAME_OBJ(wcm->body, b))
return o;
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark));
wcm->key = k;
wcm->val = v;
wcm->body = b;
return (Scheme_Object *)wcm;
}
Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr)
{
#ifdef MZ_USE_JIT
@ -625,6 +648,8 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
return ref_jit(expr);
case scheme_apply_values_type:
return apply_values_jit(expr);
case scheme_with_immed_mark_type:
return with_immed_mark_jit(expr);
case scheme_case_lambda_sequence_type:
return scheme_case_lambda_jit(expr);
case scheme_module_type:

4
racket/src/racket/src/jitstate.c
View File

@ -545,6 +545,8 @@ void scheme_mz_runstack_skipped(mz_jit_state *jitter, int n)
{
int v;
if (!n) return;
if (!(jitter->mappings[jitter->num_mappings] & 0x1)
|| (jitter->mappings[jitter->num_mappings] & 0x2)
|| (jitter->mappings[jitter->num_mappings] > 0)) {
@ -561,6 +563,8 @@ void scheme_mz_runstack_unskipped(mz_jit_state *jitter, int n)
{
int v;
if (!n) return;
JIT_ASSERT(jitter->mappings[jitter->num_mappings] & 0x1);
JIT_ASSERT(!(jitter->mappings[jitter->num_mappings] & 0x2));
v = (jitter->mappings[jitter->num_mappings]) >> 2;

3
racket/src/racket/src/letrec_check.c
View File

@ -1083,6 +1083,9 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame
return letrec_check_begin0(expr, frame, pos);
case scheme_apply_values_type:
return letrec_check_apply_values(expr, frame, pos);
case scheme_with_immed_mark_type:
scheme_signal_error("internal error: with-immediate-mark not expected before optimization");
return NULL;
case scheme_require_form_type:
return expr;
case scheme_module_type:

38
racket/src/racket/src/marshal.c
View File

@ -55,6 +55,8 @@ static Scheme_Object *read_varref(Scheme_Object *obj);
static Scheme_Object *write_varref(Scheme_Object *obj);
static Scheme_Object *read_apply_values(Scheme_Object *obj);
static Scheme_Object *write_apply_values(Scheme_Object *obj);
static Scheme_Object *read_with_immed_mark(Scheme_Object *obj);
static Scheme_Object *write_with_immed_mark(Scheme_Object *obj);
static Scheme_Object *read_inline_variant(Scheme_Object *obj);
static Scheme_Object *write_inline_variant(Scheme_Object *obj);
@ -137,6 +139,8 @@ void scheme_init_marshal(Scheme_Env *env)
scheme_install_type_reader(scheme_varref_form_type, read_varref);
scheme_install_type_writer(scheme_apply_values_type, write_apply_values);
scheme_install_type_reader(scheme_apply_values_type, read_apply_values);
scheme_install_type_writer(scheme_with_immed_mark_type, write_with_immed_mark);
scheme_install_type_reader(scheme_with_immed_mark_type, read_with_immed_mark);
scheme_install_type_writer(scheme_inline_variant_type, write_inline_variant);
scheme_install_type_reader(scheme_inline_variant_type, read_inline_variant);
@ -512,6 +516,40 @@ Scheme_Object *read_apply_values(Scheme_Object *o)
return data;
}
Scheme_Object *write_with_immed_mark(Scheme_Object *o)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *vec, *v;
vec = scheme_make_vector(3, NULL);
v = scheme_protect_quote(wcm->key);
SCHEME_VEC_ELS(vec)[0] = v;
v = scheme_protect_quote(wcm->val);
SCHEME_VEC_ELS(vec)[1] = v;
v = scheme_protect_quote(wcm->body);
SCHEME_VEC_ELS(vec)[2] = v;
return vec;
}
Scheme_Object *read_with_immed_mark(Scheme_Object *o)
{
Scheme_With_Continuation_Mark *wcm;
if (!SCHEME_VECTORP(o)) return NULL;
if (SCHEME_VEC_SIZE(o) != 3) return NULL;
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm->so.type = scheme_with_immed_mark_type;
wcm->key = SCHEME_VEC_ELS(o)[0];
wcm->val = SCHEME_VEC_ELS(o)[1];
wcm->body = SCHEME_VEC_ELS(o)[2];
return (Scheme_Object *)wcm;
}
Scheme_Object *write_boxenv(Scheme_Object *o)
{
return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o));

123
racket/src/racket/src/optimize.c
View File

@ -2686,6 +2686,31 @@ static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Sc
return NULL;
}
static Scheme_Object *call_with_immed_mark(Scheme_Object *rator,
Scheme_Object *rand1,
Scheme_Object *rand2,
Scheme_Object *rand3,
Optimize_Info *info)
{
if (SAME_OBJ(rator, scheme_call_with_immed_mark_proc)
&& SAME_TYPE(SCHEME_TYPE(rand2), scheme_compiled_unclosed_procedure_type)
&& (((Scheme_Closure_Data *)rand2)->num_params == 1)
&& !(SCHEME_CLOSURE_DATA_FLAGS(((Scheme_Closure_Data *)rand2)) & CLOS_HAS_REST)) {
Scheme_With_Continuation_Mark *wcm;
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm->so.type = scheme_with_immed_mark_type;
wcm->key = rand1;
wcm->val = (rand3 ? rand3 : scheme_false);
wcm->body = ((Scheme_Closure_Data *)rand2)->code;
return (Scheme_Object *)wcm;
}
return NULL;
}
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_Object *le;
@ -2700,6 +2725,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
if (le)
return scheme_optimize_expr(le, info, context);
if (app->num_args == 3) {
le = call_with_immed_mark(app->args[0], app->args[1], app->args[2], app->args[3], info);
if (le)
return scheme_optimize_expr(le, info, context);
}
le = check_app_let_rator(o, app->args[0], info, app->num_args, context);
if (le)
return le;
@ -3370,6 +3401,10 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
if (le)
return scheme_optimize_expr(le, info, context);
le = call_with_immed_mark(app->rator, app->rand1, app->rand2, NULL, info);
if (le)
return scheme_optimize_expr(le, info, context);
le = check_app_let_rator(o, app->rator, info, 2, context);
if (le)
return le;
@ -4690,6 +4725,88 @@ apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int del
return data;
}
static Scheme_Object *
with_immed_mark_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)data;
Scheme_Object *key, *val, *body;
Optimize_Info_Sequence info_seq;
Optimize_Info *body_info;
optimize_info_seq_init(info, &info_seq);
key = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED);
optimize_info_seq_step(info, &info_seq);
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return key;
}
val = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED);
optimize_info_seq_step(info, &info_seq);
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return make_discarding_first_sequence(key, val, info, 0);
}
optimize_info_seq_done(info, &info_seq);
body_info = optimize_info_add_frame(info, 1, 1, 0);
body = scheme_optimize_expr(wcm->body, body_info, 0);
optimize_info_done(body_info, NULL);
wcm->key = key;
wcm->val = val;
wcm->body = body;
return data;
}
static Scheme_Object *
with_immed_mark_shift(Scheme_Object *data, int delta, int after_depth)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)data;
Scheme_Object *e;
e = optimize_shift(wcm->key, delta, after_depth);
wcm->key = e;
e = optimize_shift(wcm->val, delta, after_depth);
wcm->val = e;
e = optimize_shift(wcm->body, delta, after_depth+1);
wcm->body = e;
return data;
}
static Scheme_Object *
with_immed_mark_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)data;
Scheme_With_Continuation_Mark *wcm2;
Scheme_Object *e;
wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm2->so.type = scheme_with_immed_mark_type;
e = optimize_clone(dup_ok, wcm->key, info, delta, closure_depth);
if (!e) return NULL;
wcm2->key = e;
e = optimize_clone(dup_ok, wcm->val, info, delta, closure_depth);
if (!e) return NULL;
wcm2->val = e;
e = optimize_clone(dup_ok, wcm->body, info, delta, closure_depth+1);
if (!e) return NULL;
wcm2->body = e;
return (Scheme_Object *)wcm2;
}
static Scheme_Object *
case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context)
{
@ -7624,6 +7741,8 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
return begin0_optimize(expr, info, context);
case scheme_apply_values_type:
return apply_values_optimize(expr, info, context);
case scheme_with_immed_mark_type:
return with_immed_mark_optimize(expr, info, context);
case scheme_require_form_type:
return top_level_require_optimize(expr, info, context);
case scheme_module_type:
@ -7856,6 +7975,8 @@ Scheme_Object *optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *in
return set_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_apply_values_type:
return apply_values_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_with_immed_mark_type:
return with_immed_mark_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_case_lambda_sequence_type:
return case_lambda_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_module_type:
@ -8011,6 +8132,8 @@ Scheme_Object *optimize_shift(Scheme_Object *expr, int delta, int after_depth)
return ref_shift(expr, delta, after_depth);
case scheme_apply_values_type:
return apply_values_shift(expr, delta, after_depth);
case scheme_with_immed_mark_type:
return with_immed_mark_shift(expr, delta, after_depth);
case scheme_case_lambda_sequence_type:
return case_lambda_shift(expr, delta, after_depth);
case scheme_boxenv_type:

29
racket/src/racket/src/resolve.c
View File

@ -717,6 +717,33 @@ apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
return data;
}
static Scheme_Object *
with_immed_mark_resolve(Scheme_Object *data, Resolve_Info *orig_rslv)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)data;
Scheme_Object *e;
Resolve_Info *rslv = orig_rslv;
e = scheme_resolve_expr(wcm->key, rslv);
wcm->key = e;
e = scheme_resolve_expr(wcm->val, rslv);
wcm->val = e;
rslv = resolve_info_extend(rslv, 1, 1, 1);
resolve_info_add_mapping(rslv, 0, 0, 0, NULL);
e = scheme_resolve_expr(wcm->body, rslv);
wcm->body = e;
rslv->max_let_depth += 1;
if (orig_rslv->max_let_depth < rslv->max_let_depth)
orig_rslv->max_let_depth = rslv->max_let_depth;
merge_resolve_tl_map(orig_rslv, rslv);
return data;
}
static Scheme_Object *
case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
{
@ -2521,6 +2548,8 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
return ref_resolve(expr, info);
case scheme_apply_values_type:
return apply_values_resolve(expr, info);
case scheme_with_immed_mark_type:
return with_immed_mark_resolve(expr, info);
case scheme_case_lambda_sequence_type:
return case_lambda_resolve(expr, info);
case scheme_module_type:

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

@ -12,7 +12,7 @@
finally, set EXPECTED_PRIM_COUNT to the right value and
USE_COMPILED_STARTUP to 1 and `make' again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1134
#define EXPECTED_UNSAFE_COUNT 106

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

@ -472,6 +472,7 @@ extern Scheme_Object *scheme_box_p_proc;
extern Scheme_Object *scheme_box_proc;
extern Scheme_Object *scheme_box_immutable_proc;
extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_call_with_immed_mark_proc;
extern Scheme_Object *scheme_make_struct_type_proc;
extern Scheme_Object *scheme_make_struct_field_accessor_proc;
extern Scheme_Object *scheme_make_struct_field_mutator_proc;
@ -1906,6 +1907,9 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc
Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_get, Scheme_Object *key, Scheme_Object *val);
XFORM_NONGCING Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val);
Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val);
/*========================================================================*/
/* semaphores and locks */
/*========================================================================*/

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.2.900.6"
#define MZSCHEME_VERSION "6.2.900.7"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

58
racket/src/racket/src/sfs.c
View File

@ -905,6 +905,61 @@ apply_values_sfs(Scheme_Object *data, SFS_Info *info)
return data;
}
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b, *vec;
int pos, save_mnt, ip;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
scheme_sfs_push(info, 1, 1);
ip = info->ip;
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
}
return o;
}
static Scheme_Object *
case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
{
@ -1336,6 +1391,9 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_
case scheme_apply_values_type:
expr = apply_values_sfs(expr, info);
break;
case scheme_with_immed_mark_type:
expr = with_immed_mark_sfs(expr, info);
break;
case scheme_case_lambda_sequence_type:
expr = case_lambda_sfs(expr, info);
break;

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

@ -28,278 +28,279 @@ enum {
scheme_require_form_type, /* 22 */
scheme_varref_form_type, /* 23 */
scheme_apply_values_type, /* 24 */
scheme_case_lambda_sequence_type, /* 25 */
scheme_module_type, /* 26 */
scheme_inline_variant_type, /* 27 */
scheme_with_immed_mark_type, /* 25 */
scheme_case_lambda_sequence_type, /* 26 */
scheme_module_type, /* 27 */
scheme_inline_variant_type, /* 28 */
_scheme_values_types_, /* All following types are values */
/* intermediate compiled: */
scheme_compiled_unclosed_procedure_type,/* 29 */
scheme_compiled_let_value_type, /* 30 */
scheme_compiled_let_void_type, /* 31 */
scheme_compiled_toplevel_type, /* 32 */
scheme_compiled_quote_syntax_type, /* 33 */
scheme_compiled_unclosed_procedure_type,/* 30 */
scheme_compiled_let_value_type, /* 31 */
scheme_compiled_let_void_type, /* 32 */
scheme_compiled_toplevel_type, /* 33 */
scheme_compiled_quote_syntax_type, /* 34 */
scheme_quote_compilation_type, /* used while writing, only */
/* Registered in prefix table: */
scheme_variable_type, /* 35 */
scheme_variable_type, /* 36 */
scheme_module_variable_type, /* link replaces with scheme_variable_type */
_scheme_compiled_values_types_, /* 37 */
_scheme_compiled_values_types_, /* 38 */
/* procedure types */
scheme_prim_type, /* 38 */
scheme_closed_prim_type, /* 39 */
scheme_closure_type, /* 40 */
scheme_case_closure_type, /* 41 */
scheme_cont_type, /* 42 */
scheme_escaping_cont_type, /* 43 */
scheme_proc_struct_type, /* 44 */
scheme_native_closure_type, /* 45 */
scheme_proc_chaperone_type, /* 46 */
scheme_prim_type, /* 39 */
scheme_closed_prim_type, /* 40 */
scheme_closure_type, /* 41 */
scheme_case_closure_type, /* 42 */
scheme_cont_type, /* 43 */
scheme_escaping_cont_type, /* 44 */
scheme_proc_struct_type, /* 45 */
scheme_native_closure_type, /* 46 */
scheme_proc_chaperone_type, /* 47 */
scheme_chaperone_type, /* 47 */
scheme_chaperone_type, /* 48 */
/* structure type (plus one above for procs) */
scheme_structure_type, /* 48 */
scheme_structure_type, /* 49 */
/* number types (must be together) */
scheme_integer_type, /* 49 */
scheme_bignum_type, /* 50 */
scheme_rational_type, /* 51 */
scheme_float_type, /* 52 */
scheme_double_type, /* 53 */
scheme_complex_type, /* 54 */
scheme_integer_type, /* 50 */
scheme_bignum_type, /* 51 */
scheme_rational_type, /* 52 */
scheme_float_type, /* 53 */
scheme_double_type, /* 54 */
scheme_complex_type, /* 55 */
/* other eqv?-able values (must be with numbers) */
scheme_char_type, /* 55 */
scheme_char_type, /* 56 */
/* other values */
scheme_long_double_type, /* 56 */
scheme_char_string_type, /* 57 */
scheme_byte_string_type, /* 58 */
scheme_unix_path_type, /* 59 */
scheme_windows_path_type, /* 60 */
scheme_symbol_type, /* 61 */
scheme_keyword_type, /* 62 */
scheme_null_type, /* 63 */
scheme_pair_type, /* 64 */
scheme_mutable_pair_type, /* 65 */
scheme_vector_type, /* 66 */
scheme_inspector_type, /* 67 */
scheme_input_port_type, /* 68 */
scheme_output_port_type, /* 69 */
scheme_eof_type, /* 70 */
scheme_true_type, /* 71 */
scheme_false_type, /* 72 */
scheme_void_type, /* 73 */
scheme_syntax_compiler_type, /* 74 */
scheme_macro_type, /* 75 */
scheme_box_type, /* 76 */
scheme_thread_type, /* 77 */
scheme_scope_type, /* 78 */
scheme_stx_offset_type, /* 79 */
scheme_cont_mark_set_type, /* 80 */
scheme_sema_type, /* 81 */
scheme_hash_table_type, /* 82 */
scheme_hash_tree_type, /* 83 */
scheme_eq_hash_tree_type, /* 84 */
scheme_eqv_hash_tree_type, /* 85 */
scheme_hash_tree_subtree_type, /* 86 */
scheme_hash_tree_collision_type, /* 87 */
scheme_hash_tree_indirection_type, /* 88 */
scheme_cpointer_type, /* 89 */
scheme_prefix_type, /* 90 */
scheme_weak_box_type, /* 91 */
scheme_ephemeron_type, /* 92 */
scheme_struct_type_type, /* 93 */
scheme_module_index_type, /* 94 */
scheme_set_macro_type, /* 95 */
scheme_listener_type, /* 96 */
scheme_namespace_type, /* 97 */
scheme_config_type, /* 98 */
scheme_stx_type, /* 99 */
scheme_will_executor_type, /* 100 */
scheme_custodian_type, /* 101 */
scheme_random_state_type, /* 102 */
scheme_regexp_type, /* 103 */
scheme_bucket_type, /* 104 */
scheme_bucket_table_type, /* 105 */
scheme_subprocess_type, /* 106 */
scheme_compilation_top_type, /* 107 */
scheme_wrap_chunk_type, /* 108 */
scheme_eval_waiting_type, /* 109 */
scheme_tail_call_waiting_type, /* 110 */
scheme_undefined_type, /* 111 */
scheme_struct_property_type, /* 112 */
scheme_chaperone_property_type, /* 113 */
scheme_multiple_values_type, /* 114 */
scheme_placeholder_type, /* 115 */
scheme_table_placeholder_type, /* 116 */
scheme_scope_table_type, /* 117 */
scheme_propagate_table_type, /* 118 */
scheme_svector_type, /* 119 */
scheme_resolve_prefix_type, /* 120 */
scheme_security_guard_type, /* 121 */
scheme_indent_type, /* 122 */
scheme_udp_type, /* 123 */
scheme_udp_evt_type, /* 124 */
scheme_tcp_accept_evt_type, /* 125 */
scheme_id_macro_type, /* 126 */
scheme_evt_set_type, /* 127 */
scheme_wrap_evt_type, /* 128 */
scheme_handle_evt_type, /* 129 */
scheme_replace_evt_type, /* 130 */
scheme_active_replace_evt_type, /* 131 */
scheme_nack_guard_evt_type, /* 132 */
scheme_semaphore_repost_type, /* 133 */
scheme_channel_type, /* 134 */
scheme_channel_put_type, /* 135 */
scheme_thread_resume_type, /* 136 */
scheme_thread_suspend_type, /* 137 */
scheme_thread_dead_type, /* 138 */
scheme_poll_evt_type, /* 139 */
scheme_nack_evt_type, /* 140 */
scheme_module_registry_type, /* 141 */
scheme_thread_set_type, /* 142 */
scheme_string_converter_type, /* 143 */
scheme_alarm_type, /* 144 */
scheme_thread_recv_evt_type, /* 145 */
scheme_thread_cell_type, /* 146 */
scheme_channel_syncer_type, /* 147 */
scheme_special_comment_type, /* 148 */
scheme_write_evt_type, /* 149 */
scheme_always_evt_type, /* 150 */
scheme_never_evt_type, /* 151 */
scheme_progress_evt_type, /* 152 */
scheme_place_dead_type, /* 153 */
scheme_already_comp_type, /* 154 */
scheme_readtable_type, /* 155 */
scheme_intdef_context_type, /* 156 */
scheme_lexical_rib_type, /* 157 */
scheme_thread_cell_values_type, /* 158 */
scheme_global_ref_type, /* 159 */
scheme_cont_mark_chain_type, /* 160 */
scheme_raw_pair_type, /* 161 */
scheme_prompt_type, /* 162 */
scheme_prompt_tag_type, /* 163 */
scheme_continuation_mark_key_type, /* 164 */
scheme_expanded_syntax_type, /* 165 */
scheme_delay_syntax_type, /* 166 */
scheme_cust_box_type, /* 167 */
scheme_resolved_module_path_type, /* 168 */
scheme_module_phase_exports_type, /* 169 */
scheme_logger_type, /* 170 */
scheme_log_reader_type, /* 171 */
scheme_marshal_share_type, /* 172 */
scheme_rib_delimiter_type, /* 173 */
scheme_noninline_proc_type, /* 174 */
scheme_prune_context_type, /* 175 */
scheme_future_type, /* 176 */
scheme_flvector_type, /* 177 */
scheme_extflvector_type, /* 178 */
scheme_fxvector_type, /* 179 */
scheme_place_type, /* 180 */
scheme_place_object_type, /* 181 */
scheme_place_async_channel_type, /* 182 */
scheme_place_bi_channel_type, /* 183 */
scheme_once_used_type, /* 184 */
scheme_serialized_symbol_type, /* 185 */
scheme_serialized_keyword_type, /* 186 */
scheme_serialized_structure_type, /* 187 */
scheme_fsemaphore_type, /* 188 */
scheme_serialized_tcp_fd_type, /* 189 */
scheme_serialized_file_fd_type, /* 190 */
scheme_port_closed_evt_type, /* 191 */
scheme_proc_shape_type, /* 192 */
scheme_struct_proc_shape_type, /* 193 */
scheme_phantom_bytes_type, /* 194 */
scheme_environment_variables_type, /* 195 */
scheme_filesystem_change_evt_type, /* 196 */
scheme_ctype_type, /* 197 */
scheme_plumber_type, /* 198 */
scheme_plumber_handle_type, /* 199 */
scheme_long_double_type, /* 57 */
scheme_char_string_type, /* 58 */
scheme_byte_string_type, /* 59 */
scheme_unix_path_type, /* 60 */
scheme_windows_path_type, /* 61 */
scheme_symbol_type, /* 62 */
scheme_keyword_type, /* 63 */
scheme_null_type, /* 64 */
scheme_pair_type, /* 65 */
scheme_mutable_pair_type, /* 66 */
scheme_vector_type, /* 67 */
scheme_inspector_type, /* 68 */
scheme_input_port_type, /* 69 */
scheme_output_port_type, /* 70 */
scheme_eof_type, /* 71 */
scheme_true_type, /* 72 */
scheme_false_type, /* 73 */
scheme_void_type, /* 74 */
scheme_syntax_compiler_type, /* 75 */
scheme_macro_type, /* 76 */
scheme_box_type, /* 77 */
scheme_thread_type, /* 78 */
scheme_scope_type, /* 79 */
scheme_stx_offset_type, /* 80 */
scheme_cont_mark_set_type, /* 81 */
scheme_sema_type, /* 82 */
scheme_hash_table_type, /* 83 */
scheme_hash_tree_type, /* 84 */
scheme_eq_hash_tree_type, /* 85 */
scheme_eqv_hash_tree_type, /* 86 */
scheme_hash_tree_subtree_type, /* 87 */
scheme_hash_tree_collision_type, /* 88 */
scheme_hash_tree_indirection_type, /* 89 */
scheme_cpointer_type, /* 90 */
scheme_prefix_type, /* 91 */
scheme_weak_box_type, /* 92 */
scheme_ephemeron_type, /* 93 */
scheme_struct_type_type, /* 94 */
scheme_module_index_type, /* 95 */
scheme_set_macro_type, /* 96 */
scheme_listener_type, /* 97 */
scheme_namespace_type, /* 98 */
scheme_config_type, /* 99 */
scheme_stx_type, /* 100 */
scheme_will_executor_type, /* 101 */
scheme_custodian_type, /* 102 */
scheme_random_state_type, /* 103 */
scheme_regexp_type, /* 104 */
scheme_bucket_type, /* 105 */
scheme_bucket_table_type, /* 106 */
scheme_subprocess_type, /* 107 */
scheme_compilation_top_type, /* 108 */
scheme_wrap_chunk_type, /* 109 */
scheme_eval_waiting_type, /* 110 */
scheme_tail_call_waiting_type, /* 111 */
scheme_undefined_type, /* 112 */
scheme_struct_property_type, /* 113 */
scheme_chaperone_property_type, /* 114 */
scheme_multiple_values_type, /* 115 */
scheme_placeholder_type, /* 116 */
scheme_table_placeholder_type, /* 117 */
scheme_scope_table_type, /* 118 */
scheme_propagate_table_type, /* 119 */
scheme_svector_type, /* 120 */
scheme_resolve_prefix_type, /* 121 */
scheme_security_guard_type, /* 122 */
scheme_indent_type, /* 123 */
scheme_udp_type, /* 124 */
scheme_udp_evt_type, /* 125 */
scheme_tcp_accept_evt_type, /* 126 */
scheme_id_macro_type, /* 127 */
scheme_evt_set_type, /* 128 */
scheme_wrap_evt_type, /* 129 */
scheme_handle_evt_type, /* 130 */
scheme_replace_evt_type, /* 131 */
scheme_active_replace_evt_type, /* 132 */
scheme_nack_guard_evt_type, /* 133 */
scheme_semaphore_repost_type, /* 134 */
scheme_channel_type, /* 135 */
scheme_channel_put_type, /* 136 */
scheme_thread_resume_type, /* 137 */
scheme_thread_suspend_type, /* 138 */
scheme_thread_dead_type, /* 139 */
scheme_poll_evt_type, /* 140 */
scheme_nack_evt_type, /* 141 */
scheme_module_registry_type, /* 142 */
scheme_thread_set_type, /* 143 */
scheme_string_converter_type, /* 144 */
scheme_alarm_type, /* 145 */
scheme_thread_recv_evt_type, /* 146 */
scheme_thread_cell_type, /* 147 */
scheme_channel_syncer_type, /* 148 */
scheme_special_comment_type, /* 149 */
scheme_write_evt_type, /* 150 */
scheme_always_evt_type, /* 151 */
scheme_never_evt_type, /* 152 */
scheme_progress_evt_type, /* 153 */
scheme_place_dead_type, /* 154 */
scheme_already_comp_type, /* 155 */
scheme_readtable_type, /* 156 */
scheme_intdef_context_type, /* 157 */
scheme_lexical_rib_type, /* 158 */
scheme_thread_cell_values_type, /* 159 */
scheme_global_ref_type, /* 160 */
scheme_cont_mark_chain_type, /* 161 */
scheme_raw_pair_type, /* 162 */
scheme_prompt_type, /* 163 */
scheme_prompt_tag_type, /* 164 */
scheme_continuation_mark_key_type, /* 165 */
scheme_expanded_syntax_type, /* 166 */
scheme_delay_syntax_type, /* 167 */
scheme_cust_box_type, /* 168 */
scheme_resolved_module_path_type, /* 169 */
scheme_module_phase_exports_type, /* 170 */
scheme_logger_type, /* 171 */
scheme_log_reader_type, /* 172 */
scheme_marshal_share_type, /* 173 */
scheme_rib_delimiter_type, /* 174 */
scheme_noninline_proc_type, /* 175 */
scheme_prune_context_type, /* 176 */
scheme_future_type, /* 177 */
scheme_flvector_type, /* 178 */
scheme_extflvector_type, /* 179 */
scheme_fxvector_type, /* 180 */
scheme_place_type, /* 181 */
scheme_place_object_type, /* 182 */
scheme_place_async_channel_type, /* 183 */
scheme_place_bi_channel_type, /* 184 */
scheme_once_used_type, /* 185 */
scheme_serialized_symbol_type, /* 186 */
scheme_serialized_keyword_type, /* 187 */
scheme_serialized_structure_type, /* 188 */
scheme_fsemaphore_type, /* 189 */
scheme_serialized_tcp_fd_type, /* 190 */
scheme_serialized_file_fd_type, /* 191 */
scheme_port_closed_evt_type, /* 192 */
scheme_proc_shape_type, /* 193 */
scheme_struct_proc_shape_type, /* 194 */
scheme_phantom_bytes_type, /* 195 */
scheme_environment_variables_type, /* 196 */
scheme_filesystem_change_evt_type, /* 197 */
scheme_ctype_type, /* 198 */
scheme_plumber_type, /* 199 */
scheme_plumber_handle_type, /* 200 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 200 */
_scheme_last_normal_type_, /* 201 */
scheme_rt_weak_array, /* 201 */
scheme_rt_weak_array, /* 202 */
scheme_rt_comp_env, /* 202 */
scheme_rt_constant_binding, /* 203 */
scheme_rt_resolve_info, /* 204 */
scheme_rt_unresolve_info, /* 205 */
scheme_rt_optimize_info, /* 206 */
scheme_rt_compile_info, /* 207 */
scheme_rt_cont_mark, /* 208 */
scheme_rt_saved_stack, /* 209 */
scheme_rt_reply_item, /* 210 */
scheme_rt_closure_info, /* 211 */
scheme_rt_overflow, /* 212 */
scheme_rt_overflow_jmp, /* 213 */
scheme_rt_meta_cont, /* 214 */
scheme_rt_dyn_wind_cell, /* 215 */
scheme_rt_dyn_wind_info, /* 216 */
scheme_rt_dyn_wind, /* 217 */
scheme_rt_dup_check, /* 218 */
scheme_rt_thread_memory, /* 219 */
scheme_rt_input_file, /* 220 */
scheme_rt_input_fd, /* 221 */
scheme_rt_oskit_console_input, /* 222 */
scheme_rt_tested_input_file, /* 223 */
scheme_rt_tested_output_file, /* 224 */
scheme_rt_indexed_string, /* 225 */
scheme_rt_output_file, /* 226 */
scheme_rt_load_handler_data, /* 227 */
scheme_rt_pipe, /* 228 */
scheme_rt_beos_process, /* 229 */
scheme_rt_system_child, /* 230 */
scheme_rt_tcp, /* 231 */
scheme_rt_write_data, /* 232 */
scheme_rt_tcp_select_info, /* 233 */
scheme_rt_param_data, /* 234 */
scheme_rt_will, /* 235 */
scheme_rt_linker_name, /* 236 */
scheme_rt_param_map, /* 237 */
scheme_rt_finalization, /* 238 */
scheme_rt_finalizations, /* 239 */
scheme_rt_cpp_object, /* 240 */
scheme_rt_cpp_array_object, /* 241 */
scheme_rt_stack_object, /* 242 */
scheme_rt_preallocated_object, /* 243 */
scheme_thread_hop_type, /* 244 */
scheme_rt_srcloc, /* 245 */
scheme_rt_evt, /* 246 */
scheme_rt_syncing, /* 247 */
scheme_rt_comp_prefix, /* 248 */
scheme_rt_user_input, /* 249 */
scheme_rt_user_output, /* 250 */
scheme_rt_compact_port, /* 251 */
scheme_rt_read_special_dw, /* 252 */
scheme_rt_regwork, /* 253 */
scheme_rt_rx_lazy_string, /* 254 */
scheme_rt_buf_holder, /* 255 */
scheme_rt_parameterization, /* 256 */
scheme_rt_print_params, /* 257 */
scheme_rt_read_params, /* 258 */
scheme_rt_native_code, /* 259 */
scheme_rt_native_code_plus_case, /* 260 */
scheme_rt_jitter_data, /* 261 */
scheme_rt_module_exports, /* 262 */
scheme_rt_delay_load_info, /* 263 */
scheme_rt_marshal_info, /* 264 */
scheme_rt_unmarshal_info, /* 265 */
scheme_rt_runstack, /* 266 */
scheme_rt_sfs_info, /* 267 */
scheme_rt_validate_clearing, /* 268 */
scheme_rt_lightweight_cont, /* 269 */
scheme_rt_export_info, /* 270 */
scheme_rt_cont_jmp, /* 271 */
scheme_rt_letrec_check_frame, /* 272 */
scheme_rt_comp_env, /* 203 */
scheme_rt_constant_binding, /* 204 */
scheme_rt_resolve_info, /* 205 */
scheme_rt_unresolve_info, /* 206 */
scheme_rt_optimize_info, /* 207 */
scheme_rt_compile_info, /* 208 */
scheme_rt_cont_mark, /* 209 */
scheme_rt_saved_stack, /* 210 */
scheme_rt_reply_item, /* 211 */
scheme_rt_closure_info, /* 212 */
scheme_rt_overflow, /* 213 */
scheme_rt_overflow_jmp, /* 214 */
scheme_rt_meta_cont, /* 215 */
scheme_rt_dyn_wind_cell, /* 216 */
scheme_rt_dyn_wind_info, /* 217 */
scheme_rt_dyn_wind, /* 218 */
scheme_rt_dup_check, /* 219 */
scheme_rt_thread_memory, /* 220 */
scheme_rt_input_file, /* 221 */
scheme_rt_input_fd, /* 222 */
scheme_rt_oskit_console_input, /* 223 */
scheme_rt_tested_input_file, /* 224 */
scheme_rt_tested_output_file, /* 225 */
scheme_rt_indexed_string, /* 226 */
scheme_rt_output_file, /* 227 */
scheme_rt_load_handler_data, /* 228 */
scheme_rt_pipe, /* 229 */
scheme_rt_beos_process, /* 230 */
scheme_rt_system_child, /* 231 */
scheme_rt_tcp, /* 232 */
scheme_rt_write_data, /* 233 */
scheme_rt_tcp_select_info, /* 234 */
scheme_rt_param_data, /* 235 */
scheme_rt_will, /* 236 */
scheme_rt_linker_name, /* 237 */
scheme_rt_param_map, /* 238 */
scheme_rt_finalization, /* 239 */
scheme_rt_finalizations, /* 240 */
scheme_rt_cpp_object, /* 241 */
scheme_rt_cpp_array_object, /* 242 */
scheme_rt_stack_object, /* 243 */
scheme_rt_preallocated_object, /* 244 */
scheme_thread_hop_type, /* 245 */
scheme_rt_srcloc, /* 246 */
scheme_rt_evt, /* 247 */
scheme_rt_syncing, /* 248 */
scheme_rt_comp_prefix, /* 249 */
scheme_rt_user_input, /* 250 */
scheme_rt_user_output, /* 251 */
scheme_rt_compact_port, /* 252 */
scheme_rt_read_special_dw, /* 253 */
scheme_rt_regwork, /* 254 */
scheme_rt_rx_lazy_string, /* 255 */
scheme_rt_buf_holder, /* 256 */
scheme_rt_parameterization, /* 257 */
scheme_rt_print_params, /* 258 */
scheme_rt_read_params, /* 259 */
scheme_rt_native_code, /* 260 */
scheme_rt_native_code_plus_case, /* 261 */
scheme_rt_jitter_data, /* 262 */
scheme_rt_module_exports, /* 263 */
scheme_rt_delay_load_info, /* 264 */
scheme_rt_marshal_info, /* 265 */
scheme_rt_unmarshal_info, /* 266 */
scheme_rt_runstack, /* 267 */
scheme_rt_sfs_info, /* 268 */
scheme_rt_validate_clearing, /* 269 */
scheme_rt_lightweight_cont, /* 270 */
scheme_rt_export_info, /* 271 */
scheme_rt_cont_jmp, /* 272 */
scheme_rt_letrec_check_frame, /* 273 */
#endif
scheme_deferred_expr_type, /* 273 */
scheme_deferred_expr_type, /* 274 */
_scheme_last_type_
};

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

@ -135,6 +135,7 @@ scheme_init_type ()
set_name(scheme_require_form_type, "<require-code>");
set_name(scheme_varref_form_type, "<varref-code>");
set_name(scheme_apply_values_type, "<apply-values-code>");
set_name(scheme_with_immed_mark_type, "<with-immediate-mark-code>");
set_name(scheme_case_lambda_sequence_type, "<case-lambda-code>");
set_name(scheme_let_value_type, "<let-value-code>");
@ -574,6 +575,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_begin_for_syntax_type, vector_obj);
GC_REG_TRAV(scheme_varref_form_type, twoptr_obj);
GC_REG_TRAV(scheme_apply_values_type, twoptr_obj);
GC_REG_TRAV(scheme_with_immed_mark_type, with_cont_mark);
GC_REG_TRAV(scheme_boxenv_type, twoptr_obj);
GC_REG_TRAV(scheme_case_lambda_sequence_type, case_closure);
GC_REG_TRAV(scheme_begin0_sequence_type, seq_rec);

30
racket/src/racket/src/validate.c
View File

@ -1995,6 +1995,36 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result_ignored, vc, tailpos, procs);
result = validate_join(0, result);
break;
case scheme_with_immed_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr;
int r;
no_typed(need_local_type, port);
r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp,
NULL, 0, 0, vc, 0, 0, procs,
1, _st_ht);
result = validate_join_seq(r, result);
r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp,
NULL, 0, 0, vc, 0, 0, procs,
1, _st_ht);
result = validate_join_seq(r, result);
--delta;
if (delta < 0)
scheme_ill_formed_code(port);
stack[delta] = VALID_VAL;
expr = wcm->body;
goto top;
}
break;
case scheme_case_lambda_sequence_type:
no_typed(need_local_type, port);
case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta,