#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
-#include "charset.h"
+#include "character.h"
#include "syssignal.h"
#include <setjmp.h>
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
-#define MARK_STRING(S) ((S)->size |= MARKBIT)
-#define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
-#define STRING_MARKED_P(S) ((S)->size & MARKBIT)
+#define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
+#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
+#define STRING_MARKED_P(S) ((S)->size & ARRAY_MARK_FLAG)
#define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
#define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
strings. */
#define GC_STRING_BYTES(S) (STRING_BYTES (S))
-#define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
+#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
/* Number of bytes of consing done since the last gc. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
+ /* If the memory just allocated cannot be addressed thru a Lisp
+ object's pointer, and it needs to be, that's equivalent to
+ running out of memory. */
+ if (type != MEM_TYPE_NON_LISP)
+ {
+ Lisp_Object tem;
+ char *end = (char *) base + ABLOCKS_BYTES - 1;
+ XSETCONS (tem, end);
+ if ((char *) XCONS (tem) != end)
+ {
+ lisp_malloc_loser = base;
+ free (base);
+ UNBLOCK_INPUT;
+ memory_full ();
+ }
+ }
+
/* Initialize the blocks and put them on the free list.
Is `base' was not properly aligned, we can't use the last block. */
for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
val = free_ablock;
free_ablock = free_ablock->x.next_free;
- /* If the memory just allocated cannot be addressed thru a Lisp
- object's pointer, and it needs to be,
- that's equivalent to running out of memory. */
- if (val && type != MEM_TYPE_NON_LISP)
- {
- Lisp_Object tem;
- XSETCONS (tem, (char *) val + nbytes - 1);
- if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
- {
- lisp_malloc_loser = val;
- free (val);
- val = 0;
- }
- }
-
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
string_bytes (s)
struct Lisp_String *s;
{
- int nbytes = (s->size_byte < 0 ? s->size & ~MARKBIT : s->size_byte);
+ int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
if (!PURE_POINTER_P (s)
&& s->data
&& nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
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);
void
init_float ()
{
- float_block = (struct float_block *) lisp_align_malloc (sizeof *float_block,
- MEM_TYPE_FLOAT);
- float_block->next = 0;
- bzero ((char *) float_block->floats, sizeof float_block->floats);
- bzero ((char *) float_block->gcmarkbits, sizeof float_block->gcmarkbits);
- float_block_index = 0;
+ float_block = NULL;
+ float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
float_free_list = 0;
- n_float_blocks = 1;
+ n_float_blocks = 0;
}
/* We store cons cells inside of cons_blocks, allocating a new
cons_block with malloc whenever necessary. Cons cells reclaimed by
GC are put on a free list to be reallocated before allocating
- any new cons cells from the latest cons_block.
-
- Each cons_block is just under 1020 bytes long,
- since malloc really allocates in units of powers of two
- and uses 4 bytes for its own overhead. */
+ any new cons cells from the latest cons_block. */
#define CONS_BLOCK_SIZE \
- ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
+ (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
+ / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
+
+#define CONS_BLOCK(fptr) \
+ ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
+
+#define CONS_INDEX(fptr) \
+ ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
struct cons_block
{
- struct cons_block *next;
+ /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
struct Lisp_Cons conses[CONS_BLOCK_SIZE];
+ int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
+ struct cons_block *next;
};
+#define CONS_MARKED_P(fptr) \
+ GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
+#define CONS_MARK(fptr) \
+ SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
+#define CONS_UNMARK(fptr) \
+ UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
/* Current cons_block. */
struct cons_block *cons_block;
void
init_cons ()
{
- cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
- MEM_TYPE_CONS);
- cons_block->next = 0;
- bzero ((char *) cons_block->conses, sizeof cons_block->conses);
- cons_block_index = 0;
+ cons_block = NULL;
+ cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
cons_free_list = 0;
- n_cons_blocks = 1;
+ n_cons_blocks = 0;
}
if (cons_block_index == CONS_BLOCK_SIZE)
{
register struct cons_block *new;
- new = (struct cons_block *) lisp_malloc (sizeof *new,
- MEM_TYPE_CONS);
+ new = (struct cons_block *) lisp_align_malloc (sizeof *new,
+ MEM_TYPE_CONS);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
XSETCAR (val, car);
XSETCDR (val, cdr);
+ CONS_UNMARK (XCONS (val));
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
}
-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 default value DEFALT.
- 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 (defalt)
- Lisp_Object defalt;
-{
- Lisp_Object vector
- = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), Qnil);
- XCHAR_TABLE (vector)->top = Qnil;
- XCHAR_TABLE (vector)->defalt = defalt;
- 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.
one of the unused cells in the current cons block,
and not be on the free-list. */
return (offset >= 0
+ && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
&& offset % sizeof b->conses[0] == 0
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
break;
case Lisp_Cons:
- mark_p = (live_cons_p (m, po)
- && !XMARKBIT (XCONS (obj)->car));
+ mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
break;
case Lisp_Symbol:
break;
case MEM_TYPE_CONS:
- if (live_cons_p (m, p)
- && !XMARKBIT (((struct Lisp_Cons *) p)->car))
+ if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
XSETCONS (obj, p);
break;
for (i = 0; i < tail->nvars; i++)
if (!XMARKBIT (tail->var[i]))
{
- /* Explicit casting prevents compiler warning about
- discarding the `volatile' qualifier. */
mark_object (tail->var[i]);
XMARK (tail->var[i]);
}
mark_byte_stack ();
for (bind = specpdl; bind != specpdl_ptr; bind++)
{
- /* These casts avoid a warning for discarding `volatile'. */
mark_object (bind->symbol);
mark_object (bind->old_value);
}
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. */
+ case Lisp_Misc_Save_Value:
break;
case Lisp_Misc_Overlay:
case Lisp_Cons:
{
register struct Lisp_Cons *ptr = XCONS (obj);
- if (XMARKBIT (ptr->car)) break;
+ if (CONS_MARKED_P (ptr)) break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
- XMARK (ptr->car);
+ CONS_MARK (ptr);
/* If the cdr is nil, avoid recursion for the car. */
if (EQ (ptr->cdr, Qnil))
{
{
register struct Lisp_Cons *ptr = XCONS (tail);
- if (XMARKBIT (ptr->car))
+ if (CONS_MARKED_P (ptr))
break;
- XMARK (ptr->car);
+ CONS_MARK (ptr);
if (GC_CONSP (ptr->car)
- && ! XMARKBIT (XCAR (ptr->car))
+ && !CONS_MARKED_P (XCONS (ptr->car))
&& GC_MARKERP (XCAR (ptr->car)))
{
- XMARK (XCAR_AS_LVALUE (ptr->car));
+ CONS_MARK (XCONS (ptr->car));
mark_object (XCDR (ptr->car));
}
else
break;
case Lisp_String:
- {
- struct Lisp_String *s = XSTRING (obj);
- survives_p = STRING_MARKED_P (s);
- }
+ survives_p = STRING_MARKED_P (XSTRING (obj));
break;
case Lisp_Vectorlike:
- if (GC_BUFFERP (obj))
- survives_p = VECTOR_MARKED_P (XBUFFER (obj));
- else if (GC_SUBRP (obj))
- survives_p = 1;
- else
- survives_p = VECTOR_MARKED_P (XVECTOR (obj));
+ survives_p = GC_SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
break;
case Lisp_Cons:
- survives_p = XMARKBIT (XCAR (obj));
+ survives_p = CONS_MARKED_P (XCONS (obj));
break;
case Lisp_Float:
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
- if (!XMARKBIT (cblk->conses[i].car))
+ if (!CONS_MARKED_P (&cblk->conses[i]))
{
this_free++;
*(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
else
{
num_used++;
- XUNMARK (cblk->conses[i].car);
+ CONS_UNMARK (&cblk->conses[i]);
}
lim = CONS_BLOCK_SIZE;
/* If this block contains only free conses and we have already
*cprev = cblk->next;
/* Unhook from the free list. */
cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
- lisp_free (cblk);
+ lisp_align_free (cblk);
n_cons_blocks--;
}
else
DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
doc: /* Accumulated time elapsed in garbage collections.
-The time is in seconds as a floating point value.
-Programs may reset this to get statistics in a specific period. */);
+The time is in seconds as a floating point value. */);
DEFVAR_INT ("gcs-done", &gcs_done,
- doc: /* Accumulated number of garbage collections done.
-Programs may reset this to get statistics in a specific period. */);
+ doc: /* Accumulated number of garbage collections done. */);
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
- defsubr (&Smake_char_table);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);
HCoop / bpt / emacs.git / blobdiff