/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#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. */
#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;
}
}
else
{
- unsigned char str[4];
+ unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = CHAR_STRING (c, str);
nbytes = len * XINT (length);
int nchars, multibyte_nbytes;
parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
- val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
if (nbytes == nchars || nbytes != multibyte_nbytes)
/* CONTENTS contains no multibyte sequences or contains an invalid
multibyte sequence. We must make unibyte string. */
- SET_STRING_BYTES (XSTRING (val), -1);
+ val = make_unibyte_string (contents, nbytes);
+ else
+ val = make_multibyte_string (contents, nchars, nbytes);
return val;
}
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;
}
Returns info on amount of space in use:\n\
((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
(USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
- (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
+ (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)\n\
(USED-STRINGS . FREE-STRINGS))\n\
Garbage collection happens automatically if you cons more than\n\
`gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
char stack_top_variable;
register int i;
int message_p;
- Lisp_Object total[7];
+ Lisp_Object total[8];
+ int count = BINDING_STACK_SIZE ();
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
/* Save what's currently displayed in the echo area. */
message_p = push_message ();
+ record_unwind_protect (push_message_unwind, Qnil);
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
message1_nolog ("Garbage collecting...done");
}
- pop_message ();
+ unbind_to (count, Qnil);
total[0] = Fcons (make_number (total_conses),
make_number (total_free_conses));
make_number (total_free_symbols));
total[2] = Fcons (make_number (total_markers),
make_number (total_free_markers));
- total[3] = Fcons (make_number (total_string_size),
- make_number (total_vector_size));
- total[4] = Fcons (make_number (total_floats),
+ total[3] = make_number (total_string_size);
+ total[4] = make_number (total_vector_size);
+ total[5] = Fcons (make_number (total_floats),
make_number (total_free_floats));
- total[5] = Fcons (make_number (total_intervals),
+ total[6] = Fcons (make_number (total_intervals),
make_number (total_free_intervals));
- total[6] = Fcons (make_number (total_strings),
+ total[7] = Fcons (make_number (total_strings),
make_number (total_free_strings));
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
}
#endif
- return Flist (7, total);
+ return Flist (sizeof total / sizeof *total, total);
}
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;
mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
mark_image_cache (ptr);
- mark_object (&ptr->desired_tool_bar_items);
- mark_object (&ptr->current_tool_bar_items);
+ mark_object (&ptr->tool_bar_items);
mark_object (&ptr->desired_tool_bar_string);
mark_object (&ptr->current_tool_bar_string);
#endif /* HAVE_WINDOW_SYSTEM */
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 */
{
register int lim = symbol_block_index;
register int num_free = 0, num_used = 0;
- symbol_free_list = 0;
+ symbol_free_list = NULL;
for (sblk = symbol_block; sblk; sblk = *sprev)
{
- register int i;
int this_free = 0;
- for (i = 0; i < lim; i++)
- if (!XMARKBIT (sblk->symbols[i].plist))
- {
- *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
- symbol_free_list = &sblk->symbols[i];
+ struct Lisp_Symbol *sym = sblk->symbols;
+ struct Lisp_Symbol *end = sym + lim;
+
+ for (; sym < end; ++sym)
+ {
+ /* Check if the symbol was created during loadup. In such a case
+ it might be pointed to by pure bytecode which we don't trace,
+ so we conservatively assume that it is live. */
+ int pure_p = PURE_POINTER_P (sym->name);
+
+ if (!XMARKBIT (sym->plist) && !pure_p)
+ {
+ *(struct Lisp_Symbol **) &sym->value = symbol_free_list;
+ symbol_free_list = sym;
#if GC_MARK_STACK
- symbol_free_list->function = Vdead;
+ symbol_free_list->function = Vdead;
#endif
- this_free++;
- }
- else
- {
- num_used++;
- if (!PURE_POINTER_P (sblk->symbols[i].name))
- UNMARK_STRING (sblk->symbols[i].name);
- XUNMARK (sblk->symbols[i].plist);
- }
+ ++this_free;
+ }
+ else
+ {
+ ++num_used;
+ if (!pure_p)
+ UNMARK_STRING (sym->name);
+ XUNMARK (sym->plist);
+ }
+ }
+
lim = SYMBOL_BLOCK_SIZE;
/* If this block contains only free symbols and we have already
seen more than two blocks worth of free symbols then deallocate
prev = vector, vector = vector->next;
}
}
+
+#ifdef GC_CHECK_STRING_BYTES
+ if (!noninteractive)
+ check_string_bytes (1);
+#endif
}
HCoop / bpt / emacs.git / blobdiff