X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d942b71c340c317ffc6f35aca4c14279134107d2..44dc78e04abbd8fe6aa72c4a115f67ef907f35ab:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index df0ea1e587..3545f5256f 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. */ @@ -45,6 +39,7 @@ Boston, MA 02111-1307, USA. */ #undef HIDE_LISP_IMPLEMENTATION #include "lisp.h" +#include "process.h" #include "intervals.h" #include "puresize.h" #include "buffer.h" @@ -85,9 +80,6 @@ extern __malloc_size_t __malloc_extra_blocks; #endif /* not DOUG_LEA_MALLOC */ -#define max(A,B) ((A) > (B) ? (A) : (B)) -#define min(A,B) ((A) < (B) ? (A) : (B)) - /* Macro to verify that storage intended for Lisp objects is not out of range to fit in the space for a pointer. ADDRESS is the start of the block, and SIZE @@ -196,29 +188,30 @@ Lisp_Object Vpurify_flag; EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,}; #define PUREBEG (char *) pure -#else /* not HAVE_SHM */ +#else /* HAVE_SHM */ #define pure PURE_SEG_BITS /* Use shared memory segment */ #define PUREBEG (char *)PURE_SEG_BITS -/* This variable is used only by the XPNTR macro when HAVE_SHM is - defined. If we used the PURESIZE macro directly there, that would - make most of Emacs dependent on puresize.h, which we don't want - - you should be able to change that without too much recompilation. - So map_in_data initializes pure_size, and the dependencies work - out. */ +#endif /* HAVE_SHM */ + +/* Pointer to the pure area, and its size. */ -EMACS_INT pure_size; +static char *purebeg; +static size_t pure_size; -#endif /* not HAVE_SHM */ +/* Number of bytes of pure storage used before pure storage overflowed. + If this is non-zero, this implies that an overflow occurred. */ + +static size_t pure_bytes_used_before_overflow; /* Value is non-zero if P points into pure space. */ #define PURE_POINTER_P(P) \ (((PNTR_COMPARISON_TYPE) (P) \ - < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \ + < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \ && ((PNTR_COMPARISON_TYPE) (P) \ - >= (PNTR_COMPARISON_TYPE) pure)) + >= (PNTR_COMPARISON_TYPE) purebeg)) /* Index in pure at which next pure object will be allocated.. */ @@ -251,6 +244,10 @@ int ignore_warnings; Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots; +/* Hook run after GC has finished. */ + +Lisp_Object Vpost_gc_hook, Qpost_gc_hook; + static void mark_buffer P_ ((Lisp_Object)); static void mark_kboards P_ ((void)); static void gc_sweep P_ ((void)); @@ -282,7 +279,14 @@ enum mem_type MEM_TYPE_MISC, MEM_TYPE_SYMBOL, MEM_TYPE_FLOAT, - MEM_TYPE_VECTOR + /* Keep the following vector-like types together, with + MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the + first. Or change the code of live_vector_p, for instance. */ + MEM_TYPE_VECTOR, + MEM_TYPE_PROCESS, + MEM_TYPE_HASH_TABLE, + MEM_TYPE_FRAME, + MEM_TYPE_WINDOW }; #if GC_MARK_STACK || defined GC_MALLOC_CHECK @@ -349,15 +353,19 @@ Lisp_Object *stack_base; static struct mem_node *mem_root; +/* Lowest and highest known address in the heap. */ + +static void *min_heap_address, *max_heap_address; + /* Sentinel node of the tree. */ static struct mem_node mem_z; #define MEM_NIL &mem_z static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type)); +static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT, enum mem_type)); static void lisp_free P_ ((POINTER_TYPE *)); static void mark_stack P_ ((void)); -static void init_stack P_ ((Lisp_Object *)); static int live_vector_p P_ ((struct mem_node *, void *)); static int live_buffer_p P_ ((struct mem_node *, void *)); static int live_string_p P_ ((struct mem_node *, void *)); @@ -404,6 +412,7 @@ static POINTER_TYPE *pure_alloc P_ ((size_t, int)); #define ALIGN(SZ, ALIGNMENT) \ (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1)) + /************************************************************************ Malloc @@ -604,8 +613,11 @@ lisp_malloc (nbytes, type) struct buffer * allocate_buffer () { - return (struct buffer *) lisp_malloc (sizeof (struct buffer), - MEM_TYPE_BUFFER); + struct buffer *b + = (struct buffer *) lisp_malloc (sizeof (struct buffer), + MEM_TYPE_BUFFER); + VALIDATE_LISP_STORAGE (b, sizeof *b); + return b; } @@ -960,7 +972,7 @@ mark_interval_tree (tree) a cast. */ XMARK (tree->up.obj); - traverse_intervals (tree, 1, 0, mark_interval, Qnil); + traverse_intervals_noorder (tree, mark_interval, Qnil); } @@ -1201,50 +1213,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 +1340,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; } @@ -1604,17 +1659,17 @@ compact_small_strings () DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, - "Return a newly created string of length LENGTH, with each element being INIT.\n\ -Both LENGTH and INIT must be numbers.") - (length, init) + doc: /* Return a newly created string of length LENGTH, with each element being INIT. +Both LENGTH and INIT must be numbers. */) + (length, init) Lisp_Object length, init; { register Lisp_Object val; register unsigned char *p, *end; int c, nbytes; - CHECK_NATNUM (length, 0); - CHECK_NUMBER (init, 1); + CHECK_NATNUM (length); + CHECK_NUMBER (init); c = XINT (init); if (SINGLE_BYTE_CHAR_P (c)) @@ -1648,9 +1703,9 @@ Both LENGTH and INIT must be numbers.") DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0, - "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\ -LENGTH must be a number. INIT matters only in whether it is t or nil.") - (length, init) + doc: /* Return a new bool-vector of length LENGTH, using INIT for as each element. +LENGTH must be a number. INIT matters only in whether it is t or nil. */) + (length, init) Lisp_Object length, init; { register Lisp_Object val; @@ -1658,7 +1713,7 @@ LENGTH must be a number. INIT matters only in whether it is t or nil.") int real_init, i; int length_in_chars, length_in_elts, bits_per_value; - CHECK_NATNUM (length, 0); + CHECK_NATNUM (length); bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR; @@ -1863,7 +1918,7 @@ int n_float_blocks; struct Lisp_Float *float_free_list; -/* Initialze float allocation. */ +/* Initialize float allocation. */ void init_float () @@ -2002,8 +2057,8 @@ free_cons (ptr) DEFUN ("cons", Fcons, Scons, 2, 2, 0, - "Create a new cons, give it CAR and CDR as components, and return it.") - (car, cdr) + doc: /* Create a new cons, give it CAR and CDR as components, and return it. */) + (car, cdr) Lisp_Object car, cdr; { register Lisp_Object val; @@ -2031,8 +2086,8 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, XSETCONS (val, &cons_block->conses[cons_block_index++]); } - XCAR (val) = car; - XCDR (val) = cdr; + XSETCAR (val, car); + XSETCDR (val, cdr); consing_since_gc += sizeof (struct Lisp_Cons); cons_cells_consed++; return val; @@ -2075,9 +2130,10 @@ list5 (arg1, arg2, arg3, arg4, arg5) DEFUN ("list", Flist, Slist, 0, MANY, 0, - "Return a newly created list with specified arguments as elements.\n\ -Any number of arguments, even zero arguments, are allowed.") - (nargs, args) + doc: /* Return a newly created list with specified arguments as elements. +Any number of arguments, even zero arguments, are allowed. +usage: (list &rest OBJECTS) */) + (nargs, args) int nargs; register Lisp_Object *args; { @@ -2094,19 +2150,49 @@ Any number of arguments, even zero arguments, are allowed.") DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, - "Return a newly created list of length LENGTH, with each element being INIT.") - (length, init) + doc: /* Return a newly created list of length LENGTH, with each element being INIT. */) + (length, init) register Lisp_Object length, init; { register Lisp_Object val; register int size; - CHECK_NATNUM (length, 0); + CHECK_NATNUM (length); 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; } @@ -2128,9 +2214,10 @@ int n_vectors; /* Value is a pointer to a newly allocated Lisp_Vector structure with room for LEN Lisp_Objects. */ -struct Lisp_Vector * -allocate_vectorlike (len) +static struct Lisp_Vector * +allocate_vectorlike (len, type) EMACS_INT len; + enum mem_type type; { struct Lisp_Vector *p; size_t nbytes; @@ -2143,7 +2230,7 @@ allocate_vectorlike (len) #endif nbytes = sizeof *p + (len - 1) * sizeof p->contents[0]; - p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTOR); + p = (struct Lisp_Vector *) lisp_malloc (nbytes, type); #ifdef DOUG_LEA_MALLOC /* Back to a reasonable maximum of mmap'ed areas. */ @@ -2161,10 +2248,98 @@ allocate_vectorlike (len) } +/* Allocate a vector with NSLOTS slots. */ + +struct Lisp_Vector * +allocate_vector (nslots) + EMACS_INT nslots; +{ + struct Lisp_Vector *v = allocate_vectorlike (nslots, MEM_TYPE_VECTOR); + v->size = nslots; + return v; +} + + +/* Allocate other vector-like structures. */ + +struct Lisp_Hash_Table * +allocate_hash_table () +{ + EMACS_INT len = VECSIZE (struct Lisp_Hash_Table); + struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE); + EMACS_INT i; + + v->size = len; + for (i = 0; i < len; ++i) + v->contents[i] = Qnil; + + return (struct Lisp_Hash_Table *) v; +} + + +struct window * +allocate_window () +{ + EMACS_INT len = VECSIZE (struct window); + struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW); + EMACS_INT i; + + for (i = 0; i < len; ++i) + v->contents[i] = Qnil; + v->size = len; + + return (struct window *) v; +} + + +struct frame * +allocate_frame () +{ + EMACS_INT len = VECSIZE (struct frame); + struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME); + EMACS_INT i; + + for (i = 0; i < len; ++i) + v->contents[i] = make_number (0); + v->size = len; + return (struct frame *) v; +} + + +struct Lisp_Process * +allocate_process () +{ + EMACS_INT len = VECSIZE (struct Lisp_Process); + struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS); + EMACS_INT i; + + for (i = 0; i < len; ++i) + v->contents[i] = Qnil; + v->size = len; + + return (struct Lisp_Process *) v; +} + + +struct Lisp_Vector * +allocate_other_vector (len) + EMACS_INT len; +{ + struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR); + EMACS_INT i; + + for (i = 0; i < len; ++i) + v->contents[i] = Qnil; + v->size = len; + + return v; +} + + DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, - "Return a newly created vector of length LENGTH, with each element being INIT.\n\ -See also the function `vector'.") - (length, init) + doc: /* Return a newly created vector of length LENGTH, with each element being INIT. +See also the function `vector'. */) + (length, init) register Lisp_Object length, init; { Lisp_Object vector; @@ -2172,11 +2347,10 @@ See also the function `vector'.") register int index; register struct Lisp_Vector *p; - CHECK_NATNUM (length, 0); + CHECK_NATNUM (length); sizei = XFASTINT (length); - p = allocate_vectorlike (sizei); - p->size = sizei; + p = allocate_vector (sizei); for (index = 0; index < sizei; index++) p->contents[index] = init; @@ -2186,18 +2360,18 @@ See also the function `vector'.") DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0, - "Return a newly created char-table, with purpose PURPOSE.\n\ -Each element is initialized to INIT, which defaults to nil.\n\ -PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\ -The property's value should be an integer between 0 and 10.") - (purpose, init) + doc: /* Return a newly created char-table, with purpose PURPOSE. +Each element is initialized to INIT, which defaults to nil. +PURPOSE should be a symbol which has a `char-table-extra-slots' property. +The property's value should be an integer between 0 and 10. */) + (purpose, init) register Lisp_Object purpose, init; { Lisp_Object vector; Lisp_Object n; - CHECK_SYMBOL (purpose, 1); + CHECK_SYMBOL (purpose); n = Fget (purpose, Qchar_table_extra_slots); - CHECK_NUMBER (n, 0); + CHECK_NUMBER (n); if (XINT (n) < 0 || XINT (n) > 10) args_out_of_range (n, Qnil); /* Add 2 to the size for the defalt and parent slots. */ @@ -2229,9 +2403,10 @@ make_sub_char_table (defalt) DEFUN ("vector", Fvector, Svector, 0, MANY, 0, - "Return a newly created vector with specified arguments as elements.\n\ -Any number of arguments, even zero arguments, are allowed.") - (nargs, args) + doc: /* Return a newly created vector with specified arguments as elements. +Any number of arguments, even zero arguments, are allowed. +usage: (vector &rest OBJECTS) */) + (nargs, args) register int nargs; Lisp_Object *args; { @@ -2249,12 +2424,13 @@ Any number of arguments, even zero arguments, are allowed.") DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, - "Create a byte-code object with specified arguments as elements.\n\ -The arguments should be the arglist, bytecode-string, constant vector,\n\ -stack size, (optional) doc string, and (optional) interactive spec.\n\ -The first four arguments are required; at most six have any\n\ -significance.") - (nargs, args) + doc: /* Create a byte-code object with specified arguments as elements. +The arguments should be the arglist, bytecode-string, constant vector, +stack size, (optional) doc string, and (optional) interactive spec. +The first four arguments are required; at most six have any +significance. +usage: (make-byte-code &rest ELEMENTS) */) + (nargs, args) register int nargs; Lisp_Object *args; { @@ -2337,15 +2513,15 @@ init_symbol () DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, - "Return a newly allocated uninterned symbol whose name is NAME.\n\ -Its value and function definition are void, and its property list is nil.") - (name) + doc: /* Return a newly allocated uninterned symbol whose name is NAME. +Its value and function definition are void, and its property list is nil. */) + (name) Lisp_Object name; { register Lisp_Object val; register struct Lisp_Symbol *p; - CHECK_STRING (name, 0); + CHECK_STRING (name); if (symbol_free_list) { @@ -2370,11 +2546,13 @@ Its value and function definition are void, and its property list is nil.") p = XSYMBOL (val); p->name = XSTRING (name); - p->obarray = Qnil; p->plist = Qnil; p->value = Qunbound; p->function = Qunbound; - p->next = 0; + p->next = NULL; + p->interned = SYMBOL_UNINTERNED; + p->constant = 0; + p->indirect_variable = 0; consing_since_gc += sizeof (struct Lisp_Symbol); symbols_consed++; return val; @@ -2453,8 +2631,8 @@ allocate_misc () } DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, - "Return a newly allocated marker which does not point at any place.") - () + doc: /* Return a newly allocated marker which does not point at any place. */) + () { register Lisp_Object val; register struct Lisp_Marker *p; @@ -2555,6 +2733,9 @@ mem_find (start) { struct mem_node *p; + if (start < min_heap_address || start > max_heap_address) + return MEM_NIL; + /* Make the search always successful to speed up the loop below. */ mem_z.start = start; mem_z.end = (char *) start + 1; @@ -2577,6 +2758,11 @@ mem_insert (start, end, type) { struct mem_node *c, *parent, *x; + if (start < min_heap_address) + min_heap_address = start; + if (end > max_heap_address) + max_heap_address = end; + /* See where in the tree a node for START belongs. In this particular application, it shouldn't happen that a node is already present. For debugging purposes, let's check that. */ @@ -2937,7 +3123,8 @@ live_string_p (m, p) /* P must point to the start of a Lisp_String structure, and it must not be on the free-list. */ - return (offset % sizeof b->strings[0] == 0 + return (offset >= 0 + && offset % sizeof b->strings[0] == 0 && ((struct Lisp_String *) p)->data != NULL); } else @@ -2961,7 +3148,8 @@ live_cons_p (m, p) /* P must point to the start of a Lisp_Cons, not be one of the unused cells in the current cons block, and not be on the free-list. */ - return (offset % sizeof b->conses[0] == 0 + return (offset >= 0 + && offset % sizeof b->conses[0] == 0 && (b != cons_block || offset / sizeof b->conses[0] < cons_block_index) && !EQ (((struct Lisp_Cons *) p)->car, Vdead)); @@ -2987,7 +3175,8 @@ live_symbol_p (m, p) /* P must point to the start of a Lisp_Symbol, not be one of the unused cells in the current symbol block, and not be on the free-list. */ - return (offset % sizeof b->symbols[0] == 0 + return (offset >= 0 + && offset % sizeof b->symbols[0] == 0 && (b != symbol_block || offset / sizeof b->symbols[0] < symbol_block_index) && !EQ (((struct Lisp_Symbol *) p)->function, Vdead)); @@ -3013,7 +3202,8 @@ live_float_p (m, p) /* P must point to the start of a Lisp_Float, not be one of the unused cells in the current float block, and not be on the free-list. */ - return (offset % sizeof b->floats[0] == 0 + return (offset >= 0 + && offset % sizeof b->floats[0] == 0 && (b != float_block || offset / sizeof b->floats[0] < float_block_index) && !EQ (((struct Lisp_Float *) p)->type, Vdead)); @@ -3039,7 +3229,8 @@ live_misc_p (m, p) /* P must point to the start of a Lisp_Misc, not be one of the unused cells in the current misc block, and not be on the free-list. */ - return (offset % sizeof b->markers[0] == 0 + return (offset >= 0 + && offset % sizeof b->markers[0] == 0 && (b != marker_block || offset / sizeof b->markers[0] < marker_block_index) && ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free); @@ -3057,7 +3248,9 @@ live_vector_p (m, p) struct mem_node *m; void *p; { - return m->type == MEM_TYPE_VECTOR && p == m->start; + return (p == m->start + && m->type >= MEM_TYPE_VECTOR + && m->type <= MEM_TYPE_WINDOW); } @@ -3109,7 +3302,7 @@ static int max_live, max_zombies; static double avg_live; DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "", - "Show information about live and zombie objects.") + doc: /* Show information about live and zombie objects. */) () { Lisp_Object args[7]; @@ -3209,14 +3402,123 @@ mark_maybe_object (obj) } } } + + +/* If P points to Lisp data, mark that as live if it isn't already + marked. */ + +static INLINE void +mark_maybe_pointer (p) + void *p; +{ + struct mem_node *m; + + /* Quickly rule out some values which can't point to Lisp data. We + assume that Lisp data is aligned on even addresses. */ + if ((EMACS_INT) p & 1) + return; + + m = mem_find (p); + if (m != MEM_NIL) + { + Lisp_Object obj = Qnil; + + switch (m->type) + { + case MEM_TYPE_NON_LISP: + /* Nothing to do; not a pointer to Lisp memory. */ + break; + + case MEM_TYPE_BUFFER: + if (live_buffer_p (m, p) + && !XMARKBIT (((struct buffer *) p)->name)) + XSETVECTOR (obj, p); + break; + + case MEM_TYPE_CONS: + if (live_cons_p (m, p) + && !XMARKBIT (((struct Lisp_Cons *) p)->car)) + XSETCONS (obj, p); + break; + + case MEM_TYPE_STRING: + if (live_string_p (m, p) + && !STRING_MARKED_P ((struct Lisp_String *) p)) + XSETSTRING (obj, p); + break; + + case MEM_TYPE_MISC: + if (live_misc_p (m, p)) + { + Lisp_Object tem; + XSETMISC (tem, p); + + switch (XMISCTYPE (tem)) + { + case Lisp_Misc_Marker: + if (!XMARKBIT (XMARKER (tem)->chain)) + obj = tem; + break; + + case Lisp_Misc_Buffer_Local_Value: + case Lisp_Misc_Some_Buffer_Local_Value: + if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue)) + obj = tem; + break; + + case Lisp_Misc_Overlay: + if (!XMARKBIT (XOVERLAY (tem)->plist)) + obj = tem; + break; + } + } + break; + + case MEM_TYPE_SYMBOL: + if (live_symbol_p (m, p) + && !XMARKBIT (((struct Lisp_Symbol *) p)->plist)) + XSETSYMBOL (obj, p); + break; + + case MEM_TYPE_FLOAT: + if (live_float_p (m, p) + && !XMARKBIT (((struct Lisp_Float *) p)->type)) + XSETFLOAT (obj, p); + break; -/* Mark Lisp objects in the address range START..END. */ + case MEM_TYPE_VECTOR: + case MEM_TYPE_PROCESS: + case MEM_TYPE_HASH_TABLE: + case MEM_TYPE_FRAME: + case MEM_TYPE_WINDOW: + if (live_vector_p (m, p)) + { + Lisp_Object tem; + XSETVECTOR (tem, p); + if (!GC_SUBRP (tem) + && !(XVECTOR (tem)->size & ARRAY_MARK_FLAG)) + obj = tem; + } + break; + + default: + abort (); + } + + if (!GC_NILP (obj)) + mark_object (&obj); + } +} + + +/* Mark Lisp objects referenced from the address range START..END. */ static void mark_memory (start, end) void *start, *end; { Lisp_Object *p; + void **pp; #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES nzombies = 0; @@ -3230,9 +3532,31 @@ mark_memory (start, end) start = end; end = tem; } - + + /* Mark Lisp_Objects. */ for (p = (Lisp_Object *) start; (void *) p < end; ++p) mark_maybe_object (*p); + + /* Mark Lisp data pointed to. This is necessary because, in some + situations, the C compiler optimizes Lisp objects away, so that + only a pointer to them remains. Example: + + DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "") + () + { + Lisp_Object obj = build_string ("test"); + struct Lisp_String *s = XSTRING (obj); + Fgarbage_collect (); + fprintf (stderr, "test `%s'\n", s->data); + return Qnil; + } + + Here, `obj' isn't really used, and the compiler optimizes it + away. The only reference to the life string is through the + pointer `s'. */ + + for (pp = (void **) start; (void *) pp < end; ++pp) + mark_maybe_pointer (*pp); } @@ -3474,7 +3798,7 @@ pure_alloc (size, type) { size_t nbytes; POINTER_TYPE *result; - char *beg = PUREBEG; + char *beg = purebeg; /* Give Lisp_Floats an extra alignment. */ if (type == Lisp_Float) @@ -3489,8 +3813,14 @@ pure_alloc (size, type) } nbytes = ALIGN (size, sizeof (EMACS_INT)); - if (pure_bytes_used + nbytes > PURESIZE) - error ("Pure Lisp storage exhausted"); + + if (pure_bytes_used + nbytes > pure_size) + { + beg = purebeg = (char *) xmalloc (PURESIZE); + pure_size = PURESIZE; + pure_bytes_used_before_overflow += pure_bytes_used; + pure_bytes_used = 0; + } result = (POINTER_TYPE *) (beg + pure_bytes_used); pure_bytes_used += nbytes; @@ -3498,6 +3828,17 @@ pure_alloc (size, type) } +/* Signal an error if PURESIZE is too small. */ + +void +check_pure_size () +{ + if (pure_bytes_used_before_overflow) + error ("Pure Lisp storage overflow (approx. %d bytes needed)", + (int) (pure_bytes_used + pure_bytes_used_before_overflow)); +} + + /* Return a string allocated in pure space. DATA is a buffer holding NCHARS characters, and NBYTES bytes of string data. MULTIBYTE non-zero means make the result string multibyte. @@ -3539,8 +3880,8 @@ pure_cons (car, cdr) p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons); XSETCONS (new, p); - XCAR (new) = Fpurecopy (car); - XCDR (new) = Fpurecopy (cdr); + XSETCAR (new, Fpurecopy (car)); + XSETCDR (new, Fpurecopy (cdr)); return new; } @@ -3580,10 +3921,10 @@ make_pure_vector (len) DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, - "Make a copy of OBJECT in pure storage.\n\ -Recursively copies contents of vectors and cons cells.\n\ -Does not copy symbols. Copies strings without text properties.") - (obj) + doc: /* Make a copy of OBJECT in pure storage. +Recursively copies contents of vectors and cons cells. +Does not copy symbols. Copies strings without text properties. */) + (obj) register Lisp_Object obj; { if (NILP (Vpurify_flag)) @@ -3671,27 +4012,21 @@ int inhibit_garbage_collection () { int count = specpdl_ptr - specpdl; - Lisp_Object number; - int nbits = min (VALBITS, BITS_PER_INT); - - XSETINT (number, ((EMACS_INT) 1 << (nbits - 1)) - 1); - - specbind (Qgc_cons_threshold, number); - + specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); return count; } DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", - "Reclaim storage for Lisp objects no longer needed.\n\ -Returns info on amount of space in use:\n\ - ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\ - (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\ - (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\ - (USED-STRINGS . FREE-STRINGS))\n\ -Garbage collection happens automatically if you cons more than\n\ -`gc-cons-threshold' bytes of Lisp data since previous garbage collection.") - () + doc: /* Reclaim storage for Lisp objects no longer needed. +Returns info on amount of space in use: + ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) + (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS + (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS) + (USED-STRINGS . FREE-STRINGS)) +Garbage collection happens automatically if you cons more than +`gc-cons-threshold' bytes of Lisp data since previous garbage collection. */) + () { register struct gcpro *tail; register struct specbinding *bind; @@ -3701,7 +4036,13 @@ Garbage collection happens automatically if you cons more than\n\ char stack_top_variable; register int i; int message_p; - Lisp_Object total[7]; + Lisp_Object total[8]; + int count = BINDING_STACK_SIZE (); + + /* Can't GC if pure storage overflowed because we can't determine + if something is a pure object or not. */ + if (pure_bytes_used_before_overflow) + return Qnil; /* In case user calls debug_print during GC, don't let that cause a recursive GC. */ @@ -3709,6 +4050,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 @@ -3849,7 +4191,10 @@ Garbage collection happens automatically if you cons more than\n\ if (NILP (prev)) nextb->undo_list = tail = XCDR (tail); else - tail = XCDR (prev) = XCDR (tail); + { + tail = XCDR (tail); + XSETCDR (prev, tail); + } } else { @@ -3913,7 +4258,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)); @@ -3921,13 +4266,13 @@ Garbage collection happens automatically if you cons more than\n\ make_number (total_free_symbols)); total[2] = Fcons (make_number (total_markers), make_number (total_free_markers)); - total[3] = Fcons (make_number (total_string_size), - make_number (total_vector_size)); - total[4] = Fcons (make_number (total_floats), + total[3] = make_number (total_string_size); + total[4] = make_number (total_vector_size); + total[5] = Fcons (make_number (total_floats), make_number (total_free_floats)); - total[5] = Fcons (make_number (total_intervals), + total[6] = Fcons (make_number (total_intervals), make_number (total_free_intervals)); - total[6] = Fcons (make_number (total_strings), + total[7] = Fcons (make_number (total_strings), make_number (total_free_strings)); #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES @@ -3946,7 +4291,14 @@ Garbage collection happens automatically if you cons more than\n\ } #endif - return Flist (7, total); + if (!NILP (Vpost_gc_hook)) + { + int count = inhibit_garbage_collection (); + safe_run_hooks (Qpost_gc_hook); + unbind_to (count, Qnil); + } + + return Flist (sizeof total / sizeof *total, total); } @@ -4109,13 +4461,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; @@ -4457,8 +4805,8 @@ mark_buffer (buf) && ! XMARKBIT (XCAR (ptr->car)) && GC_MARKERP (XCAR (ptr->car))) { - XMARK (XCAR (ptr->car)); - mark_object (&XCDR (ptr->car)); + XMARK (XCAR_AS_LVALUE (ptr->car)); + mark_object (&XCDR_AS_LVALUE (ptr->car)); } else mark_object (&ptr->car); @@ -4469,7 +4817,7 @@ mark_buffer (buf) break; } - mark_object (&XCDR (tail)); + mark_object (&XCDR_AS_LVALUE (tail)); } else mark_object (&buffer->undo_list); @@ -4606,6 +4954,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 +5116,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 +5310,11 @@ gc_sweep () prev = vector, vector = vector->next; } } + +#ifdef GC_CHECK_STRING_BYTES + if (!noninteractive) + check_string_bytes (1); +#endif } @@ -4956,10 +5323,10 @@ gc_sweep () /* Debugging aids. */ DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0, - "Return the address of the last byte Emacs has allocated, divided by 1024.\n\ -This may be helpful in debugging Emacs's memory usage.\n\ -We divide the value by 1024 to make sure it fits in a Lisp integer.") - () + doc: /* Return the address of the last byte Emacs has allocated, divided by 1024. +This may be helpful in debugging Emacs's memory usage. +We divide the value by 1024 to make sure it fits in a Lisp integer. */) + () { Lisp_Object end; @@ -4969,38 +5336,30 @@ We divide the value by 1024 to make sure it fits in a Lisp integer.") } DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0, - "Return a list of counters that measure how much consing there has been.\n\ -Each of these counters increments for a certain kind of object.\n\ -The counters wrap around from the largest positive integer to zero.\n\ -Garbage collection does not decrease them.\n\ -The elements of the value are as follows:\n\ - (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\ -All are in units of 1 = one object consed\n\ -except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\ -objects consed.\n\ -MISCS include overlays, markers, and some internal types.\n\ -Frames, windows, buffers, and subprocesses count as vectors\n\ - (but the contents of a buffer's text do not count here).") - () + doc: /* Return a list of counters that measure how much consing there has been. +Each of these counters increments for a certain kind of object. +The counters wrap around from the largest positive integer to zero. +Garbage collection does not decrease them. +The elements of the value are as follows: + (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS) +All are in units of 1 = one object consed +except for VECTOR-CELLS and STRING-CHARS, which count the total length of +objects consed. +MISCS include overlays, markers, and some internal types. +Frames, windows, buffers, and subprocesses count as vectors + (but the contents of a buffer's text do not count here). */) + () { Lisp_Object consed[8]; - XSETINT (consed[0], - cons_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[1], - floats_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[2], - vector_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[3], - symbols_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[4], - string_chars_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[5], - misc_objects_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[6], - intervals_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); - XSETINT (consed[7], - strings_consed & ~(((EMACS_INT) 1) << (VALBITS - 1))); + consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed)); + consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed)); + consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed)); + consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed)); + consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed)); + consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed)); + consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed)); + consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed)); return Flist (8, consed); } @@ -5023,14 +5382,16 @@ void init_alloc_once () { /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ + purebeg = PUREBEG; + pure_size = PURESIZE; pure_bytes_used = 0; + pure_bytes_used_before_overflow = 0; + #if GC_MARK_STACK || defined GC_MALLOC_CHECK mem_init (); Vdead = make_pure_string ("DEAD", 4, 4, 0); #endif -#ifdef HAVE_SHM - pure_size = PURESIZE; -#endif + all_vectors = 0; ignore_warnings = 1; #ifdef DOUG_LEA_MALLOC @@ -5081,63 +5442,71 @@ void syms_of_alloc () { DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold, - "*Number of bytes of consing between garbage collections.\n\ -Garbage collection can happen automatically once this many bytes have been\n\ -allocated since the last garbage collection. All data types count.\n\n\ -Garbage collection happens automatically only when `eval' is called.\n\n\ -By binding this temporarily to a large number, you can effectively\n\ -prevent garbage collection during a part of the program."); + doc: /* *Number of bytes of consing between garbage collections. +Garbage collection can happen automatically once this many bytes have been +allocated since the last garbage collection. All data types count. + +Garbage collection happens automatically only when `eval' is called. + +By binding this temporarily to a large number, you can effectively +prevent garbage collection during a part of the program. */); DEFVAR_INT ("pure-bytes-used", &pure_bytes_used, - "Number of bytes of sharable Lisp data allocated so far."); + doc: /* Number of bytes of sharable Lisp data allocated so far. */); DEFVAR_INT ("cons-cells-consed", &cons_cells_consed, - "Number of cons cells that have been consed so far."); + doc: /* Number of cons cells that have been consed so far. */); DEFVAR_INT ("floats-consed", &floats_consed, - "Number of floats that have been consed so far."); + doc: /* Number of floats that have been consed so far. */); DEFVAR_INT ("vector-cells-consed", &vector_cells_consed, - "Number of vector cells that have been consed so far."); + doc: /* Number of vector cells that have been consed so far. */); DEFVAR_INT ("symbols-consed", &symbols_consed, - "Number of symbols that have been consed so far."); + doc: /* Number of symbols that have been consed so far. */); DEFVAR_INT ("string-chars-consed", &string_chars_consed, - "Number of string characters that have been consed so far."); + doc: /* Number of string characters that have been consed so far. */); DEFVAR_INT ("misc-objects-consed", &misc_objects_consed, - "Number of miscellaneous objects that have been consed so far."); + doc: /* Number of miscellaneous objects that have been consed so far. */); DEFVAR_INT ("intervals-consed", &intervals_consed, - "Number of intervals that have been consed so far."); + doc: /* Number of intervals that have been consed so far. */); DEFVAR_INT ("strings-consed", &strings_consed, - "Number of strings that have been consed so far."); + doc: /* Number of strings that have been consed so far. */); DEFVAR_LISP ("purify-flag", &Vpurify_flag, - "Non-nil means loading Lisp code in order to dump an executable.\n\ -This means that certain objects should be allocated in shared (pure) space."); + doc: /* Non-nil means loading Lisp code in order to dump an executable. +This means that certain objects should be allocated in shared (pure) space. */); DEFVAR_INT ("undo-limit", &undo_limit, - "Keep no more undo information once it exceeds this size.\n\ -This limit is applied when garbage collection happens.\n\ -The size is counted as the number of bytes occupied,\n\ -which includes both saved text and other data."); + doc: /* Keep no more undo information once it exceeds this size. +This limit is applied when garbage collection happens. +The size is counted as the number of bytes occupied, +which includes both saved text and other data. */); undo_limit = 20000; DEFVAR_INT ("undo-strong-limit", &undo_strong_limit, - "Don't keep more than this much size of undo information.\n\ -A command which pushes past this size is itself forgotten.\n\ -This limit is applied when garbage collection happens.\n\ -The size is counted as the number of bytes occupied,\n\ -which includes both saved text and other data."); + doc: /* Don't keep more than this much size of undo information. +A command which pushes past this size is itself forgotten. +This limit is applied when garbage collection happens. +The size is counted as the number of bytes occupied, +which includes both saved text and other data. */); undo_strong_limit = 30000; DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages, - "Non-nil means display messages at start and end of garbage collection."); + doc: /* Non-nil means display messages at start and end of garbage collection. */); garbage_collection_messages = 0; + DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook, + doc: /* Hook run after garbage collection has finished. */); + Vpost_gc_hook = Qnil; + Qpost_gc_hook = intern ("post-gc-hook"); + staticpro (&Qpost_gc_hook); + /* We build this in advance because if we wait until we need it, we might not be able to allocate the memory to hold it. */ memory_signal_data