/* 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 Free Software Foundation, Inc.
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
-#include "charset.h"
+#include "character.h"
#include "syssignal.h"
#include <setjmp.h>
extern POINTER_TYPE *sbrk ();
#endif
+#ifdef HAVE_FCNTL_H
+#define INCLUDED_FCNTL
+#include <fcntl.h>
+#endif
+#ifndef O_WRONLY
+#define O_WRONLY 1
+#endif
+
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
}
eassert ((aligned & 1) == aligned);
eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
+#ifdef HAVE_POSIX_MEMALIGN
+ eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
+#endif
free (ABLOCKS_BASE (abase));
}
UNBLOCK_INPUT;
{
INTERVAL val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (interval_free_list)
{
val = interval_free_list;
}
val = &interval_block->intervals[interval_block_index++];
}
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
consing_since_gc += sizeof (struct interval);
intervals_consed++;
RESET_INTERVAL (val);
{
struct Lisp_String *s;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
/* If the free-list is empty, allocate a new string_block, and
add all the Lisp_Strings in it to the free-list. */
if (string_free_list == NULL)
s = string_free_list;
string_free_list = NEXT_FREE_LISP_STRING (s);
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
/* Probably not strictly necessary, but play it safe. */
bzero (s, sizeof *s);
/* Determine the number of bytes needed to store NBYTES bytes
of string data. */
needed = SDATA_SIZE (nbytes);
+ old_data = s->data ? SDATA_OF_STRING (s) : NULL;
+ old_nbytes = GC_STRING_BYTES (s);
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
if (nbytes > LARGE_STRING_BYTES)
{
else
b = current_sblock;
- old_data = s->data ? SDATA_OF_STRING (s) : NULL;
- old_nbytes = GC_STRING_BYTES (s);
-
data = b->next_free;
+ b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
data->string = s;
s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
bcopy (string_overrun_cookie, (char *) data + needed,
GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
- b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
/* If S had already data assigned, mark that as free by setting its
string back-pointer to null, and recording the size of the data
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);
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
- doc: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
+ doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
LENGTH must be a number. INIT matters only in whether it is t or nil. */)
(length, init)
Lisp_Object length, init;
free_float (ptr)
struct Lisp_Float *ptr;
{
- *(struct Lisp_Float **)&ptr->data = float_free_list;
+ ptr->u.chain = float_free_list;
float_free_list = ptr;
}
{
register Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (float_free_list)
{
/* We use the data field for chaining the free list
so that we won't use the same field that has the mark bit. */
XSETFLOAT (val, float_free_list);
- float_free_list = *(struct Lisp_Float **)&float_free_list->data;
+ float_free_list = float_free_list->u.chain;
}
else
{
float_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
XFLOAT_DATA (val) = float_value;
eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
free_cons (ptr)
struct Lisp_Cons *ptr;
{
- *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
+ ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
ptr->car = Vdead;
#endif
{
register Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (cons_free_list)
{
/* We use the cdr for chaining the free list
so that we won't use the same field that has the mark bit. */
XSETCONS (val, cons_free_list);
- cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
+ cons_free_list = cons_free_list->u.chain;
}
else
{
cons_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
XSETCAR (val, car);
XSETCDR (val, cdr);
eassert (!CONS_MARKED_P (XCONS (val)));
struct Lisp_Cons *tail = cons_free_list;
while (tail)
- tail = *(struct Lisp_Cons **)&tail->cdr;
+ tail = tail->u.chain;
#endif
}
UNBLOCK_INPUT;
#endif
+ /* This gets triggered by code which I haven't bothered to fix. --Stef */
+ /* eassert (!handling_signal); */
+
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
consing_since_gc += nbytes;
vector_cells_consed += len;
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
p->next = all_vectors;
all_vectors = p;
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
++n_vectors;
return p;
}
}
-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);
- 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);
- 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.
CHECK_STRING (name);
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (symbol_free_list)
{
XSETSYMBOL (val, symbol_free_list);
- symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
+ symbol_free_list = symbol_free_list->next;
}
else
{
symbol_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
p = XSYMBOL (val);
p->xname = name;
p->plist = Qnil;
{
Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (marker_free_list)
{
XSETMISC (val, marker_free_list);
marker_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
--total_free_markers;
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
#endif
}
-
#endif /* GC_MARK_STACK != 0 */
+
+/* Return 1 if OBJ is a valid lisp object.
+ Return 0 if OBJ is NOT a valid lisp object.
+ Return -1 if we cannot validate OBJ.
+ This function can be quite slow,
+ so it should only be used in code for manual debugging. */
+
+int
+valid_lisp_object_p (obj)
+ Lisp_Object obj;
+{
+ void *p;
+#if !GC_MARK_STACK
+ int fd;
+#else
+ struct mem_node *m;
+#endif
+
+ if (INTEGERP (obj))
+ return 1;
+
+ p = (void *) XPNTR (obj);
+ if (PURE_POINTER_P (p))
+ return 1;
+
+#if !GC_MARK_STACK
+ /* We need to determine whether it is safe to access memory at
+ address P. Obviously, we cannot just access it (we would SEGV
+ trying), so we trick the o/s to tell us whether p is a valid
+ pointer. Unfortunately, we cannot use NULL_DEVICE here, as
+ emacs_write may not validate p in that case. */
+ if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
+ {
+ int valid = (emacs_write (fd, (char *)p, 16) == 16);
+ emacs_close (fd);
+ unlink ("__Valid__Lisp__Object__");
+ return valid;
+ }
+
+ return -1;
+#else
+
+ m = mem_find (p);
+
+ if (m == MEM_NIL)
+ return 0;
+
+ switch (m->type)
+ {
+ case MEM_TYPE_NON_LISP:
+ return 0;
+
+ case MEM_TYPE_BUFFER:
+ return live_buffer_p (m, p);
+
+ case MEM_TYPE_CONS:
+ return live_cons_p (m, p);
+
+ case MEM_TYPE_STRING:
+ return live_string_p (m, p);
+
+ case MEM_TYPE_MISC:
+ return live_misc_p (m, p);
+
+ case MEM_TYPE_SYMBOL:
+ return live_symbol_p (m, p);
+
+ case MEM_TYPE_FLOAT:
+ return live_float_p (m, p);
+
+ case MEM_TYPE_VECTOR:
+ case MEM_TYPE_PROCESS:
+ case MEM_TYPE_HASH_TABLE:
+ case MEM_TYPE_FRAME:
+ case MEM_TYPE_WINDOW:
+ return live_vector_p (m, p);
+
+ default:
+ break;
+ }
+
+ return 0;
+#endif
+}
+
+
+
\f
/***********************************************************************
Pure Storage Management
check_pure_size ()
{
if (pure_bytes_used_before_overflow)
- message ("Pure Lisp storage overflow (approx. %d bytes needed)",
+ message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
(int) (pure_bytes_used + pure_bytes_used_before_overflow));
}
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
- doc: /* Make a copy of OBJECT in pure storage.
+ doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
Does not copy symbols. Copies strings without text properties. */)
(obj)
total += total_floats * sizeof (struct Lisp_Float);
total += total_intervals * sizeof (struct interval);
total += total_strings * sizeof (struct Lisp_String);
-
+
gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
}
else
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
CONS_MARK (ptr);
/* If the cdr is nil, avoid recursion for the car. */
- if (EQ (ptr->cdr, Qnil))
+ if (EQ (ptr->u.cdr, Qnil))
{
obj = ptr->car;
cdr_count = 0;
goto loop;
}
mark_object (ptr->car);
- obj = ptr->cdr;
+ obj = ptr->u.cdr;
cdr_count++;
if (cdr_count == mark_object_loop_halt)
abort ();
if (!CONS_MARKED_P (&cblk->conses[i]))
{
this_free++;
- *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
+ cblk->conses[i].u.chain = cons_free_list;
cons_free_list = &cblk->conses[i];
#if GC_MARK_STACK
cons_free_list->car = Vdead;
{
*cprev = cblk->next;
/* Unhook from the free list. */
- cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
+ cons_free_list = cblk->conses[0].u.chain;
lisp_align_free (cblk);
n_cons_blocks--;
}
if (!FLOAT_MARKED_P (&fblk->floats[i]))
{
this_free++;
- *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
+ fblk->floats[i].u.chain = float_free_list;
float_free_list = &fblk->floats[i];
}
else
{
*fprev = fblk->next;
/* Unhook from the free list. */
- float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
+ float_free_list = fblk->floats[0].u.chain;
lisp_align_free (fblk);
n_float_blocks--;
}
if (!sym->gcmarkbit && !pure_p)
{
- *(struct Lisp_Symbol **) &sym->value = symbol_free_list;
+ sym->next = symbol_free_list;
symbol_free_list = sym;
#if GC_MARK_STACK
symbol_free_list->function = Vdead;
{
*sprev = sblk->next;
/* Unhook from the free list. */
- symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
+ symbol_free_list = sblk->symbols[0].next;
lisp_free (sblk);
n_symbol_blocks--;
}
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
- defsubr (&Smake_char_table);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);