/* 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
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
/* 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. */
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++;
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
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;
}
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);
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;
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.