From f0376299a8b37a6d33d384866b6e2f22728c6ed9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Dec 2018 05:45:08 -0700 Subject: [PATCH 1/3] experiment with a different fasl format original commit: e2c50bd7ae5b323fcc796eb78d892f4a2c487dfc --- c/Mf-base | 2 +- c/externs.h | 10 +- c/fasl.c | 110 ++-- c/globals.h | 5 + c/intern.c | 48 +- c/prim5.c | 2 + c/vfasl.c | 1406 +++++++++++++++++++++++++++++++++++++++++++++++++ s/7.ss | 7 +- s/back.ss | 5 + s/cmacros.ss | 4 +- s/compile.ss | 58 +- s/primdata.ss | 2 + 12 files changed, 1606 insertions(+), 53 deletions(-) create mode 100644 c/vfasl.c diff --git a/c/Mf-base b/c/Mf-base index cc23047ba7..6042207932 100644 --- a/c/Mf-base +++ b/c/Mf-base @@ -23,7 +23,7 @@ Main=../boot/$m/main.$o Scheme=../bin/$m/scheme kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-ocd.c gc-oce.c\ - number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\ + number.c schsig.c io.c new-io.c print.c fasl.c vfasl.c stats.c foreign.c prim.c prim5.c flushcache.c\ schlib.c thread.c expeditor.c scheme.c kernelobj=${kernelsrc:%.c=%.$o} ${mdobj} diff --git a/c/externs.h b/c/externs.h index c1a2aa01fd..845a157d1d 100644 --- a/c/externs.h +++ b/c/externs.h @@ -93,7 +93,7 @@ extern ptr S_relocation_table PROTO((iptr n)); /* fasl.c */ extern void S_fasl_init PROTO((void)); ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, ptr path)); -ptr S_bv_fasl_read PROTO((ptr bv, ptr path)); +ptr S_bv_fasl_read PROTO((ptr bv, int ty, ptr path)); /* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */ ptr S_boot_read PROTO((gzFile file, const char *path)); char *S_format_scheme_version PROTO((uptr n)); @@ -101,6 +101,13 @@ char *S_lookup_machine_type PROTO((uptr n)); extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n, ptr x, iptr o)); extern ptr S_get_code_obj PROTO((IFASLCODE typ, ptr p, iptr n, iptr o)); +extern int S_fasl_stream_read PROTO((void *stream, octet *dest, iptr n)); +extern int S_fasl_intern_rtd(ptr *x); + +/* vfasl.c */ +extern ptr S_to_vfasl PROTO((ptr v)); +extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr len)); +extern ptr S_vfasl_to PROTO((ptr v)); /* flushcache.c */ extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes)); @@ -152,6 +159,7 @@ extern void S_resize_oblist PROTO((void)); extern ptr S_intern PROTO((const unsigned char *s)); extern ptr S_intern_sc PROTO((const string_char *s, iptr n, ptr name_str)); extern ptr S_intern3 PROTO((const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str)); +extern ptr S_intern4 PROTO((ptr sym)); extern void S_intern_gensym PROTO((ptr g)); extern void S_retrofit_nonprocedure_code PROTO((void)); diff --git a/c/fasl.c b/c/fasl.c index c659c69ec2..00858432b7 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -211,7 +211,7 @@ static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n)); static octet uf_bytein PROTO((unbufFaslFile uf)); static uptr uf_uptrin PROTO((unbufFaslFile uf)); static ptr fasl_entry PROTO((ptr tc, unbufFaslFile uf)); -static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, unbufFaslFile uf)); +static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, unbufFaslFile uf)); static void fillFaslFile PROTO((faslFile f)); static void bytesin PROTO((octet *s, iptr n, faslFile f)); static void toolarge PROTO((ptr path)); @@ -237,7 +237,7 @@ static void ppc32_set_jump PROTO((void *address, uptr item, IBOOL callp)); static uptr ppc32_get_jump PROTO((void *address)); #endif /* PPC32 */ #ifdef X86_64 -static void x86_64_set_jump PROTO((void *address, uptr item, IBOOL callp)); +static void x86_64_set_jump PROTO((void *address, uptr item, IBOOL callp, IBOOL force_abs)); static uptr x86_64_get_jump PROTO((void *address)); #endif /* X86_64 */ #ifdef SPARC64 @@ -304,7 +304,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) { return x; } -ptr S_bv_fasl_read(ptr bv, ptr path) { +ptr S_bv_fasl_read(ptr bv, int ty, ptr path) { ptr tc = get_thread_context(); ptr x; struct unbufFaslFileObj uffo; @@ -312,7 +312,7 @@ ptr S_bv_fasl_read(ptr bv, ptr path) { tc_mutex_acquire() uffo.path = path; uffo.type = UFFO_TYPE_BV; - x = bv_fasl_entry(tc, bv, &uffo); + x = bv_fasl_entry(tc, bv, ty, &uffo); tc_mutex_release() return x; } @@ -374,6 +374,11 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) { return 0; } +int S_fasl_stream_read(void *stream, octet *dest, iptr n) +{ + return uf_read((unbufFaslFile)stream, dest, n); +} + static octet uf_bytein(unbufFaslFile uf) { octet buf[1]; if (uf_read(uf, buf, 1) < 0) @@ -451,31 +456,41 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) { ty = uf_bytein(uf); } - if (ty != fasl_type_fasl_size) + if ((ty != fasl_type_fasl_size) + && (ty != fasl_type_vfasl_size)) S_error1("", "malformed fasl-object header found in ~a", uf->path); ffo.size = uf_uptrin(uf); - ffo.buf = buf; - ffo.next = ffo.end = ffo.buf; - ffo.uf = uf; - - faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + if (ty == fasl_type_vfasl_size) { + x = S_vfasl((ptr)0, uf, ffo.size); + } else { + ffo.buf = buf; + ffo.next = ffo.end = ffo.buf; + ffo.uf = uf; + + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + } S_flush_instruction_cache(tc); return x; } -static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) { +static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, unbufFaslFile uf) { ptr x; ptr strbuf = S_G.null_string; struct faslFileObj ffo; ffo.size = Sbytevector_length(bv); - ffo.next = ffo.buf = &BVIT(bv, 0); - ffo.end = &BVIT(bv, ffo.size); - ffo.uf = uf; - faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + if (ty == fasl_type_vfasl_size) { + x = S_vfasl(bv, (ptr)0, ffo.size); + } else { + ffo.next = ffo.buf = &BVIT(bv, 0); + ffo.end = &BVIT(bv, ffo.size); + ffo.uf = uf; + + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + } S_flush_instruction_cache(tc); return x; @@ -694,27 +709,10 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { *x = rtd; return; } case fasl_type_rtd: { - ptr rtd, rtd_uid, plist, ls; - fasl_record(tc, x, t, pstrbuf, f); - rtd = *x; - rtd_uid = RECORDDESCUID(rtd); - - /* see if uid's property list already registers an rtd */ - plist = SYMSPLIST(rtd_uid); - for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) { - if (Scar(ls) == S_G.rtd_key) { - ptr old_rtd = Scar(Scdr(ls)); - /* if so, check new rtd against old rtd and return old rtd */ - if (!rtd_equiv(rtd, old_rtd)) - S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(rtd), f->uf->path); - *x = old_rtd; - return; - } + if (S_fasl_intern_rtd(x) < 0) { + S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(*x), f->uf->path); } - - /* if not, register it */ - SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist))); return; } case fasl_type_record: { @@ -1106,6 +1104,33 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { } } +/* Result: 0 => interned; 1 => replaced; -1 => inconsistent */ +int S_fasl_intern_rtd(ptr *x) +{ + ptr rtd, rtd_uid, plist, ls; + + rtd = *x; + rtd_uid = RECORDDESCUID(rtd); + + /* see if uid's property list already registers an rtd */ + plist = SYMSPLIST(rtd_uid); + for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) { + if (Scar(ls) == S_G.rtd_key) { + ptr old_rtd = Scar(Scdr(ls)); + /* if so, check new rtd against old rtd and return old rtd */ + if (!rtd_equiv(rtd, old_rtd)) + return -1; + else + *x = old_rtd; + return 1; + } + } + + /* if not, register it */ + SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist))); + return 0; +} + /* limited version for checking rtd fields */ static IBOOL equalp(x, y) ptr x, y; { if (x == y) return 1; @@ -1121,7 +1146,10 @@ static IBOOL equalp(x, y) ptr x, y; { } static IBOOL rtd_equiv(x, y) ptr x, y; { - return RECORDINSTTYPE(x) == RECORDINSTTYPE(y) && + return ((RECORDINSTTYPE(x) == RECORDINSTTYPE(y)) + /* recognize `base-rtd` shape: */ + || ((RECORDINSTTYPE(x) == x) + && (RECORDINSTTYPE(y) == y))) && RECORDDESCPARENT(x) == RECORDDESCPARENT(y) && equalp(RECORDDESCPM(x), RECORDDESCPM(y)) && equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) && @@ -1164,7 +1192,7 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p address = (void *)((uptr)p + n); item = (uptr)x + o; - switch (typ) { + switch (typ & ~reloc_force_abs) { case reloc_abs: *(uptr *)address = item; break; @@ -1198,10 +1226,10 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p #endif /* I386 */ #ifdef X86_64 case reloc_x86_64_jump: - x86_64_set_jump(address, item, 0); + x86_64_set_jump(address, item, 0, typ & reloc_force_abs); break; case reloc_x86_64_call: - x86_64_set_jump(address, item, 1); + x86_64_set_jump(address, item, 1, typ & reloc_force_abs); break; #endif /* X86_64 */ #ifdef SPARC64 @@ -1241,7 +1269,7 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; { void *address; uptr item; address = (void *)((uptr)p + n); - switch (typ) { + switch (typ & ~reloc_force_abs) { case reloc_abs: item = *(uptr *)address; break; @@ -1419,9 +1447,9 @@ static uptr ppc32_get_jump(void *address) { #endif /* PPC32 */ #ifdef X86_64 -static void x86_64_set_jump(void *address, uptr item, IBOOL callp) { +static void x86_64_set_jump(void *address, uptr item, IBOOL callp, IBOOL force_abs) { I64 disp = (I64)item - ((I64)address + 5); /* 5 = size of call instruction */ - if ((I32)disp == disp) { + if ((I32)disp == disp && !force_abs) { *(octet *)address = callp ? 0xE8 : 0xE9; /* call or jmp disp32 opcode */ *(I32 *)((uptr)address + 1) = (I32)disp; *((octet *)address + 5) = 0x90; /* nop */ diff --git a/c/globals.h b/c/globals.h index 86f74d89be..b3bf0b53a5 100644 --- a/c/globals.h +++ b/c/globals.h @@ -151,4 +151,9 @@ EXTERN struct { ptr eqvp; ptr equalp; ptr symboleqp; + + /* vfasl.c */ + struct vfasl_hash_table *c_entries; + struct vfasl_hash_table *library_entries; + struct vfasl_hash_table *library_entry_codes; } S_G; diff --git a/c/intern.c b/c/intern.c index acfee35393..ab530f887c 100644 --- a/c/intern.c +++ b/c/intern.c @@ -361,7 +361,7 @@ void S_intern_gensym(sym) ptr sym; { tc_mutex_release() S_error1("intern-gensym", "unique name ~s already interned", uname_str); } - if (Sstring_ref(str, i) != uname[i]) break; + if (STRIT(str, i) != uname[i]) break; } } } @@ -374,12 +374,58 @@ void S_intern_gensym(sym) ptr sym; { tc_mutex_release() } +/* must hold mutex */ +ptr S_intern4(sym) ptr sym; { + ptr name = SYMNAME(sym); + + if (name == Sfalse) { + /* gensym whose name wasn't generated, so far */ + return sym; + } else { + ptr uname_str = (Sstringp(name) ? name : Scar(name)); + if (uname_str == Sfalse) { + /* gensym that wasn't interned, so far */ + return sym; + } else { + const string_char *uname = &STRIT(uname_str, 0); + iptr ulen = Sstring_length(uname_str); + iptr hc = UNFIX(SYMHASH(sym)); + iptr idx = hc % S_G.oblist_length; + bucket *b; + + b = S_G.oblist[idx]; + while (b != NULL) { + ptr x = b->sym; + ptr x_name = SYMNAME(x); + if (Sstringp(name) == Sstringp(x_name)) { + ptr str = (Sstringp(x_name) ? x_name : Scar(x_name)); + if (Sstring_length(str) == ulen) { + iptr i; + for (i = 0; ; i += 1) { + if (i == ulen) { + return x; + } + if (STRIT(str, i) != uname[i]) break; + } + } + } + b = b->next; + } + + oblist_insert(sym, idx, GENERATION(sym)); + + return sym; + } + } +} + /* retrofit existing symbols once nonprocedure_code is available */ void S_retrofit_nonprocedure_code() { ptr npc, sym, val; bucket_list *bl; npc = S_G.nonprocedure_code; + /* FIXME */ /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */ for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) { sym = bl->car->sym; diff --git a/c/prim5.c b/c/prim5.c index bb40e6277b..6a9cb94385 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -1546,6 +1546,8 @@ void S_prim5_init() { Sforeign_symbol("(cs)getpid", (void *)s_getpid); Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read); Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read); + Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl); + Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to); Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float); Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd); diff --git a/c/vfasl.c b/c/vfasl.c new file mode 100644 index 0000000000..145c225d9d --- /dev/null +++ b/c/vfasl.c @@ -0,0 +1,1406 @@ +/* vfasl.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +typedef uptr vfoff; + +typedef struct vfasl_header { + vfoff data_size; + vfoff table_size; + + vfoff result_offset; + + /* symbol starting offset is 0 */ +# define sym_end_offset rtd_offset + vfoff rtd_offset; +# define rtd_end_offset closure_offset + vfoff closure_offset; +# define closure_end_offset code_offset + vfoff code_offset; +# define code_end_offset other_offset + vfoff other_offset; + + vfoff symref_count; + vfoff rtdref_count; + vfoff singletonref_count; +} vfasl_header; + +/* vfasl format, where the fixed-size header determines the rest of the + size: + + [vfasl_header] + _ +d / [symbol] ... +a / [rtd] ... +t | [closure] ... +a \ [code] ... + \_ [other] ... + +t / [vfoff: symbol reference offset] ... +a / [vfoff: rtd reference offset] ... +b | [vfoff: singleton reference offset] ... +l \ +e \_ [bitmap of pointer offsets] + +*/ + +/* Many chunks per vspace on first pass, one per vspace on second + pass: */ +typedef struct vfasl_chunk { + ptr bytes; + uptr length; + uptr used; + uptr swept; + struct vfasl_chunk *next; +} vfasl_chunk; + +/* One per vspace: */ +struct vfasl_count_and_chunk { + uptr total_bytes; + vfasl_chunk *first; +}; + +enum { + /* The order of these spaces matters: */ + vspace_symbol, + vspace_rtd, + vspace_closure, + vspace_code, + /* The rest of the spaces are "other" */ + vspace_array, + vspace_typed, + vspace_reloc, + vspace_data, /* at end, so pointer bitmap ends with zeros */ + vspaces_count +}; + +typedef struct vfasl_info { + ptr base_addr; /* address to make relocations relative to */ + + uptr sym_count; + + vfoff symref_count; + vfoff *symrefs; + + ptr base_rtd; /* track replacement base_rtd to recognize other rtds */ + + vfoff rtdref_count; + vfoff *rtdrefs; + + vfoff singletonref_count; + vfoff *singletonrefs; + + struct vfasl_count_and_chunk spaces[vspaces_count]; + + octet *ptr_bitmap; + + struct vfasl_hash_table *graph; +} vfasl_info; + +#define ptr_add(p, n) ((ptr)((uptr)(p) + (n))) +#define ptr_subtract(p, n) ((ptr)((uptr)(p) - (n))) +#define ptr_diff(p, q) ((uptr)(p) - (uptr)(q)) + +#define byte_bits 8 +#define log2_byte_bits 3 + +static ptr vfasl_copy_all(vfasl_info *vfi, ptr v); + +static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si); +static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n); +static uptr sweep_code_object(vfasl_info *vfi, ptr co); +static uptr sweep_record(vfasl_info *vfi, ptr co); +static uptr sweep(vfasl_info *vfi, ptr p); + +static void relink_code(ptr co, ptr sym_base, ptr dest_base); + +static void vfasl_relocate(vfasl_info *vfi, ptr *ppp); +static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp); +static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n); +static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp); +static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p); +static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which); +static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p); +static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p); + +static void fasl_init_entry_tables(); + +static int detect_singleton(ptr p); +static ptr lookup_singleton(int which); + +typedef struct vfasl_hash_table vfasl_hash_table; +static vfasl_hash_table *make_vfasl_hash_table(); +static void free_vfasl_hash_table(vfasl_hash_table *ht); +static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value); +static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key); + +static void sort_offsets(vfoff *p, vfoff len); + +#define vfasl_fail(vfi, what) S_error("vfasl", "cannot encode " what) + +#define print_stats(args) /* printf args */ + +ptr S_vfasl(ptr bv, void *stream, iptr input_len) +{ + ptr tc = get_thread_context(); + vfasl_header header; + ptr data, table; + vfoff *symrefs, *rtdrefs, *singletonrefs; + octet *bm, *bm_end; + iptr used_len; + + used_len = sizeof(header); + if (used_len > input_len) + S_error("fasl-read", "input length mismatch"); + + if (bv) + memcpy(&header, &BVIT(bv, 0), sizeof(vfasl_header)); + else { + if (S_fasl_stream_read(stream, (octet*)&header, sizeof(header)) < 0) + S_error("fasl-read", "input truncated"); + } + + used_len += header.data_size + header.table_size; + if (used_len > input_len) + S_error("fasl-read", "input length mismatch"); + + if (bv) { + ptr base_addr = &BVIT(bv, sizeof(vfasl_header)); + thread_find_room(tc, typemod, header.data_size, data); + memcpy(data, base_addr, header.data_size); + table = ptr_add(base_addr, header.data_size); + } else { + thread_find_room(tc, typemod, header.data_size, data); + if (S_fasl_stream_read(stream, data, header.data_size) < 0) + S_error("fasl-read", "input truncated"); + + thread_find_room(tc, typemod, ptr_align(header.table_size), table); + if (S_fasl_stream_read(stream, table, header.table_size) < 0) + S_error("fasl-read", "input truncated"); + } + + symrefs = table; + rtdrefs = ptr_add(symrefs, header.symref_count * sizeof(vfoff)); + singletonrefs = ptr_add(rtdrefs, header.rtdref_count * sizeof(vfoff)); + bm = ptr_add(singletonrefs, header.singletonref_count * sizeof(vfoff)); + bm_end = ptr_add(table, header.table_size); + + if (0) + printf("\n" + "hdr %ld\n" + "syms %ld\n" + "rtds %ld\n" + "clos %ld\n" + "code %ld\n" + "othr %ld\n" + "tabl %ld symref %ld rtdref %ld sglref %ld\n", + sizeof(vfasl_header), + header.sym_end_offset, + header.rtd_end_offset - header.rtd_offset, + header.closure_end_offset - header.closure_offset, + header.code_end_offset - header.code_offset, + header.data_size - header.other_offset, + header.table_size, + header.symref_count * sizeof(vfoff), + header.rtdref_count * sizeof(vfoff), + header.singletonref_count * sizeof(vfoff)); + + /* Fix up pointers. The content `data` initially has all pointers + relative to the start of the data, so add the `data` address + to all pointers. */ + { + ptr *p = data; + while (bm != bm_end) { + octet m; + m = *bm; +# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p)[i] += (uptr)data + MAYBE_FIXUP(0); + MAYBE_FIXUP(1); + MAYBE_FIXUP(2); + MAYBE_FIXUP(3); + MAYBE_FIXUP(4); + MAYBE_FIXUP(5); + MAYBE_FIXUP(6); + MAYBE_FIXUP(7); +# undef MAYBE_FIXUP + p += byte_bits; + bm++; + } + } + + /* Replace references to singletons like "" and #vu8(). + This needs to be before interning symbols, in case "" + is a symbol name. */ + { + vfoff i; + for (i = 0; i < header.singletonref_count; i++) { + ptr *ref; + ref = ptr_add(data, singletonrefs[i]); + *ref = lookup_singleton(UNFIX(*ref)); + } + } + + /* Intern symbols */ + { + ptr sym = TYPE(data, type_symbol); + ptr end_syms = TYPE(ptr_add(data, header.sym_end_offset), type_symbol); + + if (sym != end_syms) { + tc_mutex_acquire() + + while (sym < end_syms) { + ptr isym; + + INITSYMVAL(sym) = sunbound; + INITSYMCODE(sym,S_G.nonprocedure_code); + + isym = S_intern4(sym); + if (isym != sym) { + /* The symbol was already interned, so point to the existing one */ + INITSYMVAL(sym) = isym; + } + + sym = ptr_add(sym, size_symbol); + } + + tc_mutex_release() + } + } + + /* Replace symbol references with interned references */ + { + ptr syms = data; + vfoff i; + for (i = 0; i < header.symref_count; i++) { + uptr sym_pos; + ptr p2, sym, val; + p2 = ptr_add(data, symrefs[i]); + sym_pos = UNFIX(*(ptr **)p2); + sym = TYPE(ptr_add(syms, sym_pos * size_symbol), type_symbol); + if ((val = SYMVAL(sym)) != sunbound) + sym = val; + *(ptr **)p2 = sym; + } + } + + /* Intern rtds */ + if (header.rtd_offset < header.rtd_end_offset) { + ptr rtd = TYPE(ptr_add(data, header.rtd_offset), type_typed_object); + ptr rtd_end = TYPE(ptr_add(data, header.rtd_end_offset), type_typed_object); + + /* first one corresponds to base_rtd */ + RECORDINSTTYPE(rtd) = S_G.base_rtd; + RECORDDESCUID(rtd) = S_G.base_rtd; + + while (1) { + ptr new_rtd, parent_rtd; + + rtd = ptr_add(rtd, size_record_inst(UNFIX(RECORDDESCSIZE(S_G.base_rtd)))); + if (rtd == rtd_end) + break; + + RECORDINSTTYPE(rtd) = S_G.base_rtd; + + /* fixup type and parent before continuing, relying on parents being earlier in `rtd`s */ + parent_rtd = RECORDDESCPARENT(rtd); + if (parent_rtd != Sfalse) { + ptr parent_uid = RECORDDESCUID(parent_rtd); + if (!Ssymbolp(parent_uid)) + RECORDDESCPARENT(rtd) = parent_uid; + } + + new_rtd = rtd; + if (S_fasl_intern_rtd(&new_rtd)) { + if (new_rtd == rtd) { + S_error1("vfasl", "incompatible record type ~s", RECORDDESCNAME(rtd)); + } else { + /* Use the UID field to record already-interned replacement: */ + RECORDDESCUID(rtd) = new_rtd; + } + } + } + } + + /* Replace rtd references to interned references */ + { + vfoff i; + for (i = 0; i < header.rtdref_count; i++) { + ptr *ref, rtd, uid; + ref = ptr_add(data, rtdrefs[i]); + rtd = *ref; + uid = RECORDDESCUID(rtd); + if (!Ssymbolp(uid)) { + /* uid is replacement interned rtd */ + *ref = uid; + } + } + } + + /* Fix code pointers on closures */ + { + ptr cl = TYPE(ptr_add(data, header.closure_offset), type_closure); + ptr end_closures = TYPE(ptr_add(data, header.closure_end_offset), type_closure); + + while (cl != end_closures) { + ptr code = CLOSCODE(cl); + code = ptr_add(code, (uptr)data); + SETCLOSCODE(cl,code); + cl = ptr_add(cl, size_closure(CLOSLEN(cl))); + } + } + + /* Fix code via relocations */ + { + + ptr sym_base = data; + ptr code = TYPE(ptr_add(data, header.code_offset), type_typed_object); + ptr code_end = TYPE(ptr_add(data, header.code_end_offset), type_typed_object); + while (code != code_end) { + relink_code(code, sym_base, data); + code = ptr_add(code, size_code(CODELEN(code))); + } + } + + /* Turn result offset into a value, unboxing if it's a box (which + supports a symbol result, for example). */ + { + ptr v; + ITYPE t; + v = ptr_add(data, header.result_offset); + if (((t = TYPEBITS(v)) == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_box, type_box)) + v = Sunbox(v); + + return v; + } +} + +ptr S_vfasl_to(ptr bv) +{ + return S_vfasl(bv, (ptr)0, Sbytevector_length(bv)); +} + +ptr S_to_vfasl(ptr v) +{ + vfasl_info *vfi; + vfasl_header header; + ITYPE t; + int s; + uptr size, data_size, bitmap_size, pre_bitmap_size; + ptr bv, p; + + fasl_init_entry_tables(); + + /* Box certain kinds of values where the vfasl process needs a + pointer into data */ + if (IMMEDIATE(v) + || detect_singleton(v) + || ((t = TYPEBITS(v)) == type_symbol) + || ((t == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_record, type_record) + && (TYPEFIELD(v) == v)) + || ((t == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_box, type_box))) { + v = Sbox(v); + } + + vfi = malloc(sizeof(vfasl_info)); + + vfi->base_addr = (ptr)0; + vfi->sym_count = 0; + vfi->symref_count = 0; + vfi->symrefs = (ptr)0; + vfi->base_rtd = S_G.base_rtd; + vfi->rtdref_count = 0; + vfi->rtdrefs = (ptr)0; + vfi->singletonref_count = 0; + vfi->singletonrefs = (ptr)0; + vfi->graph = make_vfasl_hash_table(); + vfi->ptr_bitmap = (ptr)0; + + /* First pass: determine sizes */ + + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = (ptr)0; + c->length = 0; + c->used = 0; + c->swept = 0; + c->next = (ptr)0; + + vfi->spaces[s].first = c; + vfi->spaces[s].total_bytes = 0; + } + + (void)vfasl_copy_all(vfi, v); + + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c, *next; + for (c = vfi->spaces[s].first; c; c = next) { + next = c->next; + free(c->bytes); + free(c); + } + } + + free_vfasl_hash_table(vfi->graph); + + /* Setup for second pass: allocate to contiguous bytes */ + + size = sizeof(vfasl_header); + + data_size = 0; + for (s = 0; s < vspaces_count; s++) { + data_size += vfi->spaces[s].total_bytes; + } + header.data_size = data_size; + size += data_size; + + size += vfi->symref_count * sizeof(vfoff); + size += vfi->rtdref_count * sizeof(vfoff); + size += vfi->singletonref_count * sizeof(vfoff); + + header.table_size = size - data_size - sizeof(header); /* doesn't yet include the bitmap */ + + header.rtd_offset = vfi->spaces[vspace_symbol].total_bytes; + header.closure_offset = header.rtd_offset + vfi->spaces[vspace_rtd].total_bytes; + header.code_offset = header.closure_offset + vfi->spaces[vspace_closure].total_bytes; + header.other_offset = header.code_offset + vfi->spaces[vspace_code].total_bytes; + + header.symref_count = vfi->symref_count; + header.rtdref_count = vfi->rtdref_count; + header.singletonref_count = vfi->singletonref_count; + + pre_bitmap_size = size; + + bitmap_size = (data_size + (byte_bits-1)) >> log2_byte_bits; + + size += bitmap_size; + + bv = S_bytevector(size); + memset(&BVIT(bv, 0), 0, size); + + p = &BVIT(bv, 0); + + /* Skip header for now */ + p = ptr_add(p, sizeof(vfasl_header)); + + vfi->base_addr = p; + + /* Set pointers to vspaces based on sizes frm first pass */ + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = p; + c->length = vfi->spaces[s].total_bytes; + c->used = 0; + c->swept = 0; + c->next = (ptr)0; + vfi->spaces[s].first = c; + + p = ptr_add(p, vfi->spaces[s].total_bytes); + vfi->spaces[s].total_bytes = 0; + } + + vfi->symrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->symref_count); + + vfi->base_rtd = S_G.base_rtd; + vfi->rtdrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->rtdref_count); + + vfi->singletonrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->singletonref_count); + + vfi->sym_count = 0; + vfi->symref_count = 0; + vfi->rtdref_count = 0; + vfi->singletonref_count = 0; + + vfi->graph = make_vfasl_hash_table(); + + vfi->ptr_bitmap = p; + + /* Write data */ + + v = vfasl_copy_all(vfi, v); + + header.result_offset = ptr_diff(v, vfi->base_addr); + + /* Make all pointers relative to the start of the data area */ + { + ptr *p2 = vfi->base_addr; + uptr base_addr = (uptr)vfi->base_addr; + octet *bm = vfi->ptr_bitmap; + octet *bm_end = bm + bitmap_size; + uptr zeros = 0; + for (; bm != bm_end; bm++, p2 += byte_bits) { + octet m = *bm; + if (m == 0) { + zeros++; + } else { +# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p2)[i] -= base_addr; + MAYBE_FIXUP(0); + MAYBE_FIXUP(1); + MAYBE_FIXUP(2); + MAYBE_FIXUP(3); + MAYBE_FIXUP(4); + MAYBE_FIXUP(5); + MAYBE_FIXUP(6); + MAYBE_FIXUP(7); +# undef MAYBE_FIXUP + zeros = 0; + } + } + + /* We can ignore trailing zeros */ + header.table_size += (bitmap_size - zeros); + } + + /* Truncate bytevector to match end of bitmaps */ + { + uptr sz = sizeof(vfasl_header) + header.data_size + header.table_size; + BYTEVECTOR_TYPE(bv) = (sz << bytevector_length_offset) | type_bytevector; + } + + memcpy(&BVIT(bv, 0), &header, sizeof(vfasl_header)); + + sort_offsets(vfi->symrefs, vfi->symref_count); + sort_offsets(vfi->rtdrefs, vfi->rtdref_count); + sort_offsets(vfi->singletonrefs, vfi->singletonref_count); + + for (s = 0; s < vspaces_count; s++) { + free(vfi->spaces[s].first); + } + + free_vfasl_hash_table(vfi->graph); + + free(vfi); + + return bv; +} + +static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { + seginfo *si; + int s; + int changed = 1; + + si = MaybeSegInfo(ptr_get_segment(v)); + + v = copy(vfi, v, si); + + while (changed) { + changed = 0; + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c = vfi->spaces[s].first; + while (c && (c->swept < c->used)) { + ptr pp, pp_end; + + pp = ptr_add(c->bytes, c->swept); + pp_end = ptr_add(c->bytes, c->used); + c->swept = c->used; + + switch(s) { + case vspace_symbol: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_symbol))); + } + break; + case vspace_closure: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_closure))); + } + break; + case vspace_array: + while (pp < pp_end) { + vfasl_relocate(vfi, pp); + pp = ptr_add(pp, sizeof(ptr)); + } + break; + case vspace_rtd: + case vspace_code: + case vspace_typed: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_typed_object))); + } + break; + case vspace_data: + case vspace_reloc: + break; + default: + S_error_abort("vfasl: unrecognized space"); + break; + } + + c = c->next; + changed = 1; + } + } + } + + return v; +} + +static void vfasl_register_pointer(vfasl_info *vfi, ptr *pp) { + if (vfi->ptr_bitmap) { + uptr delta = ptr_diff(pp, vfi->base_addr) >> log2_ptr_bytes; + uptr i = delta >> log2_byte_bits; + uptr bit = (((uptr)1) << (delta & (byte_bits - 1))); + vfi->ptr_bitmap[i] |= bit; + } +} + +static uptr ptr_base_diff(vfasl_info *vfi, ptr p) { + if ((uptr)vfi->base_addr > (uptr)UNTYPE(p, TYPEBITS(p))) + S_error_abort("vfasl: pointer not in region"); + + return ptr_diff(p, vfi->base_addr); +} + +static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p) { + if (vfi->symrefs) + vfi->symrefs[vfi->symref_count] = ptr_base_diff(vfi, pp); + vfi->symref_count++; + *pp = SYMVAL(p); /* replace symbol reference with index of symbol */ +} + +static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp) { + if (vfi->rtdrefs) + vfi->rtdrefs[vfi->rtdref_count] = ptr_base_diff(vfi, pp); + vfi->rtdref_count++; +} + +static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which) { + if (vfi->singletonrefs) + vfi->singletonrefs[vfi->singletonref_count] = ptr_base_diff(vfi, pp); + vfi->singletonref_count++; + *pp = FIX(which); +} + +static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p) { + vfasl_hash_table_set(vfi->graph, pp, p); +} + +static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p) { + return vfasl_hash_table_ref(vfi->graph, p); +} + +static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { + ptr p; + + vfi->spaces[s].total_bytes += n; + + if (vfi->spaces[s].first->used + n > vfi->spaces[s].first->length) { + vfasl_chunk *c; + iptr newlen = n * 2; + if (newlen < 4096) + newlen = 4096; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = malloc(newlen); + c->length = newlen; + c->used = 0; + c->swept = 0; + + c->next = vfi->spaces[s].first; + vfi->spaces[s].first = c; + } + + p = ptr_add(vfi->spaces[s].first->bytes, vfi->spaces[s].first->used); + vfi->spaces[s].first->used += n; + + return TYPE(p, t); +} + +#define FIND_ROOM(vfi, s, t, n, p) p = vfasl_find_room(vfi, s, t, n) + +#define copy_ptrs(ty, p1, p2, n) {\ + ptr *Q1, *Q2, *Q1END;\ + Q1 = (ptr *)UNTYPE((p1),ty);\ + Q2 = (ptr *)UNTYPE((p2),ty);\ + Q1END = (ptr *)((uptr)Q1 + n);\ + while (Q1 != Q1END) *Q1++ = *Q2++;} + +static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { + ptr p, tf; ITYPE t; + + if ((t = TYPEBITS(pp)) == type_typed_object) { + tf = TYPEFIELD(pp); + if (TYPEP(tf, mask_record, type_record)) { + ptr rtd; iptr n; int s; + + rtd = tf; + + if (tf == S_G.base_rtd) { + if ((pp != S_G.base_rtd) && (vfi->base_rtd == S_G.base_rtd)) { + /* make sure base_rtd is first one registered */ + (void)vfasl_relocate_help(vfi, S_G.base_rtd); + } + /* need type and parent before child; FIXME: stack overflow possible */ + if (RECORDDESCPARENT(pp) != Sfalse) { + (void)vfasl_relocate_help(vfi, RECORDDESCPARENT(pp)); + } + + s = vspace_rtd; + } else + s = vspace_typed; + + n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + + FIND_ROOM(vfi, s, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + + if (pp == S_G.base_rtd) + vfi->base_rtd = p; + } else if (TYPEP(tf, mask_vector, type_vector)) { + iptr len, n; + len = Svector_length(pp); + n = size_vector(len); + FIND_ROOM(vfi, vspace_typed, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_string, type_string)) { + iptr n; + n = size_string(Sstring_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { + iptr n; + n = size_fxvector(Sfxvector_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + iptr n; + n = size_bytevector(Sbytevector_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if ((iptr)tf == type_tlc) { + vfasl_fail(vfi, "tlc"); + return (ptr)0; + } else if (TYPEP(tf, mask_box, type_box)) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_box, p); + BOXTYPE(p) = (iptr)tf; + INITBOXREF(p) = Sunbox(pp); + } else if ((iptr)tf == type_ratnum) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_ratnum, p); + RATTYPE(p) = type_ratnum; + RATNUM(p) = RATNUM(pp); + RATDEN(p) = RATDEN(pp); + } else if ((iptr)tf == type_exactnum) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_exactnum, p); + EXACTNUM_TYPE(p) = type_exactnum; + EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); + EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); + } else if ((iptr)tf == type_inexactnum) { + FIND_ROOM(vfi, vspace_data, type_typed_object, size_inexactnum, p); + INEXACTNUM_TYPE(p) = type_inexactnum; + INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); + INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + iptr n; + n = size_bignum(BIGLEN(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_port, type_port)) { + vfasl_fail(vfi, "port"); + return (ptr)0; + } else if (TYPEP(tf, mask_code, type_code)) { + iptr n; + n = size_code(CODELEN(pp)); + FIND_ROOM(vfi, vspace_code, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + if (CODERELOC(pp) == (ptr)0) { + /* We only get here if we're vfasling code that belongs in + the static generation. */ + ptr l; iptr ln; + ln = size_reloc_table(0); + FIND_ROOM(vfi, vspace_reloc, typemod, ln, l); + RELOCSIZE(l) = 0; + RELOCCODE(l) = p; + CODERELOC(p) = l; + vfasl_register_pointer(vfi, &CODERELOC(p)); + } + } else if ((iptr)tf == type_rtd_counts) { + /* prune counts, since GC will recreate as needed */ + return Sfalse; + } else if ((iptr)tf == type_thread) { + vfasl_fail(vfi, "thread"); + return (ptr)0; + } else { + S_error_abort("vfasl: illegal type"); + return (ptr)0 /* not reached */; + } + } else if (t == type_pair) { + if (si->space == space_ephemeron) { + vfasl_fail(vfi, "emphemeron"); + return (ptr)0; + } else if (si->space == space_weakpair) { + vfasl_fail(vfi, "weakpair"); + return (ptr)0; + } else { + FIND_ROOM(vfi, vspace_array, type_pair, size_pair, p); + } + INITCAR(p) = Scar(pp); + INITCDR(p) = Scdr(pp); + } else if (t == type_closure) { + ptr code; + code = CLOSCODE(pp); + if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { + vfasl_fail(vfi, "continuation"); + return (ptr)0; + } else { + iptr len, n; + len = CLOSLEN(pp); + n = size_closure(len); + FIND_ROOM(vfi, vspace_closure, type_closure, n, p); + copy_ptrs(type_closure, p, pp, n); + } + } else if (t == type_symbol) { + iptr pos = vfi->sym_count++; + FIND_ROOM(vfi, vspace_symbol, type_symbol, size_symbol, p); + INITSYMVAL(p) = FIX(pos); /* stores symbol index for now; will get reset on load */ + INITSYMPVAL(p) = Snil; /* will get reset on load */ + INITSYMPLIST(p) = Snil; + INITSYMSPLIST(p) = Snil; + INITSYMNAME(p) = SYMNAME(pp); + INITSYMHASH(p) = SYMHASH(pp); + } else if (t == type_flonum) { + FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p); + FLODAT(p) = FLODAT(pp); + /* note: unlike GC, sharing flonums */ + } else { + S_error_abort("copy(gc): illegal type"); + return (ptr)0 /* not reached */; + } + + vfasl_register_forward(vfi, pp, p); + + return p; +} + +static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp) { + ptr fpp; + seginfo *si; + + si = MaybeSegInfo(ptr_get_segment(pp)); + if (!si) + vfasl_fail(vfi, "unknown"); + + fpp = vfasl_lookup_forward(vfi, pp); + if (fpp) + return fpp; + else + return copy(vfi, pp, si); +} + +/* Use vfasl_relocate only on addresses that are in the vfasl target area */ +static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) { + ptr pp = *ppp, tf; + if (!IMMEDIATE(pp)) { + int which_singleton; + if ((which_singleton = detect_singleton(pp))) + vfasl_register_singleton_reference(vfi, ppp, which_singleton); + else { + pp = vfasl_relocate_help(vfi, pp); + *ppp = pp; + if (!IMMEDIATE(pp)) { + if (TYPEBITS(pp) == type_symbol) + vfasl_register_symbol_reference(vfi, ppp, pp); + else { + if ((TYPEBITS(pp) == type_typed_object) + && (((tf = TYPEFIELD(pp)) == vfi->base_rtd) + || (tf == S_G.base_rtd))) + vfasl_register_rtd_reference(vfi, ppp); + vfasl_register_pointer(vfi, ppp); + } + } + } + } +} + +static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n) { + ptr *end = pp + n; + + while (pp != end) { + vfasl_relocate(vfi, pp); + pp += 1; + } +} + +static uptr sweep(vfasl_info *vfi, ptr p) { + ptr tf; ITYPE t; + + t = TYPEBITS(p); + if (t == type_closure) { + uptr len; + ptr code; + + len = CLOSLEN(p); + sweep_ptrs(vfi, &CLOSIT(p, 0), len); + + /* To code-entry pointer looks like an immediate to + sweep, so relocate the code directly, and also make it + relative to the base address. */ + code = vfasl_relocate_help(vfi, CLOSCODE(p)); + code = (ptr)ptr_diff(code, vfi->base_addr); + SETCLOSCODE(p,code); + + return size_closure(len); + } else if (t == type_symbol) { + vfasl_relocate(vfi, &INITSYMNAME(p)); + /* other parts are replaced on load */ + return size_symbol; + } else if (t == type_flonum) { + /* nothing to sweep */; + return size_flonum; + /* typed objects */ + } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { + uptr len = Svector_length(p); + sweep_ptrs(vfi, &INITVECTIT(p, 0), len); + return size_vector(len); + } else if (TYPEP(tf, mask_record, type_record)) { + return sweep_record(vfi, p); + } else if (TYPEP(tf, mask_box, type_box)) { + vfasl_relocate(vfi, &INITBOXREF(p)); + return size_box; + } else if ((iptr)tf == type_ratnum) { + vfasl_relocate(vfi, &RATNUM(p)); + vfasl_relocate(vfi, &RATDEN(p)); + return size_ratnum; + } else if ((iptr)tf == type_exactnum) { + vfasl_relocate(vfi, &EXACTNUM_REAL_PART(p)); + vfasl_relocate(vfi, &EXACTNUM_IMAG_PART(p)); + return size_exactnum; + } else if (TYPEP(tf, mask_code, type_code)) { + return sweep_code_object(vfi, p); + } else { + S_error_abort("vfasl_sweep: illegal type"); + return 0; + } +} + +static uptr sweep_record(vfasl_info *vfi, ptr x) +{ + ptr *pp; ptr num; ptr rtd; + + rtd = RECORDINSTTYPE(x); + if (rtd == S_G.base_rtd) { + /* base-rtd is reset directly in all rtds */ + RECORDINSTTYPE(x) = vfi->base_rtd; + + if (x == vfi->base_rtd) { + /* Don't need to save fields of base-rtd */ + ptr *pp = &RECORDINSTIT(x,0); + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; + while (pp < ppend) { + *pp = Snil; + pp += 1; + } + return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + } + } else + vfasl_relocate(vfi, &RECORDINSTTYPE(x)); + + num = RECORDDESCPM(rtd); + pp = &RECORDINSTIT(x,0); + + /* process cells for which bit in pm is set; quit when pm == 0. */ + if (Sfixnump(num)) { + /* ignore bit for already forwarded rtd */ + uptr mask = (uptr)UNFIX(num) >> 1; + if (mask == (uptr)-1 >> 1) { + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; + while (pp < ppend) { + vfasl_relocate(vfi, pp); + pp += 1; + } + } else { + while (mask != 0) { + if (mask & 1) vfasl_relocate(vfi, pp); + mask >>= 1; + pp += 1; + } + } + } else { + iptr index; bigit mask; INT bits; + + /* bignum pointer mask */ + num = RECORDDESCPM(rtd); + vfasl_relocate(vfi, &RECORDDESCPM(rtd)); + index = BIGLEN(num) - 1; + /* ignore bit for already forwarded rtd */ + mask = BIGIT(num,index) >> 1; + bits = bigit_bits - 1; + for (;;) { + do { + if (mask & 1) vfasl_relocate(vfi, pp); + mask >>= 1; + pp += 1; + } while (--bits > 0); + if (index-- == 0) break; + mask = BIGIT(num,index); + bits = bigit_bits; + } + } + + return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); +} + +#define VFASL_RELOC_TAG_BITS 3 + +#define VFASL_RELOC_C_ENTRY_TAG 1 +#define VFASL_RELOC_LIBRARY_ENTRY_TAG 2 +#define VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG 3 +#define VFASL_RELOC_SYMBOL_TAG 4 +#define VFASL_RELOC_SINGLETON_TAG 5 +/* FXIME: rtds? */ + +#define VFASL_RELOC_C_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_C_ENTRY_TAG) +#define VFASL_RELOC_LIBRARY_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_TAG) +#define VFASL_RELOC_LIBRARY_ENTRY_CODE(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) +#define VFASL_RELOC_SYMBOL(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SYMBOL_TAG) +#define VFASL_RELOC_SINGLETON(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SINGLETON_TAG) + +#define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1)) +#define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS) + +static uptr sweep_code_object(vfasl_info *vfi, ptr co) { + ptr t, oldco, oldt; iptr a, m, n; + + vfasl_relocate(vfi, &CODENAME(co)); + vfasl_relocate(vfi, &CODEARITYMASK(co)); + vfasl_relocate(vfi, &CODEINFO(co)); + vfasl_relocate(vfi, &CODEPINFOS(co)); + + oldt = CODERELOC(co); + + n = size_reloc_table(RELOCSIZE(oldt)); + t = vfasl_find_room(vfi, vspace_reloc, typemod, n); + copy_ptrs(typemod, t, oldt, n); + + m = RELOCSIZE(t); + oldco = RELOCCODE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj, pos; + int which_singleton; + + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + + if ((which_singleton = detect_singleton(obj))) { + obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); + } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { + obj = FIX(VFASL_RELOC_C_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos)); + } else if (Ssymbolp(obj)) { + obj = vfasl_relocate_help(vfi, obj); + obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj)))); + } else if (IMMEDIATE(obj)) { + /* as-is */ + if (Sfixnump(obj)) + S_error("vfasl", "unexpected fixnum in relocation"); + } else { + obj = vfasl_relocate_help(vfi, obj); + obj = (ptr)ptr_diff(obj, vfi->base_addr); + } + + S_set_code_obj("vfasl", RELOC_TYPE(entry) | reloc_force_abs, co, a, obj, item_off); + } + + RELOCCODE(t) = co; + CODERELOC(co) = t; + + vfasl_register_pointer(vfi, &RELOCCODE(t)); + vfasl_register_pointer(vfi, &CODERELOC(co)); + + return size_code(CODELEN(co)); +} + +static void relink_code(ptr co, ptr sym_base, ptr dest_base) { + ptr t; iptr a, m, n; + + t = CODERELOC(co); + + m = RELOCSIZE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj; + + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry) | reloc_force_abs, co, a, item_off); + + if (IMMEDIATE(obj)) { + if (Sfixnump(obj)) { + int tag = VFASL_RELOC_TAG(obj); + int pos = VFASL_RELOC_POS(obj); + if (tag == VFASL_RELOC_SINGLETON_TAG) + obj = lookup_singleton(pos); + else if (tag == VFASL_RELOC_C_ENTRY_TAG) + obj = S_lookup_c_entry(pos); + else if ((tag == VFASL_RELOC_LIBRARY_ENTRY_TAG) + || (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG)) { + obj = S_lookup_library_entry(pos, 1); + if (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) + obj = CLOSCODE(obj); + } else if (tag == VFASL_RELOC_SYMBOL_TAG) { + ptr val; + obj = TYPE(ptr_add(sym_base, pos * size_symbol), type_symbol); + if ((val = SYMVAL(obj)) != sunbound) + obj = val; + } else { + S_error_abort("vfasl: bad relocation tag"); + } + } else { + /* some other immediate, such as black-hole; leave as-is */ + } + } else { + uptr offset = (uptr)obj; + obj = ptr_add(dest_base, offset); + if ((TYPEBITS(obj) == type_typed_object) + && (TYPEFIELD(obj) == S_G.base_rtd)) { + /* Similar to symbols: potentially replace with interned */ + ptr uid = RECORDDESCUID(obj); + if (!Ssymbolp(uid)) { + /* "uid" is actually the interned rtd to use instead */ + obj = uid; + } + } + } + + S_set_code_obj("vfasl", RELOC_TYPE(entry), co, a, obj, item_off); + } +} + +/*************************************************************/ + +static void fasl_init_entry_tables() +{ + tc_mutex_acquire() + + if (!S_G.c_entries) { + iptr i; + + S_G.c_entries = make_vfasl_hash_table(); + S_G.library_entries = make_vfasl_hash_table(); + S_G.library_entry_codes = make_vfasl_hash_table(); + + for (i = Svector_length(S_G.c_entry_vector); i--; ) { + ptr entry = Svector_ref(S_G.c_entry_vector, i); + vfasl_hash_table_set(S_G.c_entries, entry, (ptr)i); + } + + for (i = Svector_length(S_G.library_entry_vector); i--; ) { + ptr entry = Svector_ref(S_G.library_entry_vector, i); + if (entry != Sfalse) { + vfasl_hash_table_set(S_G.library_entries, entry, (ptr)i); + vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)i); + } + } + } + + tc_mutex_release() +} + +/*************************************************************/ + +static int detect_singleton(ptr p) { + if (p == S_G.null_string) + return 1; + else if (p == S_G.null_vector) + return 2; + else if (p == S_G.null_fxvector) + return 3; + else if (p == S_G.null_bytevector) + return 4; + else if (p == S_G.eqp) + return 5; + else if (p == S_G.eqvp) + return 6; + else if (p == S_G.equalp) + return 7; + else if (p == S_G.symboleqp) + return 8; + else + return 0; +} + +static ptr lookup_singleton(int which) { + switch (which) { + case 1: + return S_G.null_string; + case 2: + return S_G.null_vector; + case 3: + return S_G.null_fxvector; + case 4: + return S_G.null_bytevector; + case 5: + return S_G.eqp; + case 6: + return S_G.eqvp; + case 7: + return S_G.equalp; + case 8: + return S_G.symboleqp; + default: + S_error("vfasl", "bad singleton index"); + return (ptr)0; + } +} + +/*************************************************************/ + +typedef struct hash_entry { + ptr key, value; +} hash_entry; + +struct vfasl_hash_table { + uptr count; + uptr size; + hash_entry *entries; +}; + +#define HASH_CODE(p) ((uptr)(p) >> log2_ptr_bytes) +#define HASH_CODE2(p) (((uptr)(p) >> (log2_ptr_bytes + log2_ptr_bytes)) | 1) + +static vfasl_hash_table *make_vfasl_hash_table() { + vfasl_hash_table *ht; + + ht = malloc(sizeof(vfasl_hash_table)); + + ht->count = 0; + ht->size = 16; + ht->entries = calloc(sizeof(hash_entry), ht->size); + + return ht; +} + +static void free_vfasl_hash_table(vfasl_hash_table *ht) { + free(ht->entries); + free(ht); +} + +static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value) { + uptr hc = HASH_CODE(key); + uptr hc2 = HASH_CODE2(key); + uptr size = ht->size; + + if (ht->count > ht->size >> 1) { + /* rehash */ + uptr i; + hash_entry *old_entries = ht->entries; + + ht->count = 0; + ht->size *= 2; + ht->entries = calloc(sizeof(hash_entry), ht->size); + + for (i = 0; i < size; i++) { + if (old_entries[i].key) + vfasl_hash_table_set(ht, old_entries[i].key, old_entries[i].value); + } + + free(old_entries); + size = ht->size; + } + + hc = hc & (size - 1); + while (ht->entries[hc].key) { + hc = (hc + hc2) & (size - 1); + } + + ht->entries[hc].key = key; + ht->entries[hc].value = value; + ht->count++; +} + +static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key) { + uptr hc = HASH_CODE(key); + uptr hc2 = HASH_CODE2(key); + uptr size = ht->size; + ptr old_key; + + hc = hc & (size - 1); + while ((old_key = ht->entries[hc].key) != key) { + if (!old_key) + return (ptr)0; + hc = (hc + hc2) & (size - 1); + } + + return ht->entries[hc].value; +} + +/*************************************************************/ + +static void sort_offsets(vfoff *p, vfoff len) +{ + while (1) { + if (len > 1) { + vfoff i, pivot = 0; + + { + vfoff mid = len >> 2; + vfoff tmp = p[mid]; + p[mid] = p[0]; + p[0] = tmp; + } + + for (i = 1; i < len; i++) { + if (p[i] < p[pivot]) { + vfoff tmp = p[pivot]; + p[pivot] = p[i]; + pivot++; + p[i] = p[pivot]; + p[pivot] = tmp; + } + } + + if (pivot > (len >> 1)) { + sort_offsets(p+pivot+1, len-pivot-1); + len = pivot; + } else { + sort_offsets(p, pivot); + p = p+pivot+1; + len = len-pivot-1; + } + } else + return; + } +} diff --git a/s/7.ss b/s/7.ss index c012aed2a6..0155c8bbdd 100644 --- a/s/7.ss +++ b/s/7.ss @@ -121,7 +121,7 @@ (set! fasl-read (let () (define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr)) - (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr)) + (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int ptr) ptr)) (define (get-uptr p) (let ([k (get-u8 p)]) (let f ([k k] [n (fxsrl k 1)]) @@ -168,8 +168,9 @@ [(eqv? ty (constant fasl-type-header)) (check-header p) (fasl-entry)] - [(eqv? ty (constant fasl-type-fasl-size)) - ($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))] + [(or (eqv? ty (constant fasl-type-fasl-size)) + (eqv? ty (constant fasl-type-vfasl-size))) + ($bv-fasl-read (get-bytevector-n p (get-uptr p)) ty (port-name p))] [else (malformed p)]))))))) (define ($compiled-file-header? ip) diff --git a/s/back.ss b/s/back.ss index 7f8b59fe99..9f9ae878ec 100644 --- a/s/back.ss +++ b/s/back.ss @@ -126,6 +126,11 @@ (lambda (x) (and x #t)))) +(define generate-vfasl + ($make-thread-parameter #f + (lambda (x) + (and x #t)))) + (define $enable-check-prelex-flags ($make-thread-parameter #f (lambda (x) diff --git a/s/cmacros.ss b/s/cmacros.ss index b034522e29..a44d4f0680 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -433,7 +433,7 @@ (define-constant fasl-type-graph-ref 18) (define-constant fasl-type-gensym 19) (define-constant fasl-type-exactnum 20) -; 21 +(define-constant fasl-type-vfasl-size 21) (define-constant fasl-type-fasl-size 22) (define-constant fasl-type-record 23) (define-constant fasl-type-rtd 24) @@ -498,6 +498,8 @@ (arm32 reloc-arm32-abs reloc-arm32-call reloc-arm32-jump) (ppc32 reloc-ppc32-abs reloc-ppc32-call reloc-ppc32-jump)) +(define-constant reloc-force-abs #x100) ; flag to add to other `reloc-` constants + (constant-case ptr-bits [(64) (define-constant reloc-extended-format #x1) diff --git a/s/compile.ss b/s/compile.ss index 10a961e66b..878dae4ae6 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -22,6 +22,7 @@ (define $c-make-code) (define make-boot-header) (define make-boot-file) +(define vfasl-convert-file) (let () (import (nanopass)) @@ -440,10 +441,32 @@ [else (c-assembler-output-error x)]))) (define (c-print-fasl x p) - (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))]) - (c-build-fasl x t a?) - ($fasl-start p t - (lambda (p) (c-faslobj x t p a?))))) + (cond + [(generate-vfasl) (c-print-vfasl x p)] + [else + (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))]) + (c-build-fasl x t a?) + ($fasl-start p t + (lambda (p) (c-faslobj x t p a?))))])) + +(define (c-vfaslobj x) + (let f ([x x]) + (record-case x + [(group) elt* + (apply vector (map c-vfaslobj elt*))] + [(visit-stuff) elt + (cons (constant visit-tag) (c-vfaslobj elt))] + [(revisit-stuff) elt + (cons (constant revisit-tag) (c-vfaslobj elt))] + [else (c-mkcode x)]))) + +(define c-print-vfasl + (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]) + (lambda (x p) + (let ([bv (->vfasl (c-vfaslobj x))]) + (put-u8 p (constant fasl-type-vfasl-size)) + (put-uptr p (bytevector-length bv)) + (put-bytevector p bv))))) (define-record-type visit-chunk (nongenerative) @@ -1588,7 +1611,32 @@ (set-who! $make-boot-header ; create boot loader (invoke) for entry into Scheme from C (lambda (out machine . bootfiles) - (do-make-boot-header who out machine bootfiles)))) + (do-make-boot-header who out machine bootfiles))) + + (set-who! vfasl-convert-file + (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]) + (lambda (in-file out-file bootfile*) + (let ([op ($open-file-output-port who out-file + (if (compile-compressed) + (file-options replace compressed) + (file-options replace)))]) + (on-reset (delete-file out-file #f) + (on-reset (close-port op) + (when bootfile* + (emit-boot-header op (constant machine-type) bootfile*)) + (let ([ip ($open-file-input-port who in-file (file-options compressed))]) + (on-reset (close-port ip) + (let loop () + (let ([x (fasl-read ip)]) + (unless (eof-object? x) + (emit-header op (constant machine-type)) + (let ([bv (->vfasl x)]) + (put-u8 op (constant fasl-type-vfasl-size)) + (put-uptr op (bytevector-length bv)) + (put-bytevector op bv)) + (loop)))) + (close-port ip))) + (close-port op)))))))) (set-who! compile-port (rec compile-port diff --git a/s/primdata.ss b/s/primdata.ss index 0e829857eb..f4d086d572 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -960,6 +960,7 @@ (generate-interrupt-trap [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (generate-procedure-source-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (generate-profile-forms [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) + (generate-vfasl [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (generate-wpo-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (gensym-count [sig [() -> (uint)] [(uint) -> (void)]] [flags]) (gensym-prefix [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted]) @@ -1278,6 +1279,7 @@ (fasl-file [sig [(pathname pathname) -> (void)]] [flags true]) (fasl-read [sig [(binary-input-port) -> (ptr)]] [flags true]) (fasl-write [sig [(sub-ptr binary-output-port) -> (void)]] [flags true]) + (vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags]) (file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-directory? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard]) From a993c9c11e22312ffb4215ada77375aa7049c7db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Dec 2018 08:58:28 -0700 Subject: [PATCH 2/3] combine multiple fasl to one vfasl when possible original commit: d8d4400b42196088defac994b7f97a26446d8ed2 --- c/externs.h | 1 + c/prim5.c | 1 + c/scheme.c | 11 ++++ c/vfasl.c | 158 +++++++++++++++++++++++++++++++++++---------------- s/compile.ss | 34 +++++++---- s/library.ss | 1 + 6 files changed, 148 insertions(+), 58 deletions(-) diff --git a/c/externs.h b/c/externs.h index 845a157d1d..72e9713d47 100644 --- a/c/externs.h +++ b/c/externs.h @@ -108,6 +108,7 @@ extern int S_fasl_intern_rtd(ptr *x); extern ptr S_to_vfasl PROTO((ptr v)); extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr len)); extern ptr S_vfasl_to PROTO((ptr v)); +extern IBOOL S_vfasl_can_combinep(ptr v); /* flushcache.c */ extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes)); diff --git a/c/prim5.c b/c/prim5.c index 6a9cb94385..a2ac55bc5e 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -1548,6 +1548,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read); Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl); Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to); + Sforeign_symbol("(cs)vfasl_can_combinep", (void *)S_vfasl_can_combinep); Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float); Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd); diff --git a/c/scheme.c b/c/scheme.c index ebf30b4eeb..b741d1e94e 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -884,7 +884,11 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; { i = 0; while (i++ < LOADSKIP && S_boot_read(bd[n].file, bd[n].path) != Seof_object); + ptr pre = S_cputime(); + uptr reading = 0; + while ((x = S_boot_read(bd[n].file, bd[n].path)) != Seof_object) { + reading += UNFIX(S_cputime()) - UNFIX(pre); if (loadecho) { printf("%ld: ", (long)i); fflush(stdout); @@ -917,8 +921,11 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; { fflush(stdout); } i += 1; + pre = S_cputime(); } + printf("done %ld\n", reading); + S_G.load_binary = Sfalse; gzclose(bd[n].file); } @@ -1142,8 +1149,12 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i while (i < boot_count) load(tc, i++, 0); } + ptr pre = S_cputime(); + if (boot_count != 0) Scompact_heap(); + printf("compact %ld\n", UNFIX(S_cputime()) - UNFIX(pre)); + /* complete the initialization on the Scheme side */ p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init")); if (!Sprocedurep(p)) { diff --git a/c/vfasl.c b/c/vfasl.c index 145c225d9d..be816c05f6 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -75,7 +75,7 @@ struct vfasl_count_and_chunk { }; enum { - /* The order of these spaces matters: */ + /* The order of these spaces needs to match vfasl_header: */ vspace_symbol, vspace_rtd, vspace_closure, @@ -109,6 +109,8 @@ typedef struct vfasl_info { octet *ptr_bitmap; struct vfasl_hash_table *graph; + + IBOOL installs_library_entry; /* to determine whether vfasls can be combined */ } vfasl_info; #define ptr_add(p, n) ((ptr)((uptr)(p) + (n))) @@ -138,6 +140,7 @@ static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p); static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p); static void fasl_init_entry_tables(); +static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name); static int detect_singleton(ptr p); static ptr lookup_singleton(int which); @@ -364,8 +367,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) } /* Fix code via relocations */ - { - + { ptr sym_base = data; ptr code = TYPE(ptr_add(data, header.code_offset), type_typed_object); ptr code_end = TYPE(ptr_add(data, header.code_end_offset), type_typed_object); @@ -394,6 +396,50 @@ ptr S_vfasl_to(ptr bv) return S_vfasl(bv, (ptr)0, Sbytevector_length(bv)); } +static void vfasl_init(vfasl_info *vfi) { + int s; + + vfi->base_addr = (ptr)0; + vfi->sym_count = 0; + vfi->symref_count = 0; + vfi->symrefs = (ptr)0; + vfi->base_rtd = S_G.base_rtd; + vfi->rtdref_count = 0; + vfi->rtdrefs = (ptr)0; + vfi->singletonref_count = 0; + vfi->singletonrefs = (ptr)0; + vfi->graph = make_vfasl_hash_table(); + vfi->ptr_bitmap = (ptr)0; + vfi->installs_library_entry = 0; + + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = (ptr)0; + c->length = 0; + c->used = 0; + c->swept = 0; + c->next = (ptr)0; + + vfi->spaces[s].first = c; + vfi->spaces[s].total_bytes = 0; + } +} + +static void vfasl_free_chunks(vfasl_info *vfi) { + int s; + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c, *next; + for (c = vfi->spaces[s].first; c; c = next) { + next = c->next; + if (c->bytes) + free(c->bytes); + free(c); + } + } +} + ptr S_to_vfasl(ptr v) { vfasl_info *vfi; @@ -420,44 +466,13 @@ ptr S_to_vfasl(ptr v) vfi = malloc(sizeof(vfasl_info)); - vfi->base_addr = (ptr)0; - vfi->sym_count = 0; - vfi->symref_count = 0; - vfi->symrefs = (ptr)0; - vfi->base_rtd = S_G.base_rtd; - vfi->rtdref_count = 0; - vfi->rtdrefs = (ptr)0; - vfi->singletonref_count = 0; - vfi->singletonrefs = (ptr)0; - vfi->graph = make_vfasl_hash_table(); - vfi->ptr_bitmap = (ptr)0; + vfasl_init(vfi); /* First pass: determine sizes */ - for (s = 0; s < vspaces_count; s++) { - vfasl_chunk *c; - - c = malloc(sizeof(vfasl_chunk)); - c->bytes = (ptr)0; - c->length = 0; - c->used = 0; - c->swept = 0; - c->next = (ptr)0; - - vfi->spaces[s].first = c; - vfi->spaces[s].total_bytes = 0; - } - (void)vfasl_copy_all(vfi, v); - for (s = 0; s < vspaces_count; s++) { - vfasl_chunk *c, *next; - for (c = vfi->spaces[s].first; c; c = next) { - next = c->next; - free(c->bytes); - free(c); - } - } + vfasl_free_chunks(vfi); free_vfasl_hash_table(vfi->graph); @@ -587,8 +602,9 @@ ptr S_to_vfasl(ptr v) sort_offsets(vfi->singletonrefs, vfi->singletonref_count); for (s = 0; s < vspaces_count; s++) { - free(vfi->spaces[s].first); + free(vfi->spaces[s].first->bytes = (ptr)0); } + vfasl_free_chunks(vfi); free_vfasl_hash_table(vfi->graph); @@ -597,6 +613,40 @@ ptr S_to_vfasl(ptr v) return bv; } +/* If compiled code uses `$install-library-entry`, then it can't be + combined into a single vfasled object, because the installation + needs to be evaluated for laster vfasls. Recognize a non-combinable + value as anything that references the C entry or even mentions the + symbol `$install-library-entry` (as defined in "library.ss"). If + non-boot code mentions the symbol `$install-library-entry`, it just + isn't as optimal. + + This is an expensive test, since we perform half of a vfasl + encoding to look for `$install-library-entry`. */ +IBOOL S_vfasl_can_combinep(ptr v) +{ + IBOOL installs; + vfasl_info *vfi; + + fasl_init_entry_tables(); + + /* Run a "first pass" */ + + vfi = malloc(sizeof(vfasl_info)); + vfasl_init(vfi); + (void)vfasl_copy_all(vfi, v); + vfasl_free_chunks(vfi); + free_vfasl_hash_table(vfi->graph); + + installs = vfi->installs_library_entry; + + free(vfi); + + return !installs; +} + +/*************************************************************/ + static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { seginfo *si; int s; @@ -825,17 +875,8 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { n = size_code(CODELEN(pp)); FIND_ROOM(vfi, vspace_code, type_typed_object, n, p); copy_ptrs(type_typed_object, p, pp, n); - if (CODERELOC(pp) == (ptr)0) { - /* We only get here if we're vfasling code that belongs in - the static generation. */ - ptr l; iptr ln; - ln = size_reloc_table(0); - FIND_ROOM(vfi, vspace_reloc, typemod, ln, l); - RELOCSIZE(l) = 0; - RELOCCODE(l) = p; - CODERELOC(p) = l; - vfasl_register_pointer(vfi, &CODERELOC(p)); - } + if (CODERELOC(pp) == (ptr)0) + vfasl_fail(vfi, "code without relocation"); } else if ((iptr)tf == type_rtd_counts) { /* prune counts, since GC will recreate as needed */ return Sfalse; @@ -864,6 +905,9 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { vfasl_fail(vfi, "continuation"); return (ptr)0; + } else if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) { + vfasl_fail(vfi, "mutable closure"); + return (ptr)0; } else { iptr len, n; len = CLOSLEN(pp); @@ -880,6 +924,8 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { INITSYMSPLIST(p) = Snil; INITSYMNAME(p) = SYMNAME(pp); INITSYMHASH(p) = SYMHASH(pp); + if (Sstringp(SYMNAME(pp))) + vfasl_check_install_library_entry(vfi, SYMNAME(pp)); } else if (t == type_flonum) { FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p); FLODAT(p) = FLODAT(pp); @@ -1116,6 +1162,8 @@ static uptr sweep_code_object(vfasl_info *vfi, ptr co) { if ((which_singleton = detect_singleton(obj))) { obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { + if ((uptr)pos == CENTRY_install_library_entry) + vfi->installs_library_entry = 1; obj = FIX(VFASL_RELOC_C_ENTRY(pos)); } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); @@ -1239,6 +1287,20 @@ static void fasl_init_entry_tables() tc_mutex_release() } +static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name) +{ + const char *ile = "$install-library-entry"; + iptr len = Sstring_length(name), i; + + for (i = 0; i < len; i++) { + if (Sstring_ref(name, i) != (unsigned)ile[i]) + return; + } + + if (!ile[i]) + vfi->installs_library_entry = 1; +} + /*************************************************************/ static int detect_singleton(ptr p) { diff --git a/s/compile.ss b/s/compile.ss index 878dae4ae6..20eec02c62 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -1614,7 +1614,8 @@ (do-make-boot-header who out machine bootfiles))) (set-who! vfasl-convert-file - (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]) + (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)] + [vfasl-can-combine? (foreign-procedure "(cs)vfasl_can_combinep" (scheme-object) boolean)]) (lambda (in-file out-file bootfile*) (let ([op ($open-file-output-port who out-file (if (compile-compressed) @@ -1626,15 +1627,28 @@ (emit-boot-header op (constant machine-type) bootfile*)) (let ([ip ($open-file-input-port who in-file (file-options compressed))]) (on-reset (close-port ip) - (let loop () - (let ([x (fasl-read ip)]) - (unless (eof-object? x) - (emit-header op (constant machine-type)) - (let ([bv (->vfasl x)]) - (put-u8 op (constant fasl-type-vfasl-size)) - (put-uptr op (bytevector-length bv)) - (put-bytevector op bv)) - (loop)))) + (let* ([write-out (lambda (x) + (emit-header op (constant machine-type)) + (let ([bv (->vfasl x)]) + (put-u8 op (constant fasl-type-vfasl-size)) + (put-uptr op (bytevector-length bv)) + (put-bytevector op bv)))] + [write-out-accum (lambda (accum) + (unless (null? accum) + (write-out (list->vector (reverse accum)))))]) + (let loop ([accum '()]) + (let ([x (fasl-read ip)]) + (cond + [(eof-object? x) + (write-out-accum accum)] + [(not (vfasl-can-combine? x)) + (write-out-accum accum) + (write-out x) + (loop '())] + [(vector? x) + (loop (append (reverse (vector->list x)) accum))] + [else + (loop (cons x accum))])))) (close-port ip))) (close-port op)))))))) diff --git a/s/library.ss b/s/library.ss index 81a6e763a9..25c55b738d 100644 --- a/s/library.ss +++ b/s/library.ss @@ -74,6 +74,7 @@ ($hand-coded 'nonprocedure-code))) (define $foreign-entry ($hand-coded '$foreign-entry-procedure)) +;; The name `$install-library-entry` is special to `vfasl-can-combine?` (define $install-library-entry ($hand-coded '$install-library-entry-procedure)) From f3bbf06ce3e52865838339765a5b577674a760f6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 Dec 2018 13:41:17 -0700 Subject: [PATCH 3/3] direct to static original commit: ca6b0890ebd1cdeeae31dc3f11daa7fa02af013e --- c/fasl.c | 6 + c/globals.h | 1 + c/scheme.c | 6 +- c/vfasl.c | 364 +++++++++++++++++++++++++++++++++++++++------------- 4 files changed, 287 insertions(+), 90 deletions(-) diff --git a/c/fasl.c b/c/fasl.c index 00858432b7..e1e3d4998d 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -463,6 +463,12 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) { ffo.size = uf_uptrin(uf); if (ty == fasl_type_vfasl_size) { + if (S_vfasl_boot_mode == -1) { + ptr pre = S_cputime(); + Scompact_heap(); + S_vfasl_boot_mode = 1; + printf("pre compact %ld\n", UNFIX(S_cputime()) - UNFIX(pre)); + } x = S_vfasl((ptr)0, uf, ffo.size); } else { ffo.buf = buf; diff --git a/c/globals.h b/c/globals.h index b3bf0b53a5..d71f0ddc75 100644 --- a/c/globals.h +++ b/c/globals.h @@ -26,6 +26,7 @@ EXTERN ptr S_child_processes[static_generation+1]; /* scheme.c */ EXTERN IBOOL S_boot_time; +EXTERN int S_vfasl_boot_mode; EXTERN IBOOL S_errors_to_console; EXTERN ptr S_threads; EXTERN uptr S_nthreads; diff --git a/c/scheme.c b/c/scheme.c index b741d1e94e..520b99bc06 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -924,7 +924,7 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; { pre = S_cputime(); } - printf("done %ld\n", reading); + printf("load %ld\n", reading); S_G.load_binary = Sfalse; gzclose(bd[n].file); @@ -1123,6 +1123,8 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i } } + S_vfasl_boot_mode = -1; /* to static generation after compacting initial */ + if (boot_count != 0) { INT i = 0; @@ -1149,6 +1151,8 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i while (i < boot_count) load(tc, i++, 0); } + S_vfasl_boot_mode = 0; + ptr pre = S_cputime(); if (boot_count != 0) Scompact_heap(); diff --git a/c/vfasl.c b/c/vfasl.c index be816c05f6..9090282732 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -16,6 +16,43 @@ #include "system.h" +/* + + vfasl ("very fast load") format, where "data" corresponds to an + image to load into memory, "table" is metadata to relocate that + data, and the fixed-size header determines the overall size. The + data can be loaded directly to the static generation on boot, since + it's organized into pieces that should reside in a particular + space. + + [vfasl_header] + _ + / [symbol] ... -> space_symbol + / [rtd] ... -> space_pure +d | [closure] ... -> space_pure +a | [impure] ... -> space_impure +t | [pure_typed] ... -> space_pure_typed +a | [impure_record] ... -> space_impure_record + | [code] ... -> space_code + \ [data] ... -> space_data + \_ [reloc] ... -> (not kept for direct-to-static) + _ +t / [symbol reference offset] ... +a / [rtd reference offset] ... +b | [singleton reference offset] ... +l \ +e \_ [bitmap of pointers to relocate] + + + The bitmap at the end has one bit for each pointer-sized word in + the data, but it's shorter than the "data" size (divided by the + pointer size then divided by 8 bits per byte) because the trailing + zeros for data are omitted. The bitmap doesn't include some fixups + that are handled more directly, such as for code and its + relocations. + +*/ + typedef uptr vfoff; typedef struct vfasl_header { @@ -29,37 +66,59 @@ typedef struct vfasl_header { vfoff rtd_offset; # define rtd_end_offset closure_offset vfoff closure_offset; -# define closure_end_offset code_offset +# define closure_end_offset impure_offset + vfoff impure_offset; +# define impure_end_offset pure_typed_offset + vfoff pure_typed_offset; +# define pure_typed_object_end_offset impure_record_offset + vfoff impure_record_offset; +# define impure_record_end_offset code_offset vfoff code_offset; -# define code_end_offset other_offset - vfoff other_offset; +# define code_end_offset data_offset + vfoff data_offset; +# define data_end_offset reloc_offset + vfoff reloc_offset; +# define reloc_end_offset data_size vfoff symref_count; vfoff rtdref_count; vfoff singletonref_count; } vfasl_header; -/* vfasl format, where the fixed-size header determines the rest of the - size: +enum { + /* The order of these spaces needs to match vfasl_header: */ + vspace_symbol, + vspace_rtd, + vspace_closure, + vspace_impure, + vspace_pure_typed, + vspace_impure_record, + /* rest rest are at then end to make the pointer bitmap + end with zeros (that can be dropped): */ + vspace_code, + vspace_data, + vspace_reloc, /* can be dropped after direct to static generation */ + vspaces_count +}; - [vfasl_header] - _ -d / [symbol] ... -a / [rtd] ... -t | [closure] ... -a \ [code] ... - \_ [other] ... +/* Needs to match order above: */ +static ISPC vspace_spaces[] = { + space_symbol, + space_pure, /* rtd */ + space_pure, /* closure */ + space_impure, + space_pure_typed_object, + space_impure_record, + space_code, + space_data, + space_data /* reloc --- but not really, since relocs are never in static */ +}; -t / [vfoff: symbol reference offset] ... -a / [vfoff: rtd reference offset] ... -b | [vfoff: singleton reference offset] ... -l \ -e \_ [bitmap of pointer offsets] - -*/ +/************************************************************/ +/* Encode-time data structures */ -/* Many chunks per vspace on first pass, one per vspace on second - pass: */ +/* During encoding, we use many chunks per vspace on first pass, one + per vspace on second pass: */ typedef struct vfasl_chunk { ptr bytes; uptr length; @@ -74,20 +133,6 @@ struct vfasl_count_and_chunk { vfasl_chunk *first; }; -enum { - /* The order of these spaces needs to match vfasl_header: */ - vspace_symbol, - vspace_rtd, - vspace_closure, - vspace_code, - /* The rest of the spaces are "other" */ - vspace_array, - vspace_typed, - vspace_reloc, - vspace_data, /* at end, so pointer bitmap ends with zeros */ - vspaces_count -}; - typedef struct vfasl_info { ptr base_addr; /* address to make relocations relative to */ @@ -128,7 +173,8 @@ static uptr sweep_code_object(vfasl_info *vfi, ptr co); static uptr sweep_record(vfasl_info *vfi, ptr co); static uptr sweep(vfasl_info *vfi, ptr p); -static void relink_code(ptr co, ptr sym_base, ptr dest_base); +static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static); +static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets); static void vfasl_relocate(vfasl_info *vfi, ptr *ppp); static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp); @@ -155,16 +201,21 @@ static void sort_offsets(vfoff *p, vfoff len); #define vfasl_fail(vfi, what) S_error("vfasl", "cannot encode " what) -#define print_stats(args) /* printf args */ +/************************************************************/ +/* Loading */ ptr S_vfasl(ptr bv, void *stream, iptr input_len) { ptr tc = get_thread_context(); vfasl_header header; + ptr vspaces[vspaces_count]; + uptr vspace_offsets[vspaces_count+1], vspace_deltas[vspaces_count]; ptr data, table; vfoff *symrefs, *rtdrefs, *singletonrefs; octet *bm, *bm_end; iptr used_len; + int s; + IBOOL to_static = 0; used_len = sizeof(header); if (used_len > input_len) @@ -181,21 +232,65 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) if (used_len > input_len) S_error("fasl-read", "input length mismatch"); + vspace_offsets[vspace_symbol] = 0; + vspace_offsets[vspace_rtd] = header.rtd_offset; + vspace_offsets[vspace_closure] = header.closure_offset; + vspace_offsets[vspace_impure] = header.impure_offset; + vspace_offsets[vspace_pure_typed] = header.pure_typed_offset; + vspace_offsets[vspace_impure_record] = header.impure_record_offset; + vspace_offsets[vspace_code] = header.code_offset; + vspace_offsets[vspace_data] = header.data_offset; + vspace_offsets[vspace_reloc] = header.reloc_offset; + vspace_offsets[vspaces_count] = header.data_size; + if (bv) { ptr base_addr = &BVIT(bv, sizeof(vfasl_header)); thread_find_room(tc, typemod, header.data_size, data); memcpy(data, base_addr, header.data_size); table = ptr_add(base_addr, header.data_size); } else { - thread_find_room(tc, typemod, header.data_size, data); - if (S_fasl_stream_read(stream, data, header.data_size) < 0) - S_error("fasl-read", "input truncated"); + if (S_vfasl_boot_mode > 0) { + for (s = 0; s < vspaces_count; s++) { + uptr sz = vspace_offsets[s+1] - vspace_offsets[s]; + if (sz > 0) { + if (s == vspace_reloc) { + thread_find_room(tc, typemod, sz, vspaces[s]); + } else { + find_room(vspace_spaces[s], static_generation, typemod, sz, vspaces[s]); + } + if (S_fasl_stream_read(stream, vspaces[s], sz) < 0) + S_error("fasl-read", "input truncated"); + } else + vspaces[s] = (ptr)0; + } + for (s = vspaces_count - 1; s--; ) { + if (!vspaces[s]) + vspaces[s] = vspaces[s+1]; + } + data = (ptr)0; /* => initialize below */ + to_static = 1; + } else { + thread_find_room(tc, typemod, header.data_size, data); + if (S_fasl_stream_read(stream, data, header.data_size) < 0) + S_error("fasl-read", "input truncated"); + } thread_find_room(tc, typemod, ptr_align(header.table_size), table); if (S_fasl_stream_read(stream, table, header.table_size) < 0) S_error("fasl-read", "input truncated"); } + if (data) { + for (s = 0; s < vspaces_count; s++) { + vspaces[s] = ptr_add(data, vspace_offsets[s]); + vspace_deltas[s] = (uptr)data; + } + } else { + data = vspaces[0]; + for (s = 0; s < vspaces_count; s++) + vspace_deltas[s] = (uptr)ptr_subtract(vspaces[s], vspace_offsets[s]); + } + symrefs = table; rtdrefs = ptr_add(symrefs, header.symref_count * sizeof(vfoff)); singletonrefs = ptr_add(rtdrefs, header.rtdref_count * sizeof(vfoff)); @@ -216,21 +311,50 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) header.rtd_end_offset - header.rtd_offset, header.closure_end_offset - header.closure_offset, header.code_end_offset - header.code_offset, - header.data_size - header.other_offset, + ((header.code_offset - header.closure_end_offset) + + (header.data_size - header.code_end_offset)), header.table_size, header.symref_count * sizeof(vfoff), header.rtdref_count * sizeof(vfoff), header.singletonref_count * sizeof(vfoff)); - /* Fix up pointers. The content `data` initially has all pointers - relative to the start of the data, so add the `data` address - to all pointers. */ + /* We have to convert an offset relative to the start of data in the + vfasl format to an offset relative to an individual space, at + least for target generations other than 0. Rely on the fact that + the spaces and the references are both sorted. */ +#define SPACE_OFFSET_DECLS \ + int s2 = 0; \ + uptr offset2 = vspace_offsets[s2]; \ + uptr next_offset2 = vspace_offsets[s2+1] +#define INC_SPACE_OFFSET(off) \ + do { \ + while ((off) >= next_offset2) { \ + s2++; \ + offset2 = next_offset2; \ + next_offset2 = vspace_offsets[s2+1]; \ + } \ + } while (0) +#define SPACE_PTR(off) ptr_add(vspaces[s2], (off) - offset2) + + /* Fix up pointers. The initial content has all pointers relative to + the start of the data. If the data were all still contiguous, + we'd add the `data` address to all pointers. Since the spaces may + be disconnected, though, add `vspace_deltas[s]` for the right + `s`. */ { - ptr *p = data; + SPACE_OFFSET_DECLS; + uptr p_off = 0; while (bm != bm_end) { - octet m; - m = *bm; -# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p)[i] += (uptr)data + octet m = *bm; +# define MAYBE_FIXUP(i) \ + if (m & (1 << i)) { \ + ptr *p3; \ + INC_SPACE_OFFSET(p_off); \ + p3 = SPACE_PTR(p_off); \ + *p3 = find_pointer_from_offset((uptr)*p3, vspaces, vspace_offsets); \ + } \ + p_off += sizeof(uptr); + MAYBE_FIXUP(0); MAYBE_FIXUP(1); MAYBE_FIXUP(2); @@ -239,8 +363,8 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) MAYBE_FIXUP(5); MAYBE_FIXUP(6); MAYBE_FIXUP(7); + # undef MAYBE_FIXUP - p += byte_bits; bm++; } } @@ -249,18 +373,22 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) This needs to be before interning symbols, in case "" is a symbol name. */ { + SPACE_OFFSET_DECLS; vfoff i; for (i = 0; i < header.singletonref_count; i++) { + uptr r_off; ptr *ref; - ref = ptr_add(data, singletonrefs[i]); + r_off = singletonrefs[i]; + INC_SPACE_OFFSET(r_off); + ref = SPACE_PTR(r_off); *ref = lookup_singleton(UNFIX(*ref)); } } /* Intern symbols */ { - ptr sym = TYPE(data, type_symbol); - ptr end_syms = TYPE(ptr_add(data, header.sym_end_offset), type_symbol); + ptr sym = TYPE(vspaces[vspace_symbol], type_symbol); + ptr end_syms = TYPE(ptr_add(vspaces[vspace_symbol], header.sym_end_offset), type_symbol); if (sym != end_syms) { tc_mutex_acquire() @@ -286,12 +414,15 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) /* Replace symbol references with interned references */ { - ptr syms = data; + SPACE_OFFSET_DECLS; + ptr syms = vspaces[vspace_symbol]; vfoff i; for (i = 0; i < header.symref_count; i++) { - uptr sym_pos; + uptr p2_off, sym_pos; ptr p2, sym, val; - p2 = ptr_add(data, symrefs[i]); + p2_off = symrefs[i]; + INC_SPACE_OFFSET(p2_off); + p2 = SPACE_PTR(p2_off); sym_pos = UNFIX(*(ptr **)p2); sym = TYPE(ptr_add(syms, sym_pos * size_symbol), type_symbol); if ((val = SYMVAL(sym)) != sunbound) @@ -302,9 +433,10 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) /* Intern rtds */ if (header.rtd_offset < header.rtd_end_offset) { - ptr rtd = TYPE(ptr_add(data, header.rtd_offset), type_typed_object); - ptr rtd_end = TYPE(ptr_add(data, header.rtd_end_offset), type_typed_object); - + ptr rtd = TYPE(ptr_add(vspaces[vspace_rtd], header.rtd_offset - vspace_offsets[vspace_rtd]), + type_typed_object); + ptr rtd_end = ptr_add(rtd, header.rtd_end_offset - header.rtd_offset); + /* first one corresponds to base_rtd */ RECORDINSTTYPE(rtd) = S_G.base_rtd; RECORDDESCUID(rtd) = S_G.base_rtd; @@ -318,7 +450,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) RECORDINSTTYPE(rtd) = S_G.base_rtd; - /* fixup type and parent before continuing, relying on parents being earlier in `rtd`s */ + /* fixup parent before continuing, relying on parents being earlier in `rtd`s */ parent_rtd = RECORDDESCPARENT(rtd); if (parent_rtd != Sfalse) { ptr parent_uid = RECORDDESCUID(parent_rtd); @@ -340,10 +472,14 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) /* Replace rtd references to interned references */ { + SPACE_OFFSET_DECLS; vfoff i; for (i = 0; i < header.rtdref_count; i++) { + uptr r_off; ptr *ref, rtd, uid; - ref = ptr_add(data, rtdrefs[i]); + r_off = rtdrefs[i]; + INC_SPACE_OFFSET(r_off); + ref = SPACE_PTR(r_off); rtd = *ref; uid = RECORDDESCUID(rtd); if (!Ssymbolp(uid)) { @@ -355,12 +491,14 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) /* Fix code pointers on closures */ { - ptr cl = TYPE(ptr_add(data, header.closure_offset), type_closure); - ptr end_closures = TYPE(ptr_add(data, header.closure_end_offset), type_closure); + ptr cl = TYPE(ptr_add(vspaces[vspace_closure], header.closure_offset - vspace_offsets[vspace_closure]), + type_closure); + ptr end_closures = ptr_add(cl, header.closure_end_offset - header.closure_offset); + uptr code_delta = vspace_deltas[vspace_code]; while (cl != end_closures) { ptr code = CLOSCODE(cl); - code = ptr_add(code, (uptr)data); + code = ptr_add(code, code_delta); SETCLOSCODE(cl,code); cl = ptr_add(cl, size_closure(CLOSLEN(cl))); } @@ -368,11 +506,11 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) /* Fix code via relocations */ { - ptr sym_base = data; - ptr code = TYPE(ptr_add(data, header.code_offset), type_typed_object); - ptr code_end = TYPE(ptr_add(data, header.code_end_offset), type_typed_object); + ptr sym_base = vspaces[vspace_symbol]; + ptr code = TYPE(vspaces[vspace_code], type_typed_object); + ptr code_end = ptr_add(code, header.code_end_offset - header.code_offset); while (code != code_end) { - relink_code(code, sym_base, data); + relink_code(code, sym_base, vspaces, vspace_offsets, to_static); code = ptr_add(code, size_code(CODELEN(code))); } } @@ -382,7 +520,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len) { ptr v; ITYPE t; - v = ptr_add(data, header.result_offset); + v = find_pointer_from_offset(header.result_offset, vspaces, vspace_offsets); if (((t = TYPEBITS(v)) == type_typed_object) && TYPEP(TYPEFIELD(v), mask_box, type_box)) v = Sunbox(v); @@ -396,6 +534,9 @@ ptr S_vfasl_to(ptr bv) return S_vfasl(bv, (ptr)0, Sbytevector_length(bv)); } +/************************************************************/ +/* Saving */ + static void vfasl_init(vfasl_info *vfi) { int s; @@ -495,8 +636,12 @@ ptr S_to_vfasl(ptr v) header.rtd_offset = vfi->spaces[vspace_symbol].total_bytes; header.closure_offset = header.rtd_offset + vfi->spaces[vspace_rtd].total_bytes; - header.code_offset = header.closure_offset + vfi->spaces[vspace_closure].total_bytes; - header.other_offset = header.code_offset + vfi->spaces[vspace_code].total_bytes; + header.impure_offset = header.closure_offset + vfi->spaces[vspace_closure].total_bytes; + header.pure_typed_offset = header.impure_offset + vfi->spaces[vspace_impure].total_bytes; + header.impure_record_offset = header.pure_typed_offset + vfi->spaces[vspace_pure_typed].total_bytes; + header.code_offset = header.impure_record_offset + vfi->spaces[vspace_impure_record].total_bytes; + header.data_offset = header.code_offset + vfi->spaces[vspace_code].total_bytes; + header.reloc_offset = header.data_offset + vfi->spaces[vspace_data].total_bytes; header.symref_count = vfi->symref_count; header.rtdref_count = vfi->rtdref_count; @@ -518,7 +663,7 @@ ptr S_to_vfasl(ptr v) vfi->base_addr = p; - /* Set pointers to vspaces based on sizes frm first pass */ + /* Set pointers to vspaces based on sizes from first pass */ for (s = 0; s < vspaces_count; s++) { vfasl_chunk *c; @@ -600,7 +745,7 @@ ptr S_to_vfasl(ptr v) sort_offsets(vfi->symrefs, vfi->symref_count); sort_offsets(vfi->rtdrefs, vfi->rtdref_count); sort_offsets(vfi->singletonrefs, vfi->singletonref_count); - + for (s = 0; s < vspaces_count; s++) { free(vfi->spaces[s].first->bytes = (ptr)0); } @@ -645,7 +790,8 @@ IBOOL S_vfasl_can_combinep(ptr v) return !installs; } -/*************************************************************/ +/************************************************************/ +/* Traversals for saving */ static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { seginfo *si; @@ -678,7 +824,7 @@ static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_closure))); } break; - case vspace_array: + case vspace_impure: while (pp < pp_end) { vfasl_relocate(vfi, pp); pp = ptr_add(pp, sizeof(ptr)); @@ -686,7 +832,8 @@ static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { break; case vspace_rtd: case vspace_code: - case vspace_typed: + case vspace_pure_typed: + case vspace_impure_record: while (pp < pp_end) { pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_typed_object))); } @@ -809,8 +956,14 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { } s = vspace_rtd; - } else - s = vspace_typed; + } else { + /* See gc.c for original rationale but the fine-grained + choices only matter when loading into the static + generation, so we make */ + s = (RECORDDESCMPM(rtd) == FIX(0) + ? vspace_pure_typed + : vspace_impure_record); + } n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); @@ -823,8 +976,10 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { iptr len, n; len = Svector_length(pp); n = size_vector(len); - FIND_ROOM(vfi, vspace_typed, type_typed_object, n, p); + FIND_ROOM(vfi, vspace_impure, type_typed_object, n, p); copy_ptrs(type_typed_object, p, pp, n); + /* pad if necessary */ + if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0); } else if (TYPEP(tf, mask_string, type_string)) { iptr n; n = size_string(Sstring_length(pp)); @@ -844,19 +999,27 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { vfasl_fail(vfi, "tlc"); return (ptr)0; } else if (TYPEP(tf, mask_box, type_box)) { - FIND_ROOM(vfi, vspace_typed, type_typed_object, size_box, p); + FIND_ROOM(vfi, vspace_impure, type_typed_object, size_box, p); BOXTYPE(p) = (iptr)tf; INITBOXREF(p) = Sunbox(pp); } else if ((iptr)tf == type_ratnum) { - FIND_ROOM(vfi, vspace_typed, type_typed_object, size_ratnum, p); + /* note: vspace_impure is suboptimal for loading into static + generation, but these will be rare in boot code */ + FIND_ROOM(vfi, vspace_impure, type_typed_object, size_ratnum, p); RATTYPE(p) = type_ratnum; RATNUM(p) = RATNUM(pp); RATDEN(p) = RATDEN(pp); + /* pad */ + ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0; } else if ((iptr)tf == type_exactnum) { - FIND_ROOM(vfi, vspace_typed, type_typed_object, size_exactnum, p); + /* note: vspace_impure is suboptimal for loading into static + generation, but these will be rare in boot code */ + FIND_ROOM(vfi, vspace_impure, type_typed_object, size_exactnum, p); EXACTNUM_TYPE(p) = type_exactnum; EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); + /* pad */ + ((void **)UNTYPE(p, type_typed_object))[3] = (ptr)0; } else if ((iptr)tf == type_inexactnum) { FIND_ROOM(vfi, vspace_data, type_typed_object, size_inexactnum, p); INEXACTNUM_TYPE(p) = type_inexactnum; @@ -895,7 +1058,7 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { vfasl_fail(vfi, "weakpair"); return (ptr)0; } else { - FIND_ROOM(vfi, vspace_array, type_pair, size_pair, p); + FIND_ROOM(vfi, vspace_impure, type_pair, size_pair, p); } INITCAR(p) = Scar(pp); INITCDR(p) = Scdr(pp); @@ -1108,6 +1271,10 @@ static uptr sweep_record(vfasl_info *vfi, ptr x) return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); } + +/*************************************************************/ +/* Code and relocation handling for save and load */ + #define VFASL_RELOC_TAG_BITS 3 #define VFASL_RELOC_C_ENTRY_TAG 1 @@ -1184,19 +1351,25 @@ static uptr sweep_code_object(vfasl_info *vfi, ptr co) { S_set_code_obj("vfasl", RELOC_TYPE(entry) | reloc_force_abs, co, a, obj, item_off); } - RELOCCODE(t) = co; - CODERELOC(co) = t; - - vfasl_register_pointer(vfi, &RELOCCODE(t)); - vfasl_register_pointer(vfi, &CODERELOC(co)); + RELOCCODE(t) = (ptr)ptr_diff(co, vfi->base_addr); + CODERELOC(co) = (ptr)ptr_diff(t, vfi->base_addr); + /* no vfasl_register_pointer, since relink_code can handle it */ return size_code(CODELEN(co)); } -static void relink_code(ptr co, ptr sym_base, ptr dest_base) { +static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static) { ptr t; iptr a, m, n; t = CODERELOC(co); + t = ptr_add(vspaces[vspace_reloc], (uptr)t - vspace_offsets[vspace_reloc]); + + if (to_static) + CODERELOC(co) = (ptr)0; + else { + CODERELOC(co) = t; + RELOCCODE(t) = co; + } m = RELOCSIZE(t); a = 0; @@ -1241,7 +1414,8 @@ static void relink_code(ptr co, ptr sym_base, ptr dest_base) { } } else { uptr offset = (uptr)obj; - obj = ptr_add(dest_base, offset); + + obj = find_pointer_from_offset(offset, vspaces, vspace_offsets); if ((TYPEBITS(obj) == type_typed_object) && (TYPEFIELD(obj) == S_G.base_rtd)) { /* Similar to symbols: potentially replace with interned */ @@ -1257,6 +1431,18 @@ static void relink_code(ptr co, ptr sym_base, ptr dest_base) { } } +static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets) +{ + int s = 0; + ITYPE t = TYPEBITS(p_off); + + p_off = (uptr)UNTYPE(p_off, t); + while (p_off >= vspace_offsets[s+1]) + s++; + + return TYPE(ptr_add(vspaces[s], p_off - vspace_offsets[s]), t); +} + /*************************************************************/ static void fasl_init_entry_tables()