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

add compiled-expression-recompile

Browse Source 
Uses an unresolver pass, which is expanded to work on more programs.
This commit is contained in:
Blake Johnson 2015-08-10 14:34:07 -06:00 committed by Matthew Flatt
parent d66da8ff3b
commit fbe8537f18
14 changed files with 2291 additions and 773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-doc/scribblings/reference/eval.scrbl
View File

@ -484,6 +484,18 @@ Like @racket[eval-syntax], but calls the current @tech{compilation
handler} in tail position with @racket[stx].} handler} in tail position with @racket[stx].}
@defproc[(compiled-expression-recompile [ce compiled-expression?]) compiled-expression?]{
Recompiles @racket[ce], effectively re-running optimization passes to
produce an equivalent compiled form with potentially different
performance characteristics.
If @racket[ce] includes module forms, then only phase-0 code in the
immediate module (not in submodules) is recompiled.
@history[#:added "6.2.900.9"]}
@defproc[(compiled-expression? [v any/c]) boolean?]{ @defproc[(compiled-expression? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a compiled form, @racket[#f] Returns @racket[#t] if @racket[v] is a compiled form, @racket[#f]

114
racket/src/racket/mk-gdbinit.rkt
View File

@ -73,6 +73,10 @@ define psoq
set $TL = ((Scheme_Toplevel*) ($O)) set $TL = ((Scheme_Toplevel*) ($O))
printf "scheme_toplevel_type depth=%d position=%d", $TL->depth, $TL->position printf "scheme_toplevel_type depth=%d position=%d", $TL->depth, $TL->position
end end
if ( $OT == <<scheme_local_type>> )
set $local = ((Scheme_Local *) ($O))
printf "scheme_local position=%d", $local->position
end
# if ( $OT == <<scheme_symbol_type>> ) # if ( $OT == <<scheme_symbol_type>> )
# set $SSO = ((Scheme_Simple_Object*) ($O)) # set $SSO = ((Scheme_Simple_Object*) ($O))
# set $index = $SSO->u.ptr_int_val.pint # set $index = $SSO->u.ptr_int_val.pint
@ -86,11 +90,11 @@ define psoq
printf "scheme_application_type - args %i\n", $size printf "scheme_application_type - args %i\n", $size
set $RATOR = $AP->args[0] set $RATOR = $AP->args[0]
indent $arg1 indent $arg1
printf "rator=" printf "rator = "
psox $RATOR $arg1+1 psonn $RATOR
printf "\n"
set $cnt = 1 set $cnt = 1
while ( $cnt < $size ) while ( $cnt <= $size )
indent $arg1 indent $arg1
printf "rand%i = ", ($cnt - 1) printf "rand%i = ", ($cnt - 1)
psonn $AP->args[$cnt] psonn $AP->args[$cnt]
@ -135,7 +139,85 @@ define psoq
psox $unclosure->code $arg1+1 psox $unclosure->code $arg1+1
set $OT = <<scheme_unclosed_procedure_type>> set $OT = <<scheme_unclosed_procedure_type>>
end end
if ( $OT == <<scheme_compiled_unclosed_procedure_type>> )
set $unclosure = ((Scheme_Closure_Data *) $O)
#set $name = $code->name
set $param_num = $unclosure->num_params
printf "scheme_compiled_unclosed_procedure_type - num_params %i\n", $param_num
psox $unclosure->code $arg1+1
end
if ( $OT == <<scheme_let_value_type>> )
set $let_value = ((Scheme_Let_Value *) $O)
set $cnt = $let_value->count
set $pos = $let_value->position
set $val = $let_value->value
set $body = $let_value->body
printf "scheme_let_value\n"
indent $arg1
printf "count = %i\n", $cnt
indent $arg1
printf "position = %i\n", $pos
psox $val $arg1+1
printf "\n"
psox $body $arg1+1
printf "\n"
end
if ( $OT == <<scheme_let_void_type>> )
set $let_void = ((Scheme_Let_Void *) $O)
set $cnt = $let_void->count
set $body = $let_void->body
printf "scheme_let_void\n"
indent $arg1
printf "count = %i\n", $cnt
indent $arg1
printf "body = "
psox $body $arg1+1
printf "\n"
end
if ( $OT == <<scheme_compiled_let_void_type>> )
set $let_header = ((Scheme_Let_Header *) $O)
set $cnt = $let_header->count
set $clauses = $let_header->num_clauses
set $body = $let_header->body
printf "scheme_let_header\n"
indent $arg1
printf "count = %i, num_clauses = %i\n", $cnt, $clauses
indent $arg1
printf "body = "
psox $body $arg1+1
printf "\n"
end
if ( $OT == <<scheme_compiled_let_value_type>> )
set $let_value = ((Scheme_Compiled_Let_Value *) $O)
set $cnt = $let_value->count
set $pos = $let_value->position
set $val = $let_value->value
set $body = $let_value->body
printf "scheme_compiled_let_value\n"
indent $arg1
printf "count = %i, position = %i\n", $cnt, $pos
indent $arg1
printf "value =\n"
psox $val $arg1+1
printf "\n"
indent $arg1
printf "body =\n"
psox $body $arg1+1
printf "\n"
end
if ( $OT == <<scheme_set_bang_type>> )
set $sb = ((Scheme_Set_Bang *) $O)
set $var = $sb->var
set $val = $sb->val
printf "scheme_set_bang\n"
indent $arg1
printf "var = "
psox $var $arg1+1
printf "\n"
printf "val = "
psox $val $arg1+1
printf "\n"
end
if ( $OT == <<scheme_sequence_type>> ) if ( $OT == <<scheme_sequence_type>> )
set $seq = ((Scheme_Sequence *) $O) set $seq = ((Scheme_Sequence *) $O)
set $size = $seq->count set $size = $seq->count
@ -151,6 +233,21 @@ define psoq
end end
set $OT = 0 set $OT = 0
end end
if ( $OT == <<scheme_begin0_sequence_type>> )
set $seq = ((Scheme_Sequence *) $O)
set $size = $seq->count
printf "scheme_begin0_sequence - size %i\n", $size
set $cnt = 0
while ( $cnt < $size )
indent $arg1
printf "%i - ", $cnt
psonn $seq->array[$cnt]
printf "\n"
#psox $seq->array[$cnt] $arg1+2
set $cnt++
end
set $OT = 0
end
if ( $OT == <<scheme_branch_type>>) if ( $OT == <<scheme_branch_type>>)
set $breq = ((Scheme_Branch_Rec *) $O) set $breq = ((Scheme_Branch_Rec *) $O)
printf "scheme_branch_type\n" printf "scheme_branch_type\n"
@ -185,6 +282,13 @@ define psoq
indent $arg1+1 indent $arg1+1
printf "body %p\n", $letone->body printf "body %p\n", $letone->body
end end
if ( $OT == <<scheme_boxenv_type>> )
set $box = ((Scheme_Simple_Object *) $O)
printf "scheme_boxenv_type\n"
psox $box->u.two_ptr_val.ptr1 $arg1+1
printf "\n"
psox $box->u.two_ptr_val.ptr2 $arg1+1
end
if ( $OT == <<scheme_closure_type>> ) if ( $OT == <<scheme_closure_type>> )
printf "scheme_closure_type\n" printf "scheme_closure_type\n"
set $closure = ((Scheme_Closure *) $O) set $closure = ((Scheme_Closure *) $O)

31
racket/src/racket/src/compenv.c
View File

@ -730,23 +730,12 @@ Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags
return scheme_make_toplevel(tl->depth, tl->position, 0, flags); return scheme_make_toplevel(tl->depth, tl->position, 0, flags);
} }
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp)
Scheme_Compile_Info *rec, int drec)
{ {
Comp_Prefix *cp = env->prefix;
Scheme_Local *l; Scheme_Local *l;
Scheme_Object *o; Scheme_Object *o;
int pos; int pos;
if (rec && rec[drec].dont_mark_local_use) {
/* Make up anything; it's going to be ignored. */
l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local));
l->iso.so.type = scheme_compiled_quote_syntax_type;
l->position = 0;
return (Scheme_Object *)l;
}
if (!cp->stxes) { if (!cp->stxes) {
Scheme_Hash_Table *ht; Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr); ht = scheme_make_hash_table(SCHEME_hash_ptr);
@ -767,6 +756,24 @@ Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env
return o; return o;
} }
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
{
Scheme_Local *l;
Comp_Prefix *cp = env->prefix;
if (rec && rec[drec].dont_mark_local_use) {
/* Make up anything; it's going to be ignored. */
l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local));
l->iso.so.type = scheme_compiled_quote_syntax_type;
l->position = 0;
return (Scheme_Object *)l;
}
return scheme_register_stx_in_comp_prefix(var, cp);
}
/*========================================================================*/ /*========================================================================*/
/* compile-time env, lookup bindings */ /* compile-time env, lookup bindings */
/*========================================================================*/ /*========================================================================*/

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

