X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b3843c61858aa78d450bdaaa2e597f0a1f7b39e4..8510724d46951d651a78424e12b93ccee100c665:/src/alloc.c
diff --git a/src/alloc.c b/src/alloc.c
index a768180bfe..c150157ee0 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,13 +1,14 @@
/* 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
@@ -15,9 +16,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
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 . */
#include
#include
@@ -53,7 +52,7 @@ Boston, MA 02110-1301, USA. */
#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
@@ -241,7 +240,7 @@ static int total_free_floats, total_floats;
out of memory. We keep one large block, four cons-blocks, and
two string blocks. */
-char *spare_memory[7];
+static char *spare_memory[7];
/* Amount of spare memory to keep in large reserve block. */
@@ -324,13 +323,13 @@ Lisp_Object Vmemory_signal_data;
/* Buffer in which we save a copy of the C stack at each GC. */
-char *stack_copy;
-int stack_copy_size;
+static char *stack_copy;
+static int stack_copy_size;
/* Non-zero means ignore malloc warnings. Set during initialization.
Currently not used. */
-int ignore_warnings;
+static int ignore_warnings;
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
@@ -352,8 +351,6 @@ static void mark_face_cache P_ ((struct face_cache *));
#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));
@@ -397,12 +394,12 @@ void refill_memory_reserve ();
/* A unique object in pure space used to make some Lisp objects
on free lists recognizable in O(1). */
-Lisp_Object Vdead;
+static Lisp_Object Vdead;
#ifdef GC_MALLOC_CHECK
enum mem_type allocated_mem_type;
-int dont_register_blocks;
+static int dont_register_blocks;
#endif /* GC_MALLOC_CHECK */
@@ -502,12 +499,12 @@ struct gcpro *gcprolist;
/* Addresses of staticpro'd variables. Initialize it to a nonzero
value; otherwise some compilers put it into BSS. */
-#define NSTATICS 1280
-Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
+#define NSTATICS 0x640
+static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
/* Index of next unused slot in staticvec. */
-int staticidx = 0;
+static int staticidx = 0;
static POINTER_TYPE *pure_alloc P_ ((size_t, int));
@@ -800,6 +797,8 @@ void
xfree (block)
POINTER_TYPE *block;
{
+ if (!block)
+ return;
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
@@ -1367,6 +1366,7 @@ void
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.
@@ -1374,6 +1374,11 @@ uninterrupt_malloc ()
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)
@@ -1417,7 +1422,7 @@ struct interval_block
/* Current interval block. Its `next' pointer points to older
blocks. */
-struct interval_block *interval_block;
+static struct interval_block *interval_block;
/* Index in interval_block above of the next unused interval
structure. */
@@ -1434,7 +1439,7 @@ INTERVAL interval_free_list;
/* Total number of interval blocks now in use. */
-int n_interval_blocks;
+static int n_interval_blocks;
/* Initialize interval allocation. */
@@ -1536,7 +1541,7 @@ mark_interval_tree (tree)
} while (0)
-/* 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
@@ -1756,7 +1761,7 @@ static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
/* Initialize string allocation. Called from init_alloc_once. */
-void
+static void
init_strings ()
{
total_strings = total_free_strings = total_string_size = 0;
@@ -1773,8 +1778,8 @@ init_strings ()
static int check_string_bytes_count;
-void check_string_bytes P_ ((int));
-void check_sblock P_ ((struct sblock *));
+static void check_string_bytes P_ ((int));
+static void check_sblock P_ ((struct sblock *));
#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
@@ -1795,7 +1800,7 @@ string_bytes (s)
/* Check validity of Lisp strings' string_bytes member in B. */
-void
+static void
check_sblock (b)
struct sblock *b;
{
@@ -1829,7 +1834,7 @@ check_sblock (b)
non-zero means check all strings, otherwise check only most
recently allocated strings. Used for hunting a bug. */
-void
+static void
check_string_bytes (all_p)
int all_p;
{
@@ -1927,11 +1932,7 @@ allocate_string ()
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)
{
@@ -2288,7 +2289,7 @@ INIT must be an integer that represents a character. */)
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);
@@ -2582,7 +2583,7 @@ struct Lisp_Float *float_free_list;
/* Initialize float allocation. */
-void
+static void
init_float ()
{
float_block = NULL;
@@ -2594,7 +2595,7 @@ init_float ()
/* Explicitly free a float cell by putting it on the free-list. */
-void
+static void
free_float (ptr)
struct Lisp_Float *ptr;
{
@@ -2701,12 +2702,12 @@ struct Lisp_Cons *cons_free_list;
/* Total number of cons blocks now in use. */
-int n_cons_blocks;
+static int n_cons_blocks;
/* Initialize cons allocation. */
-void
+static void
init_cons ()
{
cons_block = NULL;
@@ -2903,11 +2904,11 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
/* Singly-linked list of all vectors. */
-struct Lisp_Vector *all_vectors;
+static struct Lisp_Vector *all_vectors;
/* Total number of vector-like objects now in use. */
-int n_vectors;
+static int n_vectors;
/* Value is a pointer to a newly allocated Lisp_Vector structure
@@ -2967,7 +2968,7 @@ allocate_vector (nslots)
/* Allocate other vector-like structures. */
-static struct Lisp_Vector *
+struct Lisp_Vector *
allocate_pseudovector (memlen, lisplen, tag)
int memlen, lisplen;
EMACS_INT tag;
@@ -2983,10 +2984,6 @@ allocate_pseudovector (memlen, lisplen, 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)
@@ -3033,22 +3030,6 @@ allocate_process ()
}
-/* 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'. */)
@@ -3072,51 +3053,6 @@ 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.
@@ -3202,21 +3138,21 @@ struct symbol_block
/* Current symbol block and index of first unused Lisp_Symbol
structure in it. */
-struct symbol_block *symbol_block;
-int symbol_block_index;
+static struct symbol_block *symbol_block;
+static int symbol_block_index;
/* List of free symbols. */
-struct Lisp_Symbol *symbol_free_list;
+static struct Lisp_Symbol *symbol_free_list;
/* Total number of symbol blocks now in use. */
-int n_symbol_blocks;
+static int n_symbol_blocks;
/* Initialize symbol allocation. */
-void
+static void
init_symbol ()
{
symbol_block = NULL;
@@ -3298,16 +3234,16 @@ struct marker_block
struct marker_block *next;
};
-struct marker_block *marker_block;
-int marker_block_index;
+static struct marker_block *marker_block;
+static int marker_block_index;
-union Lisp_Misc *marker_free_list;
+static union Lisp_Misc *marker_free_list;
/* Total number of marker blocks now in use. */
-int n_marker_blocks;
+static int n_marker_blocks;
-void
+static void
init_marker ()
{
marker_block = NULL;
@@ -4181,7 +4117,7 @@ mark_maybe_object (obj)
{
int mark_p = 0;
- switch (XGCTYPE (obj))
+ switch (XTYPE (obj))
{
case Lisp_String:
mark_p = (live_string_p (m, po)
@@ -4201,13 +4137,13 @@ mark_maybe_object (obj)
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:
@@ -4298,7 +4234,7 @@ mark_maybe_pointer (p)
{
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;
@@ -4307,7 +4243,7 @@ mark_maybe_pointer (p)
abort ();
}
- if (!GC_NILP (obj))
+ if (!NILP (obj))
mark_object (obj);
}
}
@@ -4551,8 +4487,13 @@ mark_stack ()
/* 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
@@ -4604,7 +4545,7 @@ mark_stack ()
/* Determine whether it is safe to access memory at address P. */
-int
+static int
valid_pointer_p (p)
void *p;
{
@@ -4900,7 +4841,7 @@ pure_cons (car, cdr)
/* Value is a float object with value NUM allocated from pure space. */
-Lisp_Object
+static Lisp_Object
make_pure_float (num)
double num;
{
@@ -5071,7 +5012,8 @@ returns nil, because real GC can't be done. */)
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
@@ -5210,8 +5152,8 @@ returns nil, because real GC can't be done. */)
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))
@@ -5360,7 +5302,7 @@ mark_glyph_matrix (matrix)
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);
}
@@ -5391,48 +5333,20 @@ mark_face_cache (c)
}
-#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 */
-
-
/* Mark reference to a Lisp_Object.
If the object referred to has not been seen yet, recursively mark
all the references contained in it. */
#define LAST_MARKED_SIZE 500
-Lisp_Object last_marked[LAST_MARKED_SIZE];
+static Lisp_Object last_marked[LAST_MARKED_SIZE];
int last_marked_index;
/* For debugging--call abort when we cdr down this many
links of a list, in mark_object. In debugging,
the call to abort will hit a breakpoint.
Normally this is zero and the check never goes off. */
-int mark_object_loop_halt;
+static int mark_object_loop_halt;
/* Return non-zero if the object was not yet marked. */
static int
@@ -5447,7 +5361,7 @@ mark_vectorlike (ptr)
VECTOR_MARK (ptr); /* Else mark it */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
-
+
/* Note that this size is not the memory-footprint size, but only
the number of Lisp_Object fields that we should trace.
The distinction is used e.g. by Lisp_Process which places extra
@@ -5516,7 +5430,7 @@ mark_object (arg)
#endif /* not GC_CHECK_MARKED_OBJECTS */
- switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
+ switch (SWITCH_ENUM_CAST (XTYPE (obj)))
{
case Lisp_String:
{
@@ -5535,13 +5449,13 @@ mark_object (arg)
case Lisp_Vectorlike:
#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)))
{
@@ -5558,9 +5472,9 @@ mark_object (arg)
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. */
@@ -5583,18 +5497,13 @@ mark_object (arg)
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_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);
@@ -5612,13 +5521,13 @@ mark_object (arg)
}
}
}
- 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))
+ if (NILP (h->weak))
mark_object (h->key_and_value);
else
VECTOR_MARK (XVECTOR (h->key_and_value));
@@ -5802,6 +5711,8 @@ mark_buffer (buf)
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++)
@@ -5825,6 +5736,9 @@ mark_terminals (void)
for (t = terminal_list; t; t = t->next_terminal)
{
eassert (t->name != NULL);
+#ifdef HAVE_WINDOW_SYSTEM
+ mark_image_cache (t->image_cache);
+#endif /* HAVE_WINDOW_SYSTEM */
mark_vectorlike ((struct Lisp_Vector *)t);
}
}
@@ -5840,7 +5754,7 @@ survives_gc_p (obj)
{
int survives_p;
- switch (XGCTYPE (obj))
+ switch (XTYPE (obj))
{
case Lisp_Int:
survives_p = 1;
@@ -5859,7 +5773,7 @@ survives_gc_p (obj)
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:
@@ -6295,6 +6209,7 @@ Frames, windows, buffers, and subprocesses count as vectors
}
int suppress_checking;
+
void
die (msg, file, line)
const char *msg;
@@ -6339,6 +6254,7 @@ init_alloc_once ()
init_marker ();
init_float ();
init_intervals ();
+ init_weak_hash_tables ();
#ifdef REL_ALLOC
malloc_hysteresis = 32;
@@ -6468,7 +6384,6 @@ The time is in seconds as a floating point value. */);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
- defsubr (&Smake_char_table);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);