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

attempts to improve expansion/compilation for deeply nested scopes

Browse Source 
svn: r2088
This commit is contained in:
Matthew Flatt 2006-02-02 15:36:23 +00:00
parent 67ebc2e4a0
commit 5c77673da3
8 changed files with 3004 additions and 2574 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4990
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

79
src/mzscheme/src/env.c
View File

@ -144,6 +144,9 @@ static void init_compile_data(Scheme_Comp_Env *env);
/* Precise GC WARNING: this macro produces unaligned pointers: */
#define COMPILE_DATA(e) (&((Scheme_Full_Comp_Env *)e)->data)
#define SCHEME_NON_SIMPLE_FRAME (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME \
| SCHEME_FOR_STOPS | SCHEME_FOR_INTDEF | SCHEME_CAPTURE_LIFTED)
/*========================================================================*/
/* initialization */
/*========================================================================*/
@ -1100,6 +1103,13 @@ Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags,
frame->prefix = base->prefix;
frame->in_modidx = base->in_modidx;
if (flags & SCHEME_NON_SIMPLE_FRAME)
frame->skip_depth = 0;
else if (base->next)
frame->skip_depth = base->skip_depth + 1;
else
frame->skip_depth = 0;
init_compile_data(frame);
return frame;
@ -1110,7 +1120,6 @@ Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int
Scheme_Comp_Env *e;
Comp_Prefix *cp;
if (!insp)
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
@ -1188,6 +1197,7 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
"index out of range: %d", index);
frame->values[index] = val;
frame->skip_table = NULL;
}
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data)
@ -1232,6 +1242,7 @@ void scheme_set_local_syntax(int pos,
{
COMPILE_DATA(env)->const_names[pos] = name;
COMPILE_DATA(env)->const_vals[pos] = val;
env->skip_table = NULL;
}
Scheme_Comp_Env *
@ -2063,6 +2074,49 @@ void scheme_seal_env_renames(Scheme_Comp_Env *env)
env->dup_check = NULL;
}
/*********************************************************************/
void create_skip_table(Scheme_Comp_Env *start_frame)
{
Scheme_Comp_Env *end_frame, *frame;
int depth, dj = 0, dp = 0, i;
Scheme_Hash_Table *table;
int stride = 0;
depth = start_frame->skip_depth;
/* Find frames to be covered by the skip table.
The theory here is the same as the `mapped' table
in Scheme_Cert (see stxobj.c) */
for (end_frame = start_frame->next;
end_frame && ((depth & end_frame->skip_depth) != end_frame->skip_depth);
end_frame = end_frame->next) {
stride++;
}
table = scheme_make_hash_table(SCHEME_hash_ptr);
for (frame = start_frame; frame != end_frame; frame = frame->next) {
if (frame->flags & SCHEME_LAMBDA_FRAME)
dj++;
dp += frame->num_bindings;
for (i = frame->num_bindings; i--; ) {
if (frame->values[i]) {
scheme_hash_set(table, SCHEME_STX_VAL(frame->values[i]), scheme_true);
}
}
for (i = COMPILE_DATA(frame)->num_const; i--; ) {
scheme_hash_set(table, SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]), scheme_true);
}
}
scheme_hash_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame);
scheme_hash_set(table, scheme_make_integer(1), scheme_make_integer(dj));
scheme_hash_set(table, scheme_make_integer(2), scheme_make_integer(dp));
start_frame->skip_table = table;
}
/*********************************************************************/
/*
@ -2101,14 +2155,31 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
phase = env->genv->phase;
/* Walk through the compilation frames */
frame = env;
for (frame = env; frame->next != NULL; frame = frame->next) {
int i;
Scheme_Object *uid;
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
while (1) {
if (frame->skip_table) {
if (!scheme_hash_get(frame->skip_table, SCHEME_STX_VAL(find_id))) {
/* Skip ahead. 0 maps to frame, 1 maps to j delta, and 2 maps to p delta */
val = scheme_hash_get(frame->skip_table, scheme_make_integer(1));
j += SCHEME_INT_VAL(val);
val = scheme_hash_get(frame->skip_table, scheme_make_integer(2));
p += SCHEME_INT_VAL(val);
frame = (Scheme_Comp_Env *)scheme_hash_get(frame->skip_table, scheme_make_integer(0));
} else
break;
} else if (frame->skip_depth && !(frame->skip_depth & 0x1F)) {
/* We're some multiple of 32 frames deep. Build a skip table and try again. */
create_skip_table(frame);
} else
break;
}
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) {
if (frame->flags & SCHEME_FOR_STOPS)
skip_stops = 1;

2
src/mzscheme/src/mzmark.c
View File

@ -2323,6 +2323,7 @@ int mark_comp_env_MARK(void *p) {
gcMARK(e->base.dup_check);
gcMARK(e->base.intdef_name);
gcMARK(e->base.in_modidx);
gcMARK(e->base.skip_table);
gcMARK(e->data.stat_dists);
gcMARK(e->data.sd_depths);
@ -2351,6 +2352,7 @@ int mark_comp_env_FIXUP(void *p) {
gcFIXUP(e->base.dup_check);
gcFIXUP(e->base.intdef_name);
gcFIXUP(e->base.in_modidx);
gcFIXUP(e->base.skip_table);
gcFIXUP(e->data.stat_dists);
gcFIXUP(e->data.sd_depths);

1
src/mzscheme/src/mzmarksrc.c
View File

@ -919,6 +919,7 @@ mark_comp_env {
gcMARK(e->base.dup_check);
gcMARK(e->base.intdef_name);
gcMARK(e->base.in_modidx);
gcMARK(e->base.skip_table);
gcMARK(e->data.stat_dists);
gcMARK(e->data.sd_depths);

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

@ -1452,7 +1452,10 @@ typedef struct Scheme_Comp_Env
Scheme_Object *intdef_name; /* syntax-local-context name for INTDEF frames */
Scheme_Object *in_modidx; /* an implicit certificate for syntax-local lookup/expand in macro */
Scheme_Object *in_modidx; /* an implicit certificate for syntax-local lookup/expand in macro */
Scheme_Hash_Table *skip_table; /* for jumping ahead in the chain */
int skip_depth; /* depth in simple frames, used to trigger skip_table creation */
struct Scheme_Comp_Env *next;
} Scheme_Comp_Env;

14
src/mzscheme/src/startup.inc
View File

@ -1234,13 +1234,13 @@
" ,(apply-cons #f h t p) "
"(quote-syntax ,ctx))))"
"((eq? t 'null)"
" `(list ,h))"
" `(list-immutable ,h))"
"((and(pair? t)"
"(memq(car t) '(list list*)))"
"(memq(car t) '(list-immutable list*-immutable)))"
" `(,(car t) ,h ,@(cdr t)))"
"((and(pair? t)"
"(eq?(car t) 'cons))"
" `(list* ,h ,@(cdr t)))"
"(eq?(car t) 'cons-immutable))"
" `(list*-immutable ,h ,@(cdr t)))"
"((and(pair? h)(pair? t)"
"(eq?(car h) 'car)"
"(eq?(car t) 'cdr)"
@ -1248,7 +1248,7 @@
"(eq?(cadr h)(cadr t)))"
"(cadr h))"
"(else"
" `(cons ,h ,t))))"
" `(cons-immutable ,h ,t))))"
"(-define(apply-list-ref e p use-tail-pos)"
"(cond"
"((and use-tail-pos(= p use-tail-pos))"
@ -1684,11 +1684,13 @@
"(syntax(syntax-case** _ #f stxe kl module-identifier=? clause ...))))))"
"(-define loc-insp(current-code-inspector))"
"(-define(relocate loc stx)"
"(if(syntax-source loc)"
"(let((new-stx(datum->syntax-object"
" stx"
"(syntax-e stx)"
" loc)))"
"(syntax-recertify new-stx stx loc-insp #f)))"
"(syntax-recertify new-stx stx loc-insp #f))"
" stx))"
"(-define-syntax syntax/loc"
"(lambda(stx)"
"(syntax-case** #f #t stx() module-identifier=?"

24
src/mzscheme/src/startup.ss
View File

@ -1466,22 +1466,22 @@
(eq? (cadr t) (stx-cdr p)))))
`(quote-syntax ,p)]
[(syntax? stx)
;; Keep location information
;; Keep context and location information
(let ([ctx (datum->syntax-object stx 'ctx stx)])
`(datum->syntax-object (quote-syntax ,ctx)
,(apply-cons #f h t p)
(quote-syntax ,ctx)))]
;; (cons X null) => (list X)
[(eq? t 'null)
`(list ,h)]
`(list-immutable ,h)]
;; (cons X (list[*] Y ...)) => (list[*] X Y ...)
[(and (pair? t)
(memq (car t) '(list list*)))
(memq (car t) '(list-immutable list*-immutable)))
`(,(car t) ,h ,@(cdr t))]
;; (cons X (cons Y Z)) => (list* X Y Z)
[(and (pair? t)
(eq? (car t) 'cons))
`(list* ,h ,@(cdr t))]
(eq? (car t) 'cons-immutable))
`(list*-immutable ,h ,@(cdr t))]
;; (cons (car X) (cdr X)) => X
[(and (pair? h) (pair? t)
(eq? (car h) 'car)
@ -1490,7 +1490,7 @@
(eq? (cadr h) (cadr t)))
(cadr h)]
[else
`(cons ,h ,t)]))
`(cons-immutable ,h ,t)]))
;; Generates a list-ref expression; if use-tail-pos
;; is not #f, then the argument list is really a list*
@ -1988,11 +1988,13 @@
(-define loc-insp (current-code-inspector))
(-define (relocate loc stx)
(let ([new-stx (datum->syntax-object
stx
(syntax-e stx)
loc)])
(syntax-recertify new-stx stx loc-insp #f)))
(if (syntax-source loc)
(let ([new-stx (datum->syntax-object
stx
(syntax-e stx)
loc)])
(syntax-recertify new-stx stx loc-insp #f))
stx))
;; Like syntax, but also takes a syntax object
;; that supplies a source location for the

463
src/mzscheme/src/stxobj.c
View File

@ -82,6 +82,8 @@ static Scheme_Object *last_phase_shift;
static Scheme_Hash_Table *id_marks_ht, *than_id_marks_ht;
static Scheme_Object *no_nested_inactive_certs;
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -92,6 +94,7 @@ static struct Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx,
Scheme_Object *insp, Scheme_Object *key,
struct Scheme_Cert *next_cert);
static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len);
static void preemptive_chunk(Scheme_Stx *stx);
#define CONS scheme_make_pair
#define ICONS scheme_make_immutable_pair
@ -134,6 +137,11 @@ typedef struct Scheme_Cert {
struct Scheme_Cert *next;
} Scheme_Cert;
/* Certs encoding:
- NULL: no inactive or active certs;
maybe inactive certs in nested parts
- cons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
no inactive certs in nested parts */
#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_PAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_PAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Scheme_Hash_Table **ht);
@ -171,6 +179,7 @@ static Module_Renames *krn;
var resolved
where the variables have already been resolved and filtered (no mark
comparison needed with the remaining wraps)
- A wrap-elem (make-rib vector rib)
is an extensible set of lexical renames; it is the same as
having the vectors inline in place of the rib, except that
@ -180,6 +189,13 @@ static Module_Renames *krn;
- A wrap-elem <rename-table> is a module rename set
the hash table maps renamed syms to modname-srcname pairs
- A wrap-elem <hash-table> is a chain-specific cache; it maps
identifiers to #t, and 0 to a deeper part of the chain; a
resolution for an identifier can safely skip to the deeper
part if the identifer does not have a mapping; this skips
simple lexical renames (not ribs) and marks, only, and it's
inserted into a chain heuristically
- A wrap-elem (box (vector <num> <midx> <midx>)) is a phase shift
by <num>, remapping the first <midx> to the second <midx>
@ -187,6 +203,9 @@ static Module_Renames *krn;
result of an expansion so that top-level marks do not
break re-expansions
[Don't add a pair case, because sometimes we test for element
versus list-of-element.]
The lazy_prefix field of a syntax object keeps track of how many of
the first wraps (items and chunks in the list) need to be propagated
to sub-syntax. */
@ -488,6 +507,9 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(id_marks_ht);
REGISTER_SO(than_id_marks_ht);
REGISTER_SO(no_nested_inactive_certs);
no_nested_inactive_certs = scheme_make_pair(NULL, NULL);
}
/*========================================================================*/
@ -741,6 +763,120 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
return (Scheme_Object *)nstx;
}
/******************** chain cache ********************/
static int maybe_add_chain_cache(Scheme_Stx *stx)
{
WRAP_POS awl;
Scheme_Object *p;
int skipable = 0, pos = 1;
WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
while (!WRAP_POS_END_P(awl)) {
/* Skip over renames, cancelled marks, and negative marks: */
p = WRAP_POS_FIRST(awl);
if (SCHEME_VECTORP(p)) {
skipable++;
} else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
/* ok to skip, but don't count toward needing a cache */
} else if (SCHEME_HASHTP(p)) {
/* Hack: we store the depth of the table in the chain
in the `step' fields, at least until the table is initialized: */
Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
if (!ht2->count)
pos = ht2->step;
else {
p = scheme_hash_get(ht2, scheme_make_integer(2));
pos = SCHEME_INT_VAL(p);
}
pos++;
break;
} else
break;
WRAP_POS_INC(awl);
}
if (skipable >= 32) {
/* Insert a cache placeholder. We'll fill it if
it's ever used in resolve_env(). */
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
ht->step = pos;
p = scheme_make_pair((Scheme_Object *)ht, stx->wraps);
stx->wraps = p;
if (STX_KEY(stx) & STX_SUBSTX_FLAG)
stx->u.lazy_prefix++;
return 1;
}
return 0;
}
static void fill_chain_cache(Scheme_Object *wraps)
{
int pos;
Scheme_Hash_Table *ht;
Scheme_Object *p, *id;
WRAP_POS awl;
ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps);
pos = ht->step;
ht->step = 0;
wraps = SCHEME_CDR(wraps);
WRAP_POS_INIT(awl, wraps);
while (!WRAP_POS_END_P(awl)) {
p = WRAP_POS_FIRST(awl);
if (SCHEME_VECTORP(p)) {
int i, len;
len = SCHEME_RENAME_LEN(p);
for (i = 0; i < len; i++) {
id = SCHEME_VEC_ELS(p)[i+2];
if (SCHEME_STXP(id))
id = SCHEME_STX_VAL(id);
scheme_hash_set(ht, id, scheme_true);
}
} else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
/* ok to skip */
} else if (SCHEME_HASHTP(p)) {
/* Hack: we store the depth of the table in the chain
in the `step' fields, at least until the table is initialized: */
Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
int pos2;
if (!ht2->count)
pos2 = ht2->step;
else {
p = scheme_hash_get(ht2, scheme_make_integer(2));
pos2 = SCHEME_INT_VAL(p);
}
/* The theory here is the same as the `mapped' table:
every power of two covers the whole range, etc. */
if ((pos & pos2) == pos2)
break;
} else
break;
WRAP_POS_INC(awl);
}
/* Record skip destination: */
scheme_hash_set(ht, scheme_make_integer(0), awl.l);
if (!awl.is_limb) {
scheme_hash_set(ht, scheme_make_integer(1), scheme_false);
} else {
scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos));
}
scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos));
}
/******************** marks ********************/
Scheme_Object *scheme_new_mark()
@ -776,6 +912,9 @@ Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m)
--lp;
wraps = SCHEME_CDR(wraps);
} else {
if (maybe_add_chain_cache(stx))
lp++;
wraps = stx->wraps;
lp++;
wraps = CONS(m, wraps);
}
@ -1082,6 +1221,14 @@ Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
long lp;
int graph;
if (STX_KEY(stx) & STX_SUBSTX_FLAG)
preemptive_chunk(stx);
/* relative order matters: chunk first, so that chunking
doesn't immediately throw away a chain cache */
maybe_add_chain_cache(stx);
graph = (STX_KEY(stx) & STX_GRAPH_FLAG);
wraps = CONS(rename, stx->wraps);
@ -1254,15 +1401,176 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
}
}
static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps)
/* Result is a single wrap element (possibly a chunk) or a list
of elements in reverse order. */
{
Wrap_Chunk *wc;
Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml;
int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0;
if (len > 1) {
for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
j = ((Wrap_Chunk *)a)->len;
if (j > max_chunk_size) {
max_chunk_start_list = l;
max_chunk_start_pos = i;
max_chunk_size = j;
}
count += j;
} else if (SCHEME_NUMBERP(a)) {
if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
count++;
else {
/* Skip canceling marks */
i++;
l = SCHEME_CDR(l);
}
} else if (SCHEME_HASHTP(a)) {
/* Don't propagate chain-specific table */
} else
count++;
}
if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) {
/* It's not worth copying a big existing chunk into
a new chunk. First copy over the part before new chunk,
then the new chunk, and finally the rest. */
Scheme_Object *ml2;
if (max_chunk_start_pos) {
ml = make_chunk(max_chunk_start_pos, owner_wraps);
if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml))
ml = scheme_make_pair(ml, scheme_null);
} else
ml = scheme_null;
ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml);
if (max_chunk_start_pos + 1 < len) {
ml2 = make_chunk(len - 1 - max_chunk_start_pos,
SCHEME_CDR(max_chunk_start_list));
if (!SCHEME_NULLP(ml2)) {
if (SCHEME_PAIRP(ml2))
ml = scheme_append(ml2, ml);
else
ml = scheme_make_pair(ml2, ml);
}
}
} else {
if (!count) {
ml = scheme_null; /* everything disappeared! */
} else {
wc = MALLOC_WRAP_CHUNK(count);
wc->type = scheme_wrap_chunk_type;
wc->len = count;
ml = NULL; /* to make compiler happy */
j = 0;
for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
int k, cl = ((Wrap_Chunk *)a)->len;
for (k = 0; k < cl; k++) {
wc->a[j++] = ((Wrap_Chunk *)a)->a[k];
}
} else if (SCHEME_NUMBERP(a)) {
if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
wc->a[j++] = a;
else {
/* Skip canceling marks */
i++;
l= SCHEME_CDR(l);
}
} else if (SCHEME_HASHTP(a)) {
/* Skip chain-specific table */
} else
wc->a[j++] = a;
}
if (count == 1) /* in case mark removal left only one */
ml = wc->a[0];
else
ml = (Scheme_Object *)wc;
}
}
} else {
ml = SCHEME_CAR(owner_wraps);
if (SCHEME_HASHTP(ml))
return scheme_null;
}
return ml;
}
#define PREEMPTIVE_CHUNK_THRESHOLD 32
static void preemptive_chunk(Scheme_Stx *stx)
{
int wl_count;
int new_count;
Scheme_Object *here_wraps, *ml;
/* If the lazy prefix is long, transform it into a chunk. Probably,
some syntax object derived from this one will be unpacked, and
then the lazy prefix will need to be pushed down.
This chunking fights somewhat with the chain-cache heuristic,
since a chain cache can't be included in a chunk. Still, the
combination seems to work better than either alone for deeply
nested scopes.
It might also interact badly with simplication or marshaling,
since it decreases chain sharing. This is seems unlikely to
matter, since deeply nested syntax information will be expensive
in any case, and nodes in the wraps are still shared. */
wl_count = stx->u.lazy_prefix;
if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) {
/* Chunk it */
here_wraps = stx->wraps;
ml = make_chunk(wl_count, here_wraps);
if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) {
new_count = scheme_list_length(ml);
if (new_count == 1)
ml = SCHEME_CAR(ml);
} else {
new_count = 1;
}
while (wl_count--) {
here_wraps = SCHEME_CDR(here_wraps);
}
wl_count = new_count;
if (new_count == 1)
here_wraps = scheme_make_pair(ml, here_wraps);
else {
while (new_count--) {
here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps);
ml = SCHEME_CDR(ml);
}
}
stx->wraps = here_wraps;
stx->u.lazy_prefix = wl_count;
}
}
static Scheme_Object *propagate_wraps(Scheme_Object *o,
int len, Scheme_Object **_ml,
Scheme_Object *owner_wraps)
{
int i;
Scheme_Object *ml;
Scheme_Object *ml, *a;
/* Would adding the wraps generate a list equivalent to owner_wraps? */
{
/* Would adding the wraps generate a list equivalent to owner_wraps?
If so, use owner_wraps directly. But if len is too big, then it
takes too long to check, and so it's better to start chunking. */
if (len < 128) {
Scheme_Stx *stx = (Scheme_Stx *)o;
Scheme_Object *p1 = owner_wraps;
Scheme_Object *certs;
@ -1275,7 +1583,7 @@ static Scheme_Object *propagate_wraps(Scheme_Object *o,
if (SAME_OBJ(stx->wraps, p1)) {
/* So, we can use owner_wraps directly instead of building
new wraps */
new wraps. */
long lp;
int graph;
@ -1304,69 +1612,24 @@ static Scheme_Object *propagate_wraps(Scheme_Object *o,
ml = *_ml;
if (!ml) {
if (len > 1) {
Wrap_Chunk *wc;
Scheme_Object *l, *a;
int count = 0, j;
for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
count += ((Wrap_Chunk *)a)->len;
} else if (SCHEME_NUMBERP(a)) {
if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
count++;
else {
/* Cancelled marks */
i++;
l= SCHEME_CDR(l);
}
} else
count++;
}
if (!count) {
ml = scheme_null; /* everything disappeared! */
} else {
wc = MALLOC_WRAP_CHUNK(count);
wc->type = scheme_wrap_chunk_type;
wc->len = count;
j = 0;
for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
int k, cl = ((Wrap_Chunk *)a)->len;
for (k = 0; k < cl; k++) {
wc->a[j++] = ((Wrap_Chunk *)a)->a[k];
}
} else if (SCHEME_NUMBERP(a)) {
if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
wc->a[j++] = a;
else {
/* Cancelled marks */
i++;
l= SCHEME_CDR(l);
}
} else
wc->a[j++] = a;
}
if (count == 1) /* in case mark removal left only one */
ml = wc->a[0];
else
ml = (Scheme_Object *)wc;
}
} else
ml = SCHEME_CAR(owner_wraps);
ml = make_chunk(len, owner_wraps);
*_ml = ml;
}
if (SCHEME_NUMBERP(ml))
if (SCHEME_PAIRP(ml)) {
while (SCHEME_PAIRP(ml)) {
a = SCHEME_CAR(ml);
if (SCHEME_NUMBERP(a)) {
o = scheme_add_remove_mark(o, a);
} else {
o = scheme_add_rename(o, a);
}
ml = SCHEME_CDR(ml);
}
} else if (SCHEME_NUMBERP(ml))
o = scheme_add_remove_mark(o, ml);
else if (SCHEME_NULLP(ml)) {
/* ok */
/* nothing to add */
} else
o = scheme_add_rename(o, ml);
@ -1699,7 +1962,7 @@ Scheme_Object *scheme_stx_content(Scheme_Object *o)
Scheme_Object *here_wraps;
Scheme_Object *ml = NULL;
int wl_count = 0;
here_wraps = stx->wraps;
wl_count = stx->u.lazy_prefix;
stx->u.lazy_prefix = 0;
@ -1934,6 +2197,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
/* Change inactive certs to active certs. (No
sub-object has inactive certs, because they
are always lifted when inactive certs are added.) */
Scheme_Object *np;
Scheme_Stx *res;
Scheme_Cert *certs, *cc;
res = (Scheme_Stx *)scheme_make_stx(stx->val,
@ -1941,7 +2205,8 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
res->certs = SCHEME_CAR(stx->certs);
np = scheme_make_pair(SCHEME_CAR(stx->certs), NULL);
res->certs = np;
cc = *cp;
for (certs = INACTIVE_CERTS(stx); certs; certs = certs->next) {
@ -1951,6 +2216,10 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
*cp = cc;
return (Scheme_Object *)res;
} else if (stx->certs && SCHEME_PAIRP(stx->certs)) {
/* Explicit pair but NULL for inactive certs means no
inactive certs anywhere in this object. */
return (Scheme_Object *)stx;
} else {
/* Before going to stx->val, we have to check
for cycles: */
@ -1992,7 +2261,16 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
res->certs = stx->certs;
/* stx->certs must not be a pair, otherwise we
would have taken an earlier branch; allocate
a pair with an explicitl NULL now to inidicate
that there are no nested certs here */
if (stx->certs) {
Scheme_Object *np;
np = scheme_make_pair(stx->certs, NULL);
res->certs = np;
} else
res->certs = no_nested_inactive_certs;
if (ph) {
scheme_make_graph_stx((Scheme_Object *)res, -1, -1, -1);
@ -2001,6 +2279,14 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
return (Scheme_Object *)res;
} else {
/* Record the absence of certificates in sub-parts: */
if (stx->certs) {
Scheme_Object *np;
np = scheme_make_pair(stx->certs, NULL);
stx->certs = np;
} else
stx->certs = no_nested_inactive_certs;
if (ph) {
/* Must not be a cycle, but may be shared. Avoid
using the placeholder. */
@ -2424,10 +2710,12 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
if (SCHEME_VOIDP(other_env)) {
SCHEME_USE_FUEL(1);
other_env = resolve_env(renamed, 0, 0, NULL,
scheme_make_pair(WRAP_POS_FIRST(wraps),
skip_ribs));
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
SCHEME_USE_FUEL(1);
}
{
@ -2439,7 +2727,11 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
if (same) {
/* If it turns out that we're going to return
other_env, then return envname instead. */
other_env, then return envname instead.
It's tempting to try to compare envname to the
top element of the stack and combine the two
mappings, but the intermediate name may be needed
(for other_env values that don't come from this stack. */
if (stack_pos < QUICK_STACK_SIZE) {
rename_stack[stack_pos++] = envname;
rename_stack[stack_pos++] = other_env;
@ -2473,6 +2765,32 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))
|| SAME_OBJ(WRAP_POS_FIRST(wraps), barrier_symbol)) {
did_rib = NULL;
} else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) {
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps);
Scheme_Object *v;
did_rib = NULL;
if (!ht->count) {
fill_chain_cache(wraps.l);
}
if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) {
v = scheme_hash_get(ht, scheme_make_integer(0));
wraps.l = v;
v = scheme_hash_get(ht, scheme_make_integer(1));
if (SCHEME_TRUEP(v)) {
wraps.pos = SCHEME_INT_VAL(v);
wraps.is_limb = 1;
wraps.a = ((Wrap_Chunk *)SCHEME_CAR(wraps.l))->a[wraps.pos];
} else {
wraps.is_limb = 0;
if (!SCHEME_NULLP(wraps.l))
wraps.a = SCHEME_CAR(wraps.l);
}
continue; /* <<<<< ------ */
}
}
if (!rib)
@ -3426,6 +3744,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* mark barrier */
stack = CONS(a, stack);
stack_size++;
} else if (SCHEME_HASHTP(a)) {
/* chain-specific cache; drop it */
} else {
/* box, a phase shift */
/* Any more rename tables? */
@ -4320,6 +4640,11 @@ Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
if (copy_props && (copy_props != 1)) {
Scheme_Object *certs;
certs = ((Scheme_Stx *)stx_src)->certs;
/* To be on the safe side, drop a "definitely no inactive certs"
indication, if any: */
if (certs && SCHEME_PAIRP(certs) && !SCHEME_CDR(certs)) {
certs = SCHEME_CAR(certs);
}
((Scheme_Stx *)v)->certs = certs;
}
@ -4550,7 +4875,7 @@ static int pos_exact_or_false_p(Scheme_Object *o)
static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
{
Scheme_Object *src = scheme_false, *properties = NULL;
if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0]))
scheme_wrong_type("datum->syntax-object", "syntax or #f", 0, argc, argv);
if (argc > 2) {
@ -4610,7 +4935,7 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
NULL);
}
}
src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0);
if (properties) {
@ -5104,7 +5429,7 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv)
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
if (!i && (!stx->certs || !SCHEME_PAIRP(stx->certs)))
if (!i && (!stx->certs || !SCHEME_PAIRP(stx->certs) || !SCHEME_CDR(stx->certs)))
res->certs = (Scheme_Object *)new_certs;
else {
Scheme_Object *pr;