/* 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, 2006, 2007, 2008
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#include <stdio.h>
#include <limits.h> /* For CHAR_BIT. */
+#include <setjmp.h>
#ifdef STDC_HEADERS
#include <stddef.h> /* For offsetof, used by PSEUDOVECSIZE. */
#undef INLINE
#endif
-/* Note that this declares bzero on OSF/1. How dumb. */
-
#include <signal.h>
#ifdef HAVE_GTK_AND_PTHREAD
#endif
#ifdef HAVE_FCNTL_H
-#define INCLUDED_FCNTL
#include <fcntl.h>
#endif
#ifndef O_WRONLY
Lisp_Object Vmemory_full;
-#ifndef HAVE_SHM
-
/* 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
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
-#else /* HAVE_SHM */
-
-#define pure PURE_SEG_BITS /* Use shared memory segment */
-#define PUREBEG (char *)PURE_SEG_BITS
-
-#endif /* HAVE_SHM */
-
/* Pointer to the pure area, and its size. */
static char *purebeg;
/* Addresses of staticpro'd variables. Initialize it to a nonzero
value; otherwise some compilers put it into BSS. */
-#define NSTATICS 0x600
+#define NSTATICS 0x640
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
/* Index of next unused slot in staticvec. */
pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
pthread_mutex_init (&alloc_mutex, &attr);
#else /* !DOUG_LEA_MALLOC */
- /* Some systems such as Solaris 2.6 doesn't have a recursive mutex,
+ /* Some systems such as Solaris 2.6 don't have a recursive mutex,
and the bundled gmalloc.c doesn't require it. */
pthread_mutex_init (&alloc_mutex, NULL);
#endif /* !DOUG_LEA_MALLOC */
MALLOC_UNBLOCK_INPUT;
- XFLOAT_DATA (val) = float_value;
+ XFLOAT_INIT (val, float_value);
eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
p = XSYMBOL (val);
p->xname = name;
p->plist = Qnil;
- p->value = Qunbound;
+ p->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_VAL (p, Qunbound);
p->function = Qunbound;
p->next = NULL;
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
- p->indirect_variable = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;
mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
break;
- case Lisp_Int:
- case Lisp_Type_Limit:
+ default:
break;
}
needed on ia64 too. See mach_dep.c, where it also says inline
assembler doesn't work with relevant proprietary compilers. */
#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
asm ("ta 3");
+#endif
#endif
/* Save registers that we need to see on the stack. We need to see
static char *
find_string_data_in_pure (data, nbytes)
- char *data;
+ const char *data;
int nbytes;
{
int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
- unsigned char *p;
+ const unsigned char *p;
char *non_lisp_beg;
if (pure_bytes_used_non_lisp < nbytes + 1)
for (i = 0; i < 256; i++)
bm_skip[i] = skip;
- p = (unsigned char *) data;
+ p = (const unsigned char *) data;
while (--skip > 0)
bm_skip[*p++] = skip;
infinity = pure_bytes_used_non_lisp + 1;
bm_skip['\0'] = infinity;
- p = (unsigned char *) non_lisp_beg + nbytes;
+ p = (const unsigned char *) non_lisp_beg + nbytes;
start = 0;
do
{
Lisp_Object
make_pure_string (data, nchars, nbytes, multibyte)
- char *data;
+ const char *data;
int nchars, nbytes;
int multibyte;
{
return string;
}
+/* Return a string 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)
+{
+ Lisp_Object string;
+ struct Lisp_String *s;
+ int nchars = strlen (data);
+
+ s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
+ s->size = nchars;
+ s->size_byte = -1;
+ s->data = (unsigned char *) data;
+ s->intervals = NULL_INTERVAL;
+ XSETSTRING (string, s);
+ return string;
+}
/* Return a cons allocated from pure space. Give it pure copies
of CAR as car and CDR as cdr. */
p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
XSETFLOAT (new, p);
- XFLOAT_DATA (new) = num;
+ XFLOAT_INIT (new, num);
return new;
}
if (PURE_POINTER_P (XPNTR (obj)))
return obj;
+ if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
+ {
+ Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
+ if (!NILP (tmp))
+ return tmp;
+ }
+
if (CONSP (obj))
- return pure_cons (XCAR (obj), XCDR (obj));
+ obj = pure_cons (XCAR (obj), XCDR (obj));
else if (FLOATP (obj))
- return make_pure_float (XFLOAT_DATA (obj));
+ obj = make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
- return make_pure_string (SDATA (obj), SCHARS (obj),
- SBYTES (obj),
- STRING_MULTIBYTE (obj));
+ obj = make_pure_string (SDATA (obj), SCHARS (obj),
+ SBYTES (obj),
+ STRING_MULTIBYTE (obj));
else if (COMPILEDP (obj) || VECTORP (obj))
{
register struct Lisp_Vector *vec;
}
else
XSETVECTOR (obj, vec);
- return obj;
}
else if (MARKERP (obj))
error ("Attempt to copy a marker to pure storage");
+ else
+ /* Not purified, don't hash-cons. */
+ return obj;
+
+ if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
+ Fputhash (obj, obj, Vpurify_flag);
return obj;
}
abort ();
}
-struct catchtag
-{
- Lisp_Object tag;
- Lisp_Object val;
- struct catchtag *next;
-};
-
\f
/***********************************************************************
Protection from GC
Normally this is zero and the check never goes off. */
static int mark_object_loop_halt;
-/* Return non-zero if the object was not yet marked. */
-static int
+static void
mark_vectorlike (ptr)
struct Lisp_Vector *ptr;
{
register EMACS_INT size = ptr->size;
register int i;
- if (VECTOR_MARKED_P (ptr))
- return 0; /* Already marked */
+ eassert (!VECTOR_MARKED_P (ptr));
VECTOR_MARK (ptr); /* Else mark it */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
non-Lisp_Object fields at the end of the structure. */
for (i = 0; i < size; i++) /* and then mark its elements */
mark_object (ptr->contents[i]);
- return 1;
+}
+
+/* Like mark_vectorlike but optimized for char-tables (and
+ sub-char-tables) assuming that the contents are mostly integers or
+ symbols. */
+
+static void
+mark_char_table (ptr)
+ struct Lisp_Vector *ptr;
+{
+ register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
+ register int i;
+
+ eassert (!VECTOR_MARKED_P (ptr));
+ VECTOR_MARK (ptr);
+ for (i = 0; i < size; i++)
+ {
+ Lisp_Object val = ptr->contents[i];
+
+ if (INTEGERP (val) || SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)
+ continue;
+ if (SUB_CHAR_TABLE_P (val))
+ {
+ if (! VECTOR_MARKED_P (XVECTOR (val)))
+ mark_char_table (XVECTOR (val));
+ }
+ else
+ mark_object (val);
+ }
}
void
case Lisp_String:
{
register struct Lisp_String *ptr = XSTRING (obj);
+ if (STRING_MARKED_P (ptr))
+ break;
CHECK_ALLOCATED_AND_LIVE (live_string_p);
MARK_INTERVAL_TREE (ptr->intervals);
MARK_STRING (ptr);
break;
case Lisp_Vectorlike:
+ if (VECTOR_MARKED_P (XVECTOR (obj)))
+ break;
#ifdef GC_CHECK_MARKED_OBJECTS
m = mem_find (po);
if (m == MEM_NIL && !SUBRP (obj)
if (BUFFERP (obj))
{
- if (!VECTOR_MARKED_P (XBUFFER (obj)))
- {
#ifdef GC_CHECK_MARKED_OBJECTS
- if (po != &buffer_defaults && po != &buffer_local_symbols)
- {
- struct buffer *b;
- for (b = all_buffers; b && b != po; b = b->next)
- ;
- if (b == NULL)
- abort ();
- }
-#endif /* GC_CHECK_MARKED_OBJECTS */
- mark_buffer (obj);
+ if (po != &buffer_defaults && po != &buffer_local_symbols)
+ {
+ struct buffer *b;
+ for (b = all_buffers; b && b != po; b = b->next)
+ ;
+ if (b == NULL)
+ abort ();
}
+#endif /* GC_CHECK_MARKED_OBJECTS */
+ mark_buffer (obj);
}
else if (SUBRP (obj))
break;
register EMACS_INT size = ptr->size;
register int i;
- if (VECTOR_MARKED_P (ptr))
- break; /* Already marked */
-
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr); /* Else mark it */
size &= PSEUDOVECTOR_SIZE_MASK;
else if (FRAMEP (obj))
{
register struct frame *ptr = XFRAME (obj);
- if (mark_vectorlike (XVECTOR (obj)))
- mark_face_cache (ptr->face_cache);
+ mark_vectorlike (XVECTOR (obj));
+ mark_face_cache (ptr->face_cache);
}
else if (WINDOWP (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
struct window *w = XWINDOW (obj);
- if (mark_vectorlike (ptr))
+ mark_vectorlike (ptr);
+ /* Mark glyphs for leaf windows. Marking window matrices is
+ sufficient because frame matrices use the same glyph
+ memory. */
+ if (NILP (w->hchild)
+ && NILP (w->vchild)
+ && w->current_matrix)
{
- /* Mark glyphs for leaf windows. Marking window matrices is
- sufficient because frame matrices use the same glyph
- memory. */
- if (NILP (w->hchild)
- && NILP (w->vchild)
- && w->current_matrix)
- {
- mark_glyph_matrix (w->current_matrix);
- mark_glyph_matrix (w->desired_matrix);
- }
+ mark_glyph_matrix (w->current_matrix);
+ mark_glyph_matrix (w->desired_matrix);
}
}
else if (HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
- if (mark_vectorlike ((struct Lisp_Vector *)h))
- { /* If hash table is not weak, mark all keys and values.
- For weak tables, mark only the vector. */
- if (NILP (h->weak))
- mark_object (h->key_and_value);
- else
- VECTOR_MARK (XVECTOR (h->key_and_value));
- }
+ mark_vectorlike ((struct Lisp_Vector *)h);
+ /* If hash table is not weak, mark all keys and values.
+ For weak tables, mark only the vector. */
+ if (NILP (h->weak))
+ mark_object (h->key_and_value);
+ else
+ VECTOR_MARK (XVECTOR (h->key_and_value));
}
+ else if (CHAR_TABLE_P (obj))
+ mark_char_table (XVECTOR (obj));
else
mark_vectorlike (XVECTOR (obj));
break;
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
struct Lisp_Symbol *ptrx;
- if (ptr->gcmarkbit) break;
+ if (ptr->gcmarkbit)
+ break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
ptr->gcmarkbit = 1;
- mark_object (ptr->value);
mark_object (ptr->function);
mark_object (ptr->plist);
-
+ switch (ptr->redirect)
+ {
+ case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
+ case SYMBOL_VARALIAS:
+ {
+ Lisp_Object tem;
+ XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
+ mark_object (tem);
+ break;
+ }
+ case SYMBOL_LOCALIZED:
+ {
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ /* If the value is forwarded to a buffer or keyboard field,
+ these are marked when we see the corresponding object.
+ And if it's forwarded to a C variable, either it's not
+ a Lisp_Object var, or it's staticpro'd already. */
+ mark_object (blv->where);
+ mark_object (blv->valcell);
+ mark_object (blv->defcell);
+ break;
+ }
+ case SYMBOL_FORWARDED:
+ /* If the value is forwarded to a buffer or keyboard field,
+ these are marked when we see the corresponding object.
+ And if it's forwarded to a C variable, either it's not
+ a Lisp_Object var, or it's staticpro'd already. */
+ break;
+ default: abort ();
+ }
if (!PURE_POINTER_P (XSTRING (ptr->xname)))
MARK_STRING (XSTRING (ptr->xname));
MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
- /* Note that we do not mark the obarray of the symbol.
- It is safe not to do so because nothing accesses that
- slot except to check whether it is nil. */
ptr = ptr->next;
if (ptr)
{
switch (XMISCTYPE (obj))
{
- case Lisp_Misc_Buffer_Local_Value:
- {
- register struct Lisp_Buffer_Local_Value *ptr
- = XBUFFER_LOCAL_VALUE (obj);
- /* If the cdr is nil, avoid recursion for the car. */
- if (EQ (ptr->cdr, Qnil))
- {
- obj = ptr->realvalue;
- goto loop;
- }
- mark_object (ptr->realvalue);
- mark_object (ptr->buffer);
- mark_object (ptr->frame);
- obj = ptr->cdr;
- goto loop;
- }
case Lisp_Misc_Marker:
/* DO NOT mark thru the marker's chain.
instead, markers are removed from the chain when freed by gc. */
break;
- case Lisp_Misc_Intfwd:
- case Lisp_Misc_Boolfwd:
- case Lisp_Misc_Objfwd:
- case Lisp_Misc_Buffer_Objfwd:
- case Lisp_Misc_Kboard_Objfwd:
- /* Don't bother with Lisp_Buffer_Objfwd,
- since all markable slots in current buffer marked anyway. */
- /* Don't need to do Lisp_Objfwd, since the places they point
- are protected with staticpro. */
- break;
-
case Lisp_Misc_Save_Value:
#if GC_MARK_STACK
{
case Lisp_Cons:
{
register struct Lisp_Cons *ptr = XCONS (obj);
- if (CONS_MARKED_P (ptr)) break;
+ if (CONS_MARKED_P (ptr))
+ break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
CONS_MARK (ptr);
/* If the cdr is nil, avoid recursion for the car. */
FLOAT_MARK (XFLOAT (obj));
break;
- case Lisp_Int:
+ case_Lisp_Int:
break;
default:
register Lisp_Object *ptr, tmp;
Lisp_Object base_buffer;
+ eassert (!VECTOR_MARKED_P (buffer));
VECTOR_MARK (buffer);
MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
for (t = terminal_list; t; t = t->next_terminal)
{
eassert (t->name != NULL);
+ if (!VECTOR_MARKED_P (t))
+ {
#ifdef HAVE_WINDOW_SYSTEM
- mark_image_cache (t->image_cache);
+ mark_image_cache (t->image_cache);
#endif /* HAVE_WINDOW_SYSTEM */
- mark_vectorlike ((struct Lisp_Vector *)t);
+ mark_vectorlike ((struct Lisp_Vector *)t);
+ }
}
}
switch (XTYPE (obj))
{
- case Lisp_Int:
+ case_Lisp_Int:
survives_p = 1;
break;
if (!sym->gcmarkbit && !pure_p)
{
+ if (sym->redirect == SYMBOL_LOCALIZED)
+ xfree (SYMBOL_BLV (sym));
sym->next = symbol_free_list;
symbol_free_list = sym;
#if GC_MARK_STACK
DEFVAR_LISP ("purify-flag", &Vpurify_flag,
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. */);
+This means that certain objects should be allocated in shared (pure) space.
+It can also be set to a hash-table, in which case this table is used to
+do hash-consing of the objects allocated to pure space. */);
DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
doc: /* Non-nil means display messages at start and end of garbage collection. */);
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");
+ Qpost_gc_hook = intern_c_string ("post-gc-hook");
staticpro (&Qpost_gc_hook);
DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
/* 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. */
Vmemory_signal_data
- = list2 (Qerror,
- build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
+ = pure_cons (Qerror,
+ pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
DEFVAR_LISP ("memory-full", &Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
staticpro (&Qgc_cons_threshold);
- Qgc_cons_threshold = intern ("gc-cons-threshold");
+ Qgc_cons_threshold = intern_c_string ("gc-cons-threshold");
staticpro (&Qchar_table_extra_slots);
- Qchar_table_extra_slots = intern ("char-table-extra-slots");
+ Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
doc: /* Accumulated time elapsed in garbage collections.
HCoop / bpt / emacs.git / blobdiff