add compiled-expression-recompile
Uses an unresolver pass, which is expanded to work on more programs.
This commit is contained in:
parent
d66da8ff3b
commit
fbe8537f18
|
@ -484,6 +484,18 @@ Like @racket[eval-syntax], but calls the current @tech{compilation
|
|||
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?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is a compiled form, @racket[#f]
|
||||
|
|
|
@ -73,6 +73,10 @@ define psoq
|
|||
set $TL = ((Scheme_Toplevel*) ($O))
|
||||
printf "scheme_toplevel_type depth=%d position=%d", $TL->depth, $TL->position
|
||||
end
|
||||
if ( $OT == <<scheme_local_type>> )
|
||||
set $local = ((Scheme_Local *) ($O))
|
||||
printf "scheme_local position=%d", $local->position
|
||||
end
|
||||
# if ( $OT == <<scheme_symbol_type>> )
|
||||
# set $SSO = ((Scheme_Simple_Object*) ($O))
|
||||
# set $index = $SSO->u.ptr_int_val.pint
|
||||
|
@ -86,11 +90,11 @@ define psoq
|
|||
printf "scheme_application_type - args %i\n", $size
|
||||
set $RATOR = $AP->args[0]
|
||||
indent $arg1
|
||||
printf "rator="
|
||||
psox $RATOR $arg1+1
|
||||
|
||||
printf "rator = "
|
||||
psonn $RATOR
|
||||
printf "\n"
|
||||
set $cnt = 1
|
||||
while ( $cnt < $size )
|
||||
while ( $cnt <= $size )
|
||||
indent $arg1
|
||||
printf "rand%i = ", ($cnt - 1)
|
||||
psonn $AP->args[$cnt]
|
||||
|
@ -135,7 +139,85 @@ define psoq
|
|||
psox $unclosure->code $arg1+1
|
||||
set $OT = <<scheme_unclosed_procedure_type>>
|
||||
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>> )
|
||||
set $seq = ((Scheme_Sequence *) $O)
|
||||
set $size = $seq->count
|
||||
|
@ -151,6 +233,21 @@ define psoq
|
|||
end
|
||||
set $OT = 0
|
||||
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>>)
|
||||
set $breq = ((Scheme_Branch_Rec *) $O)
|
||||
printf "scheme_branch_type\n"
|
||||
|
@ -185,6 +282,13 @@ define psoq
|
|||
indent $arg1+1
|
||||
printf "body %p\n", $letone->body
|
||||
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>> )
|
||||
printf "scheme_closure_type\n"
|
||||
set $closure = ((Scheme_Closure *) $O)
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
|
||||
Scheme_Compile_Info *rec, int drec)
|
||||
Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp)
|
||||
{
|
||||
Comp_Prefix *cp = env->prefix;
|
||||
Scheme_Local *l;
|
||||
Scheme_Object *o;
|
||||
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) {
|
||||
Scheme_Hash_Table *ht;
|
||||
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;
|
||||
}
|
||||
|
||||
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 */
|
||||
/*========================================================================*/
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -96,7 +96,9 @@
|
|||
|
||||
The third pass, called "optimize", performs constant propagation,
|
||||
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
|
||||
variable offsets and indirections (often mutating the records
|
||||
|
@ -191,7 +193,8 @@
|
|||
SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON;
|
||||
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_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 *compile(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 *local_expand(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 *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);
|
||||
|
||||
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_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("compiled-expression?", compiled_p, 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,
|
||||
to double-check that the compiler is producing
|
||||
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;
|
||||
|
||||
i = lv->position;
|
||||
ab = SCHEME_LET_AUTOBOX(lv);
|
||||
ab = SCHEME_LET_VALUE_AUTOBOX(lv);
|
||||
value = lv->value;
|
||||
obj = lv->body;
|
||||
|
||||
|
@ -3593,7 +3617,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
|
|||
PUSH_RUNSTACK(p, RUNSTACK, c);
|
||||
RUNSTACK_CHANGED();
|
||||
|
||||
if (SCHEME_LET_AUTOBOX(lv)) {
|
||||
if (SCHEME_LET_VOID_AUTOBOX(lv)) {
|
||||
GC_MAYBE_IGNORE_INTERIOR Scheme_Object **stack = RUNSTACK;
|
||||
|
||||
UPDATE_THREAD_RSPTR_FOR_GC();
|
||||
|
@ -3991,6 +4015,48 @@ static int get_comp_flags(Scheme_Config *config)
|
|||
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)
|
||||
{
|
||||
Scheme_Thread *p = scheme_current_thread;
|
||||
|
@ -4189,7 +4255,14 @@ static void *compile_k(void)
|
|||
top->code = o;
|
||||
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,
|
||||
top->max_let_depth,
|
||||
top->prefix->num_toplevels,
|
||||
|
@ -4810,6 +4883,39 @@ compiled_p(int argc, Scheme_Object *argv[])
|
|||
: 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)
|
||||
{
|
||||
Scheme_Env *env;
|
||||
|
|
|
@ -719,7 +719,7 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth)
|
|||
case scheme_let_value_type:
|
||||
if (depth) {
|
||||
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
|
||||
if (SCHEME_LET_AUTOBOX(lv))
|
||||
if (SCHEME_LET_VALUE_AUTOBOX(lv))
|
||||
return 0;
|
||||
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:
|
||||
if (depth) {
|
||||
Scheme_Let_Void *lv = (Scheme_Let_Void *)obj;
|
||||
if (SCHEME_LET_AUTOBOX(lv))
|
||||
if (SCHEME_LET_VOID_AUTOBOX(lv))
|
||||
return 0;
|
||||
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:
|
||||
{
|
||||
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;
|
||||
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);
|
||||
mz_runstack_pushed(jitter, c);
|
||||
|
||||
if (SCHEME_LET_AUTOBOX(lv)) {
|
||||
if (SCHEME_LET_VOID_AUTOBOX(lv)) {
|
||||
int i;
|
||||
mz_rs_sync();
|
||||
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
|
||||
|
|
|
@ -180,7 +180,7 @@ static Scheme_Object *write_let_value(Scheme_Object *obj)
|
|||
|
||||
return cons(scheme_make_integer(lv->count),
|
||||
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),
|
||||
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));
|
||||
obj = SCHEME_CDR(obj);
|
||||
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);
|
||||
if (!SCHEME_PAIRP(obj)) return NULL;
|
||||
lv->value = SCHEME_CAR(obj);
|
||||
|
@ -215,7 +215,7 @@ static Scheme_Object *write_let_void(Scheme_Object *obj)
|
|||
lv = (Scheme_Let_Void *)obj;
|
||||
|
||||
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)));
|
||||
}
|
||||
|
||||
|
@ -230,7 +230,7 @@ static Scheme_Object *read_let_void(Scheme_Object *obj)
|
|||
lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
|
||||
obj = SCHEME_CDR(obj);
|
||||
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);
|
||||
|
||||
return (Scheme_Object *)lv;
|
||||
|
|
|
@ -57,6 +57,12 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) {
|
|||
gcMARK2(i->depths, gc);
|
||||
gcMARK2(i->prefix, 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
|
||||
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->prefix, 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
|
||||
gcBYTES_TO_WORDS(sizeof(Unresolve_Info));
|
||||
|
|
|
@ -1309,6 +1309,12 @@ mark_unresolve_info {
|
|||
gcMARK2(i->depths, gc);
|
||||
gcMARK2(i->prefix, 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:
|
||||
gcBYTES_TO_WORDS(sizeof(Unresolve_Info));
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -14,7 +14,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1132
|
||||
#define EXPECTED_PRIM_COUNT 1133
|
||||
#define EXPECTED_UNSAFE_COUNT 106
|
||||
#define EXPECTED_FLFXNUM_COUNT 69
|
||||
#define EXPECTED_EXTFL_COUNT 45
|
||||
|
|
|
@ -1415,7 +1415,7 @@ typedef struct {
|
|||
with a chain of Scheme_Compiled_Let_Value records as its body,
|
||||
where there's one Scheme_Compiled_Let_Value for each binding
|
||||
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
|
||||
into `let*.
|
||||
|
||||
|
@ -1542,7 +1542,7 @@ typedef struct Scheme_Let_Value {
|
|||
Scheme_Object *body;
|
||||
} 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 {
|
||||
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_Let_Void;
|
||||
|
||||
#define SCHEME_LET_VOID_AUTOBOX(lv) MZ_OPT_HASH_KEY(&lv->iso)
|
||||
|
||||
typedef struct Scheme_Letrec {
|
||||
Scheme_Object so;
|
||||
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);
|
||||
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
|
||||
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_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_list(Scheme_Object *, Resolve_Info *);
|
||||
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);
|
||||
|
||||
|
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "6.2.900.8"
|
||||
#define MZSCHEME_VERSION "6.2.900.9"
|
||||
|
||||
#define MZSCHEME_VERSION_X 6
|
||||
#define MZSCHEME_VERSION_Y 2
|
||||
#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_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
@ -1798,16 +1798,16 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
|
|||
for (i = 0; i < c; i++, p++) {
|
||||
if ((q < 0)
|
||||
|| (p < 0)
|
||||
|| (SCHEME_LET_AUTOBOX(lv) && ((p >= depth)
|
||||
|| (SCHEME_LET_VALUE_AUTOBOX(lv) && ((p >= depth)
|
||||
|| ((stack[p] != VALID_BOX)
|
||||
&& (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_NOCLEAR)
|
||||
|| (stack[p] == VALID_UNINIT)))))
|
||||
scheme_ill_formed_code(port);
|
||||
|
||||
if (!SCHEME_LET_AUTOBOX(lv)) {
|
||||
if (!SCHEME_LET_VALUE_AUTOBOX(lv)) {
|
||||
if (stack[p] != VALID_VAL_NOCLEAR)
|
||||
stack[p] = VALID_VAL;
|
||||
}
|
||||
|
@ -1827,7 +1827,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
|
|||
if ((c < 0) || (c > delta))
|
||||
scheme_ill_formed_code(port);
|
||||
|
||||
if (SCHEME_LET_AUTOBOX(lv)) {
|
||||
if (SCHEME_LET_VOID_AUTOBOX(lv)) {
|
||||
for (i = 0; i < c; i++) {
|
||||
stack[--delta] = VALID_BOX;
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue
Block a user