X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b782773b44634aa94bdcdb356ffee9c434003ac9..844e0de1bc2bf56118b749f50a4880db7c918fd5:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 3ddb47779a..a300396514 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -35,7 +35,6 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "process.h" #include "intervals.h" -#include "puresize.h" #include "character.h" #include "buffer.h" #include "window.h" @@ -118,72 +117,11 @@ static void *spare_memory; #define SPARE_MEMORY (1 << 15) -/* Initialize it to a nonzero value to force it into data space - (rather than bss space). That way unexec will remap it into text - space (pure), on some systems. We have not implemented the - remapping on more recent systems because this is less important - nowadays than in the days of small memories and timesharing. */ - -EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,}; -#define PUREBEG (char *) pure - -/* Pointer to the pure area, and its size. */ - -static char *purebeg; -static ptrdiff_t pure_size; - -/* Number of bytes of pure storage used before pure storage overflowed. - If this is non-zero, this implies that an overflow occurred. */ - -static ptrdiff_t pure_bytes_used_before_overflow; - -/* True if P points into pure space. */ - -#define PURE_POINTER_P(P) \ - ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size) - -/* Index in pure at which next pure Lisp object will be allocated.. */ - -static ptrdiff_t pure_bytes_used_lisp; - -/* Number of bytes allocated for non-Lisp objects in pure storage. */ - -static ptrdiff_t pure_bytes_used_non_lisp; - /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ const char *pending_malloc_warning; -#if 0 /* Normally, pointer sanity only on request... */ -#ifdef ENABLE_CHECKING -#define SUSPICIOUS_OBJECT_CHECKING 1 -#endif -#endif - -/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC - bug is unresolved. */ -#define SUSPICIOUS_OBJECT_CHECKING 1 - -#ifdef SUSPICIOUS_OBJECT_CHECKING -struct suspicious_free_record -{ - void *suspicious_object; - void *backtrace[128]; -}; -static void *suspicious_objects[32]; -static int suspicious_object_index; -struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE; -static int suspicious_free_history_index; -/* Find the first currently-monitored suspicious pointer in range - [begin,end) or NULL if no such pointer exists. */ -static void *find_suspicious_object_in_range (void *begin, void *end); -static void detect_suspicious_free (void *ptr); -#else -# define find_suspicious_object_in_range(begin, end) NULL -# define detect_suspicious_free(ptr) (void) -#endif - static Lisp_Object Qgc_cons_threshold; Lisp_Object Qchar_table_extra_slots; @@ -191,11 +129,10 @@ Lisp_Object Qchar_table_extra_slots; static Lisp_Object Qpost_gc_hook; -static Lisp_Object make_pure_vector (ptrdiff_t); - #if !defined REL_ALLOC || defined SYSTEM_MALLOC static void refill_memory_reserve (void); #endif +static Lisp_Object make_empty_string (int); extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; #ifndef DEADP @@ -205,58 +142,6 @@ extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; /* Recording what needs to be marked for gc. */ struct gcpro *gcprolist; - -/* Addresses of staticpro'd variables. Initialize it to a nonzero - value; otherwise some compilers put it into BSS. */ - -enum { NSTATICS = 2048 }; -static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag}; - -/* Index of next unused slot in staticvec. */ - -static int staticidx; - -static void *pure_alloc (size_t, int); - -/* Return X rounded to the next multiple of Y. Arguments should not - have side effects, as they are evaluated more than once. Assume X - + Y - 1 does not overflow. Tune for Y being a power of 2. */ - -#define ROUNDUP(x, y) ((y) & ((y) - 1) \ - ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \ - : ((x) + (y) - 1) & ~ ((y) - 1)) - -/* Return PTR rounded up to the next multiple of ALIGNMENT. */ - -static void * -ALIGN (void *ptr, int alignment) -{ - return (void *) ROUNDUP ((uintptr_t) ptr, alignment); -} - -static void -XFLOAT_INIT (Lisp_Object f, double n) -{ - XFLOAT (f)->u.data = n; -} - -static bool -pointers_fit_in_lispobj_p (void) -{ - return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG; -} - -static bool -mmap_lisp_allowed_p (void) -{ - /* If we can't store all memory addresses in our lisp objects, it's - risky to let the heap use mmap and give us addresses from all - over our address space. We also can't use mmap for lisp objects - if we might dump: unexec doesn't preserve the contents of mmaped - regions. */ - return pointers_fit_in_lispobj_p () && !might_dump; -} - /************************************************************************ Malloc @@ -340,6 +225,51 @@ xfree (void *block) return; } +/* Allocate pointerless memory. */ + +void * +xmalloc_atomic (size_t size) +{ + void *val = GC_MALLOC_ATOMIC (size); + if (! val && size) + memory_full (size); + return val; +} + +void * +xzalloc_atomic (size_t size) +{ + return xmalloc_atomic (size); +} + +/* Allocate uncollectable memory. */ + +void * +xmalloc_uncollectable (size_t size) +{ + void *val = GC_MALLOC_UNCOLLECTABLE (size); + if (! val && size) + memory_full (size); + return val; +} + +/* Allocate memory, but if memory is exhausted, return NULL instead of + signalling an error. */ + +void * +xmalloc_unsafe (size_t size) +{ + return GC_MALLOC (size); +} + +/* Allocate pointerless memory, but if memory is exhausted, return + NULL instead of signalling an error. */ + +void * +xmalloc_atomic_unsafe (size_t size) +{ + return GC_MALLOC_ATOMIC (size); +} /* Other parts of Emacs pass large int values to allocator functions expecting ptrdiff_t. This is portable in practice, but check it to @@ -359,6 +289,16 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) return xmalloc (nitems * item_size); } +/* Like xnmalloc for pointerless objects. */ + +void * +xnmalloc_atomic (ptrdiff_t nitems, ptrdiff_t item_size) +{ + eassert (0 <= nitems && 0 < item_size); + if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) + memory_full (SIZE_MAX); + return xmalloc_atomic (nitems * item_size); +} /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE. Signal an error on memory exhaustion. */ @@ -439,7 +379,7 @@ xstrdup (const char *s) ptrdiff_t size; eassert (s); size = strlen (s) + 1; - return memcpy (xmalloc (size), s, size); + return memcpy (xmalloc_atomic (size), s, size); } /* Like above, but duplicates Lisp string to C string. */ @@ -448,7 +388,7 @@ char * xlispstrdup (Lisp_Object string) { ptrdiff_t size = SBYTES (string) + 1; - return memcpy (xmalloc (size), SSDATA (string), size); + return memcpy (xmalloc_atomic (size), SSDATA (string), size); } /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly @@ -474,16 +414,6 @@ xputenv (char const *string) if (putenv ((char *) string) != 0) memory_full (0); } - -/* Return a newly allocated memory block of SIZE bytes, remembering - to free it when unwinding. */ -void * -record_xmalloc (size_t size) -{ - void *p = xmalloc (size); - record_unwind_protect_ptr (xfree, p); - return p; -} /*********************************************************************** Interval Allocation @@ -508,8 +438,8 @@ make_interval (void) static void init_strings (void) { - empty_unibyte_string = make_pure_string ("", 0, 0, 0); - empty_multibyte_string = make_pure_string ("", 0, 0, 1); + empty_unibyte_string = make_empty_string (0); + empty_multibyte_string = make_empty_string (1); } /* Return a new Lisp_String. */ @@ -517,7 +447,11 @@ init_strings (void) static struct Lisp_String * allocate_string (void) { - return xmalloc (sizeof (struct Lisp_String)); + struct Lisp_String *p; + + p = xmalloc (sizeof *p); + SCM_NEWSMOB (p->self, lisp_string_tag, p); + return p; } @@ -549,6 +483,21 @@ string_overflow (void) error ("Maximum string size exceeded"); } +static Lisp_Object +make_empty_string (int multibyte) +{ + Lisp_Object string; + struct Lisp_String *s; + + s = allocate_string (); + allocate_string_data (s, 0, 0); + XSETSTRING (string, s); + if (! multibyte) + STRING_SET_UNIBYTE (string); + + return string; +} + DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, doc: /* Return a newly created string of length LENGTH, with INIT in each element. LENGTH must be an integer. @@ -824,13 +773,9 @@ make_formatted_string (char *buf, const char *format, ...) Lisp_Object make_float (double float_value) { - register Lisp_Object val; - XSETFLOAT (val, xmalloc (sizeof (struct Lisp_Float))); - XFLOAT_INIT (val, float_value); - return val; + return scm_from_double (float_value); } - /*********************************************************************** Cons Allocation @@ -840,12 +785,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, doc: /* Create a new cons, give it CAR and CDR as components, and return it. */) (Lisp_Object car, Lisp_Object cdr) { - register Lisp_Object val; - - XSETCONS (val, xmalloc (sizeof (struct Lisp_Cons))); - XSETCAR (val, car); - XSETCDR (val, cdr); - return val; + return scm_cons (car, cdr); } /* Make a list of 1, 2, 3, 4 or 5 specified objects. */ @@ -996,7 +936,11 @@ Lisp_Object zero_vector; static void init_vectors (void) { - zero_vector = make_pure_vector (0); + struct Lisp_Vector *p = xmalloc (header_size); + + SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); + p->header.size = 0; + XSETVECTOR (zero_vector, p); } /* Value is a pointer to a newly allocated Lisp_Vector structure @@ -1005,10 +949,17 @@ init_vectors (void) static struct Lisp_Vector * allocate_vectorlike (ptrdiff_t len) { + struct Lisp_Vector *p; + if (len == 0) - return XVECTOR (zero_vector); + p = XVECTOR (zero_vector); else - return xmalloc (header_size + len * word_size); + { + p = xmalloc (header_size + len * word_size); + SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); + } + + return p; } @@ -1054,6 +1005,7 @@ allocate_buffer (void) { struct buffer *b = xmalloc (sizeof *b); + SCM_NEWSMOB (b->header.self, lisp_vectorlike_tag, b); BUFFER_PVEC_INIT (b); /* Put B on the chain of all buffers including killed ones. */ b->next = all_buffers; @@ -1213,10 +1165,20 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT Symbol Allocation ***********************************************************************/ -static void -set_symbol_name (Lisp_Object sym, Lisp_Object name) +void +initialize_symbol (Lisp_Object val, Lisp_Object name) { - XSYMBOL (sym)->name = name; + sym_t p; + + scm_module_define (symbol_module, val, scm_c_make_vector (5, SCM_BOOL_F)); + p = XSYMBOL (val); + SET_SYMBOL_SELF (p, val); + scm_module_define (plist_module, val, Qnil); + SET_SYMBOL_REDIRECT (p, SYMBOL_PLAINVAL); + SET_SYMBOL_VAL (p, Qunbound); + scm_module_define (function_module, val, Qnil); + SET_SYMBOL_CONSTANT (p, 0); + SET_SYMBOL_DECLARED_SPECIAL (p, false); } DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, @@ -1225,23 +1187,12 @@ Its value is void, and its function definition and property list are nil. */) (Lisp_Object name) { register Lisp_Object val; - register struct Lisp_Symbol *p; CHECK_STRING (name); - XSETSYMBOL (val, xmalloc (sizeof (struct Lisp_Symbol))); - p = XSYMBOL (val); - set_symbol_name (val, name); - set_symbol_plist (val, Qnil); - p->redirect = SYMBOL_PLAINVAL; - SET_SYMBOL_VAL (p, Qunbound); - set_symbol_function (val, Qnil); - set_symbol_next (val, NULL); - p->gcmarkbit = false; - p->interned = SYMBOL_UNINTERNED; - p->constant = 0; - p->declared_special = false; - p->pinned = false; + val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name), + SBYTES (name))); + initialize_symbol (val, name); return val; } @@ -1257,8 +1208,11 @@ static Lisp_Object allocate_misc (enum Lisp_Misc_Type type) { Lisp_Object val; + union Lisp_Misc *p; - XSETMISC (val, xmalloc (sizeof (union Lisp_Misc))); + p = xmalloc (sizeof *p); + SCM_NEWSMOB (p->u_any.self, lisp_misc_tag, p); + XSETMISC (val, p); XMISCANY (val)->type = type; return val; } @@ -1496,7 +1450,7 @@ memory_full (size_t nbytes) bool enough_free_memory = 0; if (SPARE_MEMORY < nbytes) { - void *p = GC_MALLOC (SPARE_MEMORY); + void *p = xmalloc_atomic_unsafe (SPARE_MEMORY); if (p) { xfree (p); @@ -1532,7 +1486,7 @@ void refill_memory_reserve (void) { if (spare_memory == NULL) - spare_memory = GC_MALLOC (SPARE_MEMORY); + spare_memory = xmalloc_atomic_unsafe (SPARE_MEMORY); if (spare_memory) Vmemory_full = Qnil; @@ -1576,12 +1530,10 @@ valid_lisp_object_p (Lisp_Object obj) { void *p; - if (INTEGERP (obj)) + if (SCM_IMP (obj)) return 1; - p = (void *) XPNTR (obj); - if (PURE_POINTER_P (p)) - return 1; + p = (void *) SCM2PTR (obj); if (p == &buffer_defaults || p == &buffer_local_symbols) return 2; @@ -1597,324 +1549,54 @@ valid_lisp_object_p (Lisp_Object obj) int relocatable_string_data_p (const char *str) { - if (PURE_POINTER_P (str)) - return 0; return -1; } /*********************************************************************** - Pure Storage Management + Pure Storage Compatibility Functions ***********************************************************************/ -/* 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. */ - -static void * -pure_alloc (size_t size, int type) -{ - void *result; -#if USE_LSB_TAG - size_t alignment = GCALIGNMENT; -#else - size_t alignment = alignof (EMACS_INT); - - /* Give Lisp_Floats an extra alignment. */ - if (type == Lisp_Float) - alignment = alignof (struct Lisp_Float); -#endif - - again: - if (type >= 0) - { - /* Allocate space for a Lisp object from the beginning of the free - space with taking account of alignment. */ - result = ALIGN (purebeg + pure_bytes_used_lisp, alignment); - pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; - } - else - { - /* Allocate space for a non-Lisp object from the end of the free - space. */ - pure_bytes_used_non_lisp += size; - result = purebeg + pure_size - pure_bytes_used_non_lisp; - } - pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; - - if (pure_bytes_used <= pure_size) - return result; - - /* Don't allocate a large amount here, - because it might get mmap'd and then its address - might not be usable. */ - purebeg = xmalloc (10000); - pure_size = 10000; - pure_bytes_used_before_overflow += pure_bytes_used - size; - pure_bytes_used = 0; - pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0; - goto again; -} - - -/* Print a warning if PURESIZE is too small. */ - void check_pure_size (void) { - if (pure_bytes_used_before_overflow) - message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d" - " bytes needed)"), - pure_bytes_used + pure_bytes_used_before_overflow); -} - - -/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from - the non-Lisp data pool of the pure storage, and return its start - address. Return NULL if not found. */ - -static char * -find_string_data_in_pure (const char *data, ptrdiff_t nbytes) -{ - int i; - ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max; - const unsigned char *p; - char *non_lisp_beg; - - if (pure_bytes_used_non_lisp <= nbytes) - return NULL; - - /* Set up the Boyer-Moore table. */ - skip = nbytes + 1; - for (i = 0; i < 256; i++) - bm_skip[i] = skip; - - p = (const unsigned char *) data; - while (--skip > 0) - bm_skip[*p++] = skip; - - last_char_skip = bm_skip['\0']; - - non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp; - start_max = pure_bytes_used_non_lisp - (nbytes + 1); - - /* See the comments in the function `boyer_moore' (search.c) for the - use of `infinity'. */ - infinity = pure_bytes_used_non_lisp + 1; - bm_skip['\0'] = infinity; - - p = (const unsigned char *) non_lisp_beg + nbytes; - start = 0; - do - { - /* Check the last character (== '\0'). */ - do - { - start += bm_skip[*(p + start)]; - } - while (start <= start_max); - - if (start < infinity) - /* Couldn't find the last character. */ - return NULL; - - /* No less than `infinity' means we could find the last - character at `p[start - infinity]'. */ - start -= infinity; - - /* Check the remaining characters. */ - if (memcmp (data, non_lisp_beg + start, nbytes) == 0) - /* Found. */ - return non_lisp_beg + start; - - start += last_char_skip; - } - while (start <= start_max); - - return NULL; + return; } - -/* Return a string allocated in pure space. DATA is a buffer holding - NCHARS characters, and NBYTES bytes of string data. MULTIBYTE - means make the result string multibyte. - - Must get an error if pure storage is full, since if it cannot hold - a large string it may be able to hold conses that point to that - string; then the string is not protected from gc. */ - Lisp_Object make_pure_string (const char *data, ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) { - Lisp_Object string; - struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); - s->data = (unsigned char *) find_string_data_in_pure (data, nbytes); - if (s->data == NULL) - { - s->data = pure_alloc (nbytes + 1, -1); - memcpy (s->data, data, nbytes); - s->data[nbytes] = '\0'; - } - s->size = nchars; - s->size_byte = multibyte ? nbytes : -1; - s->intervals = NULL; - XSETSTRING (string, s); - return string; + return make_specified_string (data, nchars, nbytes, multibyte); } -/* Return a string allocated in pure space. Do not - allocate the string data, just point to DATA. */ - Lisp_Object make_pure_c_string (const char *data, ptrdiff_t nchars) { - Lisp_Object string; - struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); - s->size = nchars; - s->size_byte = -1; - s->data = (unsigned char *) data; - s->intervals = NULL; - XSETSTRING (string, s); - return string; + return build_string (data); } -static Lisp_Object purecopy (Lisp_Object obj); - -/* Return a cons allocated from pure space. Give it pure copies - of CAR as car and CDR as cdr. */ - Lisp_Object pure_cons (Lisp_Object car, Lisp_Object cdr) { - Lisp_Object new; - struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons); - XSETCONS (new, p); - XSETCAR (new, purecopy (car)); - XSETCDR (new, purecopy (cdr)); - return new; -} - - -/* Value is a float object with value NUM allocated from pure space. */ - -static Lisp_Object -make_pure_float (double num) -{ - Lisp_Object new; - struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float); - XSETFLOAT (new, p); - XFLOAT_INIT (new, num); - return new; + return Fcons (car, cdr); } - -/* Return a vector with room for LEN Lisp_Objects allocated from - pure space. */ - -static Lisp_Object -make_pure_vector (ptrdiff_t len) -{ - Lisp_Object new; - size_t size = header_size + len * word_size; - struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike); - XSETVECTOR (new, p); - XVECTOR (new)->header.size = len; - return new; -} - - DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, - 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. */) + doc: /* Return OBJ. */) (register Lisp_Object obj) { - if (NILP (Vpurify_flag)) - return obj; - else if (MARKERP (obj) || OVERLAYP (obj) - || HASH_TABLE_P (obj) || SYMBOLP (obj)) - /* Can't purify those. */ - return obj; - else - return purecopy (obj); -} - -static Lisp_Object -purecopy (Lisp_Object obj) -{ - if (PURE_POINTER_P (XPNTR (obj)) || INTEGERP (obj) || SUBRP (obj)) - return obj; /* Already pure. */ - - if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ - { - Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil); - if (!NILP (tmp)) - return tmp; - } - - if (CONSP (obj)) - obj = pure_cons (XCAR (obj), XCDR (obj)); - else if (FLOATP (obj)) - obj = make_pure_float (XFLOAT_DATA (obj)); - else if (STRINGP (obj)) - obj = make_pure_string (SSDATA (obj), SCHARS (obj), - SBYTES (obj), - STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj)) - { - register struct Lisp_Vector *vec; - register ptrdiff_t i; - ptrdiff_t size; - - size = ASIZE (obj); - if (size & PSEUDOVECTOR_FLAG) - size &= PSEUDOVECTOR_SIZE_MASK; - vec = XVECTOR (make_pure_vector (size)); - for (i = 0; i < size; i++) - vec->contents[i] = purecopy (AREF (obj, i)); - if (COMPILEDP (obj)) - { - XSETPVECTYPE (vec, PVEC_COMPILED); - XSETCOMPILED (obj, vec); - } - else - XSETVECTOR (obj, vec); - } - else if (SYMBOLP (obj)) - { - return obj; - } - else - { - Lisp_Object args[2]; - args[0] = build_pure_c_string ("Don't know how to purify: %S"); - args[1] = obj; - Fsignal (Qerror, (Fcons (Fformat (2, args), Qnil))); - } - - if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ - Fputhash (obj, obj, Vpurify_flag); - return obj; } - - /*********************************************************************** Protection from GC ***********************************************************************/ -/* Put an entry in staticvec, pointing at the variable with address - VARADDRESS. */ - void staticpro (Lisp_Object *varaddress) { - if (staticidx >= NSTATICS) - fatal ("NSTATICS too small; try increasing and recompiling Emacs."); - staticvec[staticidx++] = varaddress; + return; } - DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", doc: /* Reclaim storage for Lisp objects no longer needed. @@ -1937,78 +1619,6 @@ See Info node `(elisp)Garbage Collection'. */) return Qt; } -#ifdef SUSPICIOUS_OBJECT_CHECKING - -static void * -find_suspicious_object_in_range (void *begin, void *end) -{ - char *begin_a = begin; - char *end_a = end; - int i; - - for (i = 0; i < ARRAYELTS (suspicious_objects); ++i) - { - char *suspicious_object = suspicious_objects[i]; - if (begin_a <= suspicious_object && suspicious_object < end_a) - return suspicious_object; - } - - return NULL; -} - -static void -note_suspicious_free (void* ptr) -{ - struct suspicious_free_record* rec; - - rec = &suspicious_free_history[suspicious_free_history_index++]; - if (suspicious_free_history_index == - ARRAYELTS (suspicious_free_history)) - { - suspicious_free_history_index = 0; - } - - memset (rec, 0, sizeof (*rec)); - rec->suspicious_object = ptr; - backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace)); -} - -static void -detect_suspicious_free (void* ptr) -{ - int i; - - eassert (ptr != NULL); - - for (i = 0; i < ARRAYELTS (suspicious_objects); ++i) - if (suspicious_objects[i] == ptr) - { - note_suspicious_free (ptr); - suspicious_objects[i] = NULL; - } -} - -#endif /* SUSPICIOUS_OBJECT_CHECKING */ - -DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0, - doc: /* Return OBJ, maybe marking it for extra scrutiny. -If Emacs is compiled with suspicous object checking, capture -a stack trace when OBJ is freed in order to help track down -garbage collection bugs. Otherwise, do nothing and return OBJ. */) - (Lisp_Object obj) -{ -#ifdef SUSPICIOUS_OBJECT_CHECKING - /* Right now, we care only about vectors. */ - if (VECTORLIKEP (obj)) - { - suspicious_objects[suspicious_object_index++] = XVECTOR (obj); - if (suspicious_object_index == ARRAYELTS (suspicious_objects)) - suspicious_object_index = 0; - } -#endif - return obj; -} - #ifdef ENABLE_CHECKING bool suppress_checking; @@ -2027,9 +1637,11 @@ die (const char *msg, const char *file, int line) void init_alloc_once (void) { + lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0); + lisp_string_tag = scm_make_smob_type ("elisp-string", 0); + lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0); + /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ - purebeg = PUREBEG; - pure_size = PURESIZE; init_strings (); init_vectors (); @@ -2053,6 +1665,8 @@ init_alloc (void) void syms_of_alloc (void) { +#include "alloc.x" + DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold, doc: /* Number of bytes of consing between garbage collections. Garbage collection can happen automatically once this many bytes have been @@ -2109,21 +1723,6 @@ do hash-consing of the objects allocated to pure space. */); The time is in seconds as a floating point value. */); DEFVAR_INT ("gcs-done", gcs_done, doc: /* Accumulated number of garbage collections done. */); - - defsubr (&Scons); - defsubr (&Slist); - defsubr (&Svector); - defsubr (&Sbool_vector); - defsubr (&Smake_byte_code); - defsubr (&Smake_list); - defsubr (&Smake_vector); - defsubr (&Smake_string); - defsubr (&Smake_bool_vector); - defsubr (&Smake_symbol); - defsubr (&Smake_marker); - defsubr (&Spurecopy); - defsubr (&Sgarbage_collect); - defsubr (&Ssuspicious_object); } /* When compiled with GCC, GDB might say "No enum type named @@ -2136,7 +1735,6 @@ union enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS; enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS; enum char_bits char_bits; - enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE; enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; enum Lisp_Bits Lisp_Bits; enum Lisp_Compiled Lisp_Compiled;