experiment with a different fasl format
Use `vfasl-convert-file` to convert to the vfasl format, something
like this:
(vfasl-convert-file "orig/petite.boot" "new/petite.boot" '())
(vfasl-convert-file "orig/scheme.boot" "new/scheme.boot" '("petite"))
(vfasl-convert-file "orig/racket.boot" "new/racket.boot" '("petite" "scheme"))
original commit: a40886e2fba741ca8cfc5ebd16b902d6414da0ae
This commit is contained in:
Matthew Flatt
parent
efb93d2653
commit
14e910409c
|
|
@ -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}
|
||||
|
|
|
|||
11
c/externs.h
11
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,14 @@ 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));
|
||||
extern IBOOL S_vfasl_can_combinep(ptr v);
|
||||
|
||||
/* flushcache.c */
|
||||
extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes));
|
||||
|
|
@ -152,6 +160,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));
|
||||
|
||||
|
|
|
|||
102
c/fasl.c
102
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));
|
||||
|
|
@ -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,47 @@ 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) {
|
||||
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;
|
||||
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 +715,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 +1110,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 +1152,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)) &&
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -151,4 +152,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;
|
||||
|
|
|
|||
48
c/intern.c
48
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;
|
||||
|
|
|
|||
|
|
@ -1546,6 +1546,9 @@ 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)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);
|
||||
|
|
|
|||
15
c/scheme.c
15
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("load %ld\n", reading);
|
||||
|
||||
S_G.load_binary = Sfalse;
|
||||
gzclose(bd[n].file);
|
||||
}
|
||||
|
|
@ -1116,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;
|
||||
|
||||
|
|
@ -1142,8 +1151,14 @@ 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();
|
||||
|
||||
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)) {
|
||||
|
|
|
|||
7
s/7.ss
7
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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
72
s/compile.ss
72
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,46 @@
|
|||
(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)]
|
||||
[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)
|
||||
(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* ([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))))))))
|
||||
|
||||
(set-who! compile-port
|
||||
(rec compile-port
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user