File diff suppressed because it is too large Load Diff

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

@ -96,7 +96,9 @@
The third pass, called "optimize", performs constant propagation, The third pass, called "optimize", performs constant propagation,
constant folding, and function inlining; this pass mutates records constant folding, and function inlining; this pass mutates records
produced by the "letrec_check" pass. See "optimize.c". produced by the "letrec_check" pass. See "optimize.c". This pass
isn't optional; for example, it calculates closure information that
the third pass uses.
The fourth pass, called "resolve", finishes compilation by computing The fourth pass, called "resolve", finishes compilation by computing
variable offsets and indirections (often mutating the records variable offsets and indirections (often mutating the records
@ -191,7 +193,8 @@
SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON; SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON;
void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; } void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; }
SHARED_OK static int valdiate_compile_result = 0; SHARED_OK static int validate_compile_result = 0;
SHARED_OK static int recompile_every_compile = 0;
/* THREAD LOCAL SHARED */ /* THREAD LOCAL SHARED */
THREAD_LOCAL_DECL(volatile int scheme_fuel_counter); THREAD_LOCAL_DECL(volatile int scheme_fuel_counter);
@ -234,6 +237,7 @@ READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rand
static Scheme_Object *eval(int argc, Scheme_Object *argv[]); static Scheme_Object *eval(int argc, Scheme_Object *argv[]);
static Scheme_Object *compile(int argc, Scheme_Object *argv[]); static Scheme_Object *compile(int argc, Scheme_Object *argv[]);
static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]); static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *recompile(int argc, Scheme_Object *argv[]);
static Scheme_Object *expand(int argc, Scheme_Object **argv); static Scheme_Object *expand(int argc, Scheme_Object **argv);
static Scheme_Object *local_expand(int argc, Scheme_Object **argv); static Scheme_Object *local_expand(int argc, Scheme_Object **argv);
static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv); static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv);
@ -259,6 +263,8 @@ static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv);
static Scheme_Object *use_jit(int argc, Scheme_Object **argv); static Scheme_Object *use_jit(int argc, Scheme_Object **argv);
static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv); static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv);
static Scheme_Object *recompile_top(Scheme_Object *top);
static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env); static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full); void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full);
@ -351,6 +357,7 @@ scheme_init_eval (Scheme_Env *env)
GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env); GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env);
GLOBAL_PRIM_W_ARITY("compile", compile, 1, 1, env); GLOBAL_PRIM_W_ARITY("compile", compile, 1, 1, env);
GLOBAL_PRIM_W_ARITY("compiled-expression-recompile", recompile, 1, 1, env);
GLOBAL_PRIM_W_ARITY("compile-syntax", compile_stx, 1, 1, env); GLOBAL_PRIM_W_ARITY("compile-syntax", compile_stx, 1, 1, env);
GLOBAL_PRIM_W_ARITY("compiled-expression?", compiled_p, 1, 1, env); GLOBAL_PRIM_W_ARITY("compiled-expression?", compiled_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("expand", expand, 1, 1, env); GLOBAL_PRIM_W_ARITY("expand", expand, 1, 1, env);
@ -379,7 +386,24 @@ scheme_init_eval (Scheme_Env *env)
/* Enables validation of bytecode as it is generated, /* Enables validation of bytecode as it is generated,
to double-check that the compiler is producing to double-check that the compiler is producing
valid bytecode as it should. */ valid bytecode as it should. */
valdiate_compile_result = 1; validate_compile_result = 1;
}
{
/* Enables re-running the optimizer N times on every compilation. */
const char *s;
s = getenv("PLT_RECOMPILE_COMPILE");
if (s) {
int i = 0;
while ((s[i] >= '0') && (s[i] <= '9')) {
recompile_every_compile = (recompile_every_compile * 10) + (s[i]-'0');
i++;
}
if (recompile_every_compile <= 0)
recompile_every_compile = 1;
else if (recompile_every_compile > 32)
recompile_every_compile = 32;
}
} }
} }
@ -3531,7 +3555,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
c = lv->count; c = lv->count;
i = lv->position; i = lv->position;
ab = SCHEME_LET_AUTOBOX(lv); ab = SCHEME_LET_VALUE_AUTOBOX(lv);
value = lv->value; value = lv->value;
obj = lv->body; obj = lv->body;
@ -3593,7 +3617,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
PUSH_RUNSTACK(p, RUNSTACK, c); PUSH_RUNSTACK(p, RUNSTACK, c);
RUNSTACK_CHANGED(); RUNSTACK_CHANGED();
if (SCHEME_LET_AUTOBOX(lv)) { if (SCHEME_LET_VOID_AUTOBOX(lv)) {
GC_MAYBE_IGNORE_INTERIOR Scheme_Object **stack = RUNSTACK; GC_MAYBE_IGNORE_INTERIOR Scheme_Object **stack = RUNSTACK;
UPDATE_THREAD_RSPTR_FOR_GC(); UPDATE_THREAD_RSPTR_FOR_GC();
@ -3991,6 +4015,48 @@ static int get_comp_flags(Scheme_Config *config)
return comp_flags; return comp_flags;
} }
static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, Comp_Prefix *cp, Scheme_Object *src_insp_desc)
{
Optimize_Info *oi;
Resolve_Prefix *rp;
Resolve_Info *ri;
Scheme_Compilation_Top *top;
/* TODO: see if this can be moved here completely */
int comp_flags, enforce_consts, max_let_depth;
Scheme_Config *config;
config = scheme_current_config();
enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS));
comp_flags = get_comp_flags(config);
if (enforce_consts)
comp_flags |= COMP_ENFORCE_CONSTS;
oi = scheme_optimize_info_create(cp, 1);
scheme_optimize_info_enforce_const(oi, enforce_consts);
if (!(comp_flags & COMP_CAN_INLINE))
scheme_optimize_info_never_inline(oi);
o = scheme_optimize_expr(o, oi, 0);
rp = scheme_resolve_prefix(0, cp, src_insp_desc);
ri = scheme_resolve_info_create(rp);
scheme_resolve_info_enforce_const(ri, enforce_consts);
scheme_enable_expression_resolve_lifts(ri);
o = scheme_resolve_expr(o, ri);
max_let_depth = scheme_resolve_info_max_let_depth(ri);
o = scheme_sfs(o, NULL, max_let_depth);
o = scheme_merge_expression_resolve_lifts(o, rp, ri);
rp = scheme_remap_prefix(rp, ri);
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->iso.so.type = scheme_compilation_top_type;
top->max_let_depth = max_let_depth;
top->code = o;
top->prefix = rp;
return (Scheme_Object *)top;
}
static void *compile_k(void) static void *compile_k(void)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
@ -4189,7 +4255,14 @@ static void *compile_k(void)
top->code = o; top->code = o;
top->prefix = rp; top->prefix = rp;
if (valdiate_compile_result) { if (recompile_every_compile) {
int i;
for (i = recompile_every_compile; i--; ) {
top = (Scheme_Compilation_Top *)recompile_top((Scheme_Object *)top);
}
}
if (validate_compile_result) {
scheme_validate_code(NULL, top->code, scheme_validate_code(NULL, top->code,
top->max_let_depth, top->max_let_depth,
top->prefix->num_toplevels, top->prefix->num_toplevels,
@ -4810,6 +4883,39 @@ compiled_p(int argc, Scheme_Object *argv[])
: scheme_false); : scheme_false);
} }
static Scheme_Object *recompile_top(Scheme_Object *top)
{
Comp_Prefix *cp;
Scheme_Object *code;
#if 0
printf("Resolved Code:\n%s\n\n", scheme_print_to_string(((Scheme_Compilation_Top *)top)->code, NULL));
#endif
code = scheme_unresolve_top(top, &cp);
#if 0
printf("Unresolved Prefix:\n");
printf("%s\n\n", scheme_print_to_string(cp, NULL));
printf("Unresolved Code:\n");
printf("%s\n\n", scheme_print_to_string(code, NULL));
#endif
top = optimize_resolve_expr(code, cp, ((Scheme_Compilation_Top*)top)->prefix->src_insp_desc);
return top;
}
static Scheme_Object *
recompile(int argc, Scheme_Object *argv[])
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type)) {
scheme_wrong_contract("compiled-expression-recompile", "compiled-expression?", 0, argc, argv);
}
return recompile_top(argv[0]);
}
static Scheme_Object *expand(int argc, Scheme_Object **argv) static Scheme_Object *expand(int argc, Scheme_Object **argv)
{ {
Scheme_Env *env; Scheme_Env *env;

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

@ -719,7 +719,7 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth)
case scheme_let_value_type: case scheme_let_value_type:
if (depth) { if (depth) {
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj; Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
if (SCHEME_LET_AUTOBOX(lv)) if (SCHEME_LET_VALUE_AUTOBOX(lv))
return 0; return 0;
return scheme_is_non_gc(lv->body, depth - 1); return scheme_is_non_gc(lv->body, depth - 1);
} }
@ -733,7 +733,7 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth)
case scheme_let_void_type: case scheme_let_void_type:
if (depth) { if (depth) {
Scheme_Let_Void *lv = (Scheme_Let_Void *)obj; Scheme_Let_Void *lv = (Scheme_Let_Void *)obj;
if (SCHEME_LET_AUTOBOX(lv)) if (SCHEME_LET_VOID_AUTOBOX(lv))
return 0; return 0;
return scheme_is_non_gc(lv->body, depth - 1); return scheme_is_non_gc(lv->body, depth - 1);
} }
@ -2721,7 +2721,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_let_value_type: case scheme_let_value_type:
{ {
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj; Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos; int ab = SCHEME_LET_VALUE_AUTOBOX(lv), i, pos;
mz_jit_unbox_state ubs; mz_jit_unbox_state ubs;
START_JIT_DATA(); START_JIT_DATA();
@ -2829,7 +2829,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
scheme_stack_safety(jitter, c, 0); scheme_stack_safety(jitter, c, 0);
mz_runstack_pushed(jitter, c); mz_runstack_pushed(jitter, c);
if (SCHEME_LET_AUTOBOX(lv)) { if (SCHEME_LET_VOID_AUTOBOX(lv)) {
int i; int i;
mz_rs_sync(); mz_rs_sync();
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();

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

@ -180,7 +180,7 @@ static Scheme_Object *write_let_value(Scheme_Object *obj)
return cons(scheme_make_integer(lv->count), return cons(scheme_make_integer(lv->count),
cons(scheme_make_integer(lv->position), cons(scheme_make_integer(lv->position),
cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, cons(SCHEME_LET_VALUE_AUTOBOX(lv) ? scheme_true : scheme_false,
cons(scheme_protect_quote(lv->value), cons(scheme_protect_quote(lv->value),
scheme_protect_quote(lv->body))))); scheme_protect_quote(lv->body)))));
} }
@ -199,7 +199,7 @@ static Scheme_Object *read_let_value(Scheme_Object *obj)
lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj)); lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL; if (!SCHEME_PAIRP(obj)) return NULL;
SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); SCHEME_LET_VALUE_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL; if (!SCHEME_PAIRP(obj)) return NULL;
lv->value = SCHEME_CAR(obj); lv->value = SCHEME_CAR(obj);
@ -215,7 +215,7 @@ static Scheme_Object *write_let_void(Scheme_Object *obj)
lv = (Scheme_Let_Void *)obj; lv = (Scheme_Let_Void *)obj;
return cons(scheme_make_integer(lv->count), return cons(scheme_make_integer(lv->count),
cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, cons(SCHEME_LET_VOID_AUTOBOX(lv) ? scheme_true : scheme_false,
scheme_protect_quote(lv->body))); scheme_protect_quote(lv->body)));
} }
@ -230,7 +230,7 @@ static Scheme_Object *read_let_void(Scheme_Object *obj)
lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL; if (!SCHEME_PAIRP(obj)) return NULL;
SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); SCHEME_LET_VOID_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
lv->body = SCHEME_CDR(obj); lv->body = SCHEME_CDR(obj);
return (Scheme_Object *)lv; return (Scheme_Object *)lv;

