From: Juho Snellman Date: Wed, 12 Oct 2005 23:53:47 +0000 (+0000) Subject: 0.9.5.52: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=18dbfbb4e0b4e8531e7dd882f3c55d51a8f38985;p=sbcl.git 0.9.5.52: More merging. Make non-purified cores suck less. * Do a non-conservative GC when saving a core without purifying. * Save critical bits of the page table in the core, to allow picking up the core without walking through the whole core. * The dynamic section of a core is picked up into a special non-collected generation (currently called "pseudo static" in the source, but I'm not attached to that name). * #ifdef out some fixup code that's not needed on x86-64. * Refactor save.c a bit. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 15b771b..90b20de 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -528,7 +528,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*!LOAD-TIME-VALUES*" "LOAD-TYPE-PREDICATE" "NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE" - "OPEN-FASL-OUTPUT" + "OPEN-FASL-OUTPUT" "PAGE-TABLE-CORE-ENTRY-TYPE-CODE" "READ-ONLY-CORE-SPACE-ID" "*!REVERSED-COLD-TOPLEVELS*" "STATIC-CORE-SPACE-ID" diff --git a/src/code/save.lisp b/src/code/save.lisp index defb53a..5398a5e 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -21,11 +21,13 @@ (file c-string) (initial-fun (unsigned #.sb!vm:n-word-bits))) -;;; FIXME: When this is run without the PURIFY option, -;;; it seems to save memory all the way up to the high-water mark, -;;; not just what's currently used; and then after loading the -;;; image to make a running Lisp, the memory never gets reclaimed. -;;; (But with the PURIFY option it seems to work OK.) +#!+gencgc +(define-alien-routine "gc_and_save" void + (file c-string)) + +#!+gencgc +(defvar sb!vm::*restart-lisp-function*) + (defun save-lisp-and-die (core-file-name &key (toplevel #'toplevel-init) (purify t) @@ -97,20 +99,30 @@ sufficiently motivated to do lengthy fixes." ;; function, and just do a GC :FULL T here? (Then if the user wanted ;; a PURIFYed image, he'd just run PURIFY immediately before calling ;; SAVE-LISP-AND-DIE.) - (if purify - (purify :root-structures root-structures - :environment-name environment-name) - #-gencgc (gc) #+gencgc (gc :full t)) - (flet ((restart-lisp () - (handling-end-of-the-world - (reinit) - (funcall toplevel)))) - ;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the - ;; LET as well, to avoid the off chance of an interrupt triggering - ;; GC and making our saved RESTART-LISP address invalid? - (without-gcing - (save (unix-namestring core-file-name nil) - (get-lisp-obj-address #'restart-lisp))))) + (labels ((restart-lisp () + (handling-end-of-the-world + (reinit) + (funcall toplevel))) + (save-core (gc) + (when gc + #!-gencgc (gc) + ;; Do a destructive non-conservative GC, and then save a core. + ;; A normal GC will leave huge amounts of storage unreclaimed + ;; (over 50% on x86). This needs to be done by a single function + ;; since the GC will invalidate the stack. + #!+gencgc (gc-and-save (unix-namestring core-file-name nil))) + (without-gcing + (save (unix-namestring core-file-name nil) + (get-lisp-obj-address #'restart-lisp))))) + ;; Save the restart function into a static symbol, to allow GC-AND-SAVE + ;; access to it even after the GC has moved it. + (setf sb!vm::*restart-lisp-function* #'restart-lisp) + (cond (purify + (purify :root-structures root-structures + :environment-name environment-name) + (save-core nil)) + (t + (save-core t))))) (defun deinit () (dolist (hook *save-hooks*) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 1d6941a..11696c9 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2930,6 +2930,7 @@ initially undefined function references:~2%") (defconstant build-id-core-entry-type-code 3899) (defconstant new-directory-core-entry-type-code 3861) (defconstant initial-fun-core-entry-type-code 3863) +(defconstant page-table-core-entry-type-code 3880) (defconstant end-core-entry-type-code 3840) (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word)) diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp index a6e20fe..e5954c6 100644 --- a/src/compiler/x86-64/parms.lisp +++ b/src/compiler/x86-64/parms.lisp @@ -210,6 +210,9 @@ *fp-constant-0f0* *fp-constant-1f0* + ;; For GC-AND-SAVE + *restart-lisp-function* + ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the ;; common slot unbound check. ;; diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 7368aed..e6dc71d 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -338,6 +338,9 @@ *fp-constant-lg2* *fp-constant-ln2* + ;; For GC-AND-SAVE + *restart-lisp-function* + ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the ;; common slot unbound check. ;; diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 57639ec..1a31707 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -36,6 +36,9 @@ #include "interr.h" #include "thread.h" +#include "validate.h" +#include "gc-internal.h" + unsigned char build_id[] = #include "../../output/build-id.tmp" ; @@ -224,6 +227,30 @@ load_core_file(char *file) initial_function = (lispobj)*ptr; break; +#ifdef LISP_FEATURE_GENCGC + case PAGE_TABLE_CORE_ENTRY_TYPE_CODE: + { + size_t size = *ptr; + size_t fdoffset = (*(ptr+1) + 1) * (os_vm_page_size); + size_t offset = 0; + long bytes_read; + long data[4096]; + lseek(fd, fdoffset, SEEK_SET); + while ((bytes_read = read(fd, data, (size < 4096 ? size : 4096 ))) + > 0) + { + int i = 0; + size -= bytes_read; + while (bytes_read) { + bytes_read -= sizeof(long); + page_table[offset++].first_object_offset = data[i++]; + } + } + + gencgc_partial_pickup = 1; + break; + } +#endif default: lose("unknown core file entry: %ld", (long)val); } diff --git a/src/runtime/gencgc-internal.h b/src/runtime/gencgc-internal.h index 9fc3094..41642ec 100644 --- a/src/runtime/gencgc-internal.h +++ b/src/runtime/gencgc-internal.h @@ -124,5 +124,6 @@ new_space_p(lispobj obj) } extern page_index_t last_free_page; +extern boolean gencgc_partial_pickup; #endif diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 973152b..fd982f9 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -61,7 +61,7 @@ page_index_t gc_find_freeish_pages(long *restart_page_ptr, long nbytes, */ enum { HIGHEST_NORMAL_GENERATION = 5, - PSEUDO_STATIC_GENERATION = 5, + PSEUDO_STATIC_GENERATION, SCRATCH_GENERATION, NUM_GENERATIONS }; @@ -94,8 +94,6 @@ unsigned long large_object_size = 4 * PAGE_BYTES; * debugging */ - - /* the verbosity level. All non-error messages are disabled at level 0; * and only a few rare messages are printed at level 1. */ #ifdef QSHOW @@ -135,6 +133,12 @@ boolean gencgc_enable_verify_zero_fill = 0; /* Should we check that free pages are zero filled during gc_free_heap * called after Lisp PURIFY? */ boolean gencgc_zero_check_during_free_heap = 0; + +/* When loading a core, don't do a full scan of the memory for the + * memory region boundaries. (Set to true by coreparse.c if the core + * contained a pagetable entry). + */ +boolean gencgc_partial_pickup = 0; /* * GC structures and variables @@ -341,7 +345,7 @@ count_generation_bytes_allocated (generation_index_t gen) /* Return the average age of the memory in a generation. */ static double -gen_av_mem_age(int gen) +gen_av_mem_age(generation_index_t gen) { if (generations[gen].bytes_allocated == 0) return 0.0; @@ -358,7 +362,7 @@ void fpu_restore(int *); /* defined in x86-assem.S */ static void print_generation_stats(int verbose) /* FIXME: should take FILE argument */ { - int i, gens; + generation_index_t i, gens; int fpu_state[27]; /* This code uses the FP instructions which may be set up for Lisp @@ -600,11 +604,10 @@ gc_alloc_new_region(long nbytes, int unboxed, struct alloc_region *alloc_region) * word sizes. -- WHN 19991129 */ lose("The new region at %x is not zero.", p); } + } } } -} - /* If the record_new_objects flag is 2 then all new regions created * are recorded. * @@ -952,8 +955,10 @@ gc_alloc_large(long nbytes, int unboxed, struct alloc_region *alloc_region) return((void *)(page_address(first_page)+orig_first_page_bytes_used)); } -long -gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed) +static page_index_t gencgc_alloc_start_page = -1; + +page_index_t +gc_find_freeish_pages(page_index_t *restart_page_ptr, long nbytes, int unboxed) { page_index_t first_page; page_index_t last_page; @@ -968,6 +973,10 @@ gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed) * a large object then align it on a page boundary by searching * for a free page. */ + if (gencgc_alloc_start_page != -1) { + restart_page = gencgc_alloc_start_page; + } + do { first_page = restart_page; if (large_p) @@ -1029,6 +1038,7 @@ gc_find_freeish_pages(long *restart_page_ptr, long nbytes, int unboxed) lose(NULL); } *restart_page_ptr=first_page; + return last_page; } @@ -1413,6 +1423,7 @@ static lispobj trans_boxed(lispobj object); void sniff_code_object(struct code *code, unsigned long displacement) { +#ifdef LISP_FEATURE_X86 long nheader_words, ncode_words, nwords; void *p; void *constants_start_addr = NULL, *constants_end_addr; @@ -1578,11 +1589,14 @@ sniff_code_object(struct code *code, unsigned long displacement) "/code start = %x, end = %x\n", code_start_addr, code_end_addr)); } +#endif } void gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) { +/* x86-64 uses pc-relative addressing instead of this kludge */ +#ifndef LISP_FEATURE_X86_64 long nheader_words, ncode_words, nwords; void *constants_start_addr, *constants_end_addr; void *code_start_addr, *code_end_addr; @@ -1673,6 +1687,7 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) if (check_code_fixups) { sniff_code_object(new_code,displacement); } +#endif } @@ -1699,7 +1714,6 @@ trans_unboxed_large(lispobj object) lispobj header; unsigned long length; - gc_assert(is_lisp_pointer(object)); header = *((lispobj *) native_pointer(object)); @@ -3585,38 +3599,41 @@ garbage_collect_generation(generation_index_t generation, int raise) /* we assume that none of the preceding applies to the thread that * initiates GC. If you ever call GC from inside an altstack * handler, you will lose. */ - for_each_thread(th) { - void **ptr; - void **esp=(void **)-1; + + /* And if we're saving a core, there's no point in being conservative. */ + if (conservative_stack) { + for_each_thread(th) { + void **ptr; + void **esp=(void **)-1; #ifdef LISP_FEATURE_SB_THREAD - long i,free; - if(th==arch_os_get_current_thread()) { - /* Somebody is going to burn in hell for this, but casting - * it in two steps shuts gcc up about strict aliasing. */ - esp = (void **)((void *)&raise); - } else { - void **esp1; - free=fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th)); - for(i=free-1;i>=0;i--) { - os_context_t *c=th->interrupt_contexts[i]; - esp1 = (void **) *os_context_register_addr(c,reg_SP); - if (esp1>=(void **)th->control_stack_start && - esp1<(void **)th->control_stack_end) { - if(esp1=(void **)c; ptr--) { - preserve_pointer(*ptr); + long i,free; + if(th==arch_os_get_current_thread()) { + /* Somebody is going to burn in hell for this, but casting + * it in two steps shuts gcc up about strict aliasing. */ + esp = (void **)((void *)&raise); + } else { + void **esp1; + free=fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th)); + for(i=free-1;i>=0;i--) { + os_context_t *c=th->interrupt_contexts[i]; + esp1 = (void **) *os_context_register_addr(c,reg_SP); + if (esp1>=(void **)th->control_stack_start && + esp1<(void **)th->control_stack_end) { + if(esp1=(void **)c; ptr--) { + preserve_pointer(*ptr); + } } } } - } #else - esp = (void **)((void *)&raise); + esp = (void **)((void *)&raise); #endif - for (ptr = (void **)th->control_stack_end; ptr > esp; ptr--) { - preserve_pointer(*ptr); + for (ptr = (void **)th->control_stack_end; ptr > esp; ptr--) { + preserve_pointer(*ptr); + } } } - #ifdef QSHOW if (gencgc_verbose > 1) { long num_dont_move_pages = count_dont_move_pages(); @@ -4050,7 +4067,6 @@ gc_init(void) gc_set_region_empty(&unboxed_region); last_free_page = 0; - } /* Pick up the dynamic space from after a core load. @@ -4064,24 +4080,34 @@ gencgc_pickup_dynamic(void) page_index_t page = 0; long alloc_ptr = SymbolValue(ALLOCATION_POINTER,0); lispobj *prev=(lispobj *)page_address(page); + generation_index_t gen = PSEUDO_STATIC_GENERATION; do { lispobj *first,*ptr= (lispobj *)page_address(page); page_table[page].allocated = BOXED_PAGE_FLAG; - page_table[page].gen = 0; + page_table[page].gen = gen; page_table[page].bytes_used = PAGE_BYTES; page_table[page].large_object = 0; - - first=gc_search_space(prev,(ptr+2)-prev,ptr); - if(ptr == first) prev=ptr; - page_table[page].first_object_offset = - (void *)prev - page_address(page); + page_table[page].write_protected = 0; + page_table[page].write_protected_cleared = 0; + page_table[page].dont_move = 0; + + if (!gencgc_partial_pickup) { + first=gc_search_space(prev,(ptr+2)-prev,ptr); + if(ptr == first) prev=ptr; + page_table[page].first_object_offset = + (void *)prev - page_address(page); + } page++; } while ((long)page_address(page) < alloc_ptr); - generations[0].bytes_allocated = PAGE_BYTES*page; + last_free_page = page; + + generations[gen].bytes_allocated = PAGE_BYTES*page; bytes_allocated = PAGE_BYTES*page; + gc_alloc_update_all_page_tables(); + write_protect_generation_pages(gen); } void @@ -4254,3 +4280,64 @@ gc_set_region_empty(struct alloc_region *region) region->end_addr = page_address(0); } +/* Things to do before doing a final GC before saving a core (without + * purify). + * + * + Pages in large_object pages aren't moved by the GC, so we need to + * unset that flag from all pages. + * + The pseudo-static generation isn't normally collected, but it seems + * reasonable to collect it at least when saving a core. So move the + * pages to a normal generation. + */ +static void +prepare_for_final_gc () +{ + page_index_t i; + for (i = 0; i < last_free_page; i++) { + page_table[i].large_object = 0; + if (page_table[i].gen == PSEUDO_STATIC_GENERATION) { + int used = page_table[i].bytes_used; + page_table[i].gen = HIGHEST_NORMAL_GENERATION; + generations[PSEUDO_STATIC_GENERATION].bytes_allocated -= used; + generations[HIGHEST_NORMAL_GENERATION].bytes_allocated += used; + } + } +} + + +/* Do a non-conservative GC, and then save a core with the initial + * function being set to the value of the static symbol + * SB!VM:RESTART-LISP-FUNCTION */ +void +gc_and_save(char *filename) +{ + FILE *file = open_core_for_saving(filename); + if (!file) { + perror(filename); + return; + } + conservative_stack = 0; + + /* The filename might come from Lisp, and be moved by the now + * non-conservative GC. */ + filename = strdup(filename); + + /* Collect twice: once into relatively high memory, and then back + * into low memory. This compacts the retained data into the lower + * pages, minimizing the size of the core file. + */ + prepare_for_final_gc(); + gencgc_alloc_start_page = last_free_page; + collect_garbage(HIGHEST_NORMAL_GENERATION+1); + + prepare_for_final_gc(); + gencgc_alloc_start_page = -1; + collect_garbage(HIGHEST_NORMAL_GENERATION+1); + + save_to_filehandle(file, filename, SymbolValue(RESTART_LISP_FUNCTION,0)); + /* Oops. Save still managed to fail. Since we've mangled the stack + * beyond hope, there's not much we can do. + * (beyond FUNCALLing RESTART_LISP_FUNCTION, but I suspect that's + * going to be rather unsatisfactory too... */ + lose("Attempt to save core after non-conservative GC failed."); +} diff --git a/src/runtime/save.c b/src/runtime/save.c index 4ace124..36b8ae8 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -87,21 +87,20 @@ output_space(FILE *file, int id, lispobj *addr, lispobj *end) write_lispobj((bytes + os_vm_page_size - 1) / os_vm_page_size, file); } -boolean -save(char *filename, lispobj init_function) +FILE * +open_core_for_saving(char *filename) { - FILE *file; - struct thread *th; - /* Open the output file. We don't actually need the file yet, but * the fopen() might fail for some reason, and we want to detect * that and back out before we do anything irreversible. */ unlink(filename); - file = fopen(filename, "w"); - if (!file) { - perror(filename); - return 1; - } + return fopen(filename, "w"); +} + +boolean +save_to_filehandle(FILE *file, char *filename, lispobj init_function) +{ + struct thread *th; /* Smash the enclosing state. (Once we do this, there's no good * way to go back, which is a sufficient reason that this ends up @@ -160,7 +159,7 @@ save(char *filename, lispobj init_function) #ifdef LISP_FEATURE_GENCGC /* Flush the current_region, updating the tables. */ gc_alloc_update_all_page_tables(); - update_x86_dynamic_space_free_pointer(); + update_dynamic_space_free_pointer(); #endif output_space(file, DYNAMIC_CORE_SPACE_ID, @@ -172,6 +171,26 @@ save(char *filename, lispobj init_function) write_lispobj(3, file); write_lispobj(init_function, file); +#ifdef LISP_FEATURE_GENCGC + { + size_t size = (last_free_page*sizeof(long)+os_vm_page_size-1) + &~(os_vm_page_size-1); + long *data = calloc(size, 1); + if (data) { + long offset; + int i; + for (i = 0; i < last_free_page; i++) { + data[i] = page_table[i].first_object_offset; + } + write_lispobj(PAGE_TABLE_CORE_ENTRY_TYPE_CODE, file); + write_lispobj(4, file); + write_lispobj(size, file); + offset = write_bytes(file, (char *) data, size); + write_lispobj(offset, file); + } + } +#endif + write_lispobj(END_CORE_ENTRY_TYPE_CODE, file); fclose(file); @@ -179,3 +198,16 @@ save(char *filename, lispobj init_function) exit(0); } + +boolean +save(char *filename, lispobj init_function) +{ + FILE *file = open_core_for_saving(filename); + + if (!file) { + perror(filename); + return 1; + } + + return save_to_filehandle(file, filename, init_function); +} diff --git a/src/runtime/save.h b/src/runtime/save.h index 75c78d0..93b6afa 100644 --- a/src/runtime/save.h +++ b/src/runtime/save.h @@ -14,6 +14,8 @@ #include "core.h" +extern FILE* open_core_for_saving(char *filename); +extern boolean save_to_filehandle(FILE *file, char *filename, lispobj initfun); extern boolean save(char *filename, lispobj initfun); #endif diff --git a/version.lisp-expr b/version.lisp-expr index ffd7686..8963d33 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.5.51" +"0.9.5.52"