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

update vfasl merge

Browse Source 
original commit: 99dac3f53f4a7d2b2c373489135e5d270c256726
This commit is contained in:
Matthew Flatt 2018-12-26 09:03:47 -06:00
parent d8dc4c71cc
commit 7c548bb3a1
16 changed files with 215 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LOG
View File

@ -1041,3 +1041,7 @@
gc-oce.c, gc.c, gcwrapper.c, prim.c, scheme.c,
globals.h, externs.h,
system.stex, 7.ms
- add vfasl format for faster loading
compile.ss, back.ss, library.ss, primdata.ss, cmacros.ss,
vfasl.c, fasl.c, alloc.c, scheme.c, intern.c, globals.h, externs.h,
Mf-base, misc.ms, system.stex, release_notes.stex

16
c/alloc.c
View File

@ -60,6 +60,22 @@ void S_alloc_init() {
S_protect(&S_G.null_string);
find_room(space_new, 0, type_typed_object, size_string(0), S_G.null_string);
STRTYPE(S_G.null_string) = (0 << string_length_offset) | type_string;
S_protect(&S_G.null_immutable_vector);
find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_immutable_vector);
VECTTYPE(S_G.null_immutable_vector) = (0 << vector_length_offset) | type_vector | vector_immutable_flag;
S_protect(&S_G.null_immutable_fxvector);
find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_immutable_fxvector);
FXVECTOR_TYPE(S_G.null_immutable_fxvector) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag;
S_protect(&S_G.null_immutable_bytevector);
find_room(space_new, 0, type_typed_object, size_bytevector(0), S_G.null_immutable_bytevector);
BYTEVECTOR_TYPE(S_G.null_immutable_bytevector) = (0 << bytevector_length_offset) | type_bytevector | bytevector_immutable_flag;
S_protect(&S_G.null_immutable_string);
find_room(space_new, 0, type_typed_object, size_string(0), S_G.null_immutable_string);
STRTYPE(S_G.null_immutable_string) = (0 << string_length_offset) | type_string | string_immutable_flag;
}
}

4
c/externs.h
View File

@ -94,7 +94,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, int ty, ptr path));
ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, 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));
@ -107,7 +107,7 @@ 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 PROTO((ptr bv, void *stream, iptr offset, iptr len));
extern ptr S_vfasl_to PROTO((ptr v));
extern IBOOL S_vfasl_can_combinep(ptr v);

23
c/fasl.c
View File

@ -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, IFASLCODE ty, unbufFaslFile uf));
static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf));
static void fillFaslFile PROTO((faslFile f));
static void bytesin PROTO((octet *s, iptr n, faslFile f));
static void toolarge PROTO((ptr path));
@ -304,7 +304,7 @@ ptr S_fasl_read(ptr file, IBOOL gzflag, ptr path) {
return x;
}
ptr S_bv_fasl_read(ptr bv, int ty, ptr path) {
ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path) {
ptr tc = get_thread_context();
ptr x; struct unbufFaslFileObj uffo;
@ -312,7 +312,7 @@ ptr S_bv_fasl_read(ptr bv, int ty, ptr path) {
tc_mutex_acquire()
uffo.path = path;
uffo.type = UFFO_TYPE_BV;
x = bv_fasl_entry(tc, bv, ty, &uffo);
x = bv_fasl_entry(tc, bv, ty, offset, len, &uffo);
tc_mutex_release()
return x;
}
@ -464,12 +464,10 @@ static ptr fasl_entry(ptr tc, unbufFaslFile 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));
Scompact_heap();
}
x = S_vfasl((ptr)0, uf, ffo.size);
x = S_vfasl((ptr)0, uf, 0, ffo.size);
} else {
ffo.buf = buf;
ffo.next = ffo.end = ffo.buf;
@ -482,17 +480,16 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) {
return x;
}
static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, unbufFaslFile uf) {
static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFaslFile uf) {
ptr x; ptr strbuf = S_G.null_string;
struct faslFileObj ffo;
ffo.size = Sbytevector_length(bv);
if (ty == fasl_type_vfasl_size) {
x = S_vfasl(bv, (ptr)0, ffo.size);
x = S_vfasl(bv, (ptr)0, offset, len);
} else {
ffo.next = ffo.buf = &BVIT(bv, 0);
ffo.end = &BVIT(bv, ffo.size);
ffo.size = len;
ffo.next = ffo.buf = &BVIT(bv, offset);
ffo.end = &BVIT(bv, offset + len);
ffo.uf = uf;
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);

4
c/globals.h
View File

@ -105,6 +105,10 @@ EXTERN struct {
ptr null_vector;
ptr null_fxvector;
ptr null_bytevector;
ptr null_immutable_string;
ptr null_immutable_vector;
ptr null_immutable_fxvector;
ptr null_immutable_bytevector;
seginfo *dirty_segments[DIRTY_SEGMENT_LISTS];
/* schsig.c */

1
c/intern.c
View File

@ -425,7 +425,6 @@ void S_retrofit_nonprocedure_code() {
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;

21
c/scheme.c
View File

@ -94,10 +94,10 @@ static void main_init() {
i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0);
}
NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector();
NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector();
NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector();
NULLIMMUTABLESTRING(tc) = S_null_immutable_string();
NULLIMMUTABLEVECTOR(tc) = S_G.null_immutable_vector;
NULLIMMUTABLEFXVECTOR(tc) = S_G.null_immutable_fxvector;
NULLIMMUTABLEBYTEVECTOR(tc) = S_G.null_immutable_bytevector;
NULLIMMUTABLESTRING(tc) = S_G.null_immutable_string;
PARAMETERS(tc) = S_G.null_vector;
for (i = 0 ; i < virtual_register_count ; i += 1) {
@ -888,11 +888,7 @@ 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);
@ -925,11 +921,8 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
fflush(stdout);
}
i += 1;
pre = S_cputime();
}
printf("load %ld\n", reading);
S_G.load_binary = Sfalse;
gzclose(bd[n].file);
}
@ -1157,14 +1150,8 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
S_vfasl_boot_mode = 0;
printf("vfasl %ld %ld / %ld\n", vfasl_load_time, vfasl_fix_time, vfasl_relocs);
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)) {

166
c/vfasl.c
View File

@ -16,10 +16,6 @@
#include "system.h"
iptr vfasl_load_time;
iptr vfasl_fix_time;
iptr vfasl_relocs;
/*
vfasl ("very fast load") format, where "data" corresponds to an
@ -44,10 +40,9 @@ a | [impure_record] ... -> space_impure_record
t / [symbol reference offset] ...
a / [rtd reference offset] ...
b | [singleton reference offset] ...
l \
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
@ -59,7 +54,9 @@ e \_ [bitmap of pointers to relocate]
typedef uptr vfoff;
/* Similar to allocation spaces, but more detailed in some cases: */
/* Similar to allocation spaces, but not all allocation spaces are
represented, and these spaces are more fine-grained in some
cases: */
enum {
vspace_symbol,
vspace_rtd,
@ -75,7 +72,8 @@ enum {
vspaces_count
};
/* Needs to match order above: */
/* Needs to match order above, maps vfasl spaces to allocation
spaces: */
static ISPC vspace_spaces[] = {
space_symbol,
space_pure, /* rtd */
@ -194,7 +192,7 @@ static void sort_offsets(vfoff *p, vfoff len);
/************************************************************/
/* Loading */
ptr S_vfasl(ptr bv, void *stream, iptr input_len)
ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
{
ptr vspaces[vspaces_count];
uptr vspace_offsets[vspaces_count+1];
@ -209,14 +207,12 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
int s;
IBOOL to_static = 0;
ptr pre = S_cputime();
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));
memcpy(&header, &BVIT(bv, offset), sizeof(vfasl_header));
else {
if (S_fasl_stream_read(stream, (octet*)&header, sizeof(header)) < 0)
S_error("fasl-read", "input truncated");
@ -233,7 +229,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
vspace_offsets[vspaces_count] = header.data_size;
if (bv) {
ptr base_addr = &BVIT(bv, sizeof(vfasl_header));
ptr base_addr = &BVIT(bv, sizeof(vfasl_header) + offset);
thread_find_room(tc, typemod, header.data_size, data);
memcpy(data, base_addr, header.data_size);
table = ptr_add(base_addr, header.data_size);
@ -289,6 +285,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
"clos %ld\n"
"code %ld\n"
"rloc %ld\n"
"data %ld\n"
"othr %ld\n"
"tabl %ld symref %ld rtdref %ld sglref %ld\n",
sizeof(vfasl_header),
@ -297,10 +294,10 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
VSPACE_LENGTH(vspace_closure),
VSPACE_LENGTH(vspace_code),
VSPACE_LENGTH(vspace_reloc),
VSPACE_LENGTH(vspace_data),
(VSPACE_LENGTH(vspace_impure)
+ VSPACE_LENGTH(vspace_pure_typed)
+ VSPACE_LENGTH(vspace_impure_record)
+ VSPACE_LENGTH(vspace_data)),
+ VSPACE_LENGTH(vspace_impure_record)),
header.table_size,
header.symref_count * sizeof(vfoff),
header.rtdref_count * sizeof(vfoff),
@ -323,12 +320,12 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
} \
} 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, use `find_pointer_from_offset`. */
{
/* Fix up pointers. The initiaal content has all pointers relative to
the start of the data. In not-to-static mode, we can just add the
`data` address to all pointers. In to-static mode, since the
spaces may be discontiguous, use `find_pointer_from_offset`. */
if (to_static) {
SPACE_OFFSET_DECLS;
uptr p_off = 0;
while (bm != bm_end) {
@ -354,6 +351,25 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
# undef MAYBE_FIXUP
bm++;
}
} else {
ptr *p = (ptr *)data;
while (bm != bm_end) {
octet m = *bm;
# define MAYBE_FIXUP(i) if (m & (1 << i)) p[i] = ptr_add(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().
@ -379,7 +395,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
if (sym != end_syms) {
tc_mutex_acquire()
while (sym < end_syms) {
ptr isym;
@ -500,8 +516,6 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
}
}
vfasl_fix_time += UNFIX(S_cputime()) - UNFIX(pre);
/* Turn result offset into a value, unboxing if it's a box (which
supports a symbol result, for example). */
{
@ -518,7 +532,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr input_len)
ptr S_vfasl_to(ptr bv)
{
return S_vfasl(bv, (ptr)0, Sbytevector_length(bv));
return S_vfasl(bv, (ptr)0, 0, Sbytevector_length(bv));
}
/************************************************************/
@ -561,7 +575,7 @@ ptr S_to_vfasl(ptr v)
vfasl_header header;
ITYPE t;
int s;
uptr size, data_size, bitmap_size, pre_bitmap_size;
uptr size, data_size, bitmap_size;
ptr bv, p;
fasl_init_entry_tables();
@ -603,13 +617,11 @@ ptr S_to_vfasl(ptr v)
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.symref_count = vfi->symref_count;
header.rtdref_count = vfi->rtdref_count;
header.singletonref_count = vfi->singletonref_count;
pre_bitmap_size = size;
header.table_size = size - data_size - sizeof(header); /* doesn't yet include the bitmap */
bitmap_size = (data_size + (byte_bits-1)) >> log2_byte_bits;
@ -848,6 +860,20 @@ static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p) {
return vfasl_hash_table_ref(vfi->graph, p);
}
static void vfasl_relocate_parents(vfasl_info *vfi, ptr p) {
ptr ancestors = Snil;
while ((p != Sfalse) && !vfasl_lookup_forward(vfi, p)) {
ancestors = Scons(p, ancestors);
p = RECORDDESCPARENT(p);
}
while (ancestors != Snil) {
(void)vfasl_relocate_help(vfi, Scar(ancestors));
ancestors = Scdr(ancestors);
}
}
static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) {
ptr p;
@ -899,14 +925,12 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
/* 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));
}
/* need parent before child */
vfasl_relocate_parents(vfi, RECORDDESCPARENT(pp));
s = vspace_rtd;
} else {
/* See gc.c for original rationale but the fine-grained
/* 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)
@ -1029,15 +1053,18 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) {
}
} else if (t == type_symbol) {
iptr pos = vfi->sym_count++;
ptr name = SYMNAME(pp);
if (Sstringp(name))
vfasl_check_install_library_entry(vfi, name);
else if (!Spairp(name) || (Scar(name) == Sfalse))
vfasl_fail(vfi, "gensym without unique name");
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);
INITSYMNAME(p) = name;
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);
@ -1325,7 +1352,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
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;
@ -1393,6 +1420,7 @@ static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offse
}
/*************************************************************/
/* C and library entries */
static void fasl_init_entry_tables()
{
@ -1437,53 +1465,36 @@ static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name)
}
/*************************************************************/
/* Singletons, such as "" */
static ptr *singleton_refs[] = { &S_G.null_string,
&S_G.null_vector,
&S_G.null_fxvector,
&S_G.null_bytevector,
&S_G.null_immutable_string,
&S_G.null_immutable_vector,
&S_G.null_immutable_fxvector,
&S_G.null_immutable_bytevector,
&S_G.eqp,
&S_G.eqvp,
&S_G.equalp,
&S_G.symboleqp };
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;
unsigned i;
for (i = 0; i < sizeof(singleton_refs) / sizeof(ptr*); i++) {
if (p == *(singleton_refs[i]))
return i+1;
}
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;
}
return *(singleton_refs[which-1]);
}
/*************************************************************/
/* `eq?`-based hash table during saving as critical section */
typedef struct hash_entry {
ptr key, value;
@ -1589,7 +1600,6 @@ static ptr vfasl_calloc(uptr sz, uptr n) {
return p;
}
/*************************************************************/
static void sort_offsets(vfoff *p, vfoff len)

13
csug/system.stex
View File

@ -1601,6 +1601,19 @@ as part of a binary-only package.
\end{description}
%----------------------------------------------------------------------------
\entryheader
\formdef{vfasl-convert-file}{\categoryprocedure}{(vfasl-convert-file \var{input-path} \var{output-path} \var{base-boots})}
\returns unspecified
\listlibraries
\endentryheader
Converts a compiled file to one that may load more quickly, especially
in the case of a boot file. The converted file is a boot file if
\var{base-boots} is a list of strings, otherwise \var{base-boots} must
be \scheme{#f} to create a non-boot file.
%----------------------------------------------------------------------------
\entryheader
\formdef{machine-type}{\categoryprocedure}{(machine-type)}

46
mats/misc.ms
View File

@ -14,7 +14,7 @@
;;; limitations under the License.
;;; regression and other tests that don't fit somewhere more logical
(define-syntax biglet
(lambda (x)
(syntax-case x ()
@ -2282,6 +2282,50 @@
(error? (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib3.so" #t))
)
(mat vfasl
(begin
(define-record-type vfasl-demo
(fields x y)
(nongenerative #{vfasl-demo pfwhk286n2j894o33awcq9er4-0}))
(define vfasl-content (list 1 1/2 3.0 4+5i 6.0+7.0i
"apple" 'banana
(make-vfasl-demo 10 "11")
(vector 1 'two "three")
(box 88)
"" '#() '#vu8() (make-fxvector 0)
(string->immutable-string "") (vector->immutable-vector '#())
(bytevector->immutable-bytevector '#vu8())
(fxvector->immutable-fxvector (make-fxvector 0))))
(define (same-vfasl-content? v)
(andmap (lambda (a b)
(or (eqv? a b)
(and (or (and (string? a)
(positive? (string-length a)))
(and (vector? a)
(positive? (vector-length a)))
(box? a))
(equal? a b))
(and (vfasl-demo? a)
(vfasl-demo? b)
(equal? (vfasl-demo-x a)
(vfasl-demo-x b))
(equal? (vfasl-demo-y a)
(vfasl-demo-y b)))
(printf "~s ~s\n" a b)))
vfasl-content
v))
(compile-to-file (list `(define (vfasled) ',vfasl-content)
`(define (get-vfasled) vfasled)
`(define (call-vfasled) (vfasled)))
"testfile-fasl.so")
(vfasl-convert-file "testfile-fasl.so" "testfile-vfasl.so" #f)
(load "testfile-vfasl.so")
#t)
(same-vfasl-content? (vfasled))
(eq? vfasled (get-vfasled))
(eq? (vfasled) (call-vfasled)))
(mat cost-center
(error? ; wrong number of arguments
(make-cost-center 'foo))

6
release_notes/release_notes.stex
View File

@ -58,6 +58,12 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Faster loading format (9.5.1)}
The new procedure \scheme{vfasl-convert-file} converts a file to a
format that can be loaded more quickly, especially for an uncompressed
boot file.
\subsection{Extracting a subset of hashtable cells (9.5.1)}
The new \scheme{hashtable-cells} function is similar to

21
s/7.ss
View File

@ -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 int ptr) ptr))
(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr) ptr))
(define (get-uptr p)
(let ([k (get-u8 p)])
(let f ([k k] [n (fxsrl k 1)])
@ -170,7 +170,24 @@
(fasl-entry)]
[(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))]
(let ([len (get-uptr p)]
[name (port-name p)])
;; fasl-read directly from the port buffer if it has `len`
;; bytes ready, which works for a bytevector port; disable
;; interrupt to make sure the bytes stay available (and
;; `$bv-fasl-read` takes tc-mutex, anyway)
((with-interrupts-disabled
(let ([idx (binary-port-input-index p)])
(cond
[(<= len (fx- (binary-port-input-size p) idx))
(let ([result ($bv-fasl-read (binary-port-input-buffer p) ty
idx len name)])
(set-binary-port-input-index! p (+ idx len))
(lambda () result))]
[else
;; Call `get-bytevector-n`, etc. with interrupts reenabled
(lambda ()
($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))]
[else (malformed p)])))))))
(define ($compiled-file-header? ip)

5
s/back.ss
View File

@ -126,11 +126,6 @@
(lambda (x)
(and x #t))))
(define compile-vfasl
($make-thread-parameter #f
(lambda (x)
(and x #t))))
(define $enable-check-prelex-flags
($make-thread-parameter #f
(lambda (x)

2
s/cmacros.ss
View File

@ -498,8 +498,6 @@
(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)

30
s/compile.ss
View File

@ -441,32 +441,10 @@
[else (c-assembler-output-error x)])))
(define (c-print-fasl x p)
(cond
[(compile-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)))))
(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-record-type visit-chunk
(nongenerative)

1
s/primdata.ss
View File

@ -925,7 +925,6 @@
(compile-library-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
(compile-profile [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted])
(compile-program-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
(compile-vfasl [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
(console-error-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags])
(console-input-port [sig [() -> (textual-input-port)] [(textual-input-port) -> (void)]] [flags])
(console-output-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags])