/* 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, 2010
+ 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
#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;
#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 0x600
+#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 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 */
#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)
{
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;
}
/* 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
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
}
-#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
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);
-#ifdef HAVE_WINDOW_SYSTEM
- mark_image_cache (ptr);
-#endif /* HAVE_WINDOW_SYSTEM */
- }
+ 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));
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);
+ }
}
}
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
init_marker ();
init_float ();
init_intervals ();
+ init_weak_hash_tables ();
#ifdef REL_ALLOC
malloc_hysteresis = 32;
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