X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/c70bbf0690d929279a16a5176c643828b9c2fe8f..44dc78e04abbd8fe6aa72c4a115f67ef907f35ab:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 85b9d42f1a..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,11 +26,12 @@ Boston, MA 02111-1307, USA. */ #include -/* Define this temporarily to hunt a bug. If defined, the size of - strings is always recorded in sdata structures so that it can be - compared to the sizes recorded in Lisp strings. */ +/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd + memory. Can do this only if using gmalloc.c. */ -#define GC_CHECK_STRING_BYTES 1 +#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC +#undef GC_MALLOC_CHECK +#endif /* This file is part of the core Lisp implementation, and thus must deal with the real data structures. If the Lisp implementation is @@ -38,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" @@ -78,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 @@ -189,33 +188,34 @@ 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. */ + +static char *purebeg; +static size_t pure_size; -EMACS_INT pure_size; +/* Number of bytes of pure storage used before pure storage overflowed. + If this is non-zero, this implies that an overflow occurred. */ -#endif /* not HAVE_SHM */ +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.. */ -int pureptr; +int pure_bytes_used; /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ @@ -244,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)); @@ -275,10 +279,17 @@ 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 +#if GC_MARK_STACK || defined GC_MALLOC_CHECK #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES #include /* For fprintf. */ @@ -289,11 +300,72 @@ enum mem_type Lisp_Object Vdead; -struct mem_node; +#ifdef GC_MALLOC_CHECK + +enum mem_type allocated_mem_type; +int dont_register_blocks; + +#endif /* GC_MALLOC_CHECK */ + +/* A node in the red-black tree describing allocated memory containing + Lisp data. Each such block is recorded with its start and end + address when it is allocated, and removed from the tree when it + is freed. + + A red-black tree is a balanced binary tree with the following + properties: + + 1. Every node is either red or black. + 2. Every leaf is black. + 3. If a node is red, then both of its children are black. + 4. Every simple path from a node to a descendant leaf contains + the same number of black nodes. + 5. The root is always black. + + When nodes are inserted into the tree, or deleted from the tree, + the tree is "fixed" so that these properties are always true. + + A red-black tree with N internal nodes has height at most 2 + log(N+1). Searches, insertions and deletions are done in O(log N). + Please see a text book about data structures for a detailed + description of red-black trees. Any book worth its salt should + describe them. */ + +struct mem_node +{ + struct mem_node *left, *right, *parent; + + /* Start and end of allocated region. */ + void *start, *end; + + /* Node color. */ + enum {MEM_BLACK, MEM_RED} color; + + /* Memory type. */ + enum mem_type type; +}; + +/* Base address of stack. Set in main. */ + +Lisp_Object *stack_base; + +/* Root of the tree describing allocated Lisp memory. */ + +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 *)); @@ -316,7 +388,30 @@ static INLINE struct mem_node *mem_find P_ ((void *)); static void check_gcpros P_ ((void)); #endif -#endif /* GC_MARK_STACK != 0 */ +#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */ + +/* Recording what needs to be marked for gc. */ + +struct gcpro *gcprolist; + +/* Addresses of staticpro'd variables. */ + +#define NSTATICS 1024 +Lisp_Object *staticvec[NSTATICS] = {0}; + +/* Index of next unused slot in staticvec. */ + +int staticidx = 0; + +static POINTER_TYPE *pure_alloc P_ ((size_t, int)); + + +/* Value is SZ rounded up to the next multiple of ALIGNMENT. + ALIGNMENT must be a power of 2. */ + +#define ALIGN(SZ, ALIGNMENT) \ + (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1)) + /************************************************************************ @@ -493,13 +588,18 @@ lisp_malloc (nbytes, type) register void *val; BLOCK_INPUT; + +#ifdef GC_MALLOC_CHECK + allocated_mem_type = type; +#endif + val = (void *) malloc (nbytes); -#if GC_MARK_STACK +#if GC_MARK_STACK && !defined GC_MALLOC_CHECK if (val && type != MEM_TYPE_NON_LISP) mem_insert (val, (char *) val + nbytes, type); #endif - + UNBLOCK_INPUT; if (!val && nbytes) memory_full (); @@ -513,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; } @@ -527,7 +630,7 @@ lisp_free (block) { BLOCK_INPUT; free (block); -#if GC_MARK_STACK +#if GC_MARK_STACK && !defined GC_MALLOC_CHECK mem_delete (mem_find (block)); #endif UNBLOCK_INPUT; @@ -562,8 +665,30 @@ emacs_blocked_free (ptr) void *ptr; { BLOCK_INPUT; + +#ifdef GC_MALLOC_CHECK + if (ptr) + { + struct mem_node *m; + + m = mem_find (ptr); + if (m == MEM_NIL || m->start != ptr) + { + fprintf (stderr, + "Freeing `%p' which wasn't allocated with malloc\n", ptr); + abort (); + } + else + { + /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */ + mem_delete (m); + } + } +#endif /* GC_MALLOC_CHECK */ + __free_hook = old_free_hook; free (ptr); + /* If we released our reserve (due to running out of memory), and we have a fair amount free once again, try to set aside another reserve in case we run out once more. */ @@ -610,10 +735,34 @@ emacs_blocked_malloc (size) #else __malloc_extra_blocks = malloc_hysteresis; #endif + value = (void *) malloc (size); + +#ifdef GC_MALLOC_CHECK + { + struct mem_node *m = mem_find (value); + if (m != MEM_NIL) + { + fprintf (stderr, "Malloc returned %p which is already in use\n", + value); + fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n", + m->start, m->end, (char *) m->end - (char *) m->start, + m->type); + abort (); + } + + if (!dont_register_blocks) + { + mem_insert (value, (char *) value + max (1, size), allocated_mem_type); + allocated_mem_type = MEM_TYPE_NON_LISP; + } + } +#endif /* GC_MALLOC_CHECK */ + __malloc_hook = emacs_blocked_malloc; UNBLOCK_INPUT; + /* fprintf (stderr, "%p malloc\n", value); */ return value; } @@ -629,7 +778,48 @@ emacs_blocked_realloc (ptr, size) BLOCK_INPUT; __realloc_hook = old_realloc_hook; + +#ifdef GC_MALLOC_CHECK + if (ptr) + { + struct mem_node *m = mem_find (ptr); + if (m == MEM_NIL || m->start != ptr) + { + fprintf (stderr, + "Realloc of %p which wasn't allocated with malloc\n", + ptr); + abort (); + } + + mem_delete (m); + } + + /* fprintf (stderr, "%p -> realloc\n", ptr); */ + + /* Prevent malloc from registering blocks. */ + dont_register_blocks = 1; +#endif /* GC_MALLOC_CHECK */ + value = (void *) realloc (ptr, size); + +#ifdef GC_MALLOC_CHECK + dont_register_blocks = 0; + + { + struct mem_node *m = mem_find (value); + if (m != MEM_NIL) + { + fprintf (stderr, "Realloc returns memory that is already in use\n"); + abort (); + } + + /* Can't handle zero size regions in the red-black tree. */ + mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP); + } + + /* fprintf (stderr, "%p <- realloc\n", value); */ +#endif /* GC_MALLOC_CHECK */ + __realloc_hook = emacs_blocked_realloc; UNBLOCK_INPUT; @@ -782,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); } @@ -1021,6 +1211,91 @@ init_strings () } +#ifdef GC_CHECK_STRING_BYTES + +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_sblock (b) + struct sblock *b; +{ + struct sdata *from, *end, *from_end; + + end = b->next_free; + + 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; + + /* 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); + + 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 */ + + /* Return a new Lisp_String. */ static struct Lisp_String * @@ -1064,6 +1339,23 @@ allocate_string () ++strings_consed; consing_since_gc += sizeof *s; +#ifdef GC_CHECK_STRING_BYTES + if (!noninteractive +#ifdef macintosh + && current_sblock +#endif + ) + { + if (++check_string_bytes_count == 200) + { + check_string_bytes_count = 0; + check_string_bytes (1); + } + else + check_string_bytes (0); + } +#endif /* GC_CHECK_STRING_BYTES */ + return s; } @@ -1367,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)) @@ -1391,7 +1683,7 @@ Both LENGTH and INIT must be numbers.") } else { - unsigned char str[4]; + unsigned char str[MAX_MULTIBYTE_LENGTH]; int len = CHAR_STRING (c, str); nbytes = len * XINT (length); @@ -1411,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; @@ -1421,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; @@ -1464,12 +1756,12 @@ make_string (contents, nbytes) int nchars, multibyte_nbytes; parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes); - val = make_uninit_multibyte_string (nchars, nbytes); - bcopy (contents, XSTRING (val)->data, nbytes); if (nbytes == nchars || nbytes != multibyte_nbytes) /* CONTENTS contains no multibyte sequences or contains an invalid multibyte sequence. We must make unibyte string. */ - SET_STRING_BYTES (XSTRING (val), -1); + val = make_unibyte_string (contents, nbytes); + else + val = make_multibyte_string (contents, nchars, nbytes); return val; } @@ -1626,7 +1918,7 @@ int n_float_blocks; struct Lisp_Float *float_free_list; -/* Initialze float allocation. */ +/* Initialize float allocation. */ void init_float () @@ -1765,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; @@ -1794,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; @@ -1838,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; { @@ -1857,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; } @@ -1891,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; @@ -1906,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. */ @@ -1924,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; @@ -1935,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; @@ -1949,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. */ @@ -1992,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; { @@ -2012,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; { @@ -2100,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) { @@ -2133,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; @@ -2216,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; @@ -2294,60 +2709,7 @@ make_event_array (nargs, args) C Stack Marking ************************************************************************/ -#if GC_MARK_STACK - - -/* Base address of stack. Set in main. */ - -Lisp_Object *stack_base; - -/* A node in the red-black tree describing allocated memory containing - Lisp data. Each such block is recorded with its start and end - address when it is allocated, and removed from the tree when it - is freed. - - A red-black tree is a balanced binary tree with the following - properties: - - 1. Every node is either red or black. - 2. Every leaf is black. - 3. If a node is red, then both of its children are black. - 4. Every simple path from a node to a descendant leaf contains - the same number of black nodes. - 5. The root is always black. - - When nodes are inserted into the tree, or deleted from the tree, - the tree is "fixed" so that these properties are always true. - - A red-black tree with N internal nodes has height at most 2 - log(N+1). Searches, insertions and deletions are done in O(log N). - Please see a text book about data structures for a detailed - description of red-black trees. Any book worth its salt should - describe them. */ - -struct mem_node -{ - struct mem_node *left, *right, *parent; - - /* Start and end of allocated region. */ - void *start, *end; - - /* Node color. */ - enum {MEM_BLACK, MEM_RED} color; - - /* Memory type. */ - enum mem_type type; -}; - -/* Root of the tree describing allocated Lisp memory. */ - -static struct mem_node *mem_root; - -/* Sentinel node of the tree. */ - -static struct mem_node mem_z; -#define MEM_NIL &mem_z - +#if GC_MARK_STACK || defined GC_MALLOC_CHECK /* Initialize this part of alloc.c. */ @@ -2371,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; @@ -2393,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. */ @@ -2420,7 +2790,13 @@ mem_insert (start, end, type) #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ /* Create a new node. */ +#ifdef GC_MALLOC_CHECK + x = (struct mem_node *) _malloc_internal (sizeof *x); + if (x == NULL) + abort (); +#else x = (struct mem_node *) xmalloc (sizeof *x); +#endif x->start = start; x->end = end; x->type = type; @@ -2441,6 +2817,7 @@ mem_insert (start, end, type) /* Re-establish red-black tree properties. */ mem_insert_fixup (x); + return x; } @@ -2640,7 +3017,12 @@ mem_delete (z) if (y->color == MEM_BLACK) mem_delete_fixup (x); + +#ifdef GC_MALLOC_CHECK + _free_internal (y); +#else xfree (y); +#endif } @@ -2741,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 @@ -2765,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)); @@ -2791,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)); @@ -2817,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)); @@ -2843,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); @@ -2861,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); } @@ -2880,6 +3269,9 @@ live_buffer_p (m, p) && !NILP (((struct buffer *) p)->name)); } +#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */ + +#if GC_MARK_STACK #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES @@ -2910,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]; @@ -3010,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; -/* Mark Lisp objects in the address range START..END. */ + 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; + + 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; @@ -3031,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); } @@ -3261,6 +3784,61 @@ mark_stack () Pure Storage Management ***********************************************************************/ +/* Allocate room for SIZE bytes from pure Lisp storage and return a + pointer to it. TYPE is the Lisp type for which the memory is + allocated. TYPE < 0 means it's not used for a Lisp object. + + If store_pure_type_info is set and TYPE is >= 0, the type of + the allocated object is recorded in pure_types. */ + +static POINTER_TYPE * +pure_alloc (size, type) + size_t size; + int type; +{ + size_t nbytes; + POINTER_TYPE *result; + char *beg = purebeg; + + /* Give Lisp_Floats an extra alignment. */ + if (type == Lisp_Float) + { + size_t alignment; +#if defined __GNUC__ && __GNUC__ >= 2 + alignment = __alignof (struct Lisp_Float); +#else + alignment = sizeof (struct Lisp_Float); +#endif + pure_bytes_used = ALIGN (pure_bytes_used, alignment); + } + + nbytes = ALIGN (size, sizeof (EMACS_INT)); + + 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; + return result; +} + + +/* 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. @@ -3277,29 +3855,14 @@ make_pure_string (data, nchars, nbytes, multibyte) { Lisp_Object string; struct Lisp_String *s; - int string_size, data_size; -#define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1)) - - string_size = PAD (sizeof (struct Lisp_String)); - data_size = PAD (nbytes + 1); - -#undef PAD - - if (pureptr + string_size + data_size > PURESIZE) - error ("Pure Lisp storage exhausted"); - - s = (struct Lisp_String *) (PUREBEG + pureptr); - pureptr += string_size; - s->data = (unsigned char *) (PUREBEG + pureptr); - pureptr += data_size; - + s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String); + s->data = (unsigned char *) pure_alloc (nbytes + 1, -1); s->size = nchars; s->size_byte = multibyte ? nbytes : -1; bcopy (data, s->data, nbytes); s->data[nbytes] = '\0'; s->intervals = NULL_INTERVAL; - XSETSTRING (string, s); return string; } @@ -3313,13 +3876,12 @@ pure_cons (car, cdr) Lisp_Object car, cdr; { register Lisp_Object new; + struct Lisp_Cons *p; - if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE) - error ("Pure Lisp storage exhausted"); - XSETCONS (new, PUREBEG + pureptr); - pureptr += sizeof (struct Lisp_Cons); - XCAR (new) = Fpurecopy (car); - XCDR (new) = Fpurecopy (cdr); + p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons); + XSETCONS (new, p); + XSETCAR (new, Fpurecopy (car)); + XSETCDR (new, Fpurecopy (cdr)); return new; } @@ -3331,34 +3893,11 @@ make_pure_float (num) double num; { register Lisp_Object new; + struct Lisp_Float *p; - /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof - (double) boundary. Some architectures (like the sparc) require - this, and I suspect that floats are rare enough that it's no - tragedy for those that do. */ - { - size_t alignment; - char *p = PUREBEG + pureptr; - -#ifdef __GNUC__ -#if __GNUC__ >= 2 - alignment = __alignof (struct Lisp_Float); -#else - alignment = sizeof (struct Lisp_Float); -#endif -#else - alignment = sizeof (struct Lisp_Float); -#endif - p = (char *) (((unsigned long) p + alignment - 1) & - alignment); - pureptr = p - PUREBEG; - } - - if (pureptr + sizeof (struct Lisp_Float) > PURESIZE) - error ("Pure Lisp storage exhausted"); - XSETFLOAT (new, PUREBEG + pureptr); - pureptr += sizeof (struct Lisp_Float); + p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float); + XSETFLOAT (new, p); XFLOAT_DATA (new) = num; - XSETFASTINT (XFLOAT (new)->type, 0); /* bug chasing -wsr */ return new; } @@ -3370,32 +3909,28 @@ Lisp_Object make_pure_vector (len) EMACS_INT len; { - register Lisp_Object new; - register EMACS_INT size = (sizeof (struct Lisp_Vector) - + (len - 1) * sizeof (Lisp_Object)); - - if (pureptr + size > PURESIZE) - error ("Pure Lisp storage exhausted"); + Lisp_Object new; + struct Lisp_Vector *p; + size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object); - XSETVECTOR (new, PUREBEG + pureptr); - pureptr += size; + p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike); + XSETVECTOR (new, p); XVECTOR (new)->size = len; return new; } 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)) return obj; - if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE) - && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure) + if (PURE_POINTER_P (XPNTR (obj))) return obj; if (CONSP (obj)) @@ -3435,20 +3970,6 @@ Does not copy symbols. Copies strings without text properties.") Protection from GC ***********************************************************************/ -/* Recording what needs to be marked for gc. */ - -struct gcpro *gcprolist; - -/* Addresses of staticpro'd variables. */ - -#define NSTATICS 1024 -Lisp_Object *staticvec[NSTATICS] = {0}; - -/* Index of next unused slot in staticvec. */ - -int staticidx = 0; - - /* Put an entry in staticvec, pointing at the variable with address VARADDRESS. */ @@ -3491,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; @@ -3521,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. */ @@ -3529,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 @@ -3669,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 { @@ -3733,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)); @@ -3741,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 @@ -3766,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); } @@ -3874,7 +4406,7 @@ mark_object (argptr) loop2: XUNMARK (obj); - if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE) XPNTR (obj))) + if (PURE_POINTER_P (XPNTR (obj))) return; last_marked[last_marked_index++] = objptr; @@ -3928,6 +4460,11 @@ mark_object (argptr) CHECK_ALLOCATED_AND_LIVE (live_string_p); 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. */ + CHECK_STRING_BYTES (ptr); +#endif /* GC_CHECK_STRING_BYTES */ } break; @@ -4012,8 +4549,7 @@ mark_object (argptr) mark_face_cache (ptr->face_cache); #ifdef HAVE_WINDOW_SYSTEM mark_image_cache (ptr); - mark_object (&ptr->desired_tool_bar_items); - mark_object (&ptr->current_tool_bar_items); + mark_object (&ptr->tool_bar_items); mark_object (&ptr->desired_tool_bar_string); mark_object (&ptr->current_tool_bar_string); #endif /* HAVE_WINDOW_SYSTEM */ @@ -4269,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); @@ -4281,7 +4817,7 @@ mark_buffer (buf) break; } - mark_object (&XCDR (tail)); + mark_object (&XCDR_AS_LVALUE (tail)); } else mark_object (&buffer->undo_list); @@ -4418,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 */ { @@ -4576,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 @@ -4760,6 +5310,11 @@ gc_sweep () prev = vector, vector = vector->next; } } + +#ifdef GC_CHECK_STRING_BYTES + if (!noninteractive) + check_string_bytes (1); +#endif } @@ -4768,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; @@ -4781,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); } @@ -4835,14 +5382,16 @@ void init_alloc_once () { /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ - pureptr = 0; -#if GC_MARK_STACK + 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 @@ -4893,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. - DEFVAR_INT ("pure-bytes-used", &pureptr, - "Number of bytes of sharable Lisp data allocated so far."); +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, + 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