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))