cache loaded compiled modules
using a SHA1 hash stored in the marshaled bytecode; this cache lowers the cost of sandboxes or other uses of multiple namespaces when the code inspector doesn't change; the caching is almost transparent, but an eval handler might be called with compiled code that cannot be written
This commit is contained in:
Matthew Flatt
parent
546faf8b34
commit
97ce26b182
|
|
@ -360,7 +360,17 @@
|
|||
(if (eq? base 'relative)
|
||||
(current-directory)
|
||||
(path->complete-path base (current-directory))))])
|
||||
(write code out)))
|
||||
(let ([b (open-output-bytes)])
|
||||
;; Write bytecode into string
|
||||
(write code b)
|
||||
;; Compute SHA1 over bytecode so far
|
||||
(let* ([s (get-output-bytes b)]
|
||||
[h (sha1-bytes (open-input-bytes s))]
|
||||
[delta (+ 3 (bytes-ref s 2))])
|
||||
;; Use sha1 for module hash in string form of bytecode
|
||||
(bytes-copy! s delta h)
|
||||
;; Write out the bytecode with module hash
|
||||
(write-bytes s out)))))
|
||||
;; redundant, but close as early as possible:
|
||||
(close-output-port out)
|
||||
;; Note that we check time and write .deps before returning from
|
||||
|
|
|
|||
|
|
@ -127,6 +127,8 @@
|
|||
(write-bytes (bytes (bytes-length version-bs)) outp)
|
||||
(write-bytes version-bs outp)
|
||||
|
||||
; Write empty hash code
|
||||
(write-bytes (make-bytes 20 0) outp)
|
||||
|
||||
; Write the symbol table information (size, offsets)
|
||||
(define symtabsize (add1 (vector-length symbol-table)))
|
||||
|
|
|
|||
|
|
@ -1012,6 +1012,9 @@
|
|||
|
||||
(define version (read-bytes (min 63 (read-byte port)) port))
|
||||
|
||||
;; Skip module hash code
|
||||
(read-bytes 20 port)
|
||||
|
||||
(define symtabsize (read-simple-number port))
|
||||
|
||||
(define all-short (read-byte port))
|
||||
|
|
|
|||
|
|
@ -311,6 +311,7 @@ typedef struct Thread_Local_Variables {
|
|||
struct Evt **place_evts_;
|
||||
void *place_object_;
|
||||
struct Scheme_Object *empty_self_shift_cache_;
|
||||
struct Scheme_Bucket_Table *scheme_module_code_cache_;
|
||||
} Thread_Local_Variables;
|
||||
|
||||
#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
|
||||
|
|
@ -627,6 +628,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
|
|||
#define place_evts XOA (scheme_get_thread_local_variables()->place_evts_)
|
||||
#define place_object XOA (scheme_get_thread_local_variables()->place_object_)
|
||||
#define empty_self_shift_cache XOA (scheme_get_thread_local_variables()->empty_self_shift_cache_)
|
||||
#define scheme_module_code_cache XOA (scheme_get_thread_local_variables()->scheme_module_code_cache_)
|
||||
|
||||
/* **************************************** */
|
||||
|
||||
|
|
|
|||
|
|
@ -342,7 +342,7 @@ places.@LTO@: $(COMMON_HEADERS) \
|
|||
$(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c
|
||||
port.@LTO@: $(COMMON_HEADERS) \
|
||||
$(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c
|
||||
portfun.@LTO@: $(COMMON_HEADERS) \
|
||||
portfun.@LTO@: $(COMMON_HEADERS) $(srcdir)/schvers.h \
|
||||
$(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c
|
||||
print.@LTO@: $(COMMON_HEADERS) $(srcdir)/../src/stypes.h $(srcdir)/../src/schcpt.h \
|
||||
$(srcdir)/schvers.h $(SCONFIG) $(srcdir)/mzmark.c
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -10377,7 +10377,11 @@ static void *eval_k(void)
|
|||
Resolve_Prefix *rp;
|
||||
int depth;
|
||||
|
||||
depth = top->max_let_depth + scheme_prefix_depth(top->prefix);
|
||||
if (!top->prefix)
|
||||
depth = 0;
|
||||
else
|
||||
depth = top->max_let_depth + scheme_prefix_depth(top->prefix);
|
||||
|
||||
if (!scheme_check_runstack(depth)) {
|
||||
p->ku.k.p1 = top;
|
||||
p->ku.k.p2 = env;
|
||||
|
|
@ -10388,43 +10392,49 @@ static void *eval_k(void)
|
|||
|
||||
v = top->code;
|
||||
|
||||
if (use_jit)
|
||||
v = scheme_jit_expr(v);
|
||||
else
|
||||
v = scheme_eval_clone(v);
|
||||
rp = scheme_prefix_eval_clone(top->prefix);
|
||||
if (!top->prefix) {
|
||||
/* top->code is shared module code */
|
||||
scheme_module_execute(top->code, env);
|
||||
v = scheme_void;
|
||||
} else {
|
||||
if (use_jit)
|
||||
v = scheme_jit_expr(v);
|
||||
else
|
||||
v = scheme_eval_clone(v);
|
||||
rp = scheme_prefix_eval_clone(top->prefix);
|
||||
|
||||
save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase, NULL);
|
||||
save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase, NULL);
|
||||
|
||||
if (as_tail) {
|
||||
/* Cons up a closure to capture the prefix */
|
||||
Scheme_Closure_Data *data;
|
||||
mzshort *map;
|
||||
int i, sz;
|
||||
if (as_tail) {
|
||||
/* Cons up a closure to capture the prefix */
|
||||
Scheme_Closure_Data *data;
|
||||
mzshort *map;
|
||||
int i, sz;
|
||||
|
||||
sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK);
|
||||
map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz);
|
||||
for (i = 0; i < sz; i++) {
|
||||
map[i] = i;
|
||||
}
|
||||
sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK);
|
||||
map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz);
|
||||
for (i = 0; i < sz; i++) {
|
||||
map[i] = i;
|
||||
}
|
||||
|
||||
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
|
||||
data->iso.so.type = scheme_compiled_unclosed_procedure_type;
|
||||
data->num_params = 0;
|
||||
data->max_let_depth = top->max_let_depth + sz;
|
||||
data->closure_size = sz;
|
||||
data->closure_map = map;
|
||||
data->code = v;
|
||||
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
|
||||
data->iso.so.type = scheme_compiled_unclosed_procedure_type;
|
||||
data->num_params = 0;
|
||||
data->max_let_depth = top->max_let_depth + sz;
|
||||
data->closure_size = sz;
|
||||
data->closure_map = map;
|
||||
data->code = v;
|
||||
|
||||
v = scheme_make_closure(p, (Scheme_Object *)data, 1);
|
||||
v = scheme_make_closure(p, (Scheme_Object *)data, 1);
|
||||
|
||||
v = _scheme_tail_apply(v, 0, NULL);
|
||||
} else if (multi)
|
||||
v = _scheme_eval_linked_expr_multi_wp(v, p);
|
||||
else
|
||||
v = _scheme_eval_linked_expr_wp(v, p);
|
||||
v = _scheme_tail_apply(v, 0, NULL);
|
||||
} else if (multi)
|
||||
v = _scheme_eval_linked_expr_multi_wp(v, p);
|
||||
else
|
||||
v = _scheme_eval_linked_expr_wp(v, p);
|
||||
|
||||
scheme_pop_prefix(save_runstack);
|
||||
scheme_pop_prefix(save_runstack);
|
||||
}
|
||||
} else {
|
||||
v = scheme_void;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2593,7 +2593,12 @@ void scheme_prep_namespace_rename(Scheme_Env *menv)
|
|||
rn_stx = SCHEME_CAR(m->rn_stx);
|
||||
midx = SCHEME_CDR(m->rn_stx);
|
||||
rns = scheme_stx_to_rename(rn_stx);
|
||||
rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx);
|
||||
rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx,
|
||||
/* CERT-INSP-CACHE <- grep for that in read.c;
|
||||
if certificates are changed to no have inspectors,
|
||||
then the NULL below should be something like m->insp,
|
||||
but maybe not for inspector pairs */
|
||||
NULL);
|
||||
rn_stx = scheme_rename_to_stx(rns);
|
||||
m->rn_stx = rn_stx;
|
||||
}
|
||||
|
|
@ -3241,9 +3246,10 @@ Scheme_Object *module_resolve_in_namespace(Scheme_Object *modidx, Scheme_Env *en
|
|||
return _module_resolve(modidx, NULL, env, load_it);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
|
||||
Scheme_Object *shift_from_modidx,
|
||||
Scheme_Object *shift_to_modidx)
|
||||
static Scheme_Object *do_modidx_shift(Scheme_Object *modidx,
|
||||
Scheme_Object *shift_from_modidx,
|
||||
Scheme_Object *shift_to_modidx,
|
||||
int must_clone)
|
||||
{
|
||||
Scheme_Object *base;
|
||||
|
||||
|
|
@ -3261,7 +3267,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
|
|||
if (!SCHEME_FALSEP(base)) {
|
||||
/* FIXME: depth */
|
||||
Scheme_Object *sbase;
|
||||
sbase = scheme_modidx_shift(base, shift_from_modidx, shift_to_modidx);
|
||||
sbase = do_modidx_shift(base, shift_from_modidx, shift_to_modidx, must_clone);
|
||||
|
||||
if (!SAME_OBJ(base, sbase)) {
|
||||
/* There was a shift in the relative part. */
|
||||
|
|
@ -3343,11 +3349,25 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
|
|||
|
||||
return smodidx;
|
||||
}
|
||||
} else if (must_clone) {
|
||||
/* cloning here ensures that module resolution doesn't mutate
|
||||
module-declaration code that might be cached */
|
||||
modidx = scheme_make_modidx(((Scheme_Modidx *)modidx)->path,
|
||||
scheme_false,
|
||||
scheme_false);
|
||||
|
||||
}
|
||||
|
||||
return modidx;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
|
||||
Scheme_Object *shift_from_modidx,
|
||||
Scheme_Object *shift_to_modidx)
|
||||
{
|
||||
return do_modidx_shift(modidx, shift_from_modidx, shift_to_modidx, 0);
|
||||
}
|
||||
|
||||
void scheme_clear_modidx_cache(void)
|
||||
{
|
||||
Scheme_Modidx *sbm, *next;
|
||||
|
|
@ -3987,9 +4007,10 @@ static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase,
|
|||
np = scheme_null;
|
||||
|
||||
for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
|
||||
midx = scheme_modidx_shift(SCHEME_CAR(l),
|
||||
menv->module->me->src_modidx,
|
||||
(syntax_idx ? syntax_idx : menv->link_midx));
|
||||
midx = do_modidx_shift(SCHEME_CAR(l),
|
||||
menv->module->me->src_modidx,
|
||||
(syntax_idx ? syntax_idx : menv->link_midx),
|
||||
1);
|
||||
|
||||
if (load_env)
|
||||
module_load(scheme_module_resolve(midx, 1), load_env, NULL);
|
||||
|
|
@ -4929,6 +4950,9 @@ Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o)
|
|||
if (SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) {
|
||||
Scheme_Compilation_Top *c = (Scheme_Compilation_Top *)o;
|
||||
|
||||
if (!c->prefix) /* => compiled module is in `code' field */
|
||||
return (Scheme_Module *)c->code;
|
||||
|
||||
if (SAME_TYPE(SCHEME_TYPE(c->code), scheme_syntax_type)
|
||||
&& (SCHEME_PINT_VAL(c->code) == MODULE_EXPD)) {
|
||||
return (Scheme_Module *)SCHEME_IPTR_VAL(c->code);
|
||||
|
|
@ -5179,8 +5203,7 @@ static Scheme_Object **declare_insps(int n, Scheme_Object **insps, Scheme_Object
|
|||
return naya;
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
module_execute(Scheme_Object *data)
|
||||
static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, int set_cache)
|
||||
{
|
||||
Scheme_Module *m;
|
||||
Scheme_Env *env;
|
||||
|
|
@ -5191,10 +5214,22 @@ module_execute(Scheme_Object *data)
|
|||
m = MALLOC_ONE_TAGGED(Scheme_Module);
|
||||
memcpy(m, data, sizeof(Scheme_Module));
|
||||
|
||||
if (set_cache && m->code_key) {
|
||||
if (!scheme_module_code_cache) {
|
||||
REGISTER_SO(scheme_module_code_cache);
|
||||
scheme_module_code_cache = scheme_make_weak_equal_table();
|
||||
}
|
||||
scheme_add_to_table(scheme_module_code_cache,
|
||||
(const char *)m->code_key,
|
||||
scheme_make_ephemeron(m->code_key, data),
|
||||
0);
|
||||
}
|
||||
|
||||
config = scheme_current_config();
|
||||
|
||||
prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME);
|
||||
if (SCHEME_MODNAMEP(prefix)) {
|
||||
|
||||
m->modname = prefix;
|
||||
|
||||
if (m->self_modidx) {
|
||||
|
|
@ -5222,13 +5257,16 @@ module_execute(Scheme_Object *data)
|
|||
} else
|
||||
m->modsrc = m->modname;
|
||||
|
||||
env = scheme_environment_from_dummy(m->dummy);
|
||||
if (genv)
|
||||
env = genv;
|
||||
else
|
||||
env = scheme_environment_from_dummy(m->dummy);
|
||||
|
||||
old_menv = get_special_modenv(m->modname);
|
||||
if (!old_menv)
|
||||
old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
|
||||
|
||||
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
|
||||
insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
|
||||
|
||||
if (old_menv) {
|
||||
if (scheme_module_protected_wrt(old_menv->insp, insp) || old_menv->attached) {
|
||||
|
|
@ -5287,6 +5325,16 @@ module_execute(Scheme_Object *data)
|
|||
return scheme_void;
|
||||
}
|
||||
|
||||
static Scheme_Object *module_execute(Scheme_Object *data)
|
||||
{
|
||||
return do_module_execute(data, NULL, 1);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv)
|
||||
{
|
||||
return do_module_execute(data, genv, 0);
|
||||
}
|
||||
|
||||
static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp)
|
||||
{
|
||||
Scheme_Object *vec2;
|
||||
|
|
|
|||
|
|
@ -2415,6 +2415,9 @@ static int module_val_SIZE(void *p, struct NewGC *gc) {
|
|||
|
||||
static int module_val_MARK(void *p, struct NewGC *gc) {
|
||||
Scheme_Module *m = (Scheme_Module *)p;
|
||||
|
||||
gcMARK2(m->code_key, gc);
|
||||
|
||||
gcMARK2(m->modname, gc);
|
||||
gcMARK2(m->modsrc, gc);
|
||||
|
||||
|
|
@ -2462,6 +2465,9 @@ static int module_val_MARK(void *p, struct NewGC *gc) {
|
|||
|
||||
static int module_val_FIXUP(void *p, struct NewGC *gc) {
|
||||
Scheme_Module *m = (Scheme_Module *)p;
|
||||
|
||||
gcFIXUP2(m->code_key, gc);
|
||||
|
||||
gcFIXUP2(m->modname, gc);
|
||||
gcFIXUP2(m->modsrc, gc);
|
||||
|
||||
|
|
|
|||
|
|
@ -956,6 +956,9 @@ stx_off_val {
|
|||
module_val {
|
||||
mark:
|
||||
Scheme_Module *m = (Scheme_Module *)p;
|
||||
|
||||
gcMARK2(m->code_key, gc);
|
||||
|
||||
gcMARK2(m->modname, gc);
|
||||
gcMARK2(m->modsrc, gc);
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@
|
|||
port types. */
|
||||
|
||||
#include "schpriv.h"
|
||||
#include "schvers.h"
|
||||
|
||||
static Scheme_Object *input_port_p (int, Scheme_Object *[]);
|
||||
static Scheme_Object *output_port_p (int, Scheme_Object *[]);
|
||||
|
|
@ -4101,6 +4102,61 @@ static Scheme_Object *do_load_handler(void *data)
|
|||
Scheme_Env *genv;
|
||||
int save_count = 0, got_one = 0, as_module, check_module_name = 0;
|
||||
|
||||
if (scheme_module_code_cache) {
|
||||
intptr_t got;
|
||||
int vers_size, hash_header_size;
|
||||
# define HASH_HEADER_SIZE (3 + 20 + 16)
|
||||
char buffer[HASH_HEADER_SIZE];
|
||||
|
||||
vers_size = strlen(MZSCHEME_VERSION);
|
||||
hash_header_size = 3 + vers_size + 20;
|
||||
if (hash_header_size >= HASH_HEADER_SIZE)
|
||||
scheme_signal_error("internal error: buffer size mismatch");
|
||||
got = scheme_get_byte_string("default-load-handler",
|
||||
port,
|
||||
buffer, 0, hash_header_size,
|
||||
0, 1, scheme_make_integer(0));
|
||||
|
||||
obj = NULL;
|
||||
if ((got == hash_header_size)
|
||||
&& (buffer[0] == '#')
|
||||
&& (buffer[1] == '~')
|
||||
&& (buffer[2] == vers_size)
|
||||
&& (!scheme_strncmp(buffer + 3, MZSCHEME_VERSION, vers_size))) {
|
||||
int i;
|
||||
for (i = 0; i < 20; i++) {
|
||||
if (buffer[3 + vers_size + i])
|
||||
break;
|
||||
}
|
||||
if (i < 20) {
|
||||
obj = scheme_make_sized_byte_string(buffer + 3 + vers_size, 20, 1);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (obj) {
|
||||
/* CERT-INSP-CACHE <- grep for that in read.c */
|
||||
obj = scheme_make_pair(obj, scheme_get_param(config, MZCONFIG_CODE_INSPECTOR));
|
||||
obj = scheme_lookup_in_table(scheme_module_code_cache, (const char *)obj);
|
||||
if (obj) {
|
||||
/* Synthesize a wrapper to pass through `eval': */
|
||||
Scheme_Compilation_Top *top;
|
||||
|
||||
obj = scheme_ephemeron_value(obj);
|
||||
|
||||
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
|
||||
top->so.type = scheme_compilation_top_type;
|
||||
top->code = obj;
|
||||
top->prefix = NULL; /* indicates a wrapper */
|
||||
|
||||
obj = (Scheme_Object *)top;
|
||||
|
||||
return _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
|
||||
1, &obj);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, 0, -1, NULL,
|
||||
NULL, NULL, lhd->delay_load_info))
|
||||
&& !SCHEME_EOFP(obj)) {
|
||||
|
|
|
|||
|
|
@ -3098,6 +3098,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
|
|||
print_one_byte(pp, strlen(MZSCHEME_VERSION));
|
||||
print_this_string(pp, MZSCHEME_VERSION, 0, -1);
|
||||
|
||||
/* Leave space for a module hash code */
|
||||
print_this_string(pp, "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 0, 20);
|
||||
|
||||
if (mt->st_refs->count != mt->sorted_keys_count)
|
||||
scheme_signal_error("shared key count somehow changed");
|
||||
|
||||
|
|
|
|||
|
|
@ -5394,6 +5394,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
|
|||
int perma_cache = use_perma_cache;
|
||||
Scheme_Object *dir;
|
||||
Scheme_Config *config;
|
||||
char hash_code[20];
|
||||
|
||||
/* Allow delays? */
|
||||
if (params->delay_load_info) {
|
||||
|
|
@ -5422,6 +5423,10 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
|
|||
}
|
||||
offset += size + 1;
|
||||
|
||||
/* Module hash code */
|
||||
got = scheme_get_bytes(port, 20, hash_code, 0);
|
||||
offset += 20;
|
||||
|
||||
symtabsize = read_simple_number_from_port(port);
|
||||
offset += 4;
|
||||
|
||||
|
|
@ -5570,6 +5575,35 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
|
|||
top->prefix->num_lifts,
|
||||
0);
|
||||
/* If no exception, the resulting code is ok. */
|
||||
|
||||
/* Install module hash code, if any. This code is used to register
|
||||
the module in scheme_module_execute(), and it's used to
|
||||
find a registered module in the default load handler. */
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < 20; i++) {
|
||||
if (hash_code[i]) break;
|
||||
}
|
||||
|
||||
if (i < 20) {
|
||||
Scheme_Module *m;
|
||||
m = scheme_extract_compiled_module(result);
|
||||
if (m) {
|
||||
Scheme_Object *hc;
|
||||
hc = scheme_make_sized_byte_string(hash_code, 20, 1);
|
||||
|
||||
/* CERT-INSP-CACHE: Certificates hold an inspector, which
|
||||
means that the current inspector affects the way that bytecode
|
||||
is read. For now, only share compiled modules when the
|
||||
inspector is the same, but maybe certificates can be
|
||||
fixed and this hack son't be necessary one day. Grep for
|
||||
CERT-INSP-CACHE elsewhere for other places to change. */
|
||||
hc = scheme_make_pair(hc, insp);
|
||||
|
||||
m->code_key = hc;
|
||||
}
|
||||
}
|
||||
}
|
||||
} else
|
||||
scheme_ill_formed_code(rp);
|
||||
|
||||
|
|
|
|||
|
|
@ -946,8 +946,10 @@ void scheme_list_module_rename(Scheme_Object *src, Scheme_Hash_Table *ht, Scheme
|
|||
|
||||
Scheme_Object *scheme_rename_to_stx(Scheme_Object *rn);
|
||||
Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx);
|
||||
Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, Scheme_Object *old_midx, Scheme_Object *new_midx);
|
||||
Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *mrns, Scheme_Object *old_midx, Scheme_Object *new_midx);
|
||||
Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, Scheme_Object *old_midx, Scheme_Object *new_midx,
|
||||
Scheme_Object *new_insp);
|
||||
Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *mrns, Scheme_Object *old_midx, Scheme_Object *new_midx,
|
||||
Scheme_Object *new_insp);
|
||||
Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn);
|
||||
|
||||
Scheme_Object *scheme_stx_content(Scheme_Object *o);
|
||||
|
|
@ -1075,7 +1077,7 @@ typedef struct {
|
|||
Scheme_Object so;
|
||||
mzshort max_let_depth;
|
||||
Scheme_Object *code;
|
||||
struct Resolve_Prefix *prefix;
|
||||
struct Resolve_Prefix *prefix; /* NULL => a wrapper for a JITted module in `code' */
|
||||
} Scheme_Compilation_Top;
|
||||
|
||||
/* A `let', `let*', or `letrec' form is compiled to the intermediate
|
||||
|
|
@ -2970,6 +2972,8 @@ typedef struct Scheme_Module
|
|||
{
|
||||
Scheme_Object so; /* scheme_module_type */
|
||||
|
||||
Scheme_Object *code_key;
|
||||
|
||||
Scheme_Object *modname;
|
||||
Scheme_Object *modsrc;
|
||||
|
||||
|
|
@ -3112,6 +3116,8 @@ int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym
|
|||
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);
|
||||
Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase);
|
||||
|
||||
Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv);
|
||||
|
||||
Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree);
|
||||
int scheme_is_module_env(Scheme_Comp_Env *env);
|
||||
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.1.1.1"
|
||||
#define MZSCHEME_VERSION "5.1.1.2"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 1
|
||||
#define MZSCHEME_VERSION_Z 1
|
||||
#define MZSCHEME_VERSION_W 1
|
||||
#define MZSCHEME_VERSION_W 2
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -140,7 +140,8 @@ typedef struct Module_Renames {
|
|||
(cons modidx nominal_modidx) OR
|
||||
(list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR
|
||||
(list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR
|
||||
(cons insp localname)
|
||||
(cons insp localname) OR
|
||||
(cons (cons insp insp) localname)
|
||||
nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase)
|
||||
import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */
|
||||
Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
|
||||
|
|
@ -1482,7 +1483,8 @@ void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info)
|
|||
|
||||
static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
|
||||
Scheme_Object *old_midx, Scheme_Object *new_midx,
|
||||
int do_pes, int do_unm)
|
||||
int do_pes, int do_unm,
|
||||
Scheme_Object *new_insp)
|
||||
{
|
||||
Scheme_Hash_Table *ht, *hts, *drop_ht;
|
||||
Scheme_Object *v;
|
||||
|
|
@ -1551,6 +1553,7 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
|
|||
|
||||
if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) {
|
||||
insp = SCHEME_CAR(v);
|
||||
if (new_insp) insp = new_insp;
|
||||
v = SCHEME_CDR(v);
|
||||
} else
|
||||
insp = NULL;
|
||||
|
|
@ -1613,7 +1616,7 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
|
|||
|
||||
void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int do_unm)
|
||||
{
|
||||
do_append_module_rename(src, dest, NULL, NULL, 1, do_unm);
|
||||
do_append_module_rename(src, dest, NULL, NULL, 1, do_unm, NULL);
|
||||
}
|
||||
|
||||
void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env)
|
||||
|
|
@ -1742,7 +1745,8 @@ Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx)
|
|||
}
|
||||
|
||||
Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn,
|
||||
Scheme_Object *old_midx, Scheme_Object *new_midx)
|
||||
Scheme_Object *old_midx, Scheme_Object *new_midx,
|
||||
Scheme_Object *new_insp)
|
||||
{
|
||||
Scheme_Object *nmrn, *a, *l, *nl, *first, *last;
|
||||
|
||||
|
|
@ -1751,7 +1755,7 @@ Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn,
|
|||
NULL);
|
||||
|
||||
/* use "append" to copy most info: */
|
||||
do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0);
|
||||
do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0, new_insp);
|
||||
|
||||
/* Manually copy unmarshal_infos, where we have to shift anyway: */
|
||||
|
||||
|
|
@ -1797,7 +1801,8 @@ Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn,
|
|||
}
|
||||
|
||||
Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns,
|
||||
Scheme_Object *old_midx, Scheme_Object *new_midx)
|
||||
Scheme_Object *old_midx, Scheme_Object *new_midx,
|
||||
Scheme_Object *new_insp)
|
||||
{
|
||||
Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns;
|
||||
Scheme_Object *mrn, *mrns2;
|
||||
|
|
@ -1805,17 +1810,17 @@ Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns,
|
|||
|
||||
mrns2 = scheme_make_module_rename_set(mrns->kind, NULL);
|
||||
if (mrns->rt) {
|
||||
mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx);
|
||||
mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp);
|
||||
scheme_add_module_rename_to_set(mrns2, mrn);
|
||||
}
|
||||
if (mrns->et) {
|
||||
mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx);
|
||||
mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx, new_insp);
|
||||
scheme_add_module_rename_to_set(mrns2, mrn);
|
||||
}
|
||||
if (mrns->other_phases) {
|
||||
for (i = 0; i < mrns->other_phases->size; i++) {
|
||||
if (mrns->other_phases->vals[i]) {
|
||||
mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx);
|
||||
mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx, new_insp);
|
||||
scheme_add_module_rename_to_set(mrns2, mrn);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6963,6 +6963,11 @@ static Scheme_Object *write_top(Scheme_Object *obj)
|
|||
{
|
||||
Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj;
|
||||
|
||||
if (!top->prefix)
|
||||
scheme_raise_exn(MZEXN_FAIL,
|
||||
"write: cannot marshal shared compiled code: %V",
|
||||
obj);
|
||||
|
||||
return cons(scheme_make_integer(top->max_let_depth),
|
||||
cons((Scheme_Object *)top->prefix,
|
||||
scheme_protect_quote(top->code)));
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user