return bool_vector_fill (val, init);
}
+DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
+ doc: /* Return a new bool-vector with specified arguments as elements.
+Any number of arguments, even zero arguments, are allowed.
+usage: (bool-vector &rest OBJECTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t i;
+ Lisp_Object vector;
+
+ vector = make_uninit_bool_vector (nargs);
+ for (i = 0; i < nargs; i++)
+ bool_vector_set (vector, i, !NILP (args[i]));
+
+ return vector;
+}
/* Make a string from NBYTES bytes at CONTENTS, and compute the number
of characters from the contents. This string may be unibyte or
#define FLOAT_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct float_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
#define GETMARKBIT(block,n) \
- (((block)->gcmarkbits[(n) / (sizeof (unsigned) * CHAR_BIT)] \
- >> ((n) % (sizeof (unsigned) * CHAR_BIT))) \
+ (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ >> ((n) % BITS_PER_BITS_WORD)) \
& 1)
#define SETMARKBIT(block,n) \
- ((block)->gcmarkbits[(n) / (sizeof (unsigned) * CHAR_BIT)] \
- |= 1u << ((n) % (sizeof (unsigned) * CHAR_BIT)))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
#define UNSETMARKBIT(block,n) \
- ((block)->gcmarkbits[(n) / (sizeof (unsigned) * CHAR_BIT)] \
- &= ~(1u << ((n) % (sizeof (unsigned) * CHAR_BIT))))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
#define FLOAT_BLOCK(fptr) \
((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
{
/* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
- unsigned gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (unsigned) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + FLOAT_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct float_block *next;
};
#define CONS_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct cons_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
{
/* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
struct Lisp_Cons conses[CONS_BLOCK_SIZE];
- unsigned gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (unsigned) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + CONS_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct cons_block *next;
};
&& ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
== FONT_OBJECT_MAX))
{
- /* Attempt to catch subtle bugs like Bug#16140. */
- eassert (valid_font_driver (((struct font *) vector)->driver));
- ((struct font *) vector)->driver->close ((struct font *) vector);
+ struct font_driver *drv = ((struct font *) vector)->driver;
+
+ /* The font driver might sometimes be NULL, e.g. if Emacs was
+ interrupted before it had time to set it up. */
+ if (drv)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close ((struct font *) vector);
+ }
}
}
}
}
+/* Return true if P can point to Lisp data, and false otherwise.
+ USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
+ Otherwise, assume that Lisp data is aligned on even addresses. */
+
+static bool
+maybe_lisp_pointer (void *p)
+{
+ return !((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2));
+}
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
- /* Quickly rule out some values which can't point to Lisp data.
- USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
- Otherwise, assume that Lisp data is aligned on even addresses. */
- if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
+ if (!maybe_lisp_pointer (p))
return;
m = mem_find (p);
from the stack start. */
static void
-mark_stack (void)
+mark_stack (void *end)
{
- void *end;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
- /* Force callee-saved registers and register windows onto the stack.
- This is the preferred method if available, obviating the need for
- machine dependent methods. */
- __builtin_unwind_init ();
- end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
- /* jmp_buf may not be aligned enough on darwin-ppc64 */
- union aligned_jmpbuf {
- Lisp_Object o;
- sys_jmp_buf j;
- } j;
- volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
-#endif
- /* This trick flushes the register windows so that all the state of
- the process is contained in the 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__
-#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
- registers used to hold register variables and registers used to
- pass parameters. */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
- GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
- setjmp will definitely work, test it
- and print a message with the result
- of the test. */
- if (!setjmp_tested_p)
- {
- setjmp_tested_p = 1;
- test_setjmp ();
- }
-#endif /* GC_SETJMP_WORKS */
-
- sys_setjmp (j.j);
- end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
#endif
}
+/* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String
+ (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0
+ if not. Otherwise we can't rely on valid_lisp_object_p and return -1.
+ This function is slow and should be used for debugging purposes. */
+int
+relocatable_string_data_p (const char *str)
+{
+ if (PURE_POINTER_P (str))
+ return 0;
+#if GC_MARK_STACK
+ if (str)
+ {
+ struct sdata *sdata
+ = (struct sdata *) (str - offsetof (struct sdata, data));
+
+ if (valid_pointer_p (sdata)
+ && valid_pointer_p (sdata->string)
+ && maybe_lisp_pointer (sdata->string))
+ return (valid_lisp_object_p
+ (make_lisp_ptr (sdata->string, Lisp_String))
+ && (const char *) sdata->string->data == str);
+ }
+ return 0;
+#endif /* GC_MARK_STACK */
+ return -1;
+}
-\f
/***********************************************************************
Pure Storage Management
***********************************************************************/
}
}
-DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
- doc: /* Reclaim storage for Lisp objects no longer needed.
-Garbage collection happens automatically if you cons more than
-`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
-`garbage-collect' normally returns a list with info on amount of space in use,
-where each entry has the form (NAME SIZE USED FREE), where:
-- NAME is a symbol describing the kind of objects this entry represents,
-- SIZE is the number of bytes used by each one,
-- USED is the number of those objects that were found live in the heap,
-- FREE is the number of those objects that are not live but that Emacs
- keeps around for future allocations (maybe because it does not know how
- to return them to the OS).
-However, if there was overflow in pure space, `garbage-collect'
-returns nil, because real GC can't be done.
-See Info node `(elisp)Garbage Collection'. */)
- (void)
+/* Subroutine of Fgarbage_collect that does most of the work. It is a
+ separate function so that we could limit mark_stack in searching
+ the stack frames below this function, thus avoiding the rare cases
+ where mark_stack finds values that look like live Lisp objects on
+ portions of stack that couldn't possibly contain such live objects.
+ For more details of this, see the discussion at
+ http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
+static Lisp_Object
+garbage_collect_1 (void *end)
{
struct buffer *nextb;
char stack_top_variable;
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|| GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
- mark_stack ();
+ mark_stack (end);
#else
{
register struct gcpro *tail;
#endif
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- mark_stack ();
+ mark_stack (end);
#endif
/* Everything is now marked, except for the data in font caches
return retval;
}
+DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
+ doc: /* Reclaim storage for Lisp objects no longer needed.
+Garbage collection happens automatically if you cons more than
+`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
+`garbage-collect' normally returns a list with info on amount of space in use,
+where each entry has the form (NAME SIZE USED FREE), where:
+- NAME is a symbol describing the kind of objects this entry represents,
+- SIZE is the number of bytes used by each one,
+- USED is the number of those objects that were found live in the heap,
+- FREE is the number of those objects that are not live but that Emacs
+ keeps around for future allocations (maybe because it does not know how
+ to return them to the OS).
+However, if there was overflow in pure space, `garbage-collect'
+returns nil, because real GC can't be done.
+See Info node `(elisp)Garbage Collection'. */)
+ (void)
+{
+#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
+ || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS \
+ || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
+ void *end;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
+#endif
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the 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__
+#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
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_setjmp (j.j);
+ end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+ return garbage_collect_1 (end);
+#elif (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE)
+ /* Old GCPROs-based method without stack marking. */
+ return garbage_collect_1 (NULL);
+#else
+ emacs_abort ();
+#endif /* GC_MARK_STACK */
+}
/* Mark Lisp objects in glyph matrix MATRIX. Currently the
only interesting objects referenced from glyphs are strings. */
}
}
+NO_INLINE /* To reduce stack depth in mark_object. */
+static Lisp_Object
+mark_compiled (struct Lisp_Vector *ptr)
+{
+ int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
+
+ VECTOR_MARK (ptr);
+ for (i = 0; i < size; i++)
+ if (i != COMPILED_CONSTANTS)
+ mark_object (ptr->contents[i]);
+ return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
+}
+
/* Mark the chain of overlays starting at PTR. */
static void
/* Mark Lisp faces in the face cache C. */
+NO_INLINE /* To reduce stack depth in mark_object. */
static void
mark_face_cache (struct face_cache *c)
{
}
}
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_localized_symbol (struct Lisp_Symbol *ptr)
+{
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ Lisp_Object where = blv->where;
+ /* If the value is set up for a killed buffer or deleted
+ frame, restore its global binding. If the value is
+ forwarded to a C variable, either it's not a Lisp_Object
+ var, or it's staticpro'd already. */
+ if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
+ || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
+ swap_in_global_binding (ptr);
+ mark_object (blv->where);
+ mark_object (blv->valcell);
+ mark_object (blv->defcell);
+}
+
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_save_value (struct Lisp_Save_Value *ptr)
+{
+ /* If `save_type' is zero, `data[0].pointer' is the address
+ of a memory area containing `data[1].integer' potential
+ Lisp_Objects. */
+ if (GC_MARK_STACK && ptr->save_type == SAVE_TYPE_MEMORY)
+ {
+ Lisp_Object *p = ptr->data[0].pointer;
+ ptrdiff_t nelt;
+ for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
+ mark_maybe_object (*p);
+ }
+ else
+ {
+ /* Find Lisp_Objects in `data[N]' slots and mark them. */
+ int i;
+ for (i = 0; i < SAVE_VALUE_SLOTS; i++)
+ if (save_type (ptr, i) == SAVE_OBJECT)
+ mark_object (ptr->data[i].object);
+ }
+}
+
/* Remove killed buffers or items whose car is a killed buffer from
LIST, and mark other items. Return changed LIST, which is marked. */
return list;
}
-/* Determine type of generic Lisp_Object and mark it accordingly. */
+/* Determine type of generic Lisp_Object and mark it accordingly.
+
+ This function implements a straightforward depth-first marking
+ algorithm and so the recursion depth may be very high (a few
+ tens of thousands is not uncommon). To minimize stack usage,
+ a few cold paths are moved out to NO_INLINE functions above.
+ In general, inlining them doesn't help you to gain more speed. */
void
mark_object (Lisp_Object arg)
break;
case PVEC_COMPILED:
- { /* We could treat this just like a vector, but it is better
- to save the COMPILED_CONSTANTS element for last and avoid
- recursion there. */
- int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- int i;
-
- VECTOR_MARK (ptr);
- for (i = 0; i < size; i++)
- if (i != COMPILED_CONSTANTS)
- mark_object (ptr->contents[i]);
- if (size > COMPILED_CONSTANTS)
- {
- obj = ptr->contents[COMPILED_CONSTANTS];
- goto loop;
- }
- }
+ /* Although we could treat this just like a vector, mark_compiled
+ returns the COMPILED_CONSTANTS element, which is marked at the
+ next iteration of goto-loop here. This is done to avoid a few
+ recursive calls to mark_object. */
+ obj = mark_compiled (ptr);
+ if (!NILP (obj))
+ goto loop;
break;
case PVEC_FRAME:
case Lisp_Symbol:
{
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
- struct Lisp_Symbol *ptrx;
-
+ nextsym:
if (ptr->gcmarkbit)
break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
break;
}
case SYMBOL_LOCALIZED:
- {
- struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
- Lisp_Object where = blv->where;
- /* If the value is set up for a killed buffer or deleted
- frame, restore it's global binding. If the value is
- forwarded to a C variable, either it's not a Lisp_Object
- var, or it's staticpro'd already. */
- if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
- || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
- swap_in_global_binding (ptr);
- mark_object (blv->where);
- mark_object (blv->valcell);
- mark_object (blv->defcell);
- break;
- }
+ mark_localized_symbol (ptr);
+ break;
case SYMBOL_FORWARDED:
/* If the value is forwarded to a buffer or keyboard field,
these are marked when we see the corresponding object.
if (!PURE_POINTER_P (XSTRING (ptr->name)))
MARK_STRING (XSTRING (ptr->name));
MARK_INTERVAL_TREE (string_intervals (ptr->name));
-
+ /* Inner loop to mark next symbol in this bucket, if any. */
ptr = ptr->next;
if (ptr)
- {
- ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
- XSETSYMBOL (obj, ptrx);
- goto loop;
- }
+ goto nextsym;
}
break;
case Lisp_Misc_Save_Value:
XMISCANY (obj)->gcmarkbit = 1;
- {
- struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
- /* If `save_type' is zero, `data[0].pointer' is the address
- of a memory area containing `data[1].integer' potential
- Lisp_Objects. */
- if (GC_MARK_STACK && ptr->save_type == SAVE_TYPE_MEMORY)
- {
- Lisp_Object *p = ptr->data[0].pointer;
- ptrdiff_t nelt;
- for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
- mark_maybe_object (*p);
- }
- else
- {
- /* Find Lisp_Objects in `data[N]' slots and mark them. */
- int i;
- for (i = 0; i < SAVE_VALUE_SLOTS; i++)
- if (save_type (ptr, i) == SAVE_OBJECT)
- mark_object (ptr->data[i].object);
- }
- }
+ mark_save_value (XSAVE_VALUE (obj));
break;
case Lisp_Misc_Overlay:
static void
sweep_conses (void)
{
- register struct cons_block *cblk;
+ struct cons_block *cblk;
struct cons_block **cprev = &cons_block;
- register int lim = cons_block_index;
+ int lim = cons_block_index;
EMACS_INT num_free = 0, num_used = 0;
cons_free_list = 0;
for (cblk = cons_block; cblk; cblk = *cprev)
{
- register int i = 0;
+ int i = 0;
int this_free = 0;
- int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
+ int ilim = (lim + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
/* Scan the mark bits an int at a time. */
for (i = 0; i < ilim; i++)
{
- if (cblk->gcmarkbits[i] == -1)
+ if (cblk->gcmarkbits[i] == BITS_WORD_MAX)
{
/* Fast path - all cons cells for this int are marked. */
cblk->gcmarkbits[i] = 0;
- num_used += BITS_PER_INT;
+ num_used += BITS_PER_BITS_WORD;
}
else
{
Find which ones, and free them. */
int start, pos, stop;
- start = i * BITS_PER_INT;
+ start = i * BITS_PER_BITS_WORD;
stop = lim - start;
- if (stop > BITS_PER_INT)
- stop = BITS_PER_INT;
+ if (stop > BITS_PER_BITS_WORD)
+ stop = BITS_PER_BITS_WORD;
stop += start;
for (pos = start; pos < stop; pos++)
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
+ defsubr (&Sbool_vector);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
enum char_bits char_bits;
enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
- enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
enum Lisp_Bits Lisp_Bits;
enum Lisp_Compiled Lisp_Compiled;
enum maxargs maxargs;
HCoop / bpt / emacs.git / blobdiff