12
racket/src/racket/src/mzmark_resolve.inc
View File

@ -57,6 +57,12 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->depths, gc); gcMARK2(i->depths, gc);
gcMARK2(i->prefix, gc); gcMARK2(i->prefix, gc);
gcMARK2(i->closures, gc); gcMARK2(i->closures, gc);
gcMARK2(i->closures, gc);
gcMARK2(i->module, gc);
gcMARK2(i->comp_prefix, gc);
gcMARK2(i->toplevels, gc);
gcMARK2(i->definitions, gc);
gcMARK2(i->ref_args, gc);
return return
gcBYTES_TO_WORDS(sizeof(Unresolve_Info)); gcBYTES_TO_WORDS(sizeof(Unresolve_Info));
@ -69,6 +75,12 @@ static int mark_unresolve_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->depths, gc); gcFIXUP2(i->depths, gc);
gcFIXUP2(i->prefix, gc); gcFIXUP2(i->prefix, gc);
gcFIXUP2(i->closures, gc); gcFIXUP2(i->closures, gc);
gcFIXUP2(i->closures, gc);
gcFIXUP2(i->module, gc);
gcFIXUP2(i->comp_prefix, gc);
gcFIXUP2(i->toplevels, gc);
gcFIXUP2(i->definitions, gc);
gcFIXUP2(i->ref_args, gc);
return return
gcBYTES_TO_WORDS(sizeof(Unresolve_Info)); gcBYTES_TO_WORDS(sizeof(Unresolve_Info));

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

