#include <signal.h>
-/* Define this temporarily to hunt a bug. If defined, the size of
- strings is redundantly recorded in sdata structures so that it can
- be compared to the sizes recorded in Lisp strings. */
-
-#define GC_CHECK_STRING_BYTES 1
-
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
memory. Can do this only if using gmalloc.c. */
#undef HIDE_LISP_IMPLEMENTATION
#include "lisp.h"
+#include "process.h"
#include "intervals.h"
#include "puresize.h"
#include "buffer.h"
MEM_TYPE_MISC,
MEM_TYPE_SYMBOL,
MEM_TYPE_FLOAT,
- MEM_TYPE_VECTOR
+ /* Keep the following vector-like types together, with
+ MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
+ first. Or change the code of live_vector_p, for instance. */
+ MEM_TYPE_VECTOR,
+ MEM_TYPE_PROCESS,
+ MEM_TYPE_HASH_TABLE,
+ MEM_TYPE_FRAME,
+ MEM_TYPE_WINDOW
};
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static struct mem_node *mem_root;
+/* Lowest and highest known address in the heap. */
+
+static void *min_heap_address, *max_heap_address;
+
/* Sentinel node of the tree. */
static struct mem_node mem_z;
#define MEM_NIL &mem_z
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
+static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT, enum mem_type));
static void lisp_free P_ ((POINTER_TYPE *));
static void mark_stack P_ ((void));
static void init_stack P_ ((Lisp_Object *));
#define ALIGN(SZ, ALIGNMENT) \
(((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1))
+
\f
/************************************************************************
Malloc
#ifdef GC_CHECK_STRING_BYTES
-/* Check validity of all live Lisp strings' string_bytes member.
- Used for hunting a bug. */
-
static int check_string_bytes_count;
+void check_string_bytes P_ ((int));
+void check_sblock P_ ((struct sblock *));
+
+#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
+
+
+/* Like GC_STRING_BYTES, but with debugging check. */
+
+int
+string_bytes (s)
+ struct Lisp_String *s;
+{
+ int nbytes = (s->size_byte < 0 ? s->size : s->size_byte) & ~MARKBIT;
+ if (!PURE_POINTER_P (s)
+ && s->data
+ && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
+ abort ();
+ return nbytes;
+}
+
+/* Check validity Lisp strings' string_bytes member in B. */
+
void
-check_string_bytes ()
+check_sblock (b)
+ struct sblock *b;
{
- struct sblock *b;
-
- for (b = large_sblocks; b; b = b->next)
- {
- struct Lisp_String *s = b->first_data.string;
- if (s && GC_STRING_BYTES (s) != SDATA_NBYTES (SDATA_OF_STRING (s)))
- abort ();
- }
+ struct sdata *from, *end, *from_end;
- for (b = oldest_sblock; b; b = b->next)
+ end = b->next_free;
+
+ for (from = &b->first_data; from < end; from = from_end)
{
- struct sdata *from, *end, *from_end;
+ /* Compute the next FROM here because copying below may
+ overwrite data we need to compute it. */
+ int nbytes;
- end = b->next_free;
+ /* Check that the string size recorded in the string is the
+ same as the one recorded in the sdata structure. */
+ if (from->string)
+ CHECK_STRING_BYTES (from->string);
- for (from = &b->first_data; from < end; from = from_end)
- {
- /* Compute the next FROM here because copying below may
- overwrite data we need to compute it. */
- int nbytes;
+ if (from->string)
+ nbytes = GC_STRING_BYTES (from->string);
+ else
+ nbytes = SDATA_NBYTES (from);
+
+ nbytes = SDATA_SIZE (nbytes);
+ from_end = (struct sdata *) ((char *) from + nbytes);
+ }
+}
- /* Check that the string size recorded in the string is the
- same as the one recorded in the sdata structure. */
- if (from->string
- && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
- abort ();
-
- if (from->string)
- nbytes = GC_STRING_BYTES (from->string);
- else
- nbytes = SDATA_NBYTES (from);
-
- nbytes = SDATA_SIZE (nbytes);
- from_end = (struct sdata *) ((char *) from + nbytes);
+
+/* Check validity of Lisp strings' string_bytes member. ALL_P
+ non-zero means check all strings, otherwise check only most
+ recently allocated strings. Used for hunting a bug. */
+
+void
+check_string_bytes (all_p)
+ int all_p;
+{
+ if (all_p)
+ {
+ struct sblock *b;
+
+ for (b = large_sblocks; b; b = b->next)
+ {
+ struct Lisp_String *s = b->first_data.string;
+ if (s)
+ CHECK_STRING_BYTES (s);
}
+
+ for (b = oldest_sblock; b; b = b->next)
+ check_sblock (b);
}
+ else
+ check_sblock (current_sblock);
}
#endif /* GC_CHECK_STRING_BYTES */
consing_since_gc += sizeof *s;
#ifdef GC_CHECK_STRING_BYTES
- if (!noninteractive && ++check_string_bytes_count == 50)
+ if (!noninteractive
+#ifdef macintosh
+ && current_sblock
+#endif
+ )
{
- check_string_bytes_count = 0;
- check_string_bytes ();
+ if (++check_string_bytes_count == 200)
+ {
+ check_string_bytes_count = 0;
+ check_string_bytes (1);
+ }
+ else
+ check_string_bytes (0);
}
-#endif
+#endif /* GC_CHECK_STRING_BYTES */
return s;
}
size = XFASTINT (length);
val = Qnil;
- while (size-- > 0)
- val = Fcons (init, val);
+ while (size > 0)
+ {
+ val = Fcons (init, val);
+ --size;
+
+ if (size > 0)
+ {
+ val = Fcons (init, val);
+ --size;
+
+ if (size > 0)
+ {
+ val = Fcons (init, val);
+ --size;
+
+ if (size > 0)
+ {
+ val = Fcons (init, val);
+ --size;
+
+ if (size > 0)
+ {
+ val = Fcons (init, val);
+ --size;
+ }
+ }
+ }
+ }
+
+ QUIT;
+ }
+
return val;
}
/* Value is a pointer to a newly allocated Lisp_Vector structure
with room for LEN Lisp_Objects. */
-struct Lisp_Vector *
-allocate_vectorlike (len)
+static struct Lisp_Vector *
+allocate_vectorlike (len, type)
EMACS_INT len;
+ enum mem_type type;
{
struct Lisp_Vector *p;
size_t nbytes;
#endif
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
- p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTOR);
+ p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
}
+/* Allocate a vector with NSLOTS slots. */
+
+struct Lisp_Vector *
+allocate_vector (nslots)
+ EMACS_INT nslots;
+{
+ struct Lisp_Vector *v = allocate_vectorlike (nslots, MEM_TYPE_VECTOR);
+ v->size = nslots;
+ return v;
+}
+
+
+/* Allocate other vector-like structures. */
+
+struct Lisp_Hash_Table *
+allocate_hash_table ()
+{
+ EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
+ struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
+ EMACS_INT i;
+
+ v->size = len;
+ for (i = 0; i < len; ++i)
+ v->contents[i] = Qnil;
+
+ return (struct Lisp_Hash_Table *) v;
+}
+
+
+struct window *
+allocate_window ()
+{
+ EMACS_INT len = VECSIZE (struct window);
+ struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
+ EMACS_INT i;
+
+ for (i = 0; i < len; ++i)
+ v->contents[i] = Qnil;
+ v->size = len;
+
+ return (struct window *) v;
+}
+
+
+struct frame *
+allocate_frame ()
+{
+ EMACS_INT len = VECSIZE (struct frame);
+ struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
+ EMACS_INT i;
+
+ for (i = 0; i < len; ++i)
+ v->contents[i] = make_number (0);
+ v->size = len;
+ return (struct frame *) v;
+}
+
+
+struct Lisp_Process *
+allocate_process ()
+{
+ EMACS_INT len = VECSIZE (struct Lisp_Process);
+ struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
+ EMACS_INT i;
+
+ for (i = 0; i < len; ++i)
+ v->contents[i] = Qnil;
+ v->size = len;
+
+ return (struct Lisp_Process *) v;
+}
+
+
+struct Lisp_Vector *
+allocate_other_vector (len)
+ EMACS_INT len;
+{
+ struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
+ 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,
"Return a newly created vector of length LENGTH, with each element being INIT.\n\
See also the function `vector'.")
CHECK_NATNUM (length, 0);
sizei = XFASTINT (length);
- p = allocate_vectorlike (sizei);
- p->size = sizei;
+ p = allocate_vector (sizei);
for (index = 0; index < sizei; index++)
p->contents[index] = init;
{
struct mem_node *p;
+ if (start < min_heap_address || start > max_heap_address)
+ return MEM_NIL;
+
/* Make the search always successful to speed up the loop below. */
mem_z.start = start;
mem_z.end = (char *) start + 1;
{
struct mem_node *c, *parent, *x;
+ if (start < min_heap_address)
+ min_heap_address = start;
+ if (end > max_heap_address)
+ max_heap_address = end;
+
/* See where in the tree a node for START belongs. In this
particular application, it shouldn't happen that a node is already
present. For debugging purposes, let's check that. */
/* P must point to the start of a Lisp_String structure, and it
must not be on the free-list. */
- return (offset % sizeof b->strings[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->strings[0] == 0
&& ((struct Lisp_String *) p)->data != NULL);
}
else
/* P must point to the start of a Lisp_Cons, not be
one of the unused cells in the current cons block,
and not be on the free-list. */
- return (offset % sizeof b->conses[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->conses[0] == 0
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
&& !EQ (((struct Lisp_Cons *) p)->car, Vdead));
/* P must point to the start of a Lisp_Symbol, not be
one of the unused cells in the current symbol block,
and not be on the free-list. */
- return (offset % sizeof b->symbols[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->symbols[0] == 0
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index)
&& !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
/* P must point to the start of a Lisp_Float, not be
one of the unused cells in the current float block,
and not be on the free-list. */
- return (offset % sizeof b->floats[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->floats[0] == 0
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index)
&& !EQ (((struct Lisp_Float *) p)->type, Vdead));
/* P must point to the start of a Lisp_Misc, not be
one of the unused cells in the current misc block,
and not be on the free-list. */
- return (offset % sizeof b->markers[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->markers[0] == 0
&& (b != marker_block
|| offset / sizeof b->markers[0] < marker_block_index)
&& ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
struct mem_node *m;
void *p;
{
- return m->type == MEM_TYPE_VECTOR && p == m->start;
+ return (p == m->start
+ && m->type >= MEM_TYPE_VECTOR
+ && m->type <= MEM_TYPE_WINDOW);
}
}
}
}
+
+
+/* If P points to Lisp data, mark that as live if it isn't already
+ marked. */
+
+static INLINE void
+mark_maybe_pointer (p)
+ void *p;
+{
+ struct mem_node *m;
+
+ /* Quickly rule out some values which can't point to Lisp data. We
+ assume that Lisp data is aligned on even addresses. */
+ if ((EMACS_INT) p & 1)
+ return;
+
+ m = mem_find (p);
+ if (m != MEM_NIL)
+ {
+ Lisp_Object obj = Qnil;
+
+ switch (m->type)
+ {
+ case MEM_TYPE_NON_LISP:
+ /* Nothing to do; not a pointer to Lisp memory. */
+ break;
+
+ case MEM_TYPE_BUFFER:
+ if (live_buffer_p (m, p)
+ && !XMARKBIT (((struct buffer *) p)->name))
+ XSETVECTOR (obj, p);
+ break;
+
+ case MEM_TYPE_CONS:
+ if (live_cons_p (m, p)
+ && !XMARKBIT (((struct Lisp_Cons *) p)->car))
+ XSETCONS (obj, p);
+ break;
+
+ case MEM_TYPE_STRING:
+ if (live_string_p (m, p)
+ && !STRING_MARKED_P ((struct Lisp_String *) p))
+ XSETSTRING (obj, p);
+ break;
+
+ case MEM_TYPE_MISC:
+ if (live_misc_p (m, p))
+ {
+ Lisp_Object tem;
+ XSETMISC (tem, p);
+
+ switch (XMISCTYPE (tem))
+ {
+ case Lisp_Misc_Marker:
+ if (!XMARKBIT (XMARKER (tem)->chain))
+ obj = tem;
+ break;
+
+ case Lisp_Misc_Buffer_Local_Value:
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue))
+ obj = tem;
+ break;
+
+ case Lisp_Misc_Overlay:
+ if (!XMARKBIT (XOVERLAY (tem)->plist))
+ obj = tem;
+ break;
+ }
+ }
+ break;
-/* Mark Lisp objects in the address range START..END. */
+ case MEM_TYPE_SYMBOL:
+ if (live_symbol_p (m, p)
+ && !XMARKBIT (((struct Lisp_Symbol *) p)->plist))
+ XSETSYMBOL (obj, p);
+ break;
+
+ case MEM_TYPE_FLOAT:
+ if (live_float_p (m, p)
+ && !XMARKBIT (((struct Lisp_Float *) p)->type))
+ XSETFLOAT (obj, p);
+ break;
+
+ case MEM_TYPE_VECTOR:
+ case MEM_TYPE_PROCESS:
+ case MEM_TYPE_HASH_TABLE:
+ case MEM_TYPE_FRAME:
+ case MEM_TYPE_WINDOW:
+ if (live_vector_p (m, p))
+ {
+ Lisp_Object tem;
+ XSETVECTOR (tem, p);
+ if (!GC_SUBRP (tem)
+ && !(XVECTOR (tem)->size & ARRAY_MARK_FLAG))
+ obj = tem;
+ }
+ break;
+
+ default:
+ abort ();
+ }
+
+ if (!GC_NILP (obj))
+ mark_object (&obj);
+ }
+}
+
+
+/* Mark Lisp objects referenced from the address range START..END. */
static void
mark_memory (start, end)
void *start, *end;
{
Lisp_Object *p;
+ void **pp;
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
nzombies = 0;
start = end;
end = tem;
}
-
+
+ /* Mark Lisp_Objects. */
for (p = (Lisp_Object *) start; (void *) p < end; ++p)
mark_maybe_object (*p);
+
+ /* Mark Lisp data pointed to. This is necessary because, in some
+ situations, the C compiler optimizes Lisp objects away, so that
+ only a pointer to them remains. Example:
+
+ DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
+ ()
+ {
+ Lisp_Object obj = build_string ("test");
+ struct Lisp_String *s = XSTRING (obj);
+ Fgarbage_collect ();
+ fprintf (stderr, "test `%s'\n", s->data);
+ return Qnil;
+ }
+
+ Here, `obj' isn't really used, and the compiler optimizes it
+ away. The only reference to the life string is through the
+ pointer `s'. */
+
+ for (pp = (void **) start; (void *) pp < end; ++pp)
+ mark_maybe_pointer (*pp);
}
MARK_INTERVAL_TREE (ptr->intervals);
MARK_STRING (ptr);
#ifdef GC_CHECK_STRING_BYTES
- {
- /* Check that the string size recorded in the string is the
- same as the one recorded in the sdata structure. */
- struct sdata *p = SDATA_OF_STRING (ptr);
- if (GC_STRING_BYTES (ptr) != SDATA_NBYTES (p))
- abort ();
- }
+ /* Check that the string size recorded in the string is the
+ same as the one recorded in the sdata structure. */
+ CHECK_STRING_BYTES (ptr);
#endif /* GC_CHECK_STRING_BYTES */
}
break;
sweep_weak_hash_tables ();
sweep_strings ();
+#ifdef GC_CHECK_STRING_BYTES
+ if (!noninteractive)
+ check_string_bytes (1);
+#endif
/* Put all unmarked conses on free list */
{
prev = vector, vector = vector->next;
}
}
+
+#ifdef GC_CHECK_STRING_BYTES
+ if (!noninteractive)
+ check_string_bytes (1);
+#endif
}