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

352.1

Browse Source 
svn: r3861
This commit is contained in:
Matthew Flatt 2006-07-28 13:00:14 +00:00
parent bb5b45b181
commit b930ce0747
23 changed files with 6734 additions and 4683 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/mzscheme/benchmarks/common/tak.sch
View File

@ -20,6 +20,6 @@
;;; call: (tak 18 12 6)
(time (tak 18 12 2))
(time (tak 18 12 (read)))

2
collects/tests/mzscheme/benchmarks/shootout/run.ss
View File

@ -8,7 +8,7 @@
("cheapconcurrency.ss")
("echo.ss" . "150000")
("except.ss" . "2500000")
("fannkuch.ss")
("fannkuch.ss" . "10")
("fasta.ss")
("fibo.ss" . "32")
("hash.ss" . "100000")

7
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,10 @@
Version 352.2
Added raise-arity-error
Changed bytecode compiler to perform more closure conversion
and lifting
Changed local-expand; #f stop list means expand only immediate
Version 352, July 2006
Minor bug fixes

3
src/mzscheme/gc2/newgc.c
View File

@ -1710,7 +1710,7 @@ int GC_set_account_hook(int type, void *c1, unsigned long b, void *c2)
/* administration / initialization */
/*****************************************************************************/
static int generations_available = 0;
static int generations_available = 1;
void designate_modified(void *p)
{
@ -2608,7 +2608,6 @@ static void garbage_collect(int force_full)
/* gc_full, force_full, !generations_available, */
/* (since_last_full > 100), (memory_in_use > (2 * last_full_mem_use))); */
number++;
INIT_DEBUG_FILE(); DUMP_HEAP();

2
src/mzscheme/include/scheme.h
View File

@ -747,7 +747,7 @@ typedef struct Scheme_Hash_Table
Scheme_Inclhash_Object iso;
int size; /* power of 2 */
int count;
Scheme_Object **keys;
Scheme_Object **keys;
Scheme_Object **vals;
void (*make_hash_indices)(void *v, long *h1, long *h2);
int (*compare)(void *v1, void *v2);

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

File diff suppressed because it is too large Load Diff

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

@ -120,9 +120,10 @@ static int builtin_ref_counter = 0;
static int env_uid_counter;
#define ARBITRARY_USE 1
#define CONSTRAINED_USE 2
#define WAS_SET_BANGED 4
#define ARBITRARY_USE 0x1
#define CONSTRAINED_USE 0x2
#define WAS_SET_BANGED 0x4
#define ONE_ARBITRARY_USE 0x8
/* See also SCHEME_USE_COUNT_MASK */
typedef struct Compile_Data {
@ -1194,16 +1195,6 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env)
return SAME_OBJ(se, env);
}
int scheme_used_app_only(Scheme_Comp_Env *env, int which)
{
Compile_Data *data = COMPILE_DATA(env);
if (data->use[which] & ARBITRARY_USE)
return 0;
else
return 1;
}
int scheme_used_ever(Scheme_Comp_Env *env, int which)
{
Compile_Data *data = COMPILE_DATA(env);
@ -1488,8 +1479,10 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos)
k = type - scheme_local_type;
if (pos < MAX_CONST_LOCAL_POS)
return scheme_local[pos][k];
if (pos < MAX_CONST_LOCAL_POS) {
if (pos >= 0)
return scheme_local[pos][k];
}
v = scheme_hash_get(locals_ht[k], scheme_make_integer(pos));
if (v)
@ -1526,7 +1519,7 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
? CONSTRAINED_USE
: ARBITRARY_USE)
: ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE))
| ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
? WAS_SET_BANGED
: 0));
@ -2509,8 +2502,15 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
int old;
old = v[i];
v[i] = 0;
if (old & (ARBITRARY_USE | CONSTRAINED_USE))
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);
@ -2890,7 +2890,6 @@ int scheme_optimize_info_get_shift(Optimize_Info *info, int pos)
void scheme_optimize_info_done(Optimize_Info *info)
{
info->next->max_let_depth += info->max_let_depth;
info->next->size += info->size;
}
@ -2994,6 +2993,7 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
naya->count = mapc;
naya->pos = 0;
naya->toplevel_pos = -1;
naya->lifts = info->lifts;
if (mapc) {
int i, *ia;
@ -3017,7 +3017,7 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
return naya;
}
void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags)
void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted)
{
if (info->pos == info->count) {
scheme_signal_error("internal error: add_mapping: "
@ -3027,29 +3027,121 @@ void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int
info->old_pos[info->pos] = oldp;
info->new_pos[info->pos] = newp;
info->flags[info->pos] = flags;
if (lifted) {
if (!info->lifted) {
Scheme_Object **lifteds;
lifteds = MALLOC_N(Scheme_Object*, info->count);
info->lifted = lifteds;
}
info->lifted[info->pos] = lifted;
}
info->pos++;
}
void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted)
{
int i;
for (i = info->pos; i--; ) {
if (info->old_pos[i] == oldp) {
info->new_pos[i] = newp;
info->flags[i] = flags;
if (lifted) {
info->lifted[i] = lifted;
}
return;
}
}
scheme_signal_error("internal error: adjust_mapping: "
"couldn't find: %d", oldp);
}
void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos)
{
info->toplevel_pos = pos;
}
static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags)
static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **_lifted, int convert_shift)
{
Resolve_Info *orig_info = info;
int i, offset = 0, orig = pos;
if (_lifted)
*_lifted = NULL;
while (info) {
for (i = info->pos; i--; ) {
int oldp = info->old_pos[i];
if (pos == oldp) {
if (flags)
*flags = info->flags[i];
return info->new_pos[i] + offset;
if (info->lifted && (info->lifted[i])) {
int skip, shifted;
Scheme_Object *lifted, *tl, **ca;
if (!_lifted)
scheme_signal_error("unexpected lifted binding");
lifted = info->lifted[i];
if (SCHEME_RPAIRP(lifted)) {
tl = SCHEME_CAR(lifted);
ca = (Scheme_Object **)SCHEME_CDR(lifted);
if (convert_shift)
shifted = SCHEME_INT_VAL(ca[0]) + convert_shift - 1;
else
shifted = 0;
} else {
tl = lifted;
shifted = 0;
ca = NULL;
}
if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)) {
skip = scheme_resolve_toplevel_pos(orig_info);
tl = make_toplevel(skip + shifted,
SCHEME_TOPLEVEL_POS(tl),
1,
SCHEME_TOPLEVEL_CONST);
}
if (SCHEME_RPAIRP(lifted)) {
int sz, i;
mzshort *posmap, *boxmap;
Scheme_Object *vec, *loc;
sz = SCHEME_INT_VAL(ca[0]);
posmap = (mzshort *)ca[1];
boxmap = (mzshort *)ca[3];
vec = scheme_make_vector(sz + 1, NULL);
for (i = 0; i < sz; i++) {
loc = scheme_make_local(scheme_local_type,
posmap[i] + offset + shifted);
if (boxmap) {
if (boxmap[i / BITS_PER_MZSHORT] & ((mzshort)1 << (i & (BITS_PER_MZSHORT - 1))))
loc = scheme_box(loc);
}
SCHEME_VEC_ELS(vec)[i+1] = loc;
}
SCHEME_VEC_ELS(vec)[0] = ca[2];
lifted = scheme_make_raw_pair(tl, vec);
} else
lifted = tl;
*_lifted = lifted;
return 0;
} else
return info->new_pos[i] + offset;
}
}
if (info->in_proc) {
scheme_signal_error("internal error: scheme_resolve_info_lookup: "
"searching past procedure");
}
pos -= info->oldsize;
offset += info->size;
info = info->next;
@ -3061,18 +3153,23 @@ static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags)
return 0;
}
int scheme_resolve_info_flags(Resolve_Info *info, int pos)
Scheme_Object *scheme_resolve_generate_stub_lift()
{
return make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST);
}
int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted)
{
int flags;
resolve_info_lookup(info, pos, &flags);
resolve_info_lookup(info, pos, &flags, lifted, 0);
return flags;
}
int scheme_resolve_info_lookup(Resolve_Info *info, int pos, int *flags)
int scheme_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **lifted, int convert_shift)
{
return resolve_info_lookup(info, pos, flags);
return resolve_info_lookup(info, pos, flags, lifted, convert_shift);
}
int scheme_resolve_toplevel_pos(Resolve_Info *info)
@ -3080,6 +3177,10 @@ int scheme_resolve_toplevel_pos(Resolve_Info *info)
int pos = 0;
while (info && (info->toplevel_pos < 0)) {
if (info->in_proc) {
scheme_signal_error("internal error: scheme_resolve_toplevel_pos: "
"searching past procedure");
}
pos += info->size;
info = info->next;
}
@ -3090,6 +3191,19 @@ int scheme_resolve_toplevel_pos(Resolve_Info *info)
return info->toplevel_pos + pos;
}
int scheme_resolve_is_toplevel_available(Resolve_Info *info)
{
while (info) {
if (info->toplevel_pos >= 0)
return 1;
if (info->in_proc)
return 0;
info = info->next;
}
return 0;
}
int scheme_resolve_quote_syntax_pos(Resolve_Info *info)
{
return info->prefix->num_toplevels;
@ -3107,6 +3221,55 @@ Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr)
SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
}
Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta)
{
return make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta,
SCHEME_TOPLEVEL_POS(expr),
1,
SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
}
Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info)
{
int skip, pos;
Scheme_Object *count;
skip = scheme_resolve_toplevel_pos(info);
count = SCHEME_VEC_ELS(info->lifts)[1];
pos = (SCHEME_INT_VAL(count)
+ info->prefix->num_toplevels
+ info->prefix->num_stxes
+ (info->prefix->num_stxes ? 1 : 0));
count = scheme_make_integer(SCHEME_INT_VAL(count) + 1);
SCHEME_VEC_ELS(info->lifts)[1] = count;
return make_toplevel(skip,
pos,
1,
SCHEME_TOPLEVEL_CONST);
}
Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl)
{
return make_toplevel(0,
SCHEME_TOPLEVEL_POS(tl),
1,
SCHEME_TOPLEVEL_CONST);
}
int scheme_resolving_in_procedure(Resolve_Info *info)
{
while (info) {
if (info->in_proc)
return 1;
info = info->next;
}
return 0;
}
/*========================================================================*/
/* run-time "stack" */
/*========================================================================*/
@ -4048,7 +4211,7 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
SCHEME_VEC_ELS(sv)[i] = rp->stxes[i];
}
return scheme_make_pair(tv, sv);
return scheme_make_pair(scheme_make_integer(rp->num_lifts), scheme_make_pair(tv, sv));
}
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
@ -4059,6 +4222,12 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
if (!SCHEME_PAIRP(obj)) return NULL;
i = SCHEME_INT_VAL(SCHEME_CAR(obj));
if (i < 0) return NULL;
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
tv = SCHEME_CAR(obj);
sv = SCHEME_CDR(obj);
@ -4066,6 +4235,7 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
rp->so.type = scheme_resolve_prefix_type;
rp->num_toplevels = SCHEME_VEC_SIZE(tv);
rp->num_stxes = SCHEME_VEC_SIZE(sv);
rp->num_lifts = i;
i = rp->num_toplevels;
a = MALLOC_N(Scheme_Object *, i);

86
src/mzscheme/src/error.c
View File

@ -49,6 +49,7 @@ static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
@ -71,6 +72,8 @@ static Scheme_Object *def_error_esc_proc;
static Scheme_Object *default_display_handler, *emergency_display_handler;
Scheme_Object *scheme_def_exit_proc;
Scheme_Object *scheme_raise_arity_error_proc;
static char *init_buf(long *len, long *blen);
static char *prepared_buf;
static long prepared_buf_len;
@ -473,6 +476,8 @@ void scheme_init_error(Scheme_Env *env)
if (!scheme_console_output)
scheme_console_output = default_output;
REGISTER_SO(scheme_raise_arity_error_proc);
scheme_add_global_constant("error",
scheme_make_prim_w_arity(error,
"error",
@ -498,6 +503,12 @@ void scheme_init_error(Scheme_Env *env)
"raise-mismatch-error",
3, 3),
env);
scheme_raise_arity_error_proc = scheme_make_prim_w_arity(raise_arity_error,
"raise-arity-error",
2, -1);
scheme_add_global_constant("raise-arity-error",
scheme_raise_arity_error_proc,
env);
scheme_add_global_constant("error-display-handler",
scheme_register_parameter(error_display_handler,
"error-display-handler",
@ -839,6 +850,8 @@ static char *make_arity_expect_string(const char *name, int namelen,
int minc, int maxc,
int argc, Scheme_Object **argv,
long *_len, int is_method)
/* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
minc == -2 => use generic "no matching clause" message */
{
long len, pos, slen;
int xargc, xminc, xmaxc;
@ -928,7 +941,8 @@ static char *make_arity_expect_string(const char *name, int namelen,
void scheme_wrong_count_m(const char *name, int minc, int maxc,
int argc, Scheme_Object **argv, int is_method)
/* minc == -1 => name is really a case-lambda, native closure, or proc-struct */
/* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
minc == -2 => use generic "no matching clause" message */
{
char *s;
long len;
@ -1940,6 +1954,76 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[])
return NULL;
}
static int is_arity_at_least(Scheme_Object *v)
{
return (SCHEME_STRUCTP(v)
&& scheme_is_struct_instance(scheme_arity_at_least, v)
&& scheme_nonneg_exact_p(((Scheme_Structure *)v)->slots[0]));
}
static int is_arity_list(Scheme_Object *l)
{
int c;
Scheme_Object *a;
c = scheme_proper_list_length(l);
if (c < 0) return 0;
while (!SCHEME_NULLP(l)) {
a = SCHEME_CAR(l);
if (!scheme_nonneg_exact_p(a)
&& !scheme_nonneg_exact_p(a))
return 0;
l = SCHEME_CDR(l);
}
return 1;
}
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
{
Scheme_Object **args;
const char *name;
int minc, maxc;
if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0]))
scheme_wrong_type("raise-arity-error", "symbol or procedure", 0, argc, argv);
if (!scheme_nonneg_exact_p(argv[1])
&& !is_arity_at_least(argv[1])
&& !is_arity_list(argv[1]))
scheme_wrong_type("raise-mismatch-error", "arity (integer, arity-at-least, or list)", 1, argc, argv);
args = MALLOC_N(Scheme_Object*, argc - 2);
memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2));
if (SCHEME_SYMBOLP(argv[0]))
name = scheme_symbol_val(argv[0]);
else {
int len;
name = scheme_get_proc_name(argv[0], &len, 1);
}
if (SCHEME_INTP(argv[1])) {
minc = maxc = SCHEME_INT_VAL(argv[1]);
} else if (is_arity_at_least(argv[1])) {
Scheme_Object *v;
v = ((Scheme_Structure *)argv[1])->slots[0];
if (SCHEME_INTP(v)) {
minc = SCHEME_INT_VAL(v);
maxc = -1;
} else {
minc = -2;
maxc = 0;
}
} else {
minc = -2;
maxc = 0;
}
scheme_wrong_count_m(name, minc, maxc, argc - 2, args, 0);
return NULL;
}
static Scheme_Object *good_print_width(int c, Scheme_Object **argv)
{
int ok;

985
src/mzscheme/src/eval.c
View File

File diff suppressed because it is too large Load Diff

521
src/mzscheme/src/fun.c
View File

@ -677,10 +677,10 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
data = (Scheme_Closure_Data *)code;
#ifdef MZ_USE_JIT
if (data->native_code) {
if (data->u.native_code) {
Scheme_Object *nc;
nc = scheme_make_native_closure(data->native_code);
nc = scheme_make_native_closure(data->u.native_code);
if (close) {
runstack = MZ_RUNSTACK;
@ -722,31 +722,53 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
return (Scheme_Object *)closure;
}
Scheme_Closure *scheme_malloc_empty_closure()
{
Scheme_Closure *cl;
cl = (Scheme_Closure *)scheme_malloc_tagged(sizeof(Scheme_Closure) - sizeof(Scheme_Object *));
cl->so.type = scheme_closure_type;
return cl;
}
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
/* If lr is supplied as a letrec binding this closure, it may be used
for JIT compilation. */
{
#ifdef MZ_USE_JIT
Scheme_Closure_Data *data = (Scheme_Closure_Data *)code;
if (!data->native_code) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)code, *data2;
/* We need to cache clones to support multiple references
to a zero-sized closure in bytecode. We need either a clone
or native code, and context determines which field is releveant,
so we put the two possibilities in a union `u'. */
if (!context)
data2 = data->u.jit_clone;
else
data2 = NULL;
if (!data2) {
Scheme_Native_Closure_Data *ndata;
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data, code, sizeof(Scheme_Closure_Data));
data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data2, code, sizeof(Scheme_Closure_Data));
data->context = context;
data2->context = context;
ndata = scheme_generate_lambda(data, 1, NULL);
data->native_code = ndata;
ndata = scheme_generate_lambda(data2, 1, NULL);
data2->u.native_code = ndata;
if (!context)
data->u.jit_clone = data2;
}
/* If it's zero-sized, then create closure now */
if (!data->closure_size) {
return scheme_make_native_closure(ndata);
}
/* If it's zero-sized, then create closure now */
if (!data2->closure_size)
return scheme_make_native_closure(data2->u.native_code);
return (Scheme_Object *)data;
}
return (Scheme_Object *)data2;
#endif
return code;
@ -800,11 +822,6 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
data->closure_size = (cl->base_closure_size
+ (cl->has_tl ? 1 : 0));
info->max_let_depth += data->num_params + data->closure_size;
data->max_let_depth = info->max_let_depth;
info->max_let_depth = 0; /* So it doesn't propagate outward */
scheme_optimize_info_done(info);
return (Scheme_Object *)data;
@ -839,6 +856,17 @@ Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *_data, Optimize_I
return (Scheme_Object *)data2;
}
Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *_data, int delta, int after_depth)
{
Scheme_Object *expr;
Scheme_Closure_Data *data = (Scheme_Closure_Data *)_data;
expr = scheme_optimize_shift(data->code, delta, after_depth + data->num_params);
data->code = expr;
return _data;
}
int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign)
{
int i;
@ -861,47 +889,225 @@ int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign)
return cl->body_size;
}
int scheme_closure_has_top_level(Scheme_Closure_Data *data)
{
Closure_Info *cl;
cl = (Closure_Info *)data->closure_map;
return cl->has_tl;
}
int scheme_closure_argument_flags(Scheme_Closure_Data *data, int i)
{
return ((Closure_Info *)data->closure_map)->local_flags[i];
}
XFORM_NONGCING static int boxmap_size(int n)
{
return (n + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT;
}
static mzshort *allocate_boxmap(int n)
{
mzshort *boxmap;
int size;
size = boxmap_size(n);
boxmap = MALLOC_N_ATOMIC(mzshort, size);
memset(boxmap, 0, size * sizeof(mzshort));
return boxmap;
}
XFORM_NONGCING static void boxmap_set(mzshort *boxmap, int j)
{
boxmap[j / BITS_PER_MZSHORT] |= ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1)));
}
XFORM_NONGCING static int boxmap_get(mzshort *boxmap, int j)
{
if (boxmap[j / BITS_PER_MZSHORT] & ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1))))
return 1;
else
return 0;
}
Scheme_Object *
scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
int can_lift, int convert, int just_compute_lift,
Scheme_Object *precomputed_lift)
{
Scheme_Closure_Data *data;
int i, closure_size, offset, np, orig_first_flag;
int i, closure_size, offset, np, num_params;
int has_tl, convert_size, need_lift;
mzshort *oldpos, *closure_map;
Closure_Info *cl;
Resolve_Info *new_info;
Scheme_Object *lifted, *result, *lifteds = NULL;
Scheme_Hash_Table *captured = NULL;
mzshort *convert_map, *convert_boxes = NULL;
data = (Scheme_Closure_Data *)_data;
cl = (Closure_Info *)data->closure_map;
data->iso.so.type = scheme_unclosed_procedure_type;
if (!just_compute_lift)
data->iso.so.type = scheme_unclosed_procedure_type;
/* Set local_flags: */
orig_first_flag = (data->num_params ? cl->local_flags[0] : 0);
for (i = 0; i < data->num_params; i++) {
if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
cl->local_flags[i] = SCHEME_INFO_BOXED;
else
cl->local_flags[i] = 0;
if (convert || can_lift) {
if (!scheme_resolving_in_procedure(info)) {
convert = 0;
can_lift = 0;
}
}
/* We have to perform a small bit of constant propagation here.
Procedures closed only over top-level bindings are lifted during
this pass. Some of the captured bindings from this phase may
refer to a lifted procedure. In that case, we can replace the
lexical reference with a direct reference to the top-level
binding, which means that we can drop the binding from the
closure. */
closure_size = data->closure_size;
closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size);
has_tl = cl->has_tl;
/* Locals in closure are first: */
oldpos = cl->base_closure_map;
for (i = cl->base_closure_size; i--; ) {
int li;
li = scheme_resolve_info_lookup(info, oldpos[i], NULL);
closure_map[i] = li;
offset = 0;
for (i = 0; i < cl->base_closure_size; i++) {
int li, flags;
li = scheme_resolve_info_lookup(info, oldpos[i], &flags, &lifted, 0);
if (lifted) {
/* Drop lifted binding from closure. */
if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type)
|| SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type))
has_tl = 1;
/* If the lifted binding is for a converted closure,
we may need to add more bindings to this closure. */
if (SCHEME_RPAIRP(lifted)) {
lifteds = scheme_make_raw_pair(lifted, lifteds);
}
} else {
closure_map[offset] = li;
if (convert && (flags & SCHEME_INFO_BOXED)) {
/* The only problem with a boxed variable is that
it's more difficult to validate. We have to track
which arguments are boxes. And the resulting procedure
must be used only in application positions. */
if (!convert_boxes)
convert_boxes = allocate_boxmap(cl->base_closure_size);
boxmap_set(convert_boxes, offset);
}
offset++;
}
}
/* Add bindings introduced by closure conversion. The `captured'
table maps old positions to new positions. */
while (lifteds) {
int j, cnt, boxed;
Scheme_Object *vec, *loc;
if (!captured) {
captured = scheme_make_hash_table(SCHEME_hash_ptr);
for (i = 0; i < offset; i++) {
int cp;
cp = i;
if (convert_boxes && boxmap_get(convert_boxes, i))
cp = -(cp + 1);
scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp));
}
}
lifted = SCHEME_CAR(lifteds);
vec = SCHEME_CDR(lifted);
cnt = SCHEME_VEC_SIZE(vec);
--cnt;
for (j = 0; j < cnt; j++) {
loc = SCHEME_VEC_ELS(vec)[j+1];
if (SCHEME_BOXP(loc)) {
loc = SCHEME_BOX_VAL(loc);
boxed = 1;
} else
boxed = 0;
i = SCHEME_LOCAL_POS(loc);
if (!scheme_hash_get(captured, scheme_make_integer(i))) {
/* Need to capture an extra binding: */
int cp;
cp = captured->count;
if (boxed)
cp = -(cp + 1);
scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp));
}
}
lifteds = SCHEME_CDR(lifteds);
}
if (captured && (captured->count > offset)) {
/* We need to extend the closure map. All the info
is in captured, so just build it from scratch. */
int old_pos, j;
closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * (captured->count + (has_tl ? 1 : 0)));
offset = captured->count;
convert_boxes = NULL;
for (j = captured->size; j--; ) {
if (captured->vals[j]) {
int cp;
cp = SCHEME_INT_VAL(captured->vals[j]);
old_pos = SCHEME_INT_VAL(captured->keys[j]);
if (cp < 0) {
/* Boxed */
cp = -(cp + 1);
if (!convert_boxes)
convert_boxes = allocate_boxmap(offset);
boxmap_set(convert_boxes, cp);
}
closure_map[cp] = old_pos;
}
}
}
if (convert
&& (offset || !has_tl) /* either need args, or treat as convert becasue it's fully closed */
) {
/* Take over closure_map to be the convert map, instead. */
int new_boxes_size;
convert_map = closure_map;
convert_size = offset;
if (convert_boxes)
new_boxes_size = boxmap_size(convert_size + data->num_params);
else
new_boxes_size = 0;
if (has_tl || convert_boxes) {
int sz;
sz = ((has_tl ? sizeof(mzshort) : 0) + new_boxes_size * sizeof(mzshort));
closure_map = (mzshort *)scheme_malloc_atomic(sz);
memset(closure_map, 0, sz);
if (convert_boxes) {
int bsz;
bsz = boxmap_size(convert_size);
memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0),
convert_boxes,
bsz * sizeof(mzshort));
}
} else
closure_map = NULL;
offset = 0;
} else {
convert = 0;
convert_map = NULL;
convert_size = 0;
convert_boxes = NULL;
}
/* Then the pointer to globals, if any: */
offset = cl->base_closure_size;
if (cl->has_tl) {
if (has_tl) {
/* GLOBAL ASSUMPTION: jit.c assumes that the array
of globals is the last item in the closure; grep
for "GLOBAL ASSUMPTION" in jit.c */
@ -911,68 +1117,211 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
offset++;
}
/* Set up mappng from old locations on the stack (as if bodies were
evaluated immediately) to new locations (where closures
effectively shift and compact values on the stack): */
/* Reset closure_size, in case a lifted variable was removed: */
closure_size = offset;
if (!just_compute_lift) {
data->closure_size = closure_size;
if (convert && convert_boxes)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_REF_ARGS;
}
np = data->num_params;
/* Set up environment mapping, initialized for arguments: */
np = num_params = data->num_params;
if ((data->num_params == 1)
&& (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
&& !(orig_first_flag & SCHEME_WAS_USED)) {
&& !(cl->local_flags[0] & SCHEME_WAS_USED)) {
/* (lambda args E) where args is not in E => drop the argument */
new_info = scheme_resolve_info_extend(info, 0, 1, cl->base_closure_size);
data->num_params = 0;
num_params = 0;
if (!just_compute_lift)
data->num_params = 0;
} else {
new_info = scheme_resolve_info_extend(info, data->num_params, data->num_params,
cl->base_closure_size + data->num_params);
for (i = 0; i < data->num_params; i++) {
scheme_resolve_info_add_mapping(new_info, i, i + closure_size,
cl->local_flags[i]);
scheme_resolve_info_add_mapping(new_info, i, i + closure_size + convert_size,
((cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
? SCHEME_INFO_BOXED
: 0),
NULL);
}
}
/* Extend mapping to go from old locations on the stack (as if bodies were
evaluated immediately) to new locations (where closures
effectively shift and compact values on the stack).
We don't have to include bindings added because an oiriginal
binding was lifted (i.e., the extra bindings in `captured'),
because they don't appear in the body. Instead, they are
introduced directly in resolved form through the `lifted' info.
That means, though, that we need to transform the `lifted'
mapping. */
if (has_tl && convert) {
/* Skip handle for globals */
offset = 1;
} else {
offset = 0;
}
for (i = 0; i < cl->base_closure_size; i++) {
int p = oldpos[i];
int p = oldpos[i], flags;
if (p < 0)
p -= np;
else
p += np;
scheme_resolve_info_add_mapping(new_info, p, i,
scheme_resolve_info_flags(info, oldpos[i]));
flags = scheme_resolve_info_flags(info, oldpos[i], &lifted);
if (lifted && SCHEME_RPAIRP(lifted)) {
/* Convert from a vector of local references to an array of
positions. */
Scheme_Object *vec, *loc, **ca;
mzshort *cmap, *boxmap = NULL;
int sz, j, cp;
vec = SCHEME_CDR(lifted);
sz = SCHEME_VEC_SIZE(vec);
--sz;
cmap = MALLOC_N_ATOMIC(mzshort, sz);
for (j = 0; j < sz; j++) {
loc = SCHEME_VEC_ELS(vec)[j+1];
if (SCHEME_BOXP(loc)) {
if (!boxmap)
boxmap = allocate_boxmap(sz);
boxmap_set(boxmap, j);
loc = SCHEME_BOX_VAL(loc);
}
loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc)));
cp = SCHEME_INT_VAL(loc);
if (cp < 0)
cp = -(cp + 1);
cmap[j] = cp + (has_tl && convert ? 1 : 0);
}
ca = MALLOC_N(Scheme_Object *, 4);
ca[0] = scheme_make_integer(sz);
ca[1] = (Scheme_Object *)cmap;
ca[2] = SCHEME_VEC_ELS(vec)[0];
ca[3] = (Scheme_Object *)boxmap;
lifted = scheme_make_raw_pair(SCHEME_CAR(lifted), (Scheme_Object *)ca);
}
scheme_resolve_info_add_mapping(new_info, p, lifted ? 0 : offset++, flags, lifted);
}
if (has_tl) {
if (convert)
offset = 0; /* other closure elements converted to arguments */
else
offset = closure_size - 1;
scheme_resolve_info_set_toplevel_pos(new_info, offset);
}
if (cl->has_tl)
scheme_resolve_info_set_toplevel_pos(new_info, cl->base_closure_size);
data->closure_map = closure_map;
if (!just_compute_lift)
data->closure_map = closure_map;
{
new_info->in_proc = 1;
if (!just_compute_lift) {
Scheme_Object *code;
code = scheme_resolve_expr(data->code, new_info);
data->code = code;
}
/* Add code to box set!ed argument variables: */
for (i = 0; i < data->num_params; i++) {
if (cl->local_flags[i] & SCHEME_INFO_BOXED) {
int j = i + closure_size;
Scheme_Object *code;
data->max_let_depth = (new_info->max_let_depth
+ num_params
+ closure_size
+ convert_size);
code = scheme_make_syntax_resolved(BOXENV_EXPD,
scheme_make_pair(scheme_make_integer(j),
data->code));
data->code = code;
/* Add code to box set!ed argument variables: */
for (i = 0; i < num_params; i++) {
if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) {
int j = i + closure_size + convert_size;
Scheme_Object *bcode;
bcode = scheme_make_syntax_resolved(BOXENV_EXPD,
scheme_make_pair(scheme_make_integer(j),
data->code));
data->code = bcode;
}
}
if (SCHEME_TYPE(data->code) > _scheme_compiled_values_types_)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_FOLDABLE;
}
if (SCHEME_TYPE(data->code) > _scheme_compiled_values_types_)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_FOLDABLE;
if ((closure_size == 1)
&& can_lift
&& has_tl
&& info->lifts) {
need_lift = 1;
} else
need_lift = 0;
if (convert) {
num_params += convert_size;
if (!just_compute_lift)
data->num_params = num_params;
}
/* If the closure is empty, create the closure now */
if (!data->closure_size)
return scheme_make_closure(NULL, (Scheme_Object *)data, 1);
else
return (Scheme_Object *)data;
if (!closure_size) {
if (precomputed_lift) {
result = SCHEME_CAR(precomputed_lift);
((Scheme_Closure *)result)->code = data;
} else
result = scheme_make_closure(NULL, (Scheme_Object *)data, 0);
} else
result = (Scheme_Object *)data;
if (need_lift) {
if (just_compute_lift) {
if (just_compute_lift > 1)
result = scheme_resolve_invent_toplevel(info);
else
result = scheme_resolve_generate_stub_lift();
} else {
Scheme_Object *tl, *defn_tl;
if (precomputed_lift) {
tl = precomputed_lift;
if (SCHEME_RPAIRP(tl))
tl = SCHEME_CAR(tl);
} else {
tl = scheme_resolve_invent_toplevel(info);
}
defn_tl = scheme_resolve_invented_toplevel_to_defn(info, tl);
scheme_resolve_lift_definition(info, defn_tl, result);
if (has_tl)
closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */
result = tl;
}
}
if (convert) {
Scheme_Object **ca, *arity;
if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) {
arity = scheme_box(scheme_make_integer(num_params - convert_size - 1));
} else {
arity = scheme_make_integer(num_params - convert_size);
}
ca = MALLOC_N(Scheme_Object *, 4);
ca[0] = scheme_make_integer(convert_size);
ca[1] = (Scheme_Object *)convert_map;
ca[2] = arity;
ca[3] = (Scheme_Object *)convert_boxes;
if (precomputed_lift) {
SCHEME_CAR(precomputed_lift) = result;
SCHEME_CDR(precomputed_lift) = (Scheme_Object *)ca;
result = precomputed_lift;
} else
result = scheme_make_raw_pair(result, (Scheme_Object *)ca);
}
return result;
}
Scheme_Object *scheme_source_to_name(Scheme_Object *code)
@ -4950,7 +5299,8 @@ scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
{
Scheme_Closure_Data *data;
Scheme_Object *name;
Scheme_Object *name, *l;
int svec_size;
data = (Scheme_Closure_Data *)obj;
@ -4972,13 +5322,24 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
name = scheme_null;
}
svec_size = data->closure_size;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
svec_size += (data->num_params + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT;
}
l = CONS(scheme_make_svector(svec_size,
data->closure_map),
scheme_protect_quote(data->code));
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS)
l = CONS(scheme_make_integer(data->closure_size),
l);
return CONS(scheme_make_integer(SCHEME_CLOSURE_DATA_FLAGS(data)),
CONS(scheme_make_integer(data->num_params),
CONS(scheme_make_integer(data->max_let_depth),
CONS(name,
CONS(scheme_make_svector(data->closure_size,
data->closure_map),
scheme_protect_quote(data->code))))));
l))));
}
static Scheme_Object *read_compiled_closure(Scheme_Object *obj)
@ -5016,13 +5377,23 @@ static Scheme_Object *read_compiled_closure(Scheme_Object *obj)
if (!SCHEME_PAIRP(obj)) return NULL;
v = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
/* v is an svector */
/* v is an svector or an integer... */
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
if (!SCHEME_INTP(v)) return NULL;
data->closure_size = SCHEME_INT_VAL(v);
if (!SCHEME_PAIRP(obj)) return NULL;
v = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
}
data->code = obj;
if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL;
data->closure_size = SCHEME_SVEC_LEN(v);
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS))
data->closure_size = SCHEME_SVEC_LEN(v);
data->closure_map = SCHEME_SVEC_VEC(v);
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_FOLDABLE)
@ -5031,7 +5402,7 @@ static Scheme_Object *read_compiled_closure(Scheme_Object *obj)
if (SCHEME_TYPE(data->code) > _scheme_values_types_)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_FOLDABLE;
/* If the closure is empty, create the closure now */
/* If the closure is empty, create the closure now */
if (!data->closure_size)
return scheme_make_closure(NULL, (Scheme_Object *)data, 0);
else

187
src/mzscheme/src/jit.c
View File

@ -25,19 +25,15 @@
2) Use jit_patchable_movi_p() when a constant needs to be
visible to the GC.
3) Immediate operands (not counting moves into registers)
must be 32-bit values on a 64-bit machine.
3) Immediate operands must be 32-bit values on x86_64, except with
jit_movi, jit_sti, jit_ld, jit_bXi, jit_calli, and jit_finishi.
4) Function calls are limited to 3 arguments (i.e., jit_prepare()
must never be called with a number greater than 3). This limit
is related to the way the x86_64 port shuffles arguments into
temporary registers.
5) jit_ldi_X() and jit_sti_X() addresses must fit into 32 bits.
Currently, the code below assumes that global variables are in
the 32-bit address range.
6) On x86_64, arguments are delivered in JIT_V2, JIT_V3, and JIT_R2,
5) On x86_64, arguments are delivered in JIT_V2, JIT_V3, and JIT_R2,
in that order. So don't set JIT_R2 before getting the third
argument, etc.
*/
@ -91,7 +87,7 @@ Fix me! See use.
#endif
#define MAX_SHARED_CALL_RANDS 25
static void *shared_tail_code[3][MAX_SHARED_CALL_RANDS];
static void *shared_tail_code[4][MAX_SHARED_CALL_RANDS];
static void *shared_non_tail_code[3][MAX_SHARED_CALL_RANDS][2];
#define MAX_SHARED_ARITY_CHECK 25
@ -124,7 +120,8 @@ typedef struct {
GC_CAN_IGNORE jit_state js;
char *limit;
int extra_pushed, max_extra_pushed;
int depth, max_depth;
int depth; /* the position of the closure's first arg on the stack */
int max_depth;
int *mappings; /* For each element,
case 0x1 bit:
. 0 -> case 0x2 bit:
@ -141,6 +138,7 @@ typedef struct {
int self_pos, self_closure_size, self_toplevel_pos;
void *self_restart_code;
Scheme_Native_Closure *nc;
Scheme_Closure_Data *self_data;
} mz_jit_state;
typedef int (*Native_Check_Arity_Proc)(Scheme_Object *o, int argc, int dummy);
@ -198,12 +196,32 @@ typedef struct {
#define STACK_CACHE_SIZE 32
static Stack_Cache_Elem stack_cache_stack[STACK_CACHE_SIZE];
int stack_cache_stack_pos = 0;
long stack_cache_stack_pos = 0;
#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm))
#include "codetab.inc"
static Scheme_Object **fixup_runstack_base;
static int fixup_already_in_place;
static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
int already = fixup_already_in_place, i;
Scheme_Object **base;
base = fixup_runstack_base XFORM_OK_MINUS argc XFORM_OK_MINUS already;
/* Need to shift argc to end of base: */
for (i = 0; i < argc; i++) {
base[already + i] = argv[i];
}
return _scheme_tail_apply_from_native(rator, argc + already, base);
}
/*========================================================================*/
/* JIT buffer */
/*========================================================================*/
@ -1179,14 +1197,23 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
#endif
/* Copy args to runstack base: */
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE, WORDS_TO_BYTES(num_rands));
for (i = num_rands; i--; ) {
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(i));
jit_stxi_p(WORDS_TO_BYTES(i), JIT_R2, JIT_R1);
CHECK_LIMIT();
if (num_rands) {
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE, WORDS_TO_BYTES(num_rands));
for (i = num_rands; i--; ) {
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(i));
jit_stxi_p(WORDS_TO_BYTES(i), JIT_R2, JIT_R1);
CHECK_LIMIT();
}
jit_movr_p(JIT_RUNSTACK, JIT_R2);
} else {
jit_movr_p(JIT_RUNSTACK, JIT_RUNSTACK_BASE);
}
jit_movr_p(JIT_RUNSTACK, JIT_R2);
if (direct_native > 1) { /* => some_args_already_in_place */
mz_get_local_p(JIT_R1, JIT_LOCAL2);
jit_lshi_l(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
jit_subr_p(JIT_RUNSTACK, JIT_RUNSTACK, JIT_R1);
}
/* Extract function and data: */
jit_movr_p(JIT_R2, JIT_V1);
if (direct_native) {
@ -1197,6 +1224,10 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
/* Set up arguments; JIT_RUNSTACK and JIT_RUNSTACK_BASE must also be ready */
jit_movr_p(JIT_R0, JIT_R2);
jit_movi_i(JIT_R1, num_rands);
if (direct_native > 1) { /* => some_args_already_in_place */
mz_get_local_p(JIT_R2, JIT_LOCAL2);
jit_addr_i(JIT_R1, JIT_R1, JIT_R2);
}
jit_movr_p(JIT_R2, JIT_RUNSTACK);
/* Now jump: */
jit_jmpr(JIT_V1);
@ -1214,13 +1245,24 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
if (need_set_rs) {
JIT_UPDATE_THREAD_RSPTR();
}
if (direct_native > 1) { /* => some_args_already_in_place */
/* Need to shuffle argument lists. Since we can pass only
three arguments, use static variables for the others. */
jit_sti_p(&fixup_runstack_base, JIT_RUNSTACK_BASE);
mz_get_local_p(JIT_R1, JIT_LOCAL2);
jit_sti_l(&fixup_already_in_place, JIT_R1);
}
jit_movi_i(JIT_R0, num_rands);
mz_prepare(3);
CHECK_LIMIT();
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R0);
jit_pusharg_p(JIT_V1);
(void)mz_finish(_scheme_tail_apply_from_native);
if (direct_native > 1) { /* => some_args_already_in_place */
(void)mz_finish(_scheme_tail_apply_from_native_fixup_args);
} else {
(void)mz_finish(_scheme_tail_apply_from_native);
}
/* Pop saved runstack val and return: */
mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
@ -1443,7 +1485,8 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
return 1;
}
static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, int num_rands, jit_insn *slow_code)
static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, int num_rands, jit_insn *slow_code,
int args_already_in_place)
{
jit_insn *refslow;
int i;
@ -1469,12 +1512,12 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
__END_SHORT_JUMPS__(1);
/* Copy args to runstack after closure data: */
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE, WORDS_TO_BYTES(num_rands + closure_size));
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE, WORDS_TO_BYTES(num_rands + closure_size + args_already_in_place));
if (num_rands) {
jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + closure_size), JIT_R2, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + closure_size + args_already_in_place), JIT_R2, JIT_R0);
for (i = num_rands - 1; i--; ) {
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(i));
jit_stxi_p(WORDS_TO_BYTES(i + closure_size), JIT_R2, JIT_R1);
jit_stxi_p(WORDS_TO_BYTES(i + closure_size + args_already_in_place), JIT_R2, JIT_R1);
CHECK_LIMIT();
}
}
@ -1489,6 +1532,11 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
mz_patch_branch(refslow);
__END_SHORT_JUMPS__(1);
if (args_already_in_place) {
jit_movi_l(JIT_R2, args_already_in_place);
mz_set_local_p(JIT_R2, JIT_LOCAL2);
}
jit_stxi_p(WORDS_TO_BYTES(num_rands - 1), JIT_RUNSTACK, JIT_R0);
generate(rator, jitter, 0, 0);
CHECK_LIMIT();
@ -1562,6 +1610,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
int proc_already_in_place = 0;
Scheme_Object *rator, *v;
int reorder_ok = 0;
int args_already_in_place = 0;
START_JIT_DATA();
rator = (alt_rands ? alt_rands[0] : app->args[0]);
@ -1617,6 +1666,19 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
}
}
} else if (SAME_TYPE(t, scheme_closure_type)) {
Scheme_Closure_Data *data;
data = ((Scheme_Closure *)rator)->code;
if ((data->num_params == num_rands)
&& !(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) {
direct_native = 1;
if (is_tail
&& SAME_OBJ(data->u.jit_clone, jitter->self_data)
&& (num_rands < MAX_SHARED_CALL_RANDS))
direct_self = 1;
}
reorder_ok = 1;
} else if (t > _scheme_values_types_) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
@ -1626,6 +1688,35 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
reorder_ok = 0; /* superceded by direct_self */
}
/* Direct native tail with same number of args as just received? */
if (direct_native && is_tail && num_rands
&& (num_rands == jitter->self_data->num_params)
&& !(SCHEME_CLOSURE_DATA_FLAGS(jitter->self_data) & CLOS_HAS_REST)) {
/* Check whether the actual arguments refer to Scheme-stack
locations that will be filled with argument values; that
is, check how many arguments are already in place for
the call. */
mz_runstack_skipped(jitter, num_rands);
for (i = 0; i < num_rands; i++) {
v = (alt_rands ? alt_rands[i+1] : app->args[i+1]);
if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) {
int pos;
pos = mz_remap(SCHEME_LOCAL_POS(v));
if (pos == (jitter->depth + args_already_in_place))
args_already_in_place++;
else
break;
} else
break;
}
mz_runstack_unskipped(jitter, num_rands);
if (args_already_in_place) {
direct_native = 2;
mz_runstack_skipped(jitter, args_already_in_place);
num_rands -= args_already_in_place;
}
}
if (num_rands) {
if (!direct_prim || (num_rands > 1)) {
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(num_rands));
@ -1635,7 +1726,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
}
for (i = 0; i <= num_rands; i++) {
for (i = num_rands + args_already_in_place + 1; i--; ) {
v = (alt_rands ? alt_rands[i] : app->args[i]);
if (!is_simple(v, INIT_SIMPLE_DEPTH, 1, jitter)) {
need_non_tail = 1;
@ -1656,7 +1747,9 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
if (num_rands) {
/* Save rator where GC can see it */
Scheme_Type t;
t = SCHEME_TYPE(alt_rands ? alt_rands[1] : app->args[1]);
t = SCHEME_TYPE((alt_rands
? alt_rands[1+args_already_in_place]
: app->args[1+args_already_in_place]));
if ((num_rands == 1) && (SAME_TYPE(scheme_local_type, t)
|| (t >= _scheme_values_types_))) {
/* App of something complex to a local variable. We
@ -1672,7 +1765,10 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
for (i = 0; i < num_rands; i++) {
PAUSE_JIT_DATA();
generate_non_tail(alt_rands ? alt_rands[i+1] : app->args[i+1], jitter, 0, !need_non_tail);
generate_non_tail((alt_rands
? alt_rands[i+1+args_already_in_place]
: app->args[i+1+args_already_in_place]),
jitter, 0, !need_non_tail);
RESUME_JIT_DATA();
CHECK_LIMIT();
if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !direct_self && !proc_already_in_place) {
@ -1711,10 +1807,15 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
if (num_rands >= MAX_SHARED_CALL_RANDS) {
if (is_tail) {
if (direct_prim)
generate_direct_prim_tail_call(jitter, num_rands);
else
if (direct_prim) {
generate_direct_prim_tail_call(jitter, num_rands);
} else {
if (args_already_in_place) {
jit_movi_l(JIT_R2, args_already_in_place);
mz_set_local_p(JIT_R2, JIT_LOCAL2);
}
generate_tail_call(jitter, num_rands, direct_native, jitter->need_set_rs);
}
} else {
if (direct_prim)
generate_direct_prim_non_tail_call(jitter, num_rands, multi_ok, 0);
@ -1724,7 +1825,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
} else {
/* Jump to code to implement a tail call for num_rands arguments */
void *code;
int dp = (direct_prim ? 1 : (direct_native ? 2 : 0));
int dp = (direct_prim ? 1 : (direct_native ? (1 + direct_native) : 0));
if (is_tail) {
if (!shared_tail_code[dp][num_rands]) {
code = generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native);
@ -1732,9 +1833,13 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
code = shared_tail_code[dp][num_rands];
if (direct_self) {
generate_self_tail_call(rator, jitter, num_rands, code);
generate_self_tail_call(rator, jitter, num_rands, code, args_already_in_place);
CHECK_LIMIT();
} else {
if (args_already_in_place) {
jit_movi_l(JIT_R2, args_already_in_place);
mz_set_local_p(JIT_R2, JIT_LOCAL2);
}
(void)jit_jmpi(code);
}
} else {
@ -2800,10 +2905,10 @@ int generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int branch_s
static void ensure_closure_native(Scheme_Closure_Data *data,
Scheme_Native_Closure_Data *case_lam)
{
if (!data->native_code || SCHEME_FALSEP((Scheme_Object *)data->native_code)) {
if (!data->u.native_code || SCHEME_FALSEP((Scheme_Object *)data->u.native_code)) {
Scheme_Native_Closure_Data *code;
code = scheme_generate_lambda(data, 0, case_lam);
data->native_code = code;
data->u.native_code = code;
}
}
@ -2814,7 +2919,7 @@ static int generate_closure(Scheme_Closure_Data *data,
int retptr;
ensure_closure_native(data, NULL);
code = data->native_code;
code = data->u.native_code;
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(1);
@ -2873,8 +2978,8 @@ Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *c)
o = (Scheme_Object *)((Scheme_Closure *)o)->code;
data = (Scheme_Closure_Data *)o;
ensure_closure_native(data, ndata);
if (data->native_code->max_let_depth > max_let_depth)
max_let_depth = data->native_code->max_let_depth;
if (data->u.native_code->max_let_depth > max_let_depth)
max_let_depth = data->u.native_code->max_let_depth;
}
ndata->max_let_depth = max_let_depth;
ndata->closure_size = -(count + 1); /* Indicates case-lambda */
@ -4206,9 +4311,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_movr_p(JIT_R(3), JIT_AUX);
#endif
/* Decrement stack_cache_stack_pos */
jit_ldi_i(JIT_R1, &stack_cache_stack_pos);
jit_ldi_l(JIT_R1, &stack_cache_stack_pos);
jit_subi_i(JIT_R2, JIT_R1, 1);
jit_sti_p(&stack_cache_stack_pos, JIT_R2);
jit_sti_l(&stack_cache_stack_pos, JIT_R2);
CHECK_LIMIT();
/* Extract old return address and jump to it */
jit_lshi_l(JIT_R1, JIT_R1, (JIT_LOG_WORD_SIZE + 2));
@ -4816,6 +4921,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
LOG_IT(("PROC: %s\n", (data->name ? scheme_format_utf8("~s", 2, 1, &data->name, NULL) : "???")));
FOR_LOG(jitter->log_depth++);
jitter->self_data = data;
jitter->self_restart_code = jit_get_ip().ptr;
/* Generate code for the body: */
@ -4856,14 +4963,14 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
int has_rest, is_method, num_params, max_depth;
data = ndata->u2.orig_code;
gdata.data = data;
gdata.nc = nc;
generate_one(NULL, do_generate_closure, &gdata, 1, data->name, ndata);
if (gdata.max_depth > data->max_let_depth) {
scheme_console_printf("Bad max depth!\n");
scheme_console_printf("Bad max depth! Given %d, counted %d.\n", data->max_let_depth, gdata.max_depth);
abort();
}
@ -4904,7 +5011,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
if (case_lam->max_let_depth < max_depth)
case_lam->max_let_depth = max_depth;
}
ndata->code = code;
ndata->u.tail_code = tail_code;
ndata->arity_code = arity_code;

56
src/mzscheme/src/module.c
View File

@ -78,10 +78,12 @@ static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static Scheme_Object *write_module(Scheme_Object *obj);
static Scheme_Object *read_module(Scheme_Object *obj);
@ -202,12 +204,12 @@ void scheme_init_module(Scheme_Env *env)
module_optimize,
module_resolve, module_validate,
module_execute, module_jit,
NULL, -1);
NULL, NULL, -1);
scheme_register_syntax(REQUIRE_EXPD,
top_level_require_optimize,
top_level_require_resolve, top_level_require_validate,
top_level_require_execute, top_level_require_jit,
NULL, 2);
NULL, NULL, 2);
scheme_add_global_keyword("module",
scheme_make_compiled_syntax(module_syntax,
@ -3145,9 +3147,9 @@ static Scheme_Object *module_jit(Scheme_Object *data)
return (Scheme_Object *)m;
}
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes)
int num_toplevels, int num_stxes, int num_lifts)
{
Scheme_Module *m;
Scheme_Object *l;
@ -3161,8 +3163,8 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
scheme_ill_formed_code(port);
for (l = m->body; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
scheme_validate_code(port, SCHEME_CAR(l), m->max_let_depth,
m->prefix->num_toplevels, m->prefix->num_stxes);
scheme_validate_code(port, SCHEME_CAR(l), ht, m->max_let_depth,
m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts);
}
if (!SCHEME_NULLP(l))
scheme_ill_formed_code(port);
@ -3176,7 +3178,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *e, *b, *vars, *start_simltaneous_b;
Scheme_Hash_Table *consts = NULL, *ready_table = NULL;
int max_let_depth = 0, cont;
int cont;
start_simltaneous_b = m->body;
for (b = m->body; !SCHEME_NULLP(b); b = SCHEME_CDR(b)) {
@ -3184,10 +3186,6 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
e = scheme_optimize_expr(SCHEME_CAR(b), info);
SCHEME_CAR(b) = e;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
if (info->enforce_const) {
/* If this expression/definition can't have any side effect
(including raising an exception), then continue the group of
@ -3287,10 +3285,6 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
/* Re-optimize this expression: */
e = scheme_optimize_expr(SCHEME_CAR(start_simltaneous_b), info);
SCHEME_CAR(start_simltaneous_b) = e;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
if (SAME_OBJ(start_simltaneous_b, b))
break;
@ -3303,8 +3297,6 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
}
}
m->max_let_depth = max_let_depth;
/* Exp-time body was optimized during compilation */
return scheme_make_syntax_compiled(MODULE_EXPD, data);
@ -3314,7 +3306,7 @@ static Scheme_Object *
module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *b;
Scheme_Object *b, *lift_vec;
Resolve_Prefix *rp;
Resolve_Info *rslv;
@ -3328,6 +3320,7 @@ module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
rslv = scheme_resolve_info_create(rp);
rslv->enforce_const = old_rslv->enforce_const;
rslv->in_module = 1;
scheme_enable_expression_resolve_lifts(rslv);
for (b = m->body; !SCHEME_NULLP(b); b = SCHEME_CDR(b)) {
Scheme_Object *e;
@ -3335,6 +3328,13 @@ module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
SCHEME_CAR(b) = e;
}
m->max_let_depth = rslv->max_let_depth;
lift_vec = rslv->lifts;
b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], m->body);
m->body = b;
rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]);
/* Exp-time body was resolved during compilation */
return scheme_make_syntax_resolved(MODULE_EXPD, data);
@ -4128,19 +4128,21 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
oi = scheme_optimize_info_create(eenv);
oi = scheme_optimize_info_create();
m = scheme_optimize_expr(m, oi);
/* Simplify only in compile mode; it is too slow in expand mode. */
rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
ri = scheme_resolve_info_create(rp);
scheme_enable_expression_resolve_lifts(ri);
m = scheme_resolve_expr(m, ri);
m = scheme_merge_expression_resolve_lifts(m, rp, ri);
/* Add code with names and lexical depth to exp-time body: */
vec = scheme_make_vector(5, NULL);
SCHEME_VEC_ELS(vec)[0] = names;
SCHEME_VEC_ELS(vec)[1] = m;
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(oi->max_let_depth);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth);
SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
exp_body = scheme_make_pair(vec, exp_body);
@ -4148,7 +4150,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (ri->use_jit)
m = scheme_jit_expr(m);
eval_defmacro(names, count, m, eenv->genv, rhs_env, rp, oi->max_let_depth, 0,
eval_defmacro(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0,
(for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
rec[drec].certs);
@ -5798,9 +5800,9 @@ top_level_require_jit(Scheme_Object *data)
return data;
}
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes)
int num_toplevels, int num_stxes, int num_lifts)
{
}

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

@ -435,7 +435,7 @@ static int unclosed_proc_MARK(void *p) {
gcMARK(d->code);
gcMARK(d->closure_map);
#ifdef MZ_USE_JIT
gcMARK(d->native_code);
gcMARK(d->u.native_code);
gcMARK(d->context);
#endif
@ -450,7 +450,7 @@ static int unclosed_proc_FIXUP(void *p) {
gcFIXUP(d->code);
gcFIXUP(d->closure_map);
#ifdef MZ_USE_JIT
gcFIXUP(d->native_code);
gcFIXUP(d->u.native_code);
gcFIXUP(d->context);
#endif
@ -780,7 +780,9 @@ static int closed_prim_proc_FIXUP(void *p) {
static int scm_closure_SIZE(void *p) {
Scheme_Closure *c = (Scheme_Closure *)p;
int closure_size = ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size;
int closure_size = (c->code
? ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size
: 0);
return
gcBYTES_TO_WORDS((sizeof(Scheme_Closure)
@ -789,7 +791,9 @@ static int scm_closure_SIZE(void *p) {
static int scm_closure_MARK(void *p) {
Scheme_Closure *c = (Scheme_Closure *)p;
int closure_size = ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size;
int closure_size = (c->code
? ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size
: 0);
int i = closure_size;
@ -804,7 +808,9 @@ static int scm_closure_MARK(void *p) {
static int scm_closure_FIXUP(void *p) {
Scheme_Closure *c = (Scheme_Closure *)p;
int closure_size = ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size;
int closure_size = (c->code
? ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size
: 0);
int i = closure_size;
@ -2431,6 +2437,8 @@ static int mark_resolve_info_MARK(void *p) {
gcMARK(i->new_pos);
gcMARK(i->old_stx_pos);
gcMARK(i->flags);
gcMARK(i->lifts);
gcMARK(i->lifted);
gcMARK(i->next);
return
@ -2445,6 +2453,8 @@ static int mark_resolve_info_FIXUP(void *p) {
gcFIXUP(i->new_pos);
gcFIXUP(i->old_stx_pos);
gcFIXUP(i->flags);
gcFIXUP(i->lifts);
gcFIXUP(i->lifted);
gcFIXUP(i->next);
return
@ -4517,6 +4527,7 @@ static int mark_jit_state_SIZE(void *p) {
static int mark_jit_state_MARK(void *p) {
mz_jit_state *j = (mz_jit_state *)p;
gcMARK(j->mappings);
gcMARK(j->self_data);
return
gcBYTES_TO_WORDS(sizeof(mz_jit_state));
}
@ -4524,6 +4535,7 @@ static int mark_jit_state_MARK(void *p) {
static int mark_jit_state_FIXUP(void *p) {
mz_jit_state *j = (mz_jit_state *)p;
gcFIXUP(j->mappings);
gcFIXUP(j->self_data);
return
gcBYTES_TO_WORDS(sizeof(mz_jit_state));
}

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

@ -160,7 +160,7 @@ unclosed_proc {
gcMARK(d->code);
gcMARK(d->closure_map);
#ifdef MZ_USE_JIT
gcMARK(d->native_code);
gcMARK(d->u.native_code);
gcMARK(d->context);
#endif
@ -290,7 +290,9 @@ closed_prim_proc {
scm_closure {
Scheme_Closure *c = (Scheme_Closure *)p;
int closure_size = ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size;
int closure_size = (c->code
? ((Scheme_Closure_Data *)GC_resolve(c->code))->closure_size
: 0);
mark:
@ -960,6 +962,8 @@ mark_resolve_info {
gcMARK(i->new_pos);
gcMARK(i->old_stx_pos);
gcMARK(i->flags);
gcMARK(i->lifts);
gcMARK(i->lifted);
gcMARK(i->next);
size:
@ -1825,6 +1829,7 @@ mark_jit_state {
mark:
mz_jit_state *j = (mz_jit_state *)p;
gcMARK(j->mappings);
gcMARK(j->self_data);
size:
gcBYTES_TO_WORDS(sizeof(mz_jit_state));
}

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

@ -7110,7 +7110,7 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
}
}
/* Set real CWD - and hope no other thread changes it! */
/* Set real CWD before spawn: */
tcd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
scheme_os_setcwd(SCHEME_BYTE_STR_VAL(tcd), 0);

20
src/mzscheme/src/print.c
View File

@ -1670,9 +1670,23 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (SCHEME_TYPE(obj) == scheme_closure_type) {
Scheme_Closure *closure = (Scheme_Closure *)obj;
if (ZERO_SIZED_CLOSUREP(closure)) {
/* Print original `lambda' code: */
compact = print((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(closure), notdisplay, compact, ht, symtab, rnht, pp);
done = 1;
/* Print original `lambda' code. Closure conversion can cause
an empty closure to be duplicated in the code tree, so hash it. */
Scheme_Object *idx;
idx = scheme_hash_get(symtab, obj);
if (idx) {
print_compact(pp, CPT_SYMREF);
print_compact_number(pp, SCHEME_INT_VAL(idx));
} else {
idx = scheme_make_integer(symtab->count);
scheme_hash_set(symtab, obj, idx);
print_compact(pp, CPT_CLOSURE);
print_compact_number(pp, SCHEME_INT_VAL(idx));
print((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(closure), notdisplay, compact, ht, symtab, rnht, pp);
}
compact = 1;
done = 1;
}
} else if (SCHEME_TYPE(obj) == scheme_case_closure_type) {
obj = scheme_unclose_case_lambda(obj, 0);

23
src/mzscheme/src/read.c
View File

@ -4232,6 +4232,22 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
port->symtab[l] = v;
}
break;
case CPT_CLOSURE:
{
Scheme_Closure *cl;
l = read_compact_number(port);
cl = scheme_malloc_empty_closure();
port->symtab[l] = (Scheme_Object *)cl;
v = read_compact(port, 0);
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type)
|| ((Scheme_Closure *)v)->code->closure_size) {
scheme_ill_formed_code(port);
return NULL;
}
cl->code = ((Scheme_Closure *)v)->code;
v = (Scheme_Object *)cl;
break;
}
case CPT_SMALL_LOCAL_START:
case CPT_SMALL_LOCAL_UNBOX_START:
{
@ -4670,9 +4686,11 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result;
scheme_validate_code(rp, top->code,
scheme_make_hash_table(SCHEME_hash_ptr),
top->max_let_depth,
top->prefix->num_toplevels,
top->prefix->num_stxes);
top->prefix->num_stxes,
top->prefix->num_lifts);
/* If no exception, the the resulting code is ok. */
} else
scheme_ill_formed_code(rp);
@ -5283,6 +5301,9 @@ static Scheme_Object *copy_to_protect(Scheme_Object *v, Scheme_Object *src, Sche
static Scheme_Object *copy_to_protect_placeholders(Scheme_Object *v, Scheme_Object *src, Scheme_Hash_Table **oht)
{
/* This function turns any cycles in the data into placeholder-based
cycles, and it generally copies the data to avoid mutation (which can
introduce cycles before placeholders are later resolved). */
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
return copy_to_protect(v, src, ht, oht);

3
src/mzscheme/src/schcpt.h
View File

@ -32,10 +32,11 @@ enum {
CPT_MODULE_INDEX,
CPT_MODULE_VAR, /* 30 */
CPT_PATH,
CPT_CLOSURE,
_CPT_COUNT_
};
#define CPT_SMALL_NUMBER_START 32
#define CPT_SMALL_NUMBER_START 33
#define CPT_SMALL_NUMBER_END 60
#define CPT_SMALL_SYMBOL_START 60

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 865
#define EXPECTED_PRIM_COUNT 866
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -103,10 +103,10 @@ int scheme_num_types(void);
void scheme_reset_finalizations(void);
extern unsigned long scheme_get_stack_base();
extern unsigned long scheme_get_stack_base(void);
int scheme_propagate_ephemeron_marks();
void scheme_clear_ephemerons();
int scheme_propagate_ephemeron_marks(void);
void scheme_clear_ephemerons(void);
#ifndef MZ_XFORM
# define HIDE_FROM_XFORM(x) x
@ -114,6 +114,8 @@ void scheme_clear_ephemerons();
#define mzALIAS (void *)
#define BITS_PER_MZSHORT (8 * sizeof(mzshort))
/*========================================================================*/
/* initialization */
/*========================================================================*/
@ -231,10 +233,12 @@ extern Scheme_Object *scheme_orig_stdout_port;
extern Scheme_Object *scheme_orig_stdin_port;
extern Scheme_Object *scheme_orig_stderr_port;
extern Scheme_Object *scheme_arity_at_least;
extern Scheme_Object *scheme_arity_at_least, *scheme_make_arity_at_least;
extern Scheme_Object *scheme_write_proc, *scheme_display_proc, *scheme_print_proc;
extern Scheme_Object *scheme_raise_arity_error_proc;
#ifdef TIME_SYNTAX
extern Scheme_Object *scheme_date;
#endif
@ -551,7 +555,7 @@ Scheme_Object *scheme_make_graph_stx(Scheme_Object *stx,
Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym,
Scheme_Object *rn);
Scheme_Object *scheme_new_stx_simplify_cache();
Scheme_Object *scheme_new_stx_simplify_cache(void);
void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *simplify_cache);
Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src,
@ -566,14 +570,14 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
Scheme_Object *old,
Scheme_Object *origin);
Scheme_Object *scheme_new_mark();
Scheme_Object *scheme_new_mark(void);
Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m);
Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c);
void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname);
#define SCHEME_RIBP(v) SAME_TYPE(scheme_lexical_rib_type, SCHEME_TYPE(v))
Scheme_Object *scheme_make_rename_rib();
Scheme_Object *scheme_make_rename_rib(void);
void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename);
void scheme_drop_first_rib_rename(Scheme_Object *ro);
@ -1438,7 +1442,7 @@ extern Scheme_Object *scheme_default_global_print_handler;
void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f);
void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f);
Scheme_Object *scheme_make_default_readtable();
Scheme_Object *scheme_make_default_readtable(void);
Scheme_Object *_scheme_apply_from_native(Scheme_Object *rator,
int argc,
@ -1453,7 +1457,7 @@ Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator,
Scheme_Object *scheme_force_value_same_mark(Scheme_Object *);
Scheme_Object *scheme_force_one_value_same_mark(Scheme_Object *);
void scheme_flush_stack_cache();
void scheme_flush_stack_cache(void);
/*========================================================================*/
/* compile and link */
@ -1499,7 +1503,7 @@ typedef struct Scheme_Comp_Env
} Scheme_Comp_Env;
#define CLOS_HAS_REST 1
#define CLOS_MUST_ALLOC 2
#define CLOS_HAS_REF_ARGS 2
#define CLOS_ONLY_LOCALS 4
#define CLOS_FOLDABLE 8
#define CLOS_IS_METHOD 16
@ -1521,7 +1525,7 @@ typedef Scheme_Compile_Expand_Info Scheme_Expand_Info;
typedef struct Resolve_Prefix
{
Scheme_Object so;
int num_toplevels, num_stxes;
int num_toplevels, num_stxes, num_lifts;
Scheme_Object **toplevels;
Scheme_Object **stxes; /* simplified */
} Resolve_Prefix;
@ -1529,8 +1533,9 @@ typedef struct Resolve_Prefix
typedef struct Resolve_Info
{
MZTAG_IF_REQUIRED
char use_jit, in_module, enforce_const;
char use_jit, in_module, in_proc, enforce_const;
int size, oldsize, count, pos;
int max_let_depth; /* filled in by sub-expressions */
Resolve_Prefix *prefix;
mzshort toplevel_pos; /* -1 mean consult next */
mzshort *old_pos;
@ -1538,6 +1543,8 @@ typedef struct Resolve_Info
int stx_count;
mzshort *old_stx_pos; /* NULL => consult next; new pos is index in array */
int *flags;
Scheme_Object **lifted; /* maps bindings to lifts */
Scheme_Object *lifts; /* accumulates lift info */
struct Resolve_Info *next;
} Resolve_Info;
@ -1560,7 +1567,7 @@ typedef struct Optimize_Info
Scheme_Object *consts;
/* Propagated up and down the chain: */
int size, max_let_depth;
int size;
short inline_fuel;
char letrec_not_twice, enforce_const;
Scheme_Hash_Table *top_level_consts;
@ -1573,12 +1580,14 @@ typedef struct Optimize_Info
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
typedef struct Scheme_Object *(*Scheme_Syntax_Shifter)(Scheme_Object *data, int delta, int after_depth);
typedef struct CPort Mz_CPort;
typedef void (*Scheme_Syntax_Validater)(Scheme_Object *data, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
typedef void (*Scheme_Syntax_Validater)(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
typedef struct Scheme_Object *(*Scheme_Syntax_Executer)(struct Scheme_Object *data);
@ -1590,11 +1599,14 @@ typedef struct Scheme_Closure_Data
mzshort num_params; /* includes collecting arg if has_rest */
mzshort max_let_depth;
mzshort closure_size;
mzshort *closure_map; /* actually a Closure_Info* until resolved */
mzshort *closure_map; /* actually a Closure_Info* until resolved; if CLOS_HASH_REF_ARGS, followed by bit array */
Scheme_Object *code;
Scheme_Object *name;
#ifdef MZ_USE_JIT
struct Scheme_Native_Closure_Data *native_code; /* generated by lightning */
union {
struct Scheme_Closure_Data *jit_clone;
struct Scheme_Native_Closure_Data *native_code; /* generated by lightning */
} u;
Scheme_Object *context; /* e.g., a letrec that binds the closure */
#endif
} Scheme_Closure_Data;
@ -1707,6 +1719,7 @@ void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,
Scheme_Object *scheme_make_closure(Scheme_Thread *p,
Scheme_Object *compiled_code,
int close);
Scheme_Closure *scheme_malloc_empty_closure(void);
Scheme_Object *scheme_make_native_closure(Scheme_Native_Closure_Data *code);
Scheme_Object *scheme_make_native_case_closure(Scheme_Native_Closure_Data *code);
@ -1715,7 +1728,7 @@ Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *cl);
#define scheme_add_good_binding(i,v,f) (f->values[i] = v)
Scheme_Object *scheme_compiled_void();
Scheme_Object *scheme_compiled_void(void);
Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
@ -1742,13 +1755,14 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define REF_EXPD 10
#define _COUNT_EXPD_ 11
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, pa) \
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa) \
(scheme_syntax_optimizers[i] = fo, \
scheme_syntax_resolvers[i] = fr, \
scheme_syntax_executers[i] = fe, \
scheme_syntax_validaters[i] = fv, \
scheme_syntax_jitters[i] = fj, \
scheme_syntax_cloners[i] = cl, \
scheme_syntax_cloners[i] = cl, \
scheme_syntax_shifters[i] = sh, \
scheme_syntax_protect_afters[i] = pa)
extern Scheme_Syntax_Optimizer scheme_syntax_optimizers[_COUNT_EXPD_];
extern Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
@ -1756,6 +1770,7 @@ extern Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
extern Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
extern Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
extern Scheme_Syntax_Cloner scheme_syntax_cloners[_COUNT_EXPD_];
extern Scheme_Syntax_Shifter scheme_syntax_shifters[_COUNT_EXPD_];
extern int scheme_syntax_protect_afters[_COUNT_EXPD_];
Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
@ -1774,7 +1789,7 @@ int scheme_compiled_propagate_ok(Scheme_Object *o);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed);
int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable);
Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info);
@ -1782,12 +1797,16 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify);
Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp);
Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapcount);
void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags);
int scheme_resolve_info_flags(Resolve_Info *info, int pos);
int scheme_resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags);
void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted);
void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted);
int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted);
int scheme_resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags, Scheme_Object **lifted, int convert_shift);
void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos);
Optimize_Info *scheme_optimize_info_create();
void scheme_enable_expression_resolve_lifts(Resolve_Info *ri);
Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri);
Optimize_Info *scheme_optimize_info_create(void);
void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value);
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset);
@ -1798,10 +1817,13 @@ Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_
int scheme_optimize_is_used(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_clone(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth);
Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *obj, int delta, int after_depth);
int scheme_closure_body_size(Scheme_Closure_Data *closure_data, int check_assign);
int scheme_closure_argument_flags(Scheme_Closure_Data *closure_data, int i);
int scheme_closure_has_top_level(Scheme_Closure_Data *data);
Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags);
int scheme_optimize_info_get_shift(Optimize_Info *info, int pos);
@ -1813,9 +1835,17 @@ void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **
int scheme_env_uses_toplevel(Optimize_Info *frame);
int scheme_resolve_toplevel_pos(Resolve_Info *info);
int scheme_resolve_is_toplevel_available(Resolve_Info *info);
int scheme_resolve_quote_syntax_pos(Resolve_Info *info);
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr);
Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info);
Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl);
Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta);
Scheme_Object *scheme_resolve_generate_stub_lift(void);
int scheme_resolve_quote_syntax(Resolve_Info *info, int oldpos);
int scheme_resolving_in_procedure(Resolve_Info *info);
void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs);
Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax,
Scheme_Syntax_Expander *exp);
@ -1856,7 +1886,9 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list,
int strip_values);
Scheme_Object *scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info);
Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info);
Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
int can_lift, int convert, int just_compute_lift,
Scheme_Object *precomputed_lift);
Scheme_App_Rec *scheme_malloc_application(int n);
void scheme_finish_application(Scheme_App_Rec *app);
@ -1871,13 +1903,15 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Inf
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
/* flags reported by scheme_env_get_fags */
#define SCHEME_WAS_USED 1
#define SCHEME_WAS_SET_BANGED 2
/* 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_USE_COUNT_MASK 0x70
#define SCHEME_USE_COUNT_SHIFT 4
#define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
/* flags reported by scheme_resolve_info_flags */
#define SCHEME_INFO_BOXED 1
@ -1969,17 +2003,26 @@ void scheme_pop_prefix(Scheme_Object **rs);
Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env);
Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy);
void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, int depth,
int num_toplevels, int num_stxes);
void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, Scheme_Hash_Table *ht,
int depth,
int num_toplevels, int num_stxes, int num_lifts);
void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts,
Scheme_Object *app_rator, int proc_with_refs_ok);
void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
char *stack, int depth, int delta,
int num_toplevels, int num_stxes);
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int delta,
int num_toplevels, int num_stxes, int num_lifts);
void scheme_validate_boxenv(int pos, Mz_CPort *port,
char *stack, int depth, int delta);
int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
int hope,
Scheme_Object **tls,
int num_toplevels, int num_stxes, int num_lifts);
#define TRACK_ILL_FORMED_CATCH_LINES 1
#if TRACK_ILL_FORMED_CATCH_LINES
void scheme_ill_formed(Mz_CPort *port, const char *file, int line);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 352
#define MZSCHEME_VERSION_MINOR 0
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION "352" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "352.1" _MZ_SPECIAL_TAG

3
src/mzscheme/src/struct.c
View File

@ -24,6 +24,7 @@
/* globals */
Scheme_Object *scheme_arity_at_least, *scheme_date;
Scheme_Object *scheme_make_arity_at_least;
Scheme_Object *scheme_source_property;
/* locals */
@ -169,6 +170,7 @@ scheme_init_struct (Scheme_Env *env)
/* Add arity structure */
REGISTER_SO(scheme_arity_at_least);
REGISTER_SO(scheme_make_arity_at_least);
scheme_arity_at_least = scheme_make_struct_type_from_string("arity-at-least", NULL, 1, NULL, NULL, 0);
as_names = scheme_make_struct_names_from_array("arity-at-least",
1, arity_fields,
@ -176,6 +178,7 @@ scheme_init_struct (Scheme_Env *env)
&as_count);
as_values = scheme_make_struct_values(scheme_arity_at_least, as_names, as_count,
BUILTIN_STRUCT_FLAGS);
scheme_make_arity_at_least = as_values[1];
for (i = 0; i < as_count - 1; i++) {
scheme_add_global_constant(scheme_symbol_val(as_names[i]), as_values[i],
env);

677
src/mzscheme/src/syntax.c
View File

File diff suppressed because it is too large Load Diff