@ -1309,6 +1309,12 @@ mark_unresolve_info {
gcMARK2(i->depths, gc); gcMARK2(i->depths, gc);
gcMARK2(i->prefix, gc); gcMARK2(i->prefix, gc);
gcMARK2(i->closures, gc); gcMARK2(i->closures, gc);
gcMARK2(i->closures, gc);
gcMARK2(i->module, gc);
gcMARK2(i->comp_prefix, gc);
gcMARK2(i->toplevels, gc);
gcMARK2(i->definitions, gc);
gcMARK2(i->ref_args, gc);
size: size:
gcBYTES_TO_WORDS(sizeof(Unresolve_Info)); gcBYTES_TO_WORDS(sizeof(Unresolve_Info));

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

File diff suppressed because it is too large Load Diff

2
racket/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 1132 #define EXPECTED_PRIM_COUNT 1133
#define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_EXTFL_COUNT 45

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

@ -1415,7 +1415,7 @@ typedef struct {
with a chain of Scheme_Compiled_Let_Value records as its body, with a chain of Scheme_Compiled_Let_Value records as its body,
where there's one Scheme_Compiled_Let_Value for each binding where there's one Scheme_Compiled_Let_Value for each binding
clause. A `let*' is normally expanded to nested `let's before clause. A `let*' is normally expanded to nested `let's before
compilation, but the intermediate format also supposrts `let*', compilation, but the intermediate format also supports `let*',
which is useful mostly for converting a simple enough `letrec' form which is useful mostly for converting a simple enough `letrec' form
into `let*. into `let*.
@ -1542,7 +1542,7 @@ typedef struct Scheme_Let_Value {
Scheme_Object *body; Scheme_Object *body;
} Scheme_Let_Value; } Scheme_Let_Value;
#define SCHEME_LET_AUTOBOX(lh) MZ_OPT_HASH_KEY(&lh->iso) #define SCHEME_LET_VALUE_AUTOBOX(lv) MZ_OPT_HASH_KEY(&lv->iso)
typedef struct Scheme_Let_One { typedef struct Scheme_Let_One {
Scheme_Inclhash_Object iso; /* keyex used for eval_type + flonum/unused (and can't be hashed) */ Scheme_Inclhash_Object iso; /* keyex used for eval_type + flonum/unused (and can't be hashed) */
@ -1563,6 +1563,8 @@ typedef struct Scheme_Let_Void {
Scheme_Object *body; Scheme_Object *body;
} Scheme_Let_Void; } Scheme_Let_Void;
#define SCHEME_LET_VOID_AUTOBOX(lv) MZ_OPT_HASH_KEY(&lv->iso)
typedef struct Scheme_Letrec { typedef struct Scheme_Letrec {
Scheme_Object so; Scheme_Object so;
mzshort count; mzshort count;
@ -2949,6 +2951,10 @@ Scheme_Object *scheme_register_toplevel_in_comp_prefix(Scheme_Object *var, Comp_
void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id); void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id);
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec); Scheme_Compile_Info *rec, int drec);
Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp);
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv);
void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env); void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env);
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
@ -3024,6 +3030,7 @@ Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *); Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *); Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases); Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases);
Scheme_Object *scheme_unresolve_top(Scheme_Object *, Comp_Prefix **);
int scheme_check_leaf_rator(Scheme_Object *le, int *_flags); int scheme_check_leaf_rator(Scheme_Object *le, int *_flags);

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.2.900.8" #define MZSCHEME_VERSION "6.2.900.9"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 900 #define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_W 9
#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)

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

@ -1798,16 +1798,16 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
for (i = 0; i < c; i++, p++) { for (i = 0; i < c; i++, p++) {
if ((q < 0) if ((q < 0)
|| (p < 0) || (p < 0)
|| (SCHEME_LET_AUTOBOX(lv) && ((p >= depth) || (SCHEME_LET_VALUE_AUTOBOX(lv) && ((p >= depth)
|| ((stack[p] != VALID_BOX) || ((stack[p] != VALID_BOX)
&& (stack[p] != VALID_BOX_NOCLEAR)))) && (stack[p] != VALID_BOX_NOCLEAR))))
|| (!SCHEME_LET_AUTOBOX(lv) && ((p >= letlimit) || (!SCHEME_LET_VALUE_AUTOBOX(lv) && ((p >= letlimit)
|| !(WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL) || !(WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL)
|| WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL_NOCLEAR) || WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL_NOCLEAR)
|| (stack[p] == VALID_UNINIT))))) || (stack[p] == VALID_UNINIT)))))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
if (!SCHEME_LET_AUTOBOX(lv)) { if (!SCHEME_LET_VALUE_AUTOBOX(lv)) {
if (stack[p] != VALID_VAL_NOCLEAR) if (stack[p] != VALID_VAL_NOCLEAR)
stack[p] = VALID_VAL; stack[p] = VALID_VAL;
} }
@ -1827,7 +1827,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
if ((c < 0) || (c > delta)) if ((c < 0) || (c > delta))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
if (SCHEME_LET_AUTOBOX(lv)) { if (SCHEME_LET_VOID_AUTOBOX(lv)) {
for (i = 0; i < c; i++) { for (i = 0; i < c; i++) {
stack[--delta] = VALID_BOX; stack[--delta] = VALID_BOX;
} }