X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3cd557353770ab49a9068d6c7f9d3523cab0e17c..d2ad6275c8b11d33d6bbfa9359420d534aa641bc:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index d006b6e3f0..ea52c98fd2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,6 +1,6 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, - 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -49,7 +49,7 @@ Boston, MA 02110-1301, USA. */ #include "keyboard.h" #include "frame.h" #include "blockinput.h" -#include "charset.h" +#include "character.h" #include "syssignal.h" #include @@ -66,6 +66,14 @@ Boston, MA 02110-1301, USA. */ extern POINTER_TYPE *sbrk (); #endif +#ifdef HAVE_FCNTL_H +#define INCLUDED_FCNTL +#include +#endif +#ifndef O_WRONLY +#define O_WRONLY 1 +#endif + #ifdef DOUG_LEA_MALLOC #include @@ -1097,6 +1105,9 @@ lisp_align_free (block) } eassert ((aligned & 1) == aligned); eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1)); +#ifdef HAVE_POSIX_MEMALIGN + eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0); +#endif free (ABLOCKS_BASE (abase)); } UNBLOCK_INPUT; @@ -1411,6 +1422,12 @@ make_interval () { INTERVAL val; + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + if (interval_free_list) { val = interval_free_list; @@ -1432,6 +1449,11 @@ make_interval () } val = &interval_block->intervals[interval_block_index++]; } + +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + consing_since_gc += sizeof (struct interval); intervals_consed++; RESET_INTERVAL (val); @@ -1829,6 +1851,12 @@ allocate_string () { struct Lisp_String *s; + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + /* If the free-list is empty, allocate a new string_block, and add all the Lisp_Strings in it to the free-list. */ if (string_free_list == NULL) @@ -1858,6 +1886,10 @@ allocate_string () s = string_free_list; string_free_list = NEXT_FREE_LISP_STRING (s); +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + /* Probably not strictly necessary, but play it safe. */ bzero (s, sizeof *s); @@ -1905,6 +1937,12 @@ allocate_string_data (s, nchars, nbytes) /* Determine the number of bytes needed to store NBYTES bytes of string data. */ needed = SDATA_SIZE (nbytes); + old_data = s->data ? SDATA_OF_STRING (s) : NULL; + old_nbytes = GC_STRING_BYTES (s); + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif if (nbytes > LARGE_STRING_BYTES) { @@ -1959,10 +1997,13 @@ allocate_string_data (s, nchars, nbytes) else b = current_sblock; - old_data = s->data ? SDATA_OF_STRING (s) : NULL; - old_nbytes = GC_STRING_BYTES (s); - data = b->next_free; + b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA); + +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + data->string = s; s->data = SDATA_DATA (data); #ifdef GC_CHECK_STRING_BYTES @@ -1975,7 +2016,6 @@ allocate_string_data (s, nchars, nbytes) bcopy (string_overrun_cookie, (char *) data + needed, GC_STRING_OVERRUN_COOKIE_SIZE); #endif - b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA); /* If S had already data assigned, mark that as free by setting its string back-pointer to null, and recording the size of the data @@ -2228,7 +2268,7 @@ INIT must be an integer that represents a character. */) CHECK_NUMBER (init); c = XINT (init); - if (SINGLE_BYTE_CHAR_P (c)) + if (ASCII_CHAR_P (c)) { nbytes = XINT (length); val = make_uninit_string (nbytes); @@ -2259,7 +2299,7 @@ INIT must be an integer that represents a character. */) DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0, - doc: /* Return a new bool-vector of length LENGTH, using INIT for as each element. + doc: /* Return a new bool-vector of length LENGTH, using INIT for each element. LENGTH must be a number. INIT matters only in whether it is t or nil. */) (length, init) Lisp_Object length, init; @@ -2531,7 +2571,7 @@ void free_float (ptr) struct Lisp_Float *ptr; { - *(struct Lisp_Float **)&ptr->data = float_free_list; + ptr->u.chain = float_free_list; float_free_list = ptr; } @@ -2544,12 +2584,18 @@ make_float (float_value) { register Lisp_Object val; + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + if (float_free_list) { /* We use the data field for chaining the free list so that we won't use the same field that has the mark bit. */ XSETFLOAT (val, float_free_list); - float_free_list = *(struct Lisp_Float **)&float_free_list->data; + float_free_list = float_free_list->u.chain; } else { @@ -2569,6 +2615,10 @@ make_float (float_value) float_block_index++; } +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + XFLOAT_DATA (val) = float_value; eassert (!FLOAT_MARKED_P (XFLOAT (val))); consing_since_gc += sizeof (struct Lisp_Float); @@ -2649,7 +2699,7 @@ void free_cons (ptr) struct Lisp_Cons *ptr; { - *(struct Lisp_Cons **)&ptr->cdr = cons_free_list; + ptr->u.chain = cons_free_list; #if GC_MARK_STACK ptr->car = Vdead; #endif @@ -2663,12 +2713,18 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, { register Lisp_Object val; + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + if (cons_free_list) { /* We use the cdr for chaining the free list so that we won't use the same field that has the mark bit. */ XSETCONS (val, cons_free_list); - cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr; + cons_free_list = cons_free_list->u.chain; } else { @@ -2687,6 +2743,10 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, cons_block_index++; } +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + XSETCAR (val, car); XSETCDR (val, cdr); eassert (!CONS_MARKED_P (XCONS (val))); @@ -2703,7 +2763,7 @@ check_cons_list () struct Lisp_Cons *tail = cons_free_list; while (tail) - tail = *(struct Lisp_Cons **)&tail->cdr; + tail = tail->u.chain; #endif } @@ -2844,6 +2904,9 @@ allocate_vectorlike (len, type) UNBLOCK_INPUT; #endif + /* This gets triggered by code which I haven't bothered to fix. --Stef */ + /* eassert (!handling_signal); */ + nbytes = sizeof *p + (len - 1) * sizeof p->contents[0]; p = (struct Lisp_Vector *) lisp_malloc (nbytes, type); @@ -2857,8 +2920,17 @@ allocate_vectorlike (len, type) consing_since_gc += nbytes; vector_cells_consed += len; +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + p->next = all_vectors; all_vectors = p; + +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + ++n_vectors; return p; } @@ -2975,49 +3047,6 @@ See also the function `vector'. */) } -DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0, - 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); - n = Fget (purpose, Qchar_table_extra_slots); - 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. */ - vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)), - init); - XCHAR_TABLE (vector)->top = Qt; - XCHAR_TABLE (vector)->parent = Qnil; - XCHAR_TABLE (vector)->purpose = purpose; - XSETCHAR_TABLE (vector, XCHAR_TABLE (vector)); - return vector; -} - - -/* Return a newly created sub char table with slots initialized by INIT. - Since a sub char table does not appear as a top level Emacs Lisp - object, we don't need a Lisp interface to make it. */ - -Lisp_Object -make_sub_char_table (init) - Lisp_Object init; -{ - Lisp_Object vector - = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), init); - XCHAR_TABLE (vector)->top = Qnil; - XCHAR_TABLE (vector)->defalt = Qnil; - XSETCHAR_TABLE (vector, XCHAR_TABLE (vector)); - return vector; -} - - DEFUN ("vector", Fvector, Svector, 0, MANY, 0, doc: /* Return a newly created vector with specified arguments as elements. Any number of arguments, even zero arguments, are allowed. @@ -3137,10 +3166,16 @@ Its value and function definition are void, and its property list is nil. */) CHECK_STRING (name); + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + if (symbol_free_list) { XSETSYMBOL (val, symbol_free_list); - symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value; + symbol_free_list = symbol_free_list->next; } else { @@ -3158,6 +3193,10 @@ Its value and function definition are void, and its property list is nil. */) symbol_block_index++; } +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + p = XSYMBOL (val); p->xname = name; p->plist = Qnil; @@ -3217,6 +3256,12 @@ allocate_misc () { Lisp_Object val; + /* eassert (!handling_signal); */ + +#ifndef SYNC_INPUT + BLOCK_INPUT; +#endif + if (marker_free_list) { XSETMISC (val, marker_free_list); @@ -3239,6 +3284,10 @@ allocate_misc () marker_block_index++; } +#ifndef SYNC_INPUT + UNBLOCK_INPUT; +#endif + --total_free_markers; consing_since_gc += sizeof (union Lisp_Misc); misc_objects_consed++; @@ -4491,27 +4540,44 @@ mark_stack () /* Return 1 if OBJ is a valid lisp object. Return 0 if OBJ is NOT a valid lisp object. Return -1 if we cannot validate OBJ. -*/ + This function can be quite slow, + so it should only be used in code for manual debugging. */ int valid_lisp_object_p (obj) Lisp_Object obj; { + void *p; #if !GC_MARK_STACK - /* Cannot determine this. */ - return -1; + int fd; #else - void *p; struct mem_node *m; +#endif if (INTEGERP (obj)) return 1; p = (void *) XPNTR (obj); - if (PURE_POINTER_P (p)) return 1; +#if !GC_MARK_STACK + /* We need to determine whether it is safe to access memory at + address P. Obviously, we cannot just access it (we would SEGV + trying), so we trick the o/s to tell us whether p is a valid + pointer. Unfortunately, we cannot use NULL_DEVICE here, as + emacs_write may not validate p in that case. */ + if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0) + { + int valid = (emacs_write (fd, (char *)p, 16) == 16); + emacs_close (fd); + unlink ("__Valid__Lisp__Object__"); + return valid; + } + + return -1; +#else + m = mem_find (p); if (m == MEM_NIL) @@ -4615,7 +4681,7 @@ void check_pure_size () { if (pure_bytes_used_before_overflow) - message ("Pure Lisp storage overflow (approx. %d bytes needed)", + message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)", (int) (pure_bytes_used + pure_bytes_used_before_overflow)); } @@ -4702,7 +4768,7 @@ make_pure_vector (len) DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, - doc: /* Make a copy of OBJECT in pure storage. + doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. Does not copy symbols. Copies strings without text properties. */) (obj) @@ -5563,14 +5629,14 @@ mark_object (arg) CHECK_ALLOCATED_AND_LIVE (live_cons_p); CONS_MARK (ptr); /* If the cdr is nil, avoid recursion for the car. */ - if (EQ (ptr->cdr, Qnil)) + if (EQ (ptr->u.cdr, Qnil)) { obj = ptr->car; cdr_count = 0; goto loop; } mark_object (ptr->car); - obj = ptr->cdr; + obj = ptr->u.cdr; cdr_count++; if (cdr_count == mark_object_loop_halt) abort (); @@ -5717,7 +5783,7 @@ gc_sweep () if (!CONS_MARKED_P (&cblk->conses[i])) { this_free++; - *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list; + cblk->conses[i].u.chain = cons_free_list; cons_free_list = &cblk->conses[i]; #if GC_MARK_STACK cons_free_list->car = Vdead; @@ -5736,7 +5802,7 @@ gc_sweep () { *cprev = cblk->next; /* Unhook from the free list. */ - cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr; + cons_free_list = cblk->conses[0].u.chain; lisp_align_free (cblk); n_cons_blocks--; } @@ -5767,7 +5833,7 @@ gc_sweep () if (!FLOAT_MARKED_P (&fblk->floats[i])) { this_free++; - *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list; + fblk->floats[i].u.chain = float_free_list; float_free_list = &fblk->floats[i]; } else @@ -5783,7 +5849,7 @@ gc_sweep () { *fprev = fblk->next; /* Unhook from the free list. */ - float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data; + float_free_list = fblk->floats[0].u.chain; lisp_align_free (fblk); n_float_blocks--; } @@ -5871,7 +5937,7 @@ gc_sweep () if (!sym->gcmarkbit && !pure_p) { - *(struct Lisp_Symbol **) &sym->value = symbol_free_list; + sym->next = symbol_free_list; symbol_free_list = sym; #if GC_MARK_STACK symbol_free_list->function = Vdead; @@ -5895,7 +5961,7 @@ gc_sweep () { *sprev = sblk->next; /* Unhook from the free list. */ - symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value; + symbol_free_list = sblk->symbols[0].next; lisp_free (sblk); n_symbol_blocks--; } @@ -6245,7 +6311,6 @@ The time is in seconds as a floating point value. */); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); - defsubr (&Smake_char_table); defsubr (&Smake_string); defsubr (&Smake_bool_vector); defsubr (&Smake_symbol);