#include "lisp.h"
#include "process.h"
#include "intervals.h"
-#include "puresize.h"
#include "character.h"
#include "buffer.h"
#include "window.h"
#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;
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
/* 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;
-}
-
\f
/************************************************************************
Malloc
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
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. */
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. */
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
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;
-}
\f
/***********************************************************************
Interval Allocation
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. */
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;
}
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.
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);
}
-
\f
/***********************************************************************
Cons Allocation
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. */
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
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;
}
{
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;
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,
(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;
}
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;
}
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);
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;
{
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;
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;
}
-
-
\f
/***********************************************************************
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;
}
-
\f
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
return Qt;
}
\f
-#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;
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 ();
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
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
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;
HCoop / bpt / emacs.git / blobdiff