/* Storage allocation and gc for GNU Emacs Lisp interpreter.
-Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
- Free Software Foundation, Inc.
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+Foundation, Inc.
This file is part of GNU Emacs.
#include <limits.h> /* For CHAR_BIT. */
#ifdef ENABLE_CHECKING
-#include <signal.h> /* For SIGABRT. */
+#include <signal.h> /* For SIGABRT. */
#endif
#ifdef HAVE_PTHREAD
static Lisp_Object Qpost_gc_hook;
+static void free_save_value (Lisp_Object);
static void mark_terminals (void);
static void gc_sweep (void);
static Lisp_Object make_pure_vector (ptrdiff_t);
#endif
static void compact_small_strings (void);
static void free_large_strings (void);
-static void free_misc (Lisp_Object);
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
/* When scanning the C stack for live Lisp objects, Emacs keeps track of
#ifndef REL_ALLOC
memory_full (nbytes);
-#endif
-
+#else
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
xsignal (Qnil, Vmemory_signal_data);
+#endif
}
/* A common multiple of the positive integers A and B. Ideally this
record_xmalloc (size_t size)
{
void *p = xmalloc (size);
- record_unwind_protect (safe_alloca_unwind, make_save_value (p, 0));
+ record_unwind_protect (safe_alloca_unwind, make_save_pointer (p));
return p;
}
#define INTERVAL_BLOCK_SIZE \
((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
-/* Intervals are allocated in chunks in form of an interval_block
+/* Intervals are allocated in chunks in the form of an interval_block
structure. */
struct interval_block
b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
+ /* Back to a reasonable maximum of mmap'ed areas. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
#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. */
+ same as the one recorded in the sdata structure. */
if (s && string_bytes (s) != SDATA_NBYTES (from))
emacs_abort ();
#endif /* GC_CHECK_STRING_BYTES */
usage: (vector &rest OBJECTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- register Lisp_Object len, val;
ptrdiff_t i;
- register struct Lisp_Vector *p;
+ register Lisp_Object val = make_uninit_vector (nargs);
+ register struct Lisp_Vector *p = XVECTOR (val);
- XSETFASTINT (len, nargs);
- val = Fmake_vector (len, Qnil);
- p = XVECTOR (val);
for (i = 0; i < nargs; i++)
p->contents[i] = args[i];
return val;
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- register Lisp_Object len, val;
ptrdiff_t i;
- register struct Lisp_Vector *p;
+ register Lisp_Object val = make_uninit_vector (nargs);
+ register struct Lisp_Vector *p = XVECTOR (val);
/* We used to purecopy everything here, if purify-flag was set. This worked
OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
just wasteful and other times plainly wrong (e.g. those free vars may want
to be setcar'd). */
- XSETFASTINT (len, nargs);
- val = Fmake_vector (len, Qnil);
-
- p = XVECTOR (val);
for (i = 0; i < nargs; i++)
p->contents[i] = args[i];
make_byte_code (p);
return val;
}
-/* Free a Lisp_Misc object */
+/* Free a Lisp_Misc object. */
-static void
+void
free_misc (Lisp_Object misc)
{
XMISCTYPE (misc) = Lisp_Misc_Free;
total_free_markers++;
}
-/* Return a Lisp_Misc_Save_Value object containing POINTER and
- INTEGER. This is used to package C values to call record_unwind_protect.
- The unwind function can get the C values back using XSAVE_VALUE. */
+/* Return a Lisp_Save_Value object with the data saved according to
+ FMT. Format specifiers are `i' for an integer, `p' for a pointer
+ and `o' for Lisp_Object. Up to 4 objects can be specified. */
Lisp_Object
-make_save_value (void *pointer, ptrdiff_t integer)
+make_save_value (const char *fmt, ...)
{
- register Lisp_Object val;
- register struct Lisp_Save_Value *p;
+ va_list ap;
+ int len = strlen (fmt);
+ Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
+ struct Lisp_Save_Value *p = XSAVE_VALUE (val);
+
+ eassert (0 < len && len < 5);
+ va_start (ap, fmt);
+
+#define INITX(index) \
+ do { \
+ if (len <= index) \
+ p->type ## index = SAVE_UNUSED; \
+ else \
+ { \
+ if (fmt[index] == 'i') \
+ { \
+ p->type ## index = SAVE_INTEGER; \
+ p->data[index].integer = va_arg (ap, ptrdiff_t); \
+ } \
+ else if (fmt[index] == 'p') \
+ { \
+ p->type ## index = SAVE_POINTER; \
+ p->data[index].pointer = va_arg (ap, void *); \
+ } \
+ else if (fmt[index] == 'o') \
+ { \
+ p->type ## index = SAVE_OBJECT; \
+ p->data[index].object = va_arg (ap, Lisp_Object); \
+ } \
+ else \
+ emacs_abort (); \
+ } \
+ } while (0)
- val = allocate_misc (Lisp_Misc_Save_Value);
- p = XSAVE_VALUE (val);
- p->pointer = pointer;
- p->integer = integer;
- p->dogc = 0;
+ INITX (0);
+ INITX (1);
+ INITX (2);
+ INITX (3);
+
+#undef INITX
+
+ va_end (ap);
+ p->area = 0;
return val;
}
-/* Free a Lisp_Misc_Save_Value object. */
+/* The most common task it to save just one C pointer. */
-void
-free_save_value (Lisp_Object save)
+Lisp_Object
+make_save_pointer (void *pointer)
{
- register struct Lisp_Save_Value *p = XSAVE_VALUE (save);
+ Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
+ struct Lisp_Save_Value *p = XSAVE_VALUE (val);
+
+ p->area = 0;
+ p->type0 = SAVE_POINTER;
+ p->data[0].pointer = pointer;
+ p->type1 = p->type2 = p->type3 = SAVE_UNUSED;
+ return val;
+}
+
+/* Free a Lisp_Save_Value object. Do not use this function
+ if SAVE contains pointer other than returned by xmalloc. */
- p->dogc = 0;
- xfree (p->pointer);
- p->pointer = NULL;
+static void
+free_save_value (Lisp_Object save)
+{
+ xfree (XSAVE_POINTER (save, 0));
free_misc (save);
}
}
}
-/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
- the GCC system configuration. In gcc 3.2, the only systems for
- which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
- by others?) and ns32k-pc532-min. */
-
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
static bool setjmp_tested_p;
#endif
}
-/* Return 2 if OBJ is a killed or special buffer object.
- 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. */
+/* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
+ valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
+ cannot validate OBJ. This function can be quite slow, so its primary
+ use is the manual debugging. The only exception is print_object, where
+ we use it to check whether the memory referenced by the pointer of
+ Lisp_Save_Value object contains valid objects. */
int
valid_lisp_object_p (Lisp_Object obj)
case Lisp_Misc_Save_Value:
XMISCANY (obj)->gcmarkbit = 1;
-#if GC_MARK_STACK
{
register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
- /* If DOGC is set, POINTER is the address of a memory
- area containing INTEGER potential Lisp_Objects. */
- if (ptr->dogc)
+ /* If `area' is nonzero, `data[0].pointer' is the address
+ of a memory area containing `data[1].integer' potential
+ Lisp_Objects. */
+#if GC_MARK_STACK
+ if (ptr->area)
{
- Lisp_Object *p = (Lisp_Object *) ptr->pointer;
+ Lisp_Object *p = ptr->data[0].pointer;
ptrdiff_t nelt;
- for (nelt = ptr->integer; nelt > 0; nelt--, p++)
+ for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
mark_maybe_object (*p);
}
+ else
+#endif /* GC_MARK_STACK */
+ {
+ /* Find Lisp_Objects in `data[N]' slots and mark them. */
+ if (ptr->type0 == SAVE_OBJECT)
+ mark_object (ptr->data[0].object);
+ if (ptr->type1 == SAVE_OBJECT)
+ mark_object (ptr->data[1].object);
+ if (ptr->type2 == SAVE_OBJECT)
+ mark_object (ptr->data[2].object);
+ if (ptr->type3 == SAVE_OBJECT)
+ mark_object (ptr->data[3].object);
+ }
}
-#endif
break;
case Lisp_Misc_Overlay:
}
#endif
\f
-/* Initialization */
+/* Initialization. */
void
init_alloc_once (void)
#endif
#ifdef DOUG_LEA_MALLOC
- mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
- mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
+ mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
+ mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
#endif
init_strings ();
init_vectors ();
HCoop / bpt / emacs.git / blobdiff