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

change intermediate representation for the bytecode optimizer

Browse Source 
Correct the second-biggest design flaw in the bytecode optimizer:
instead of using a de Bruijn-like representation of variable
references in the optimizer pass, use variable objects.

This change is intended to address limitations on programs like the
one in

 http://bugs.racket-lang.org/query/?cmd=view&pr=15244

where the optimizer could not perform a straightforward-seeming
transformation due to the constraints of its representation.

Besides handling the bug-report example better, there are other minor
optimization improvements as a side effect of refactoring the code. To
simplify the optimizer's implementation (e.g., eliminate code that I
didn't want to convert) and also preserve success for optimizer tests,
the optimizer ended up getting a little better at flattening and
eliminating `let` forms and `begin`--`let` combinations.

Overall, the optimizer tests in "optimize.rktl" pass, which helps
ensure that no optimizations were lost. I had to modify just a few
tests:

 * The test at line 2139 didn't actually check against reordering as
   intended, but was instead checking that the bug-report limitation
   was intact (and now it's not).

 * The tests around 3095 got extra `p` references, because the
   optimizer is now able to eliminate an unused `let` around the
   second case, but it still doesn't discover the unusedness of `p` in
   the first case soon enough to eliminate the `let`. The extra
   references prevent eliminating the `let` in both case, since that's
   not the point of the tests.

Thanks to Gustavo for taking a close look at the changes.

 LocalWords:  pkgs rkt
This commit is contained in:
Matthew Flatt 2016-02-11 11:10:32 -07:00
parent bfc2611ff2
commit 0c38da0ee2
27 changed files with 2820 additions and 4473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.4.0.7")
(define version "6.4.0.8")
(define deps `("racket-lib"
["racket" #:version ,version]))

42
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -879,20 +879,22 @@
))
(define (comp=? c1 c2)
(define (comp=? c1 c2 want-same?)
(let ([s1 (open-output-bytes)]
[s2 (open-output-bytes)])
(write c1 s1)
(write c2 s2)
(let ([t1 (get-output-bytes s1)]
[t2 (get-output-bytes s2)])
(or (bytes=? t1 t2)
(begin
(printf "~s\n~s\n"
(zo-parse (open-input-bytes t1))
(zo-parse (open-input-bytes t2)))
#f
)))))
(define same? (bytes=? t1 t2))
(when (and (not same?) want-same?)
(printf "~s\n~s\n"
(zo-parse (open-input-bytes t1))
(zo-parse (open-input-bytes t2))))
(unless (equal? same? want-same?)
;; Unquote to cause a failure to stop
'stop)
same?)))
(define test-comp
(case-lambda
@ -902,7 +904,7 @@
;; Give `s` a minimal location, so that other macro locations
;; don't bleed through:
(datum->syntax #f s (vector 'here #f #f #f #f)))
(test same? `(compile ,same? ,expr2) (comp=? (compile (->stx expr1)) (compile (->stx expr2))))]))
(test same? `(compile ,same? ,expr2) (comp=? (compile (->stx expr1)) (compile (->stx expr2)) same?))]))
(let ([x (compile '(lambda (x) x))])
(test #t 'fixpt (eq? x (compile x))))
@ -1742,7 +1744,6 @@
(begin (quote-syntax foo) 3))])
x)
'3)
(test-comp '(if (lambda () 10)
'ok
(quote-syntax no!))
@ -2139,7 +2140,7 @@
(define z (random))
(define (f)
(let-values ([(a b) (values (cons 1 z) (cons 2 z))])
(list a b)))
(list b a)))
(set! z 5)))
'(module m racket/base
;; Reference to a ready module-level variable shouldn't
@ -2147,7 +2148,7 @@
(#%plain-module-begin
(define z (random))
(define (f)
(list (cons 1 z) (cons 2 z)))
(list (cons 2 z) (cons 1 z)))
(set! z 5)))
#f)
@ -3095,38 +3096,45 @@
(test-comp '(lambda (n)
(let ([p (fl+ n n)])
(list
(list
p p
(flonum? p)
(flonum? (begin (random) p))
(flonum? (letrec ([x (lambda (t) x)]) (x x) p)))))
'(lambda (n)
(let ([p (fl+ n n)])
(list
#t
p p
#t
(begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t)))))
(test-comp '(lambda (n)
(let ([p (fx+ n n)])
(list
(list
p p
(fixnum? p)
(fixnum? (begin (random) p))
(fixnum? (letrec ([x (lambda (t) x)]) (x x) p)))))
'(lambda (n)
(let ([p (fx+ n n)])
(list
p p
#t
(begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t)))))
(test-comp '(lambda (n)
(let ([p (extfl+ n n)])
(list
(list
p p
(extflonum? p)
(extflonum? (begin (random) p))
(extflonum? (letrec ([x (lambda (t) x)]) (x x) p)))))
'(lambda (n)
(let ([p (extfl+ n n)])
(list
#t
p p
#t
(begin (random) #t)
(letrec ([x (lambda (t) x)]) (x x) #t)))))

4
pkgs/racket-test/tests/generic/base-interfaces.rkt
View File

@ -27,5 +27,5 @@
;; ok if these don't raise unbound id errors
(check-equal? (with-output-to-string (lambda () (write (tuple 5)))) "#0=#0#")
(check-equal? (tuple 5) (tuple 5))
(check-equal? (equal-hash-code (tuple 5)) 54)
(check-equal? (equal-secondary-hash-code (tuple 5)) 45))
(check-equal? (equal-hash-code (tuple 5)) 55)
(check-equal? (equal-secondary-hash-code (tuple 5)) 46))

2
pkgs/racket-test/tests/generic/equal+hash.rkt
View File

@ -16,5 +16,5 @@
(check-false (equal? (kons 1 2) 2))
(check-false (equal? 2 (kons 1 2)))
(check-false (equal? (kons 1 2) (kons 3 4)))
(check-equal? (equal-hash-code (kons 1 2)) 61)
(check-equal? (equal-hash-code (kons 1 2)) 62)
)

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

@ -35,16 +35,12 @@
READ_ONLY static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1];
READ_ONLY static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1];
ROSYM static Scheme_Object *undefined_error_name_symbol;
/* If locked, these are probably sharable: */
THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht);
THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]);
#define ARBITRARY_USE 0x1
#define CONSTRAINED_USE 0x2
#define WAS_SET_BANGED 0x4
#define ONE_ARBITRARY_USE 0x8
/* See also SCHEME_USE_COUNT_MASK */
static void init_compile_data(Scheme_Comp_Env *env);
static void init_scheme_local();
@ -82,6 +78,8 @@ void scheme_init_compenv_places(void)
void scheme_init_compenv_symbol(void)
{
REGISTER_SO(undefined_error_name_symbol);
undefined_error_name_symbol = scheme_intern_symbol("undefined-error-name");
}
/*========================================================================*/
@ -223,20 +221,7 @@ void scheme_init_expand_observe(Scheme_Env *env)
static void init_compile_data(Scheme_Comp_Env *env)
{
int i, c, *use;
c = env->num_bindings;
if (c)
use = MALLOC_N_ATOMIC(int, c);
else
use = NULL;
env->use = use;
for (i = 0; i < c; i++) {
use[i] = 0;
}
env->min_use = c;
env->max_use = -1;
}
Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Scheme_Object *scopes, Scheme_Comp_Env *base)
@ -339,16 +324,6 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env)
return SAME_OBJ(se, env);
}
int scheme_used_ever(Scheme_Comp_Env *env, int which)
{
return !!env->use[which];
}
int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which)
{
return !!(env->use[which] & WAS_SET_BANGED);
}
void
scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame)
{
@ -901,36 +876,101 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
return v;
}
static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
int i, int j, int p, int flags)
/* Generates a Scheme_Local record for a static distance coodinate, and also
static Scheme_Object *get_local_name(Scheme_Object *id)
{
Scheme_Object *name;
name = scheme_stx_property(id, undefined_error_name_symbol, NULL);
if (name && SCHEME_SYMBOLP(name))
return name;
else
return SCHEME_STX_VAL(id);
}
static Scheme_Compiled_Local *make_variable(Scheme_Object *id)
{
Scheme_Compiled_Local *var;
var = MALLOC_ONE_TAGGED(Scheme_Compiled_Local);
var->so.type = scheme_compiled_local_type;
if (id) {
id = get_local_name(id);
var->name = id;
}
return var;
}
static Scheme_Compiled_Local *get_frame_loc(Scheme_Comp_Env *frame,
int i, int j, int p, int flags)
/* Generates a Scheme_Compiled_Local record as needed, and also
marks the variable as used for closures. */
{
int cnt, u;
if (!frame->vars) {
Scheme_Compiled_Local **vars;
vars = MALLOC_N(Scheme_Compiled_Local*, frame->num_bindings);
frame->vars = vars;
}
u = frame->use[i];
if (!frame->vars[i]) {
Scheme_Compiled_Local *var;
var = make_variable(frame->binders ? frame->binders[i] : NULL);
frame->vars[i] = var;
}
// flags -= (flags & SCHEME_APP_POS);
u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING))
? CONSTRAINED_USE
: ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE))
| ((flags & (SCHEME_SETTING | SCHEME_LINKING_REF))
? WAS_SET_BANGED
: 0));
cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
if (cnt < SCHEME_USE_COUNT_INF)
cnt++;
u -= (u & SCHEME_USE_COUNT_MASK);
u |= (cnt << SCHEME_USE_COUNT_SHIFT);
if (frame->vars[i]->use_count < SCHEME_USE_COUNT_INF)
frame->vars[i]->use_count++;
if (flags & (SCHEME_SETTING | SCHEME_LINKING_REF))
frame->vars[i]->mutated = 1;
if (!(flags & (SCHEME_APP_POS | SCHEME_SETTING)))
if (frame->vars[i]->non_app_count < SCHEME_USE_COUNT_INF)
frame->vars[i]->non_app_count++;
frame->use[i] = u;
if (i < frame->min_use)
frame->min_use = i;
if (i > frame->max_use)
frame->max_use = i;
frame->any_use = 1;
return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0);
return frame->vars[i];
}
void scheme_env_make_variables(Scheme_Comp_Env *frame)
{
Scheme_Compiled_Local *var, **vars;
int i;
if (!frame->num_bindings)
return;
if (!frame->vars) {
vars = MALLOC_N(Scheme_Compiled_Local*, frame->num_bindings);
frame->vars = vars;
}
for (i = 0; i < frame->num_bindings; i++) {
if (!frame->vars[i]) {
var = make_variable(frame->binders ? frame->binders[i] : NULL);
frame->vars[i] = var;
}
}
}
void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_Compiled_Local **vars,
int pos, int count)
{
int i;
MZ_ASSERT((pos + count) <= frame->num_bindings);
if (!frame->vars) {
Scheme_Compiled_Local **fvars;
fvars = MALLOC_N(Scheme_Compiled_Local*, frame->num_bindings);
frame->vars = fvars;
}
for (i = 0; i < count; i++) {
MZ_ASSERT(!frame->vars[i+pos]);
frame->vars[i+pos] = vars[i];
}
}
Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
@ -1155,7 +1195,7 @@ static void set_binder(Scheme_Object **_binder, Scheme_Object *ref, Scheme_Objec
scheme_macro_id_type (id was bound to a rename-transformer),
scheme_local_type (id was lexical),
scheme_compiled_local_type (id was lexical),
scheme_variable_type (id is a global or module-bound variable),
or
@ -1263,7 +1303,7 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (!frame->vals) {
if (flags & SCHEME_DONT_MARK_USE)
return scheme_make_local(scheme_local_type, p+i, 0);
return (Scheme_Object *)make_variable(NULL);
else
return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags);
} else {
@ -1279,7 +1319,7 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
/* Corresponds to a run-time binding (but will be replaced later
through a renaming to a different binding) */
if (flags & (SCHEME_OUT_OF_CONTEXT_LOCAL | SCHEME_SETTING))
return scheme_make_local(scheme_local_type, 0, 0);
return (Scheme_Object *)make_variable(NULL);
return NULL;
}
@ -1309,7 +1349,7 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
}
if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
return scheme_make_local(scheme_local_type, 0, 0);
return (Scheme_Object *)make_variable(NULL);
return NULL;
} else {
@ -1951,49 +1991,21 @@ int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame)
return any_use;
}
int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos)
int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos)
{
return frame->min_use < pos;
return frame->max_use >= pos;
}
void scheme_mark_all_use(Scheme_Comp_Env *frame)
{
/* Mark all variables as used for the purposes of `letrec-syntaxes+values`
splitting */
while (frame && (frame->min_use > -1)) {
frame->min_use = -1;
while (frame && (frame->max_use < frame->num_bindings)) {
frame->max_use = frame->num_bindings;
frame = frame->next;
}
}
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
{
int *v, i;
v = MALLOC_N_ATOMIC(int, count);
memcpy(v, frame->use + start, sizeof(int) * count);
for (i = count; i--; ) {
int old;
old = v[i];
v[i] = 0;
if (old & (ARBITRARY_USE | ONE_ARBITRARY_USE | CONSTRAINED_USE)) {
v[i] |= SCHEME_WAS_USED;
if (!(old & (ARBITRARY_USE | WAS_SET_BANGED))) {
if (old & ONE_ARBITRARY_USE)
v[i] |= SCHEME_WAS_APPLIED_EXCEPT_ONCE;
else
v[i] |= SCHEME_WAS_ONLY_APPLIED;
}
}
if (old & WAS_SET_BANGED)
v[i] |= SCHEME_WAS_SET_BANGED;
v[i] |= (old & SCHEME_USE_COUNT_MASK);
}
return v;
}
/*========================================================================*/
/* macro hooks */
/*========================================================================*/

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

@ -65,8 +65,8 @@ ROSYM static Scheme_Object *letrec_syntaxes_symbol;
ROSYM static Scheme_Object *values_symbol;
ROSYM static Scheme_Object *call_with_values_symbol;
ROSYM static Scheme_Object *inferred_name_symbol;
ROSYM static Scheme_Object *undefined_error_name_symbol;
ROSYM static Scheme_Object *local_keyword;
ROSYM static Scheme_Object *existing_variables_symbol;
THREAD_LOCAL_DECL(static Scheme_Object *quick_stx);
@ -179,10 +179,11 @@ void scheme_init_compile (Scheme_Env *env)
REGISTER_SO(compiler_inline_hint_symbol);
REGISTER_SO(inferred_name_symbol);
REGISTER_SO(undefined_error_name_symbol);
REGISTER_SO(local_keyword);
REGISTER_SO(existing_variables_symbol);
scheme_undefined->type = scheme_undefined_type;
lambda_symbol = scheme_intern_symbol("lambda");
@ -196,10 +197,11 @@ void scheme_init_compile (Scheme_Env *env)
compiler_inline_hint_symbol = scheme_intern_symbol("compiler-hint:cross-module-inline");
inferred_name_symbol = scheme_intern_symbol("inferred-name");
undefined_error_name_symbol = scheme_intern_symbol("undefined-error-name");
local_keyword = scheme_intern_exact_keyword("local", 5);
existing_variables_symbol = scheme_make_symbol("existing-variables");
scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax,
define_values_expand);
scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax,
@ -432,17 +434,6 @@ Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *cu
return current_val;
}
static Scheme_Object *get_local_name(Scheme_Object *id)
{
Scheme_Object *name;
name = scheme_stx_property(id, undefined_error_name_symbol, NULL);
if (name && SCHEME_SYMBOLP(name))
return name;
else
return SCHEME_STX_VAL(id);
}
/**********************************************************************/
/* lambda utils */
/**********************************************************************/
@ -660,6 +651,8 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
params = SCHEME_STX_CDR (params);
}
scheme_env_make_variables(frame);
if (SCHEME_STX_NULLP(forms))
scheme_wrong_syntax(NULL, NULL, code, "empty body not allowed");
@ -686,11 +679,7 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
cl = MALLOC_ONE_RT(Closure_Info);
SET_REQUIRED_TAG(cl->type = scheme_rt_closure_info);
{
int *local_flags;
local_flags = scheme_env_get_flags(frame, 0, data->num_params);
cl->local_flags = local_flags;
}
cl->vars = frame->vars;
data->closure_map = (mzshort *)cl;
return (Scheme_Object *)data;
@ -1577,7 +1566,7 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (!imported && env->genv->module && !rec[drec].testing_constantness)
SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
}
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_compiled_local_type)) {
/* ok */
} else {
scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable");
@ -1885,238 +1874,6 @@ static Scheme_Let_Header *make_header(Scheme_Object *first, int num_bindings, in
return head;
}
static Scheme_Object *shift_compiled_expression(Scheme_Object *v, int delta, int skip);
static Scheme_Object *shift_compiled_expression_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v = (Scheme_Object *)p->ku.k.p1;
p->ku.k.p1 = NULL;
return (void *)shift_compiled_expression(v, p->ku.k.i1, p->ku.k.i2);
}
static Scheme_Object *shift_compiled_expression(Scheme_Object *v, int delta, int skip)
{
if (!delta || (SCHEME_TYPE(v) > _scheme_compiled_values_types_))
return v;
if (delta < 0) scheme_signal_error("internal error: bad shift delta");
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)v;
p->ku.k.i1 = delta;
p->ku.k.i2 = skip;
return scheme_handle_stack_overflow(shift_compiled_expression_k);
}
}
#endif
/* Perform simple shifts directly. We want to avoid adding
extra `let' ayers if possible, since it might interefere
with optimizations. */
switch (SCHEME_TYPE(v)) {
case scheme_compiled_toplevel_type:
case scheme_compiled_quote_syntax_type:
return v;
case scheme_local_type:
{
int pos = SCHEME_LOCAL_POS(v);
if (pos < skip)
return v;
else
return scheme_make_local(scheme_local_type, pos - delta, 0);
}
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)v;
int i;
for (i = app->num_args + 1; i--; ) {
v = shift_compiled_expression(app->args[i], delta, skip);
app->args[i] = v;
}
return (Scheme_Object *)app;
}
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)v;
v = shift_compiled_expression(app->rator, delta, skip);
app->rator = v;
v = shift_compiled_expression(app->rand, delta, skip);
app->rand = v;
return (Scheme_Object *)app;
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)v;
v = shift_compiled_expression(app->rator, delta, skip);
app->rator = v;
v = shift_compiled_expression(app->rand1, delta, skip);
app->rand1 = v;
v = shift_compiled_expression(app->rand2, delta, skip);
app->rand2 = v;
return (Scheme_Object *)app;
}
case scheme_branch_type:
{
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)v;
v = shift_compiled_expression(b->test, delta, skip);
b->test = v;
v = shift_compiled_expression(b->tbranch, delta, skip);
b->tbranch = v;
v = shift_compiled_expression(b->fbranch, delta, skip);
b->fbranch = v;
return (Scheme_Object *)b;
}
case scheme_with_cont_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)v;
v = shift_compiled_expression(wcm->key, delta, skip);
wcm->key = v;
v = shift_compiled_expression(wcm->val, delta, skip);
wcm->val = v;
v = shift_compiled_expression(wcm->body, delta, skip);
wcm->body = v;
return (Scheme_Object *)wcm;
}
case scheme_sequence_type:
case scheme_begin0_sequence_type:
{
Scheme_Sequence *s = (Scheme_Sequence *)v;
int i;
for (i = s->count; i--; ) {
v = shift_compiled_expression(s->array[i], delta, skip);
s->array[i] = v;
}
return (Scheme_Object *)s;
}
case scheme_apply_values_type:
{
Scheme_Object *v2;
v2 = shift_compiled_expression(SCHEME_PTR1_VAL(v), delta, skip);
SCHEME_PTR1_VAL(v) = v2;
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:
{
Scheme_Set_Bang *sb = (Scheme_Set_Bang *)v;
v = shift_compiled_expression(sb->var, delta, skip);
sb->var = v;
v = shift_compiled_expression(sb->val, delta, skip);
sb->val = v;
return (Scheme_Object *)sb;
}
case scheme_compiled_unclosed_procedure_type:
{
Scheme_Closure_Data *data = (Scheme_Closure_Data *)v;
v = shift_compiled_expression(data->code, delta, skip + data->num_params);
data->code = v;
return (Scheme_Object *)data;
}
case scheme_case_lambda_sequence_type:
{
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)v;
int i;
for (i = cl->count; i--; ) {
v = shift_compiled_expression(cl->array[i], delta, skip);
cl->array[i] = v;
}
return (Scheme_Object *)cl;
}
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *lh = (Scheme_Let_Header *)v;
Scheme_Compiled_Let_Value *clv;
int post_bind = !(SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
int i;
if (!post_bind) skip += lh->count;
clv = (Scheme_Compiled_Let_Value *)lh->body;
i = lh->num_clauses;
while (1) {
v = shift_compiled_expression(clv->value, delta, skip);
clv->value = v;
if (--i)
clv = (Scheme_Compiled_Let_Value *)clv->body;
else
break;
}
if (post_bind) skip += lh->count;
if (!lh->num_clauses) {
v = shift_compiled_expression(lh->body, delta, skip);
lh->body = v;
} else {
v = shift_compiled_expression(clv->body, delta, skip);
clv->body = v;
}
return (Scheme_Object *)lh;
}
case scheme_varref_form_type:
{
Scheme_Object *sv;
sv = shift_compiled_expression(SCHEME_PTR1_VAL(v), delta, skip);
SCHEME_PTR1_VAL(v) = sv;
sv = shift_compiled_expression(SCHEME_PTR2_VAL(v), delta, skip);
SCHEME_PTR2_VAL(v) = sv;
return v;
}
default:
scheme_signal_error("internal error: compile-time shift failed: %d", SCHEME_TYPE(v));
return NULL;
}
}
static Scheme_Object *force_traditional_letrec(Scheme_Object *result, Scheme_Comp_Env *env)
{
/* Force `letrec'-style binding by adding a forward
@ -2259,15 +2016,15 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
int recursive, int multi, Scheme_Compile_Info *rec, int drec,
Scheme_Comp_Env *frame_already)
{
Scheme_Object *bindings, *l, *binding, *name, **names, **clv_names, *forms, *defname, *scope;
Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname, *scope;
int num_clauses, num_bindings, i, j, k, m, pre_k;
Scheme_Comp_Env *frame, *env, *rhs_env;
Scheme_Compile_Info *recs;
Scheme_Object *first = NULL;
Scheme_Object *first = NULL, *existing_vars;
Scheme_Compiled_Let_Value *last = NULL, *lv;
DupCheckRecord r;
int rec_env_already = rec[drec].env_already, body_block;
int rev_bind_order, post_bind, already_compiled_body;
int already_compiled_body;
Scheme_Let_Header *head;
form = scheme_stx_taint_disarm(form, NULL);
@ -2294,9 +2051,6 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
if (num_clauses < 0)
scheme_wrong_syntax(NULL, bindings, form, NULL);
post_bind = !recursive;
rev_bind_order = recursive;
/* forms ends up being the let body */
forms = SCHEME_STX_CDR(form);
forms = SCHEME_STX_CDR(forms);
@ -2343,7 +2097,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
scheme_wrong_syntax(NULL, clause, form, NULL);
names = SCHEME_STX_CAR(clause);
num_names = scheme_stx_proper_list_length(names);
if (num_names < 0)
scheme_wrong_syntax(NULL, names, form, NULL);
@ -2372,7 +2126,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
frame_already = frame;
}
env = frame;
if (post_bind)
if (!recursive)
rhs_env = scheme_no_defines(origenv);
else
rhs_env = env;
@ -2389,15 +2143,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
scheme_begin_dup_symbol_check(&r, env);
}
/* For `letrec', we bind the first set of identifiers at the deepest
position. That order makes it easier to peel off a prefix into a
separate `letrec'. For `let' and `let*', the first set of
identifiers is at the shallowest position. */
if (rev_bind_order)
k = num_bindings;
else
k = 0;
k = 0;
for (i = 0; i < num_clauses; i++) {
if (!SCHEME_STX_PAIRP(bindings))
@ -2412,20 +2158,11 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
scheme_wrong_syntax(NULL, binding, form, NULL);
}
if (rev_bind_order) {
if (multi) {
name = SCHEME_STX_CAR(binding);
while (!SCHEME_STX_NULLP(name)) {
name = SCHEME_STX_CDR(name);
k--;
}
} else
k--;
}
pre_k = k;
existing_vars = scheme_stx_property(binding, existing_variables_symbol, NULL);
name = SCHEME_STX_CAR(binding);
if (multi) {
while (!SCHEME_STX_NULLP(name)) {
@ -2464,19 +2201,6 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
last->body = (Scheme_Object *)lv;
last = lv;
lv->count = (k - pre_k);
lv->position = pre_k;
if (recursive) {
/* The names are only used for recursive bindings (in letrec_check),
currently. It would be ok if we record extra names, though. */
clv_names = MALLOC_N(Scheme_Object*, lv->count);
for (m = pre_k; m < k; m++) {
Scheme_Object *ln;
ln = get_local_name(names[m]);
clv_names[m - pre_k] = ln;
}
lv->names = clv_names;
}
if (lv->count == 1)
rhs_env->value_name = SCHEME_STX_SYM(names[pre_k]);
@ -2495,17 +2219,20 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
}
rhs_env->value_name = NULL;
if (recursive) {
for (m = pre_k; m < k; m++) {
scheme_add_compilation_binding(m, names[m], frame);
}
}
if (SCHEME_TRUEP(existing_vars)) {
/* Install variables already generated by a lift: */
scheme_set_compilation_variables(frame, (Scheme_Compiled_Local **)SCHEME_CDR(existing_vars),
pre_k, k - pre_k);
}
bindings = SCHEME_STX_CDR(bindings);
if (rev_bind_order)
k = pre_k;
}
if (!recursive) {
@ -2514,14 +2241,31 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
}
}
scheme_env_make_variables(env);
k = 0;
lv = (Scheme_Compiled_Let_Value *)first;
for (i = 0; i < num_clauses; i++) {
Scheme_Compiled_Local **vars;
vars = MALLOC_N(Scheme_Compiled_Local*, lv->count);
lv->vars = vars;
for (j = lv->count; j--; ) {
vars[j] = env->vars[k+j];
}
k += lv->count;
lv = (Scheme_Compiled_Let_Value *)lv->body;
}
head = make_header(first, num_bindings, num_clauses,
(recursive ? SCHEME_LET_RECURSIVE : 0));
if (recursive) {
Scheme_Let_Header *current_head = head;
int prev_might_invoke = 0;
int group_clauses = 0, group_count = 0;
int group_clauses = 0;
k = 0;
lv = (Scheme_Compiled_Let_Value *)first;
for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
Scheme_Object *ce, *rhs;
@ -2529,63 +2273,72 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
if (scope)
rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv));
if (lv->count == 1)
env->value_name = lv->names[0];
env->value_name = lv->vars[0]->name;
else
env->value_name = NULL;
ce = scheme_compile_expr(rhs, env, recs, i);
env->value_name = NULL;
lv->value = ce;
/* Record the fact that this binding doesn't use any or later
/* Record when this binding doesn't use any or later
bindings in the same set. In internal-definition mode,
break bindings into smaller sets based on this
information; otherwise, the `let' optimizer and resolver
may do so, but we have to be more conservative as reflected
by scheme_might_invoke_call_cc(). */
always break bindings into smaller sets based on this
information; otherwise, we have to be more conservative as reflected
by scheme_might_invoke_call_cc(), so record with
SCHEME_CLV_NO_GROUP_LATER_USES and check again at the end. */
if ((rec_env_already == 2) /* int def: semantics is `let' */
|| (!prev_might_invoke
&& !scheme_might_invoke_call_cc(ce))) {
if (!scheme_env_check_reset_any_use(env))
SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES;
if ((rec_env_already == 2)
&& !group_clauses
&& !scheme_env_min_use_below(env, lv->position + lv->count)) {
group_clauses++;
if ((group_clauses == 1)
&& !scheme_env_max_use_above(env, k)) {
/* A clause that should be in its own `let' */
Scheme_Let_Header *next_head;
next_head = make_header(lv->body,
current_head->count - lv->count,
current_head->num_clauses - 1,
SCHEME_LET_RECURSIVE);
current_head->num_clauses = 1;
current_head->count = lv->count;
current_head->body = (Scheme_Object *)next_head;
SCHEME_LET_FLAGS(current_head) -= SCHEME_LET_RECURSIVE;
current_head = next_head;
} else if (!scheme_env_min_use_below(env, lv->position)) {
SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES;
group_clauses = 0;
} else if (!scheme_env_max_use_above(env, k + lv->count)) {
/* End a recursive `letrec' group */
SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES;
if (rec_env_already == 2) {
Scheme_Let_Header *next_head;
group_clauses++;
group_count += lv->count;
group_clauses = 0;
}
} else
prev_might_invoke = 1;
k += lv->count;
}
if (!prev_might_invoke) {
Scheme_Let_Header *current_head = head;
Scheme_Compiled_Let_Value *next = NULL;
int group_count = 0;
lv = (Scheme_Compiled_Let_Value *)first;
group_clauses = 0;
for (i = 0; i < num_clauses; i++, lv = next) {
next = (Scheme_Compiled_Let_Value *)lv->body;
group_clauses++;
group_count += lv->count;
if (SCHEME_CLV_FLAGS(lv) & (SCHEME_CLV_NO_GROUP_USES
| SCHEME_CLV_NO_GROUP_LATER_USES)) {
/* A clause that should be in its own `let' */
Scheme_Let_Header *next_head;
int single = (SCHEME_CLV_FLAGS(lv) & SCHEME_CLV_NO_GROUP_USES);
MZ_ASSERT(!single || (group_clauses == 1));
if (current_head->num_clauses - group_clauses) {
next_head = make_header(lv->body,
current_head->count - group_count,
current_head->num_clauses - group_clauses,
SCHEME_LET_RECURSIVE);
lv->body = (Scheme_Object *)next_head;
current_head->num_clauses = group_clauses;
current_head->count = group_count;
current_head->body = (Scheme_Object *)next_head;
current_head = next_head;
}
} else
next_head = NULL;
if (single)
SCHEME_LET_FLAGS(current_head) -= SCHEME_LET_RECURSIVE;
current_head = next_head;
group_clauses = 0;
group_count = 0;
} else {
group_clauses++;
group_count += lv->count;
}
} else
prev_might_invoke = 1;
}
}
}
@ -2606,74 +2359,6 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
}
env->value_name = NULL;
/* Save flags: */
lv = (Scheme_Compiled_Let_Value *)first;
for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
int *flags;
flags = scheme_env_get_flags(env, lv->position, lv->count);
lv->flags = flags;
}
if (rec_env_already == 2) {
/* `head' is a chain of group headers; splice them into the lv
chain, and adjust coordinates in each lv->value due to
grouping */
Scheme_Let_Header *current_head = head, *next_head = (Scheme_Let_Header *)head->body;
Scheme_Object *rhs, *next = NULL;
int num_group_clauses = 0;
head->body = first;
lv = (Scheme_Compiled_Let_Value *)first;
for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)next) {
rhs = shift_compiled_expression(lv->value,
((SCHEME_LET_FLAGS(current_head) & SCHEME_LET_RECURSIVE)
? num_bindings - current_head->count
: num_bindings),
0);
lv->value = rhs;
lv->position -= (num_bindings - current_head->count);
next = lv->body;
num_group_clauses++;
if (current_head->num_clauses == num_group_clauses) {
num_bindings -= current_head->count;
current_head = next_head;
next_head = (Scheme_Let_Header *)current_head->body;
if ((i + 1) < num_clauses) {
current_head->body = lv->body;
lv->body = (Scheme_Object *)current_head;
}
num_group_clauses = 0;
}
}
}
if (!already_compiled_body) {
/* Help the optimizer by removing unused expressions right away */
lv = (Scheme_Compiled_Let_Value *)head->body;
for (i = 0; i < head->num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
for (j = lv->count; j--; ) {
if (lv->flags[j] & SCHEME_WAS_USED)
break;
}
if (j < 0) {
if (scheme_omittable_expr(lv->value, lv->count, 10, 0, NULL, NULL, 0, 0, 1)) {
if (lv->count == 1) {
lv->value = scheme_false;
} else {
Scheme_Object *app;
app = scheme_null;
for (k = lv->count; k--; ) {
app = scheme_make_pair(scheme_false, app);
}
app = scheme_make_application(scheme_make_pair(scheme_values_func, app), NULL);
lv->value = app;
}
}
}
}
}
scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1);
return (Scheme_Object *)head;
@ -2684,7 +2369,8 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
const char *formname, int letrec, int multi,
Scheme_Comp_Env *env_already)
{
Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname, *form, *pre_set, *scope;
Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *boundname, *form, *pre_set, *scope;
Scheme_Object *vlist_first, *vlist_last;
Scheme_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1;
DupCheckRecord r;
@ -2724,7 +2410,8 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
if (!env_already && !rec_env_already)
scheme_begin_dup_symbol_check(&r, origenv);
vlist = scheme_null;
vlist_first = scheme_null;
vlist_last = NULL;
vs = vars;
while (SCHEME_STX_PAIRP(vs)) {
Scheme_Object *v2;
@ -2747,7 +2434,13 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
name = SCHEME_STX_CAR(names);
scheme_check_identifier(NULL, name, NULL, origenv, form);
vlist = cons(name, vlist);
v = scheme_make_pair(name, scheme_null);
if (vlist_last)
SCHEME_CDR(vlist_last) = v;
else
vlist_first = v;
vlist_last = v;
if (!env_already && !rec_env_already) {
scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
@ -2774,7 +2467,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
scope = NULL;
else
scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE);
env = scheme_add_compilation_frame(vlist,
env = scheme_add_compilation_frame(vlist_first,
scope,
origenv,
(rec_env_already ? SCHEME_INTDEF_SHADOW : 0));
@ -2799,9 +2492,6 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
name = SCHEME_STX_CAR(v);
if (scope) name = scheme_stx_add_scope(name, scope, scheme_env_phase(env->genv));
if (rec_env_already == 2)
forward_ref_boundary += scheme_stx_proper_list_length(name);
rhs = SCHEME_STX_CDR(v);
rhs = SCHEME_STX_CAR(rhs);
if (scope && letrec) rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv));
@ -2872,18 +2562,18 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
int cnt;
cnt = scheme_stx_proper_list_length(name);
if (SCHEME_NULLP(SCHEME_CDR(first))
&& !scheme_env_min_use_below(use_env, forward_ref_boundary)) {
&& !scheme_env_max_use_above(use_env, forward_ref_boundary)) {
/* no self or forward references */
first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
pre_set = cons(cons(let_values_symbol, first), pre_set);
first = NULL;
} else if (!scheme_env_min_use_below(use_env, forward_ref_boundary - cnt)) {
} else if (!scheme_env_max_use_above(use_env, forward_ref_boundary + cnt)) {
/* no (further) forward references */
first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
pre_set = cons(cons(letrec_values_symbol, first), pre_set);
first = NULL;
}
forward_ref_boundary -= cnt;
forward_ref_boundary += cnt;
}
vars = SCHEME_STX_CDR(vars);
@ -2982,7 +2672,7 @@ static Scheme_Object *compile_sequence(Scheme_Object *forms,
body = compile_block(forms, env, rec, drec);
else
body = compile_list(forms, env, rec, drec);
return scheme_make_sequence_compilation(body, 1);
return scheme_make_sequence_compilation(body, 1, 0);
}
}
@ -3062,7 +2752,7 @@ do_begin_syntax(char *name,
body = compile_list(forms, env, rec, drec);
}
forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);
forms = scheme_make_sequence_compilation(body, zero ? -1 : 1, 0);
if (!zero
&& SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
@ -3093,7 +2783,7 @@ Scheme_Sequence *scheme_malloc_sequence(int count)
* sizeof(Scheme_Object *));
}
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt, int resolved)
{
/* We have to be defensive in processing `seq'; it might be bad due
to a bad .zo */
@ -3121,7 +2811,9 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
total++;
} else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, 0, 0, 1)) {
&& scheme_omittable_expr(v, -1, -1,
(resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
NULL, NULL)) {
/* A value that is not the result. We'll drop it. */
total++;
} else {
@ -3147,7 +2839,10 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
if (count == 1) {
if (opt < -1) {
/* can't optimize away a begin0 reading a .zo time */
} else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, NULL, 0, 0, 1)) {
} else if ((opt < 0)
&& !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1,
(resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
NULL, NULL)) {
/* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess
up continuation marks). */
@ -3177,7 +2872,9 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
} else if (opt
&& (((opt > 0) && (k < total))
|| ((opt < 0) && k))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, 0, 0, 1)) {
&& scheme_omittable_expr(v, -1, -1,
(resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
NULL, NULL)) {
/* Value not the result. Do nothing. */
} else
o->array[i++] = v;
@ -3201,7 +2898,7 @@ stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compil
if (SCHEME_NULLP(SCHEME_CDR(body)))
return SCHEME_CAR(body);
else
return scheme_make_sequence_compilation(body, 1);
return scheme_make_sequence_compilation(body, 1, 0);
}
static Scheme_Object *
@ -3734,7 +3431,7 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e
save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL);
if (scheme_omittable_expr(a, 1, -1, 0, NULL, NULL, 0, 0, 0)) {
if (scheme_omittable_expr(a, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) {
/* short cut */
a = _scheme_eval_linked_expr_multi(a);
} else {
@ -4052,24 +3749,9 @@ do_letrec_syntaxes(const char *where,
cnt = (i ? var_cnt : stx_cnt);
if (cnt > 0) {
/* Add new syntax/variable names to the environment: */
if (i) {
/* values in reverse order across clauses, in order within a clause */
j = var_cnt;
} else
j = 0;
j = 0;
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l;
int pre_j;
if (i) {
a = SCHEME_STX_CAR(v);
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
j--;
}
pre_j = j;
} else
pre_j = 0;
a = SCHEME_STX_CAR(v);
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
@ -4080,8 +3762,6 @@ do_letrec_syntaxes(const char *where,
} else
scheme_set_local_syntax(j++, a, NULL, stx_env, 0);
}
if (i) j = pre_j;
}
}
}
@ -4181,7 +3861,7 @@ do_letrec_syntaxes(const char *where,
v = compile_list(body, var_env, rec, drec);
else
v = compile_block(body, var_env, rec, drec);
v = scheme_make_sequence_compilation(v, 1);
v = scheme_make_sequence_compilation(v, 1, 0);
} else {
if (env_already)
v = expand_list(body, var_env, rec, drec);
@ -4278,7 +3958,8 @@ int scheme_get_eval_type(Scheme_Object *obj)
if (type > _scheme_values_types_)
return SCHEME_EVAL_CONSTANT;
else if (SAME_TYPE(type, scheme_local_type))
else if (SAME_TYPE(type, scheme_compiled_local_type)
|| SAME_TYPE(type, scheme_local_type))
return SCHEME_EVAL_LOCAL;
else if (SAME_TYPE(type, scheme_local_unbox_type))
return SCHEME_EVAL_LOCAL_UNBOX;
@ -5024,8 +4705,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* apply to global variable: compile it normally */
orig_unbound_name = find_name;
has_orig_unbound = 1;
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) {
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_compiled_local_type)) {
/* apply to local variable: compile it normally */
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
@ -5751,33 +5431,35 @@ Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Sche
}
Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env,
Scheme_Object *orig_form, int comp_rev)
Scheme_Object *orig_form, int comp)
{
Scheme_Object *revl, *a;
Scheme_Object *revl, *reve, *a;
if (SCHEME_NULLP(l)) return obj;
revl = scheme_reverse(l);
if (comp_rev) {
/* We've already compiled the body of this let
with the bindings in reverse order. So insert a series of `lets'
to match that order: */
if (!SCHEME_NULLP(SCHEME_CDR(l))) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l)));
for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) {
obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)),
scheme_null),
icons(obj, scheme_null)));
}
}
reve = NULL;
if (comp) {
for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
reve = scheme_make_raw_pair((Scheme_Object *)env, reve);
env = env->next;
}
}
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
a = SCHEME_CAR(revl);
if (comp) {
/* propagate previously generated variables for re-compile */
a = scheme_datum_to_syntax(a, scheme_false, scheme_false, 0, 0);
env = (Scheme_Comp_Env *)SCHEME_CAR(reve);
reve = SCHEME_CDR(reve);
MZ_ASSERT(env->flags & SCHEME_CAPTURE_LIFTED);
if (env->vars)
a = scheme_stx_property(a, existing_variables_symbol,
scheme_make_raw_pair(scheme_make_integer(env->num_bindings),
(Scheme_Object *)env->vars));
}
obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(a, scheme_null),
icons(obj, scheme_null)));
@ -5787,7 +5469,7 @@ Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Sch
return obj;
}
static Scheme_Object *compile_expand_expr_lift_to_let_k(void);
static Scheme_Object *
@ -5798,27 +5480,6 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *l, *orig_form = form, *context_key;
Scheme_Comp_Env *inserted, **ip;
/* This function only works when `env' has no lexical bindings,
because we might insert new ones at the beginning. In
particular, we might insert frames between `inserted' and
`env'.
This function also relies on the way that compilation of `let'
works. A let-bound variable is compiled to a count of the frames
to skip and the index within the frame, so we can insert new
frames without affecting lookups computed so far. Inserting each
new frame before any previous one turns out to be consistent with
the nested `let's that we generate at the end.
Some optimizations can happen later, for example constant
propagate. But these optimizations take place on the result of
this function, so we don't have to worry about them.
Don't generate a `let*' expression instead of nested `let's,
because the compiler actually takes shortcuts (that are
inconsistent with our frame nesting) instead of expanding `let*'
to `let'. */
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
@ -5875,7 +5536,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_IPTR_VAL(o) = form;
} else
o = form;
form = scheme_add_lifts_as_let(o, l, env, orig_form, rec[drec].comp);
form = scheme_add_lifts_as_let(o, l, inserted->next, orig_form, rec[drec].comp);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(env->observer, form);
}

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

@ -1,5 +1,5 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,56,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18,0,
22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0,89,
0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173,0,
@ -72,37 +72,37 @@
22,168,4,196,249,22,161,4,80,143,42,39,28,248,22,66,248,22,162,4,248,
22,83,197,250,22,92,2,27,248,22,92,248,22,173,20,199,248,22,104,198,27,
248,22,162,4,248,22,173,20,197,250,22,92,2,27,248,22,92,248,22,83,197,
250,22,93,2,24,248,22,174,20,199,248,22,174,20,202,145,39,9,20,121,145,
250,22,93,2,24,248,22,174,20,199,248,22,174,20,202,145,39,9,20,122,145,
2,1,39,16,1,11,16,0,20,27,15,61,9,2,2,2,2,2,3,11,11,
11,11,9,9,11,11,11,10,39,80,143,39,39,20,121,145,2,1,39,16,0,
11,11,9,9,11,11,11,10,39,80,143,39,39,20,122,145,2,1,39,16,0,
16,0,41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4,2,5,2,
6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16,11,11,11,
11,11,11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2,7,2,8,
2,9,2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39,16,1,2,
15,40,11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,
16,0,39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39,40,80,143,
39,39,39,20,121,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5,2,
13,88,148,8,36,40,56,40,9,223,0,33,37,39,20,121,145,2,1,39,16,
39,39,39,20,122,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5,2,
13,88,148,8,36,40,56,40,9,223,0,33,37,39,20,122,145,2,1,39,16,
1,2,15,16,0,11,16,5,2,14,88,148,8,36,40,56,40,9,223,0,33,
38,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,4,88,148,
8,36,40,56,42,9,223,0,33,39,39,20,121,145,2,1,39,16,1,2,15,
38,39,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,4,88,148,
8,36,40,56,42,9,223,0,33,39,39,20,122,145,2,1,39,16,1,2,15,
16,1,33,40,11,16,5,2,11,88,148,8,36,40,59,42,9,223,0,33,41,
39,20,121,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,7,88,
148,8,36,40,61,40,9,223,0,33,45,39,20,121,145,2,1,39,16,1,2,
39,20,122,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,7,88,
148,8,36,40,61,40,9,223,0,33,45,39,20,122,145,2,1,39,16,1,2,
15,16,0,11,16,5,2,10,88,148,8,36,40,56,40,9,223,0,33,47,39,
20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8,36,
40,57,40,9,223,0,33,48,39,20,121,145,2,1,39,16,1,2,15,16,0,
11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,39,20,121,145,
20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8,36,
40,57,40,9,223,0,33,48,39,20,122,145,2,1,39,16,1,2,15,16,0,
11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,39,20,122,145,
2,1,39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36,40,59,40,
9,223,0,33,50,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,
2,5,88,148,8,36,40,61,42,9,223,0,33,51,39,20,121,145,2,1,39,
9,223,0,33,50,39,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,
2,5,88,148,8,36,40,61,42,9,223,0,33,51,39,20,122,145,2,1,39,
16,1,2,15,16,1,33,52,11,16,5,2,6,88,148,8,36,40,57,40,9,
223,0,33,53,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,0,94,
223,0,33,53,39,20,122,145,2,1,39,16,1,2,15,16,0,11,16,0,94,
2,17,2,18,93,2,17,9,9,39,9,0};
EVAL_ONE_SIZED_STR((char *)expr, 2090);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,56,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,194,0,0,0,1,0,0,8,0,16,0,
29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0,211,
0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145,1,
@ -948,9 +948,9 @@
159,16,2,56,11,11,27,248,22,143,4,23,199,1,27,28,23,194,2,23,194,
1,86,94,23,194,1,39,27,248,22,143,4,23,202,1,249,22,144,6,23,198,
1,20,20,95,88,148,8,36,39,51,11,9,224,3,2,33,128,3,23,195,1,
23,196,1,248,80,144,41,8,54,42,193,145,39,9,20,121,145,2,1,39,16,
23,196,1,248,80,144,41,8,54,42,193,145,39,9,20,122,145,2,1,39,16,
1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11,11,11,11,
9,9,11,11,11,10,46,80,143,39,39,20,121,145,2,1,54,16,40,2,3,
9,9,11,11,11,10,46,80,143,39,39,20,122,145,2,1,54,16,40,2,3,
2,4,2,5,2,6,2,7,2,8,2,9,30,2,11,1,20,112,97,114,97,
109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,11,
1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,
@ -1047,7 +1047,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 19773);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,56,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23,0,
48,0,65,0,83,0,105,0,128,0,149,0,171,0,180,0,189,0,196,0,205,
0,212,0,0,0,248,1,0,0,3,1,5,105,110,115,112,48,76,35,37,112,
@ -1060,9 +1060,9 @@
45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108,97,99,101,
45,99,104,97,110,110,101,108,45,111,117,116,249,80,143,41,42,23,196,1,39,
249,80,143,41,42,23,196,1,39,249,80,143,41,42,195,39,249,80,143,41,42,
23,196,1,40,249,80,143,41,42,195,40,145,39,9,20,121,145,2,1,39,16,
23,196,1,40,249,80,143,41,42,195,40,145,39,9,20,122,145,2,1,39,16,
1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11,11,11,11,
9,9,11,11,11,10,48,80,143,39,39,20,121,145,2,1,39,16,7,2,3,
9,9,11,11,11,10,48,80,143,39,39,20,122,145,2,1,39,16,7,2,3,
2,4,2,5,2,6,2,7,2,8,2,9,16,0,40,42,39,16,0,39,16,
2,2,6,2,7,41,11,11,11,16,5,2,4,2,8,2,9,2,5,2,3,
16,5,11,11,11,11,11,16,5,2,4,2,8,2,9,2,5,2,3,44,44,
@ -1078,7 +1078,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 576);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,56,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,100,0,0,0,1,0,0,8,0,15,0,
26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0,186,
0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108,1,
@ -1492,8 +1492,8 @@
144,40,40,42,248,22,148,15,80,144,40,48,42,20,18,144,11,80,143,39,59,
248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,20,18,144,11,80,
143,39,59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,145,39,
9,20,121,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,
29,11,11,11,11,11,11,11,9,9,11,11,11,10,41,80,143,39,39,20,121,
9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,
29,11,11,11,11,11,11,11,9,9,11,11,11,10,41,80,143,39,39,20,122,
145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109,101,
116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,6,1,23,
101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,
@ -1547,7 +1547,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 9765);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,52,46,48,46,56,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,17,0,0,0,1,0,0,8,0,18,0,
24,0,38,0,52,0,64,0,84,0,98,0,113,0,126,0,131,0,135,0,147,
0,231,0,238,0,8,1,0,0,199,1,0,0,3,1,5,105,110,115,112,48,
@ -1563,9 +1563,9 @@
2,15,16,4,2,8,39,39,2,1,143,2,15,16,4,2,9,39,39,2,1,
143,2,15,16,4,2,10,39,39,2,1,16,0,38,15,143,2,14,2,11,18,
143,16,2,143,10,16,3,9,2,11,2,13,143,11,16,3,9,9,2,13,16,
3,9,9,9,145,39,9,20,121,145,2,1,39,16,1,11,16,0,20,27,15,
3,9,9,9,145,39,9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,
56,9,2,2,2,2,29,11,11,11,11,11,11,11,9,9,11,11,11,33,16,
39,80,143,39,39,20,121,145,2,1,39,16,0,16,0,40,42,39,16,0,39,
39,80,143,39,39,20,122,145,2,1,39,16,0,16,0,40,42,39,16,0,39,
16,0,39,11,11,11,16,0,16,0,16,0,39,39,40,12,11,11,16,0,16,
0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,0,104,2,
4,2,5,29,94,2,3,71,35,37,102,111,114,101,105,103,110,11,29,94,2,

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

@ -36,7 +36,7 @@ int scheme_jit_is_fixnum(Scheme_Object *rand)
|| (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)
&& (SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FIXNUM)))
return 1;
else if (scheme_expr_produces_local_type(rand) == SCHEME_LOCAL_TYPE_FIXNUM)
else if (scheme_expr_produces_local_type(rand, NULL) == SCHEME_LOCAL_TYPE_FIXNUM)
return 1;
else
return 0;

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

@ -109,7 +109,6 @@ void scheme_init_letrec_check()
#define LET_CHECKED (0x1 << 2)
#define FRAME_TYPE_LETREC 1
#define FRAME_TYPE_LETSTAR 2
#define FRAME_TYPE_LET 3
#define FRAME_TYPE_CLOSURE 4
#define FRAME_TYPE_TOP 5
@ -140,9 +139,6 @@ typedef struct Letrec_Check_Frame {
been wrapped with an #<unsafe-undefined> check */
int *ref;
/* so we can get to variable names */
Scheme_Let_Header *head;
/* we keep a list of all deferred expressions, only so that we can
drop the body for any that are not processed (which means that
they won't be used) */
@ -178,12 +174,13 @@ static Letrec_Check_Frame *init_letrec_check_frame(int frame_type, int subexpr,
mzshort count,
Letrec_Check_Frame *prev,
Letrec_Check_Frame *share_with,
Scheme_Let_Header *head)
Scheme_Let_Header *head,
Scheme_Closure_Data *data)
{
Scheme_Deferred_Expr **chain;
Letrec_Check_Frame *frame;
Scheme_Object **def;
int *ref, i;
int *ref, i, j, pos;
frame = (Letrec_Check_Frame *)MALLOC_ONE_RT(Letrec_Check_Frame);
#ifdef MZTAG_REQUIRED
@ -195,7 +192,23 @@ static Letrec_Check_Frame *init_letrec_check_frame(int frame_type, int subexpr,
frame->count = count;
frame->next = prev;
frame->head = head;
if (head) {
Scheme_Compiled_Let_Value *clv = (Scheme_Compiled_Let_Value *)head->body;
pos = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
for (j = 0; j < clv->count; j++) {
clv->vars[j]->mode = SCHEME_VAR_MODE_LETREC_CHECK;
clv->vars[j]->letrec_check.frame = frame;
clv->vars[j]->letrec_check.frame_pos = pos++;
}
}
} else if (data) {
for (j = data->num_params; j--; ) {
((Closure_Info *)data->closure_map)->vars[j]->mode = SCHEME_VAR_MODE_LETREC_CHECK;
((Closure_Info *)data->closure_map)->vars[j]->letrec_check.frame = frame;
((Closure_Info *)data->closure_map)->vars[j]->letrec_check.frame_pos = j;
}
}
if (share_with) {
/* Moving from RHS phase to BODY phase for `let[rec]`,
@ -256,33 +269,10 @@ static Letrec_Check_Frame *get_nearest_rhs(Letrec_Check_Frame *frame)
/* returns the frame that was created when pos was created, and
changes pos to be relative to that frame */
static Letrec_Check_Frame *get_relative_frame(int *pos, Letrec_Check_Frame *frame)
static Letrec_Check_Frame *get_relative_frame(int *pos, Scheme_Compiled_Local *var)
{
while (1) {
/* we've gone wrong if pos_int is negative or if the frame has
become NULL because pos should have be a valid LHS variable
reference */
SCHEME_ASSERT(*pos >= 0, "get_relative_frame: pos is negative");
SCHEME_ASSERT(frame, "get_relative_frame: frame is NULL");
/* if we're in the RHS of a let, no bindings for the LHS variables
have been pushed yet, pos can't possibly be in this frame. so
don't do any offsetting and look in the next frame */
if ((frame->frame_type == FRAME_TYPE_LET)
&& (frame->subexpr == LET_RHS_EXPR)) {
frame = frame->next;
/* recur */
} else {
if (*pos >= frame->count) {
/* we're not in the right frame yet, so offset pos by the
number of bindings in this frame */
(*pos) -= frame->count;
frame = frame->next;
/* recur */
} else
return frame;
}
}
*pos = var->letrec_check.frame_pos;
return var->letrec_check.frame;
}
/* adds expr to the deferred bindings of lhs */
@ -325,7 +315,7 @@ static void letrec_check_lets_resume(Letrec_Check_Frame *frame, Scheme_Let_Heade
{
Scheme_Compiled_Let_Value *clv;
Scheme_Object *body;
int i, j, k, *clv_flags;
int i, j, k;
int was_checked;
body = head->body;
@ -337,62 +327,36 @@ static void letrec_check_lets_resume(Letrec_Check_Frame *frame, Scheme_Let_Heade
k = head->count;
for (i = head->num_clauses; i--;) {
clv = (Scheme_Compiled_Let_Value *) body;
clv_flags = clv->flags;
k -= clv->count;
for (j = 0; j < clv->count; j++) {
was_checked = (frame->ref[k + j] & LET_CHECKED);
if (was_checked) {
clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_ONLY_APPLIED);
clv_flags[j] -= (clv_flags[j] & SCHEME_WAS_APPLIED_EXCEPT_ONCE);
}
if (was_checked)
clv->vars[j]->non_app_count = clv->vars[j]->use_count;
}
clv->flags = clv_flags;
clv->names = NULL; /* not used in later passes */
body = clv->body;
}
}
}
/* records that we have seen a reference to loc */
static Scheme_Object *record_checked(Scheme_Local *loc, Letrec_Check_Frame *frame)
static Scheme_Object *record_checked(Scheme_Compiled_Local *loc, Letrec_Check_Frame *frame)
{
int position = SCHEME_LOCAL_POS(loc), k;
Scheme_Object *obj;
frame = get_relative_frame(&position, frame);
int position;
frame = get_relative_frame(&position, loc);
frame->ref[position] |= LET_CHECKED;
obj = frame->head->body;
k = frame->head->count;
while (1) {
Scheme_Compiled_Let_Value *clv = (Scheme_Compiled_Let_Value *)obj;
SCHEME_ASSERT(SAME_TYPE(SCHEME_TYPE(obj), scheme_compiled_let_value_type), "not a clv");
SCHEME_ASSERT(position >= 0, "position went negative");
k -= clv->count;
if (position >= k)
return clv->names[position - k];
obj = clv->body;
}
ESCAPED_BEFORE_HERE;
return loc->name;
}
static Scheme_Object *letrec_check_local(Scheme_Object *o, Letrec_Check_Frame *frame,
Scheme_Object *pos)
{
Letrec_Check_Frame *in_frame;
Scheme_Local *loc = (Scheme_Local *)o;
int position, in_position;
Scheme_Compiled_Local *loc = (Scheme_Compiled_Local *)o;
int in_position;
position = SCHEME_LOCAL_POS(loc);
in_position = position;
in_frame = get_relative_frame(&in_position, frame);
in_frame = get_relative_frame(&in_position, loc);
if (SCHEME_FALSEP(pos)) {
/* mark as potentially applied (i.e., in an "unsafe" context)
@ -604,7 +568,7 @@ static Scheme_Object *letrec_check_closure_compilation(Scheme_Object *o, Letrec_
num_params = data->num_params;
new_frame = init_letrec_check_frame(FRAME_TYPE_CLOSURE, LET_BODY_EXPR,
num_params, frame, NULL,
NULL);
NULL, data);
SCHEME_ASSERT(num_params >= 0, "lambda has negative arguments what do");
@ -675,7 +639,7 @@ static void letrec_check_deferred_expr(Scheme_Object *o)
new_frame = init_letrec_check_frame(FRAME_TYPE_CLOSURE, LET_BODY_EXPR,
num_params, inner, NULL,
NULL);
NULL, data);
val = letrec_check_expr(data->code, new_frame, scheme_false);
data->code = val;
@ -751,8 +715,6 @@ static Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *ol
if (header_flags & SCHEME_LET_RECURSIVE)
frame_type = FRAME_TYPE_LETREC;
else if (header_flags & SCHEME_LET_STAR)
frame_type = FRAME_TYPE_LETSTAR;
else
frame_type = FRAME_TYPE_LET;
@ -761,23 +723,17 @@ static Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *ol
resolving local-variable offsets */
frame = init_letrec_check_frame(frame_type, LET_RHS_EXPR,
count, old_frame, NULL,
head);
head, NULL);
body = head->body;
if (frame_type == FRAME_TYPE_LETREC)
k = head->count;
else
k = 0;
k = 0;
/* loops through every right hand side */
clv = NULL;
for (i = num_clauses; i--;) {
clv = (Scheme_Compiled_Let_Value *)body;
if (frame_type == FRAME_TYPE_LETREC)
k -= clv->count;
if (clv->count == 0) {
val = letrec_check_expr(clv->value, frame,
/* deferred closures get attached to no variables,
@ -806,14 +762,13 @@ static Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *ol
val = letrec_check_expr(clv->value, frame, new_pos);
}
if (frame_type != FRAME_TYPE_LETREC)
k += clv->count;
if (frame_type == FRAME_TYPE_LETREC) {
for (j = 0; j < clv->count; j++) {
frame->ref[j + k] |= LET_READY;
}
}
k += clv->count;
clv->value = val;
@ -826,7 +781,7 @@ static Scheme_Object *letrec_check_lets(Scheme_Object *o, Letrec_Check_Frame *ol
information) */
body_frame = init_letrec_check_frame(frame_type, LET_BODY_EXPR,
count, old_frame, frame,
head);
head, NULL);
val = letrec_check_expr(body, body_frame, pos);
@ -883,12 +838,12 @@ static Scheme_Object *letrec_check_set(Scheme_Object *o, Letrec_Check_Frame *fra
val = letrec_check_expr(val, frame, rhs_pos);
sb->val = val;
if (SAME_TYPE(SCHEME_TYPE(sb->var), scheme_local_type)) {
if (SAME_TYPE(SCHEME_TYPE(sb->var), scheme_compiled_local_type)) {
/* We may need to insert a definedness check before the assignment */
Letrec_Check_Frame *in_frame;
int position = SCHEME_LOCAL_POS(sb->var);
int position;
in_frame = get_relative_frame(&position, frame);
in_frame = get_relative_frame(&position, (Scheme_Compiled_Local *)sb->var);
if (in_frame->ref
&& !(in_frame->ref[position] & LET_READY)) {
@ -897,7 +852,7 @@ static Scheme_Object *letrec_check_set(Scheme_Object *o, Letrec_Check_Frame *fra
Scheme_Object *name;
Scheme_Sequence *seq;
name = record_checked((Scheme_Local *)sb->var, frame);
name = record_checked((Scheme_Compiled_Local *)sb->var, frame);
app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
app3->iso.so.type = scheme_application3_type;
@ -1040,7 +995,7 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame
SCHEME_USE_FUEL(1);
switch (type) {
case scheme_local_type:
case scheme_compiled_local_type:
return letrec_check_local(expr, frame, pos);
case scheme_application_type:
return letrec_check_application(expr, frame, pos);
@ -1103,7 +1058,7 @@ Scheme_Object *scheme_letrec_check_expr(Scheme_Object *expr)
frame = init_letrec_check_frame(FRAME_TYPE_TOP, LET_BODY_EXPR,
0, NULL, NULL,
NULL);
NULL, NULL);
/* (Grep "EXPL-3" for information): The `pos` argument, starting
here as `init_pos`, represents whether we're in a non-application

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

@ -649,17 +649,17 @@ static Scheme_Object *write_sequence(Scheme_Object *obj)
static Scheme_Object *read_sequence(Scheme_Object *obj)
{
return scheme_make_sequence_compilation(obj, 1);
return scheme_make_sequence_compilation(obj, 1, 1);
}
static Scheme_Object *read_sequence_save_first(Scheme_Object *obj)
{
return scheme_make_sequence_compilation(obj, -2);
return scheme_make_sequence_compilation(obj, -2, 1);
}
static Scheme_Object *read_sequence_splice(Scheme_Object *obj)
{
obj = scheme_make_sequence_compilation(obj, 1);
obj = scheme_make_sequence_compilation(obj, 1, 1);
if (!obj) return NULL;
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type))

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

@ -9255,7 +9255,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
body_lists = SCHEME_CDR(m);
m = SCHEME_CAR(m);
/* turn list of compiled expressions into a splice: */
m = scheme_make_sequence_compilation(m, 0);
m = scheme_make_sequence_compilation(m, 0, 0);
if (m->type == scheme_sequence_type)
m->type = scheme_splice_sequence_type;
} else {
@ -9727,7 +9727,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
Scheme_Object *prev = NULL, *next;
for (p = first; !SCHEME_NULLP(p); p = next) {
next = SCHEME_CDR(p);
if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL, 0, 0, 0)) {
if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL)) {
if (prev)
SCHEME_CDR(prev) = next;
else

2
racket/src/racket/src/mzmark_compenv.inc
View File

@ -23,6 +23,7 @@ static int mark_comp_env_MARK(void *p, struct NewGC *gc) {
gcMARK2(e->bindings, gc);
gcMARK2(e->vals, gc);
gcMARK2(e->shadower_deltas, gc);
gcMARK2(e->vars, gc);
gcMARK2(e->dup_check, gc);
gcMARK2(e->intdef_name, gc);
gcMARK2(e->in_modidx, gc);
@ -60,6 +61,7 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(e->bindings, gc);
gcFIXUP2(e->vals, gc);
gcFIXUP2(e->shadower_deltas, gc);
gcFIXUP2(e->vars, gc);
gcFIXUP2(e->dup_check, gc);
gcFIXUP2(e->intdef_name, gc);
gcFIXUP2(e->in_modidx, gc);

8
racket/src/racket/src/mzmark_fun.inc
View File

@ -12,8 +12,8 @@ static int mark_closure_info_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Closure_Info *i = (Closure_Info *)p;
gcMARK2(i->local_flags, gc);
gcMARK2(i->base_closure_map, gc);
gcMARK2(i->base_closure, gc);
gcMARK2(i->vars, gc);
gcMARK2(i->local_type_map, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@ -29,8 +29,8 @@ static int mark_closure_info_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Closure_Info *i = (Closure_Info *)p;
gcFIXUP2(i->local_flags, gc);
gcFIXUP2(i->base_closure_map, gc);
gcFIXUP2(i->base_closure, gc);
gcFIXUP2(i->vars, gc);
gcFIXUP2(i->local_type_map, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS

2
racket/src/racket/src/mzmark_letrec_check.inc
View File

@ -15,7 +15,6 @@ static int mark_letrec_check_frame_MARK(void *p, struct NewGC *gc) {
gcMARK2(frame->def, gc);
gcMARK2(frame->next, gc);
gcMARK2(frame->ref, gc);
gcMARK2(frame->head, gc);
gcMARK2(frame->deferred_chain, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@ -34,7 +33,6 @@ static int mark_letrec_check_frame_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(frame->def, gc);
gcFIXUP2(frame->next, gc);
gcFIXUP2(frame->ref, gc);
gcFIXUP2(frame->head, gc);
gcFIXUP2(frame->deferred_chain, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS

20
racket/src/racket/src/mzmark_optimize.inc
View File

@ -12,18 +12,15 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Optimize_Info *i = (Optimize_Info *)p;
gcMARK2(i->stat_dists, gc);
gcMARK2(i->sd_depths, gc);
gcMARK2(i->next, gc);
gcMARK2(i->use, gc);
gcMARK2(i->consts, gc);
gcMARK2(i->cp, gc);
gcMARK2(i->top_level_consts, gc);
gcMARK2(i->transitive_use, gc);
gcMARK2(i->transitive_use_len, gc);
gcMARK2(i->transitive_use_var, gc);
gcMARK2(i->context, gc);
gcMARK2(i->logger, gc);
gcMARK2(i->types, gc);
gcMARK2(i->uses, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
@ -38,18 +35,15 @@ static int mark_optimize_info_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Optimize_Info *i = (Optimize_Info *)p;
gcFIXUP2(i->stat_dists, gc);
gcFIXUP2(i->sd_depths, gc);
gcFIXUP2(i->next, gc);
gcFIXUP2(i->use, gc);
gcFIXUP2(i->consts, gc);
gcFIXUP2(i->cp, gc);
gcFIXUP2(i->top_level_consts, gc);
gcFIXUP2(i->transitive_use, gc);
gcFIXUP2(i->transitive_use_len, gc);
gcFIXUP2(i->transitive_use_var, gc);
gcFIXUP2(i->context, gc);
gcFIXUP2(i->logger, gc);
gcFIXUP2(i->types, gc);
gcFIXUP2(i->uses, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
@ -76,8 +70,7 @@ static int mark_once_used_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Scheme_Once_Used *o = (Scheme_Once_Used *)p;
gcMARK2(o->expr, gc);
gcMARK2(o->info, gc);
gcMARK2(o->next, gc);
gcMARK2(o->var, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else
@ -91,8 +84,7 @@ static int mark_once_used_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Scheme_Once_Used *o = (Scheme_Once_Used *)p;
gcFIXUP2(o->expr, gc);
gcFIXUP2(o->info, gc);
gcFIXUP2(o->next, gc);
gcFIXUP2(o->var, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else

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

@ -15,12 +15,9 @@ static int mark_resolve_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->prefix, gc);
gcMARK2(i->stx_map, gc);
gcMARK2(i->tl_map, gc);
gcMARK2(i->old_pos, gc);
gcMARK2(i->new_pos, gc);
gcMARK2(i->old_stx_pos, gc);
gcMARK2(i->flags, gc);
gcMARK2(i->redirects, gc);
gcMARK2(i->lifts, gc);
gcMARK2(i->lifted, gc);
gcMARK2(i->next, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@ -39,12 +36,9 @@ static int mark_resolve_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->prefix, gc);
gcFIXUP2(i->stx_map, gc);
gcFIXUP2(i->tl_map, gc);
gcFIXUP2(i->old_pos, gc);
gcFIXUP2(i->new_pos, gc);
gcFIXUP2(i->old_stx_pos, gc);
gcFIXUP2(i->flags, gc);
gcFIXUP2(i->redirects, gc);
gcFIXUP2(i->lifts, gc);
gcFIXUP2(i->lifted, gc);
gcFIXUP2(i->next, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@ -72,16 +66,13 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Unresolve_Info *i = (Unresolve_Info *)p;
gcMARK2(i->flags, gc);
gcMARK2(i->depths, gc);
gcMARK2(i->vars, 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);
gcMARK2(i->ref_lifts, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
@ -97,16 +88,13 @@ static int mark_unresolve_info_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Unresolve_Info *i = (Unresolve_Info *)p;
gcFIXUP2(i->flags, gc);
gcFIXUP2(i->depths, gc);
gcFIXUP2(i->vars, 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);
gcFIXUP2(i->ref_lifts, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS

78
racket/src/racket/src/mzmark_type.inc
View File

@ -947,6 +947,78 @@ static int with_cont_mark_FIXUP(void *p, struct NewGC *gc) {
#define with_cont_mark_IS_CONST_SIZE 1
static int comp_local_SIZE(void *p, struct NewGC *gc) {
#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Local));
#else
return 0;
#endif
}
static int comp_local_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Scheme_Compiled_Local *var = (Scheme_Compiled_Local *)p;
gcMARK2(var->name, gc);
switch (var->mode) {
case SCHEME_VAR_MODE_LETREC_CHECK:
gcMARK2(var->letrec_check.frame, gc);
break;
case SCHEME_VAR_MODE_OPTIMIZE:
gcMARK2(var->optimize.known_val, gc);
gcMARK2(var->optimize.transitive_uses, gc);
gcMARK2(var->optimize.transitive_uses_to, gc);
break;
case SCHEME_VAR_MODE_RESOLVE:
gcMARK2(var->resolve.lifted, gc);
break;
default:
break;
}
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else
return
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Local));
# endif
#endif
}
static int comp_local_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Scheme_Compiled_Local *var = (Scheme_Compiled_Local *)p;
gcFIXUP2(var->name, gc);
switch (var->mode) {
case SCHEME_VAR_MODE_LETREC_CHECK:
gcFIXUP2(var->letrec_check.frame, gc);
break;
case SCHEME_VAR_MODE_OPTIMIZE:
gcFIXUP2(var->optimize.known_val, gc);
gcFIXUP2(var->optimize.transitive_uses, gc);
gcFIXUP2(var->optimize.transitive_uses_to, gc);
break;
case SCHEME_VAR_MODE_RESOLVE:
gcFIXUP2(var->resolve.lifted, gc);
break;
default:
break;
}
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
# else
return
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Local));
# endif
#endif
}
#define comp_local_IS_ATOMIC 0
#define comp_local_IS_CONST_SIZE 1
static int comp_let_value_SIZE(void *p, struct NewGC *gc) {
#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Let_Value));
@ -959,10 +1031,9 @@ static int comp_let_value_MARK(void *p, struct NewGC *gc) {
#ifndef GC_NO_MARK_PROCEDURE_NEEDED
Scheme_Compiled_Let_Value *c = (Scheme_Compiled_Let_Value *)p;
gcMARK2(c->flags, gc);
gcMARK2(c->value, gc);
gcMARK2(c->body, gc);
gcMARK2(c->names, gc);
gcMARK2(c->vars, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;
@ -977,10 +1048,9 @@ static int comp_let_value_FIXUP(void *p, struct NewGC *gc) {
#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED
Scheme_Compiled_Let_Value *c = (Scheme_Compiled_Let_Value *)p;
gcFIXUP2(c->flags, gc);
gcFIXUP2(c->value, gc);
gcFIXUP2(c->body, gc);
gcFIXUP2(c->names, gc);
gcFIXUP2(c->vars, gc);
# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS
return 0;

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

@ -228,14 +228,38 @@ with_cont_mark {
gcBYTES_TO_WORDS(sizeof(Scheme_With_Continuation_Mark));
}
comp_local {
mark:
Scheme_Compiled_Local *var = (Scheme_Compiled_Local *)p;
gcMARK2(var->name, gc);
switch (var->mode) {
case SCHEME_VAR_MODE_LETREC_CHECK:
gcMARK2(var->letrec_check.frame, gc);
break;
case SCHEME_VAR_MODE_OPTIMIZE:
gcMARK2(var->optimize.known_val, gc);
gcMARK2(var->optimize.transitive_uses, gc);
gcMARK2(var->optimize.transitive_uses_to, gc);
break;
case SCHEME_VAR_MODE_RESOLVE:
gcMARK2(var->resolve.lifted, gc);
break;
default:
break;
}
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Local));
}
comp_let_value {
mark:
Scheme_Compiled_Let_Value *c = (Scheme_Compiled_Let_Value *)p;
gcMARK2(c->flags, gc);
gcMARK2(c->value, gc);
gcMARK2(c->body, gc);
gcMARK2(c->names, gc);
gcMARK2(c->vars, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Let_Value));
@ -1268,6 +1292,7 @@ mark_comp_env {
gcMARK2(e->bindings, gc);
gcMARK2(e->vals, gc);
gcMARK2(e->shadower_deltas, gc);
gcMARK2(e->vars, gc);
gcMARK2(e->dup_check, gc);
gcMARK2(e->intdef_name, gc);
gcMARK2(e->in_modidx, gc);
@ -1298,12 +1323,9 @@ mark_resolve_info {
gcMARK2(i->prefix, gc);
gcMARK2(i->stx_map, gc);
gcMARK2(i->tl_map, gc);
gcMARK2(i->old_pos, gc);
gcMARK2(i->new_pos, gc);
gcMARK2(i->old_stx_pos, gc);
gcMARK2(i->flags, gc);
gcMARK2(i->redirects, gc);
gcMARK2(i->lifts, gc);
gcMARK2(i->lifted, gc);
gcMARK2(i->next, gc);
size:
@ -1314,16 +1336,13 @@ mark_unresolve_info {
mark:
Unresolve_Info *i = (Unresolve_Info *)p;
gcMARK2(i->flags, gc);
gcMARK2(i->depths, gc);
gcMARK2(i->vars, 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);
gcMARK2(i->ref_lifts, gc);
size:
@ -1361,7 +1380,6 @@ mark_letrec_check_frame {
gcMARK2(frame->def, gc);
gcMARK2(frame->next, gc);
gcMARK2(frame->ref, gc);
gcMARK2(frame->head, gc);
gcMARK2(frame->deferred_chain, gc);
size:
@ -1390,18 +1408,15 @@ mark_optimize_info {
mark:
Optimize_Info *i = (Optimize_Info *)p;
gcMARK2(i->stat_dists, gc);
gcMARK2(i->sd_depths, gc);
gcMARK2(i->next, gc);
gcMARK2(i->use, gc);
gcMARK2(i->consts, gc);
gcMARK2(i->cp, gc);
gcMARK2(i->top_level_consts, gc);
gcMARK2(i->transitive_use, gc);
gcMARK2(i->transitive_use_len, gc);
gcMARK2(i->transitive_use_var, gc);
gcMARK2(i->context, gc);
gcMARK2(i->logger, gc);
gcMARK2(i->types, gc);
gcMARK2(i->uses, gc);
size:
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
@ -1411,8 +1426,7 @@ mark_once_used {
mark:
Scheme_Once_Used *o = (Scheme_Once_Used *)p;
gcMARK2(o->expr, gc);
gcMARK2(o->info, gc);
gcMARK2(o->next, gc);
gcMARK2(o->var, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used));
}
@ -1461,8 +1475,8 @@ mark_closure_info {
mark:
Closure_Info *i = (Closure_Info *)p;
gcMARK2(i->local_flags, gc);
gcMARK2(i->base_closure_map, gc);
gcMARK2(i->base_closure, gc);
gcMARK2(i->vars, gc);
gcMARK2(i->local_type_map, gc);
size:

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -1459,6 +1459,112 @@ Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv);
/* syntax run-time structures */
/*========================================================================*/
/* A Scheme_Compiled_Local record represents a local variable,
both the binding and references to that binding. When inlining
of other transformations duplicate a variable, a new instance
is allocated to represent a separate variable. Different passes
in the comiler store different information about the variable. */
typedef struct Scheme_Compiled_Local
{
Scheme_Object so;
/* The `mode` value is one of `SCHEME_VAR_MODE_NONE`, etc.,
and it determines which of the union cases below (if any)
is active, corresponding to information for a particular
pass: */
unsigned int mode : 3;
/* Number of time the variable was referenced as counted by
the initial compile phase; a `SCHEME_USE_COUNT_INF`
value corresponds to "more than we counted": */
unsigned int use_count : 3;
/* Subset of `use_count` references that are in non-rator
positions: */
unsigned int non_app_count : 3;
/* Records whether the variable is mutated; set in several
phases, and currently never unset: */
unsigned int mutated : 1;
/* Records whether the optimizer discovered any uses;
if true, then `use_count` must be non-zero, but the
optimizer eliminate references and produce 0 here even
if `use_count` is non-zero: */
unsigned int optimize_used : 1;
/* Set while compiling the right-hand side of a letrec
to indicate that current and later left-hand sides
are not yet initialized: */
unsigned int optimize_unready : 1;
/* After optimizing a `let[rec]` form, we might still go into
the body (e.g., for funciton inlining), but mark the variable
as having a binding set up: */
unsigned int optimize_outside_binding : 1;
/* Records an anlaysis during the resolve pass: */
unsigned int resolve_omittable : 1;
/* The type desired by use positions for unboxing purposes;
set by the optimizer: */
unsigned int arg_type : SCHEME_MAX_LOCAL_TYPE_BITS;
/* The type provided by the binding position, mainly for unboxing
purposes; set by the optimizer and potentially refined by the
resolve pass (especially for function arguments whose types are
set via local_type_map): */
unsigned int val_type : SCHEME_MAX_LOCAL_TYPE_BITS;
/* Unboxing might be disabled because allocation of boxes would
be moved past a continuation: */
unsigned int escapes_after_k_tick : 1;
/* During unresolve, indicates whether references should be
converted to calls: */
unsigned int is_ref_arg : 1;
Scheme_Object *name;
/* `mode` determines which union is active: */
union {
struct {
/* Maps the variable into the letrec-check pass's frames: */
struct Letrec_Check_Frame *frame;
int frame_pos;
} letrec_check;
struct {
/* Constant- and copy-propagation information: */
Scheme_Object *known_val;
/* Number of `lambda` wrappers, which is relevant for
accumulating closures, etc.: */
int lambda_depth;
/* Vitual continuation-capture clock for the variable's
initialation, used to detect potential captures of
allocation: */
int init_kclock;
/* Transitive uses record uses that become used if
the variable itself is used; which is relevant
for analyzing a letrec-bound function that might
not get called: */
Scheme_Hash_Table *transitive_uses;
struct Optimize_Info *transitive_uses_to;
} optimize;
struct {
/* Records the position where the variable will be
on the runstack, counting down from the enclosing
procedure's starting point (i.e., backwards from the
run-time direction): */
int co_depth;
/* Records a lexical depth for the purposes of sorting
variables (as needed to make compilation deterministic): */
int lex_depth;
/* Information on closure-converstion of this
variable's binding: */
Scheme_Object *lifted;
} resolve;
};
} Scheme_Compiled_Local;
#define SCHEME_VAR(v) ((Scheme_Compiled_Local *)v)
#define SCHEME_USE_COUNT_INF 7
#define SCHEME_VAR_MODE_NONE 0
#define SCHEME_VAR_MODE_COMPILE 1
#define SCHEME_VAR_MODE_LETREC_CHECK 2
#define SCHEME_VAR_MODE_OPTIMIZE 3
#define SCHEME_VAR_MODE_RESOLVE 4
typedef struct {
Scheme_Inclhash_Object iso; /* keyex used for flags */
mzshort num_args; /* doesn't include rator, so arguments are at args[1]...args[num_args] */
@ -1514,33 +1620,12 @@ typedef struct {
additions to the top-level bindings table */
} Scheme_Compilation_Top;
/* A `let', `let*', or `letrec' form is compiled to the intermediate
/* A `let' or `letrec' form is compiled to the intermediate
format (used during the optimization pass) as a Scheme_Let_Header
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 supports `let*',
which is useful mostly for converting a simple enough `letrec' form
into `let*.
The body of the `let...' form is the body of the innermost
Scheme_Compiled_Let_Value record. Obviously, all N bindings of a
`let...' form are pushed onto the virtual stack for the body, but
the situation is more complex for the binding right-hand
sides. There are three cases:
* Plain `let': no bindings are pushed, yet. (This is in contrast
to the convention for the final bytecode format, where space for
the binding is allocated before the right-hand side is
evaluated.)
* `letrec': all bindings are pushed; the first clause is pushed
first, etc.
* `let*' can be like `letrec', but also can have the bindings in
reverse order; that is, all bindings are pushed before any
right-hand side, but the last binding may be pushed first
instead of last.
clause. The body of the `let...' form is the body of the innermost
Scheme_Compiled_Let_Value record.
*/
typedef struct Scheme_Let_Header {
@ -1552,16 +1637,13 @@ typedef struct Scheme_Let_Header {
#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define SCHEME_LET_RECURSIVE 0x1
#define SCHEME_LET_STAR 0x2
typedef struct Scheme_Compiled_Let_Value {
Scheme_Inclhash_Object iso; /* keyex used for set-starting */
mzshort count;
mzshort position;
int *flags;
Scheme_Object *value;
Scheme_Object *body;
Scheme_Object **names; /* NULL after letrec_check phase */
Scheme_Compiled_Local **vars;
} Scheme_Compiled_Let_Value;
#define SCHEME_CLV_FLAGS(clv) MZ_OPT_HASH_KEY(&(clv)->iso)
@ -2688,8 +2770,9 @@ typedef struct Scheme_Comp_Env
Scheme_Object **bindings; /* symbols */
Scheme_Object **vals; /* compile-time values */
Scheme_Object **shadower_deltas;
Scheme_Compiled_Local **vars;
int *use;
int min_use, any_use;
int max_use, any_use;
Scheme_Object *lifts;
@ -2765,10 +2848,9 @@ typedef struct Resolve_Info Resolve_Info;
before a closure mapping is resolved. */
typedef struct {
MZTAG_IF_REQUIRED
int *local_flags; /* for arguments from compile pass, flonum info updated in optimize pass */
mzshort base_closure_size; /* doesn't include top-level (if any) */
mzshort *base_closure_map;
char *local_type_map; /* NULL when has_tymap set => no local types */
Scheme_Hash_Table *base_closure;
Scheme_Compiled_Local **vars;
char *local_type_map; /* determined by callers; NULL when has_tymap set => no local types */
char has_tl, has_tymap, has_nonleaf;
int body_size, body_psize;
} Closure_Info;
@ -3189,7 +3271,7 @@ Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *);
Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags);
int scheme_expr_produces_local_type(Scheme_Object *expr);
int scheme_expr_produces_local_type(Scheme_Object *expr, int *_involves_k_cross);
Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax,
Scheme_Syntax_Expander *exp);
@ -3223,7 +3305,8 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
Scheme_Expand_Info *dest, int n);
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list,
int strip_values);
int strip_values,
int resolved);
Scheme_App_Rec *scheme_malloc_application(int n);
void scheme_finish_application(Scheme_App_Rec *app);
@ -3254,24 +3337,12 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *e
#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj)
#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj)
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame);
int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos);
int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos);
void scheme_mark_all_use(Scheme_Comp_Env *frame);
/* flags reported by scheme_env_get_flags */
#define SCHEME_WAS_USED 0x1
#define SCHEME_WAS_SET_BANGED 0x2
#define SCHEME_WAS_ONLY_APPLIED 0x4
#define SCHEME_WAS_APPLIED_EXCEPT_ONCE 0x8
#define SCHEME_USE_COUNT_MASK 0x70
#define SCHEME_USE_COUNT_SHIFT 4
#define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
#define SCHEME_WAS_TYPED_ARGUMENT_SHIFT 7
#define SCHEME_WAS_TYPED_ARGUMENT_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_WAS_TYPED_ARGUMENT_SHIFT)
#define SCHEME_WAS_TYPED_ARGUMENT(f) ((f & SCHEME_WAS_TYPED_ARGUMENT_MASK) >> SCHEME_WAS_TYPED_ARGUMENT_SHIFT)
void scheme_env_make_variables(Scheme_Comp_Env *frame);
void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_Compiled_Local **vars,
int pos, int count);
/* flags reported by scheme_resolve_info_flags */
#define SCHEME_INFO_BOXED 0x1
@ -3349,14 +3420,14 @@ void scheme_prepare_env_stx_context(Scheme_Env *env);
XFORM_NONGCING Scheme_Object *scheme_env_phase(Scheme_Env *env);
Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase);
int scheme_used_app_only(Scheme_Comp_Env *env, int which);
int scheme_used_ever(Scheme_Comp_Env *env, int which);
int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
Optimize_Info *opt_info, Optimize_Info *warn_info);
#define OMITTABLE_RESOLVED 0x1
#define OMITTABLE_KEEP_VARS 0x2
#define OMITTABLE_KEEP_MUTABLE_VARS 0x4
int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
Optimize_Info *opt_info, Optimize_Info *warn_info,
int min_id_depth, int id_offset, int no_id);
int scheme_might_invoke_call_cc(Scheme_Object *value);
int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator, int or_escape);
int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape);
int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args, int expected_vals);
typedef struct {
@ -3393,8 +3464,6 @@ int scheme_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_is_single_result(Scheme_Object *rator);
int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);
int scheme_get_eval_type(Scheme_Object *obj);
Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info);
@ -4533,6 +4602,7 @@ void scheme_place_check_memory_use();
void scheme_clear_place_ifs_stack();
Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *ht);
void scheme_sort_resolve_compiled_local_array(Scheme_Compiled_Local **a, intptr_t count);
#ifdef MZ_USE_PLACES
Scheme_Object *scheme_place_make_async_channel();

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.4.0.7"
#define MZSCHEME_VERSION "6.4.0.8"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -717,7 +717,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single
value. */
if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, NULL, 0, 0, 0)) {
if (scheme_omittable_expr(rhs, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) {
rhs = scheme_false;
} else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {

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

@ -36,270 +36,271 @@ enum {
_scheme_values_types_, /* All following types are values */
/* intermediate compiled: */
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_compiled_local_type, /* 30 */
scheme_compiled_unclosed_procedure_type,/* 31 */
scheme_compiled_let_value_type, /* 32 */
scheme_compiled_let_void_type, /* 33 */
scheme_compiled_toplevel_type, /* 34 */
scheme_compiled_quote_syntax_type, /* 35 */
scheme_quote_compilation_type, /* used while writing, only */
/* Registered in prefix table: */
scheme_variable_type, /* 36 */
scheme_variable_type, /* 37 */
scheme_module_variable_type, /* link replaces with scheme_variable_type */
_scheme_compiled_values_types_, /* 38 */
_scheme_compiled_values_types_, /* 39 */
/* procedure types */
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_prim_type, /* 40 */
scheme_closed_prim_type, /* 41 */
scheme_closure_type, /* 42 */
scheme_case_closure_type, /* 43 */
scheme_cont_type, /* 44 */
scheme_escaping_cont_type, /* 45 */
scheme_proc_struct_type, /* 46 */
scheme_native_closure_type, /* 47 */
scheme_proc_chaperone_type, /* 48 */
scheme_chaperone_type, /* 48 */
scheme_chaperone_type, /* 49 */
/* structure type (plus one above for procs) */
scheme_structure_type, /* 49 */
scheme_structure_type, /* 50 */
/* number types (must be together) */
scheme_integer_type, /* 50 */
scheme_bignum_type, /* 51 */
scheme_rational_type, /* 52 */
scheme_float_type, /* 53 */
scheme_double_type, /* 54 */
scheme_complex_type, /* 55 */
scheme_integer_type, /* 51 */
scheme_bignum_type, /* 52 */
scheme_rational_type, /* 53 */
scheme_float_type, /* 54 */
scheme_double_type, /* 55 */
scheme_complex_type, /* 56 */
/* other eqv?-able values (must be with numbers) */
scheme_char_type, /* 56 */
scheme_char_type, /* 57 */
/* other values */
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 */
scheme_long_double_type, /* 58 */
scheme_char_string_type, /* 59 */
scheme_byte_string_type, /* 60 */
scheme_unix_path_type, /* 61 */
scheme_windows_path_type, /* 62 */
scheme_symbol_type, /* 63 */
scheme_keyword_type, /* 64 */
scheme_null_type, /* 65 */
scheme_pair_type, /* 66 */
scheme_mutable_pair_type, /* 67 */
scheme_vector_type, /* 68 */
scheme_inspector_type, /* 69 */
scheme_input_port_type, /* 70 */
scheme_output_port_type, /* 71 */
scheme_eof_type, /* 72 */
scheme_true_type, /* 73 */
scheme_false_type, /* 74 */
scheme_void_type, /* 75 */
scheme_syntax_compiler_type, /* 76 */
scheme_macro_type, /* 77 */
scheme_box_type, /* 78 */
scheme_thread_type, /* 79 */
scheme_scope_type, /* 80 */
scheme_stx_offset_type, /* 81 */
scheme_cont_mark_set_type, /* 82 */
scheme_sema_type, /* 83 */
scheme_hash_table_type, /* 84 */
scheme_hash_tree_type, /* 85 */
scheme_eq_hash_tree_type, /* 86 */
scheme_eqv_hash_tree_type, /* 87 */
scheme_hash_tree_subtree_type, /* 88 */
scheme_hash_tree_collision_type, /* 89 */
scheme_hash_tree_indirection_type, /* 90 */
scheme_cpointer_type, /* 91 */
scheme_prefix_type, /* 92 */
scheme_weak_box_type, /* 93 */
scheme_ephemeron_type, /* 94 */
scheme_struct_type_type, /* 95 */
scheme_module_index_type, /* 96 */
scheme_set_macro_type, /* 97 */
scheme_listener_type, /* 98 */
scheme_namespace_type, /* 99 */
scheme_config_type, /* 100 */
scheme_stx_type, /* 101 */
scheme_will_executor_type, /* 102 */
scheme_custodian_type, /* 103 */
scheme_random_state_type, /* 104 */
scheme_regexp_type, /* 105 */
scheme_bucket_type, /* 106 */
scheme_bucket_table_type, /* 107 */
scheme_subprocess_type, /* 108 */
scheme_compilation_top_type, /* 109 */
scheme_wrap_chunk_type, /* 110 */
scheme_eval_waiting_type, /* 111 */
scheme_tail_call_waiting_type, /* 112 */
scheme_undefined_type, /* 113 */
scheme_struct_property_type, /* 114 */
scheme_chaperone_property_type, /* 115 */
scheme_multiple_values_type, /* 116 */
scheme_placeholder_type, /* 117 */
scheme_table_placeholder_type, /* 118 */
scheme_scope_table_type, /* 119 */
scheme_propagate_table_type, /* 120 */
scheme_svector_type, /* 121 */
scheme_resolve_prefix_type, /* 122 */
scheme_security_guard_type, /* 123 */
scheme_indent_type, /* 124 */
scheme_udp_type, /* 125 */
scheme_udp_evt_type, /* 126 */
scheme_tcp_accept_evt_type, /* 127 */
scheme_id_macro_type, /* 128 */
scheme_evt_set_type, /* 129 */
scheme_wrap_evt_type, /* 130 */
scheme_handle_evt_type, /* 131 */
scheme_replace_evt_type, /* 132 */
scheme_active_replace_evt_type, /* 133 */
scheme_nack_guard_evt_type, /* 134 */
scheme_semaphore_repost_type, /* 135 */
scheme_channel_type, /* 136 */
scheme_channel_put_type, /* 137 */
scheme_thread_resume_type, /* 138 */
scheme_thread_suspend_type, /* 139 */
scheme_thread_dead_type, /* 140 */
scheme_poll_evt_type, /* 141 */
scheme_nack_evt_type, /* 142 */
scheme_module_registry_type, /* 143 */
scheme_thread_set_type, /* 144 */
scheme_string_converter_type, /* 145 */
scheme_alarm_type, /* 146 */
scheme_thread_recv_evt_type, /* 147 */
scheme_thread_cell_type, /* 148 */
scheme_channel_syncer_type, /* 149 */
scheme_special_comment_type, /* 150 */
scheme_write_evt_type, /* 151 */
scheme_always_evt_type, /* 152 */
scheme_never_evt_type, /* 153 */
scheme_progress_evt_type, /* 154 */
scheme_place_dead_type, /* 155 */
scheme_already_comp_type, /* 156 */
scheme_readtable_type, /* 157 */
scheme_intdef_context_type, /* 158 */
scheme_lexical_rib_type, /* 159 */
scheme_thread_cell_values_type, /* 160 */
scheme_global_ref_type, /* 161 */
scheme_cont_mark_chain_type, /* 162 */
scheme_raw_pair_type, /* 163 */
scheme_prompt_type, /* 164 */
scheme_prompt_tag_type, /* 165 */
scheme_continuation_mark_key_type, /* 166 */
scheme_expanded_syntax_type, /* 167 */
scheme_delay_syntax_type, /* 168 */
scheme_cust_box_type, /* 169 */
scheme_resolved_module_path_type, /* 170 */
scheme_module_phase_exports_type, /* 171 */
scheme_logger_type, /* 172 */
scheme_log_reader_type, /* 173 */
scheme_marshal_share_type, /* 174 */
scheme_rib_delimiter_type, /* 175 */
scheme_noninline_proc_type, /* 176 */
scheme_prune_context_type, /* 177 */
scheme_future_type, /* 178 */
scheme_flvector_type, /* 179 */
scheme_extflvector_type, /* 180 */
scheme_fxvector_type, /* 181 */
scheme_place_type, /* 182 */
scheme_place_object_type, /* 183 */
scheme_place_async_channel_type, /* 184 */
scheme_place_bi_channel_type, /* 185 */
scheme_once_used_type, /* 186 */
scheme_serialized_symbol_type, /* 187 */
scheme_serialized_keyword_type, /* 188 */
scheme_serialized_structure_type, /* 189 */
scheme_fsemaphore_type, /* 190 */
scheme_serialized_tcp_fd_type, /* 191 */
scheme_serialized_file_fd_type, /* 192 */
scheme_port_closed_evt_type, /* 193 */
scheme_proc_shape_type, /* 194 */
scheme_struct_proc_shape_type, /* 195 */
scheme_phantom_bytes_type, /* 196 */
scheme_environment_variables_type, /* 197 */
scheme_filesystem_change_evt_type, /* 198 */
scheme_ctype_type, /* 199 */
scheme_plumber_type, /* 200 */
scheme_plumber_handle_type, /* 201 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 201 */
_scheme_last_normal_type_, /* 202 */
scheme_rt_weak_array, /* 202 */
scheme_rt_weak_array, /* 203 */
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_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, /* 204 */
scheme_rt_constant_binding, /* 205 */
scheme_rt_resolve_info, /* 206 */
scheme_rt_unresolve_info, /* 207 */
scheme_rt_optimize_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_
};

20
racket/src/racket/src/syntax.c
View File

@ -47,10 +47,10 @@ ROSYM static Scheme_Object *fallbacks_symbol;
READ_ONLY Scheme_Object *scheme_syntax_p_proc;
READ_ONLY Scheme_Hash_Tree *empty_hash_tree;
READ_ONLY Scheme_Scope_Table *empty_scope_table;
READ_ONLY Scheme_Scope_Table *empty_propagate_table;
READ_ONLY Scheme_Scope_Set *empty_scope_set;
READ_ONLY static Scheme_Hash_Tree *empty_hash_tree;
READ_ONLY static Scheme_Scope_Table *empty_scope_table;
READ_ONLY static Scheme_Scope_Table *empty_propagate_table;
READ_ONLY static Scheme_Scope_Set *empty_scope_set;
ROSYM Scheme_Object *scheme_paren_shape_symbol;
@ -5858,6 +5858,18 @@ static void sort_number_array(Scheme_Object **a, intptr_t count)
my_qsort(a, count, sizeof(Scheme_Object *), compare_nums);
}
static int compare_vars_at_resolve(const void *_a, const void *_b)
{
Scheme_Compiled_Local *a = *(Scheme_Compiled_Local **)_a;
Scheme_Compiled_Local *b = *(Scheme_Compiled_Local **)_b;
return a->resolve.lex_depth - b->resolve.lex_depth;
}
void scheme_sort_resolve_compiled_local_array(Scheme_Compiled_Local **a, intptr_t count)
{
my_qsort(a, count, sizeof(Scheme_Compiled_Local *), compare_vars_at_resolve);
}
static Scheme_Object *drop_export_registries(Scheme_Object *shifts)
{
Scheme_Object *l, *a, *vec, *p, *first = scheme_null, *last = NULL;

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

@ -140,6 +140,7 @@ scheme_init_type ()
set_name(scheme_let_value_type, "<let-value-code>");
set_name(scheme_let_void_type, "<let-void-code>");
set_name(scheme_compiled_local_type, "<local-semi-code>");
set_name(scheme_compiled_let_value_type, "<let-value-semi-code>");
set_name(scheme_compiled_let_void_type, "<let-void-semi-code>");
set_name(scheme_compiled_toplevel_type, "<variable-semi-code>");
@ -589,6 +590,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(_scheme_values_types_, bad_trav);
GC_REG_TRAV(scheme_compiled_unclosed_procedure_type, unclosed_proc);
GC_REG_TRAV(scheme_compiled_local_type, comp_local);
GC_REG_TRAV(scheme_compiled_let_value_type, comp_let_value);
GC_REG_TRAV(scheme_compiled_let_void_type, let_header);
GC_REG_TRAV(scheme_compiled_toplevel_type, toplevel_obj);

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

@ -169,9 +169,8 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
if (num_toplevels || num_stxes || num_lifts) {
stack[depth - 1] = VALID_TOPLEVELS;
}
delta = depth - ((num_toplevels || num_stxes || num_lifts) ? 1 : 0);
tls = MALLOC_N(mzshort*, num_lifts);
if (code_vec) {
@ -1024,6 +1023,8 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
vld = VALID_BOX;
typed_arg = 1;
} else if (ct) {
if ((ct - CLOS_TYPE_TYPE_OFFSET) > SCHEME_MAX_LOCAL_TYPE)
scheme_ill_formed_code(port);
vld = (VALID_TYPED + (ct - CLOS_TYPE_TYPE_OFFSET));
typed_arg = 1;
} else
@ -1199,7 +1200,7 @@ static void no_typed(int need_local_type, Mz_CPort *port)
static void check_typed(Scheme_Object *expr, int need_local_type, Mz_CPort *port)
{
if (need_local_type) {
if (scheme_expr_produces_local_type(expr) != need_local_type)
if (scheme_expr_produces_local_type(expr, NULL) != need_local_type)
scheme_ill_formed_code(port);
}
}
@ -2052,6 +2053,10 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result_ignored, vc, tailpos, procs);
result = validate_join_const(result, expected_results);
break;
case scheme_compiled_local_type:
{
scheme_ill_formed_code(port);
}
default:
/* All values are definitely ok, except pre-closed closures.
Such a closure can refer back to itself, so we use a flag