X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/96117bc7fbc053b2cf7eed42cc4d765b051352f4..c596c392c82ad7b99f6263e2ef9c7ef913addb77:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 23ab3a3bcd..4affa42e68 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,5 +1,5 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000 + Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -26,12 +26,6 @@ Boston, MA 02111-1307, USA. */ #include -/* Define this temporarily to hunt a bug. If defined, the size of - strings is redundantly recorded in sdata structures so that it can - be compared to the sizes recorded in Lisp strings. */ - -#define GC_CHECK_STRING_BYTES 1 - /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd memory. Can do this only if using gmalloc.c. */ @@ -1201,50 +1195,84 @@ init_strings () #ifdef GC_CHECK_STRING_BYTES -/* Check validity of all live Lisp strings' string_bytes member. - Used for hunting a bug. */ - static int check_string_bytes_count; +void check_string_bytes P_ ((int)); +void check_sblock P_ ((struct sblock *)); + +#define CHECK_STRING_BYTES(S) STRING_BYTES (S) + + +/* Like GC_STRING_BYTES, but with debugging check. */ + +int +string_bytes (s) + struct Lisp_String *s; +{ + int nbytes = (s->size_byte < 0 ? s->size : s->size_byte) & ~MARKBIT; + if (!PURE_POINTER_P (s) + && s->data + && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) + abort (); + return nbytes; +} + +/* Check validity Lisp strings' string_bytes member in B. */ + void -check_string_bytes () +check_sblock (b) + struct sblock *b; { - struct sblock *b; - - for (b = large_sblocks; b; b = b->next) - { - struct Lisp_String *s = b->first_data.string; - if (s && GC_STRING_BYTES (s) != SDATA_NBYTES (SDATA_OF_STRING (s))) - abort (); - } + struct sdata *from, *end, *from_end; - for (b = oldest_sblock; b; b = b->next) + end = b->next_free; + + for (from = &b->first_data; from < end; from = from_end) { - struct sdata *from, *end, *from_end; + /* Compute the next FROM here because copying below may + overwrite data we need to compute it. */ + int nbytes; - end = b->next_free; + /* Check that the string size recorded in the string is the + same as the one recorded in the sdata structure. */ + if (from->string) + CHECK_STRING_BYTES (from->string); - for (from = &b->first_data; from < end; from = from_end) - { - /* Compute the next FROM here because copying below may - overwrite data we need to compute it. */ - int nbytes; + if (from->string) + nbytes = GC_STRING_BYTES (from->string); + else + nbytes = SDATA_NBYTES (from); + + nbytes = SDATA_SIZE (nbytes); + from_end = (struct sdata *) ((char *) from + nbytes); + } +} - /* Check that the string size recorded in the string is the - same as the one recorded in the sdata structure. */ - if (from->string - && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) - abort (); - - if (from->string) - nbytes = GC_STRING_BYTES (from->string); - else - nbytes = SDATA_NBYTES (from); - - nbytes = SDATA_SIZE (nbytes); - from_end = (struct sdata *) ((char *) from + nbytes); + +/* Check validity of Lisp strings' string_bytes member. ALL_P + non-zero means check all strings, otherwise check only most + recently allocated strings. Used for hunting a bug. */ + +void +check_string_bytes (all_p) + int all_p; +{ + if (all_p) + { + struct sblock *b; + + for (b = large_sblocks; b; b = b->next) + { + struct Lisp_String *s = b->first_data.string; + if (s) + CHECK_STRING_BYTES (s); } + + for (b = oldest_sblock; b; b = b->next) + check_sblock (b); } + else + check_sblock (current_sblock); } #endif /* GC_CHECK_STRING_BYTES */ @@ -1294,12 +1322,21 @@ allocate_string () consing_since_gc += sizeof *s; #ifdef GC_CHECK_STRING_BYTES - if (!noninteractive && ++check_string_bytes_count == 50) + if (!noninteractive +#ifdef macintosh + && current_sblock +#endif + ) { - check_string_bytes_count = 0; - check_string_bytes (); + if (++check_string_bytes_count == 200) + { + check_string_bytes_count = 0; + check_string_bytes (1); + } + else + check_string_bytes (0); } -#endif +#endif /* GC_CHECK_STRING_BYTES */ return s; } @@ -2105,8 +2142,38 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, size = XFASTINT (length); val = Qnil; - while (size-- > 0) - val = Fcons (init, val); + while (size > 0) + { + val = Fcons (init, val); + --size; + + if (size > 0) + { + val = Fcons (init, val); + --size; + + if (size > 0) + { + val = Fcons (init, val); + --size; + + if (size > 0) + { + val = Fcons (init, val); + --size; + + if (size > 0) + { + val = Fcons (init, val); + --size; + } + } + } + } + + QUIT; + } + return val; } @@ -3702,6 +3769,7 @@ Garbage collection happens automatically if you cons more than\n\ register int i; int message_p; Lisp_Object total[8]; + int count = BINDING_STACK_SIZE (); /* In case user calls debug_print during GC, don't let that cause a recursive GC. */ @@ -3709,6 +3777,7 @@ Garbage collection happens automatically if you cons more than\n\ /* Save what's currently displayed in the echo area. */ message_p = push_message (); + record_unwind_protect (push_message_unwind, Qnil); /* Save a copy of the contents of the stack, for debugging. */ #if MAX_SAVE_STACK > 0 @@ -3913,7 +3982,7 @@ Garbage collection happens automatically if you cons more than\n\ message1_nolog ("Garbage collecting...done"); } - pop_message (); + unbind_to (count, Qnil); total[0] = Fcons (make_number (total_conses), make_number (total_free_conses)); @@ -4109,13 +4178,9 @@ mark_object (argptr) MARK_INTERVAL_TREE (ptr->intervals); MARK_STRING (ptr); #ifdef GC_CHECK_STRING_BYTES - { - /* Check that the string size recorded in the string is the - same as the one recorded in the sdata structure. */ - struct sdata *p = SDATA_OF_STRING (ptr); - if (GC_STRING_BYTES (ptr) != SDATA_NBYTES (p)) - abort (); - } + /* Check that the string size recorded in the string is the + same as the one recorded in the sdata structure. */ + CHECK_STRING_BYTES (ptr); #endif /* GC_CHECK_STRING_BYTES */ } break; @@ -4606,6 +4671,10 @@ gc_sweep () sweep_weak_hash_tables (); sweep_strings (); +#ifdef GC_CHECK_STRING_BYTES + if (!noninteractive) + check_string_bytes (1); +#endif /* Put all unmarked conses on free list */ { @@ -4764,29 +4833,39 @@ gc_sweep () register int lim = symbol_block_index; register int num_free = 0, num_used = 0; - symbol_free_list = 0; + symbol_free_list = NULL; for (sblk = symbol_block; sblk; sblk = *sprev) { - register int i; int this_free = 0; - for (i = 0; i < lim; i++) - if (!XMARKBIT (sblk->symbols[i].plist)) - { - *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list; - symbol_free_list = &sblk->symbols[i]; + struct Lisp_Symbol *sym = sblk->symbols; + struct Lisp_Symbol *end = sym + lim; + + for (; sym < end; ++sym) + { + /* Check if the symbol was created during loadup. In such a case + it might be pointed to by pure bytecode which we don't trace, + so we conservatively assume that it is live. */ + int pure_p = PURE_POINTER_P (sym->name); + + if (!XMARKBIT (sym->plist) && !pure_p) + { + *(struct Lisp_Symbol **) &sym->value = symbol_free_list; + symbol_free_list = sym; #if GC_MARK_STACK - symbol_free_list->function = Vdead; + symbol_free_list->function = Vdead; #endif - this_free++; - } - else - { - num_used++; - if (!PURE_POINTER_P (sblk->symbols[i].name)) - UNMARK_STRING (sblk->symbols[i].name); - XUNMARK (sblk->symbols[i].plist); - } + ++this_free; + } + else + { + ++num_used; + if (!pure_p) + UNMARK_STRING (sym->name); + XUNMARK (sym->plist); + } + } + lim = SYMBOL_BLOCK_SIZE; /* If this block contains only free symbols and we have already seen more than two blocks worth of free symbols then deallocate @@ -4948,6 +5027,11 @@ gc_sweep () prev = vector, vector = vector->next; } } + +#ifdef GC_CHECK_STRING_BYTES + if (!noninteractive) + check_string_bytes (1); +#endif }