/* 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 Free Software Foundation, Inc.
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
-GNU Emacs is free software; you can redistribute it and/or modify
+GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 3, or (at your option)
-any later version.
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#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
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
-#include "charset.h"
+#include "character.h"
#include "syssignal.h"
#include "termhooks.h" /* For struct terminal. */
#include <setjmp.h>
#ifdef HAVE_WINDOW_SYSTEM
extern void mark_fringe_data P_ ((void));
-static void mark_image P_ ((struct image *));
-static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */
static struct Lisp_String *allocate_string P_ ((void));
/* Addresses of staticpro'd variables. Initialize it to a nonzero
value; otherwise some compilers put it into BSS. */
-#define NSTATICS 1280
+#define NSTATICS 0x640
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
/* Index of next unused slot in staticvec. */
xfree (block)
POINTER_TYPE *block;
{
+ if (!block)
+ return;
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
uninterrupt_malloc ()
{
#ifdef HAVE_GTK_AND_PTHREAD
+#ifdef DOUG_LEA_MALLOC
pthread_mutexattr_t attr;
/* GLIBC has a faster way to do this, but lets keep it portable.
pthread_mutexattr_init (&attr);
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,
+ and the bundled gmalloc.c doesn't require it. */
+ pthread_mutex_init (&alloc_mutex, NULL);
+#endif /* !DOUG_LEA_MALLOC */
#endif /* HAVE_GTK_AND_PTHREAD */
if (__free_hook != emacs_blocked_free)
} while (0)
\f
-/* Number support. If NO_UNION_TYPE isn't in effect, we
+/* Number support. If USE_LISP_UNION_TYPE is in effect, we
can't create number objects in macros. */
#ifndef make_number
Lisp_Object
consing_since_gc += sizeof *s;
#ifdef GC_CHECK_STRING_BYTES
- if (!noninteractive
-#ifdef MAC_OS8
- && current_sblock
-#endif
- )
+ if (!noninteractive)
{
if (++check_string_bytes_count == 200)
{
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);
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++;
/* Allocate other vector-like structures. */
-static struct Lisp_Vector *
+struct Lisp_Vector *
allocate_pseudovector (memlen, lisplen, tag)
int memlen, lisplen;
EMACS_INT tag;
XSETPVECTYPE (v, tag); /* Add the appropriate tag. */
return v;
}
-#define ALLOCATE_PSEUDOVECTOR(typ,field,tag) \
- ((typ*) \
- allocate_pseudovector \
- (VECSIZE (typ), PSEUDOVECSIZE (typ, field), tag))
struct Lisp_Hash_Table *
allocate_hash_table (void)
}
-/* Only used for PVEC_WINDOW_CONFIGURATION. */
-struct Lisp_Vector *
-allocate_other_vector (len)
- EMACS_INT len;
-{
- struct Lisp_Vector *v = allocate_vectorlike (len);
- EMACS_INT i;
-
- for (i = 0; i < len; ++i)
- v->contents[i] = Qnil;
- v->size = len;
-
- return v;
-}
-
-
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
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);
- XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
- 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);
- XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
- 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.
{
int mark_p = 0;
- switch (XGCTYPE (obj))
+ switch (XTYPE (obj))
{
case Lisp_String:
mark_p = (live_string_p (m, po)
break;
case Lisp_Vectorlike:
- /* Note: can't check GC_BUFFERP before we know it's a
+ /* Note: can't check BUFFERP before we know it's a
buffer because checking that dereferences the pointer
PO which might point anywhere. */
if (live_vector_p (m, po))
- mark_p = !GC_SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
+ mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
else if (live_buffer_p (m, po))
- mark_p = GC_BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
+ mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
break;
case Lisp_Misc:
mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
break;
- case Lisp_Int:
- case Lisp_Type_Limit:
+ default:
break;
}
{
Lisp_Object tem;
XSETVECTOR (tem, p);
- if (!GC_SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
+ if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
obj = tem;
}
break;
abort ();
}
- if (!GC_NILP (obj))
+ if (!NILP (obj))
mark_object (obj);
}
}
/* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
needed on ia64 too. See mach_dep.c, where it also says inline
assembler doesn't work with relevant proprietary compilers. */
-#ifdef sparc
+#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
truncate_undo_list (nextb);
/* Shrink buffer gaps, but skip indirect and dead buffers. */
- if (nextb->base_buffer == 0 && !NILP (nextb->name))
+ if (nextb->base_buffer == 0 && !NILP (nextb->name)
+ && ! nextb->text->inhibit_shrinking)
{
/* If a buffer's gap size is more than 10% of the buffer
size, or larger than 2000 bytes, then shrink it
prev = Qnil;
while (CONSP (tail))
{
- if (GC_CONSP (XCAR (tail))
- && GC_MARKERP (XCAR (XCAR (tail)))
+ if (CONSP (XCAR (tail))
+ && MARKERP (XCAR (XCAR (tail)))
&& !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
if (NILP (prev))
struct glyph *end_glyph = glyph + row->used[area];
for (; glyph < end_glyph; ++glyph)
- if (GC_STRINGP (glyph->object)
+ if (STRINGP (glyph->object)
&& !STRING_MARKED_P (XSTRING (glyph->object)))
mark_object (glyph->object);
}
}
-#ifdef HAVE_WINDOW_SYSTEM
-
-/* Mark Lisp objects in image IMG. */
-
-static void
-mark_image (img)
- struct image *img;
-{
- mark_object (img->spec);
-
- if (!NILP (img->data.lisp_val))
- mark_object (img->data.lisp_val);
-}
-
-
-/* Mark Lisp objects in image cache of frame F. It's done this way so
- that we don't have to include xterm.h here. */
-
-static void
-mark_image_cache (f)
- struct frame *f;
-{
- forall_images_in_image_cache (f, mark_image);
-}
-
-#endif /* HAVE_X_WINDOWS */
-
-
\f
/* Mark reference to a Lisp_Object.
If the object referred to has not been seen yet, recursively mark
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
#endif /* not GC_CHECK_MARKED_OBJECTS */
- switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
+ switch (SWITCH_ENUM_CAST (XTYPE (obj)))
{
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 && !GC_SUBRP (obj)
+ if (m == MEM_NIL && !SUBRP (obj)
&& po != &buffer_defaults
&& po != &buffer_local_symbols)
abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
- if (GC_BUFFERP (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 (GC_SUBRP (obj))
+ else if (SUBRP (obj))
break;
- else if (GC_COMPILEDP (obj))
+ else if (COMPILEDP (obj))
/* We could treat this just like a vector, but it is better to
save the COMPILED_CONSTANTS element for last and avoid
recursion there. */
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;
obj = ptr->contents[COMPILED_CONSTANTS];
goto loop;
}
- else if (GC_FRAMEP (obj))
+ else if (FRAMEP (obj))
{
register struct frame *ptr = XFRAME (obj);
- if (mark_vectorlike (XVECTOR (obj)))
- {
- mark_face_cache (ptr->face_cache);
-#ifdef HAVE_WINDOW_SYSTEM
- mark_image_cache (ptr);
-#endif /* HAVE_WINDOW_SYSTEM */
- }
+ mark_vectorlike (XVECTOR (obj));
+ mark_face_cache (ptr->face_cache);
}
- else if (GC_WINDOWP (obj))
+ 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 (GC_HASH_TABLE_P (obj))
+ 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 (GC_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));
mark_object (tmp);
}
+ /* buffer-local Lisp variables start at `undo_list',
+ tho only the ones from `name' on are GC'd normally. */
for (ptr = &buffer->name;
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
for (t = terminal_list; t; t = t->next_terminal)
{
eassert (t->name != NULL);
- mark_vectorlike ((struct Lisp_Vector *)t);
+ if (!VECTOR_MARKED_P (t))
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ mark_image_cache (t->image_cache);
+#endif /* HAVE_WINDOW_SYSTEM */
+ mark_vectorlike ((struct Lisp_Vector *)t);
+ }
}
}
{
int survives_p;
- switch (XGCTYPE (obj))
+ switch (XTYPE (obj))
{
- case Lisp_Int:
+ case_Lisp_Int:
survives_p = 1;
break;
break;
case Lisp_Vectorlike:
- survives_p = GC_SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
+ survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
break;
case Lisp_Cons:
init_marker ();
init_float ();
init_intervals ();
+ init_weak_hash_tables ();
#ifdef REL_ALLOC
malloc_hysteresis = 32;
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.
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
- defsubr (&Smake_char_table);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);