#include <config.h>
+#include <errno.h>
#include <stdio.h>
#include <limits.h> /* For CHAR_BIT. */
-
-#ifdef ENABLE_CHECKING
-#include <signal.h> /* For SIGABRT. */
-#endif
+#include <signal.h> /* For SIGABRT, SIGDANGER. */
#ifdef HAVE_PTHREAD
#include <pthread.h>
#include "dispextern.h"
#include "intervals.h"
#include "puresize.h"
+#include "sheap.h"
#include "systime.h"
#include "character.h"
#include "buffer.h"
#include "dosfns.h" /* For dos_memory_info. */
#endif
+#ifdef HAVE_MALLOC_H
+# include <malloc.h>
+#endif
+
#if (defined ENABLE_CHECKING \
&& defined HAVE_VALGRIND_VALGRIND_H \
&& !defined USE_VALGRIND)
#ifdef DOUG_LEA_MALLOC
-#include <malloc.h>
-
/* Specify maximum number of areas to mmap. It would be nice to use a
value that explicitly means "no limit". */
inside glibc's malloc. */
static void *malloc_state_ptr;
-/* Get and free this pointer; useful around unexec. */
-void
-alloc_unexec_pre (void)
-{
- malloc_state_ptr = malloc_get_state ();
-}
-void
-alloc_unexec_post (void)
-{
- free (malloc_state_ptr);
-}
-
/* Restore the dumped malloc state. Because malloc can be invoked
even before main (e.g. by the dynamic linker), the dumped malloc
state must be restored as early as possible using this special hook. */
}
}
- malloc_set_state (malloc_state_ptr);
+ if (malloc_set_state (malloc_state_ptr) != 0)
+ emacs_abort ();
# ifndef XMALLOC_OVERRUN_CHECK
alloc_unexec_post ();
# endif
}
}
+/* Declare the malloc initialization hook, which runs before 'main' starts.
+ EXTERNALLY_VISIBLE works around Bug#22522. */
# ifndef __MALLOC_HOOK_VOLATILE
# define __MALLOC_HOOK_VOLATILE
# endif
-voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook
+voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
= malloc_initialize_hook;
#endif
+/* Allocator-related actions to do just before and after unexec. */
+
+void
+alloc_unexec_pre (void)
+{
+#ifdef DOUG_LEA_MALLOC
+ malloc_state_ptr = malloc_get_state ();
+ if (!malloc_state_ptr)
+ fatal ("malloc_get_state: %s", strerror (errno));
+#endif
+#ifdef HYBRID_MALLOC
+ bss_sbrk_did_unexec = true;
+#endif
+}
+
+void
+alloc_unexec_post (void)
+{
+#ifdef DOUG_LEA_MALLOC
+ free (malloc_state_ptr);
+#endif
+#ifdef HYBRID_MALLOC
+ bss_sbrk_did_unexec = false;
+#endif
+}
+
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
Malloc
************************************************************************/
+#if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
+
/* Function malloc calls this if it finds we are near exhausting storage. */
void
pending_malloc_warning = str;
}
+#endif
/* Display an already-pending malloc warning. */
unexmacosx.c, so don't use it on Darwin. */
#if ! ADDRESS_SANITIZER && !defined DARWIN_OS
-# if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
-# define USE_ALIGNED_ALLOC 1
-# ifndef HAVE_ALIGNED_ALLOC
-/* Defined in gmalloc.c. */
-void *aligned_alloc (size_t, size_t);
-# endif
-# elif defined HYBRID_MALLOC
-# if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
-# define USE_ALIGNED_ALLOC 1
-# define aligned_alloc hybrid_aligned_alloc
-/* Defined in gmalloc.c. */
-void *aligned_alloc (size_t, size_t);
-# endif
-# elif defined HAVE_ALIGNED_ALLOC
+# if (defined HAVE_ALIGNED_ALLOC \
+ || (defined HYBRID_MALLOC \
+ ? defined HAVE_POSIX_MEMALIGN \
+ : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
# define USE_ALIGNED_ALLOC 1
-# elif defined HAVE_POSIX_MEMALIGN
+# elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
# define USE_ALIGNED_ALLOC 1
+# define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */
static void *
aligned_alloc (size_t alignment, size_t size)
{
static void
compact_small_strings (void)
{
- struct sblock *b, *tb, *next;
- sdata *from, *to, *end, *tb_end;
- sdata *to_end, *from_end;
-
/* TB is the sblock we copy to, TO is the sdata within TB we copy
to, and TB_END is the end of TB. */
- tb = oldest_sblock;
- tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = tb->data;
-
- /* Step through the blocks from the oldest to the youngest. We
- expect that old blocks will stabilize over time, so that less
- copying will happen this way. */
- for (b = oldest_sblock; b; b = b->next)
+ struct sblock *tb = oldest_sblock;
+ if (tb)
{
- end = b->next_free;
- eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
+ sdata *tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
+ sdata *to = tb->data;
- for (from = b->data; from < end; from = from_end)
+ /* Step through the blocks from the oldest to the youngest. We
+ expect that old blocks will stabilize over time, so that less
+ copying will happen this way. */
+ struct sblock *b = tb;
+ do
{
- /* Compute the next FROM here because copying below may
- overwrite data we need to compute it. */
- ptrdiff_t nbytes;
- struct Lisp_String *s = from->string;
+ sdata *end = b->next_free;
+ eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
+
+ for (sdata *from = b->data; from < end; )
+ {
+ /* Compute the next FROM here because copying below may
+ overwrite data we need to compute it. */
+ ptrdiff_t nbytes;
+ struct Lisp_String *s = from->string;
#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. */
- if (s && string_bytes (s) != SDATA_NBYTES (from))
- emacs_abort ();
+ /* Check that the string size recorded in the string is the
+ same as the one recorded in the sdata structure. */
+ if (s && string_bytes (s) != SDATA_NBYTES (from))
+ emacs_abort ();
#endif /* GC_CHECK_STRING_BYTES */
- nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
- eassert (nbytes <= LARGE_STRING_BYTES);
+ nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
+ eassert (nbytes <= LARGE_STRING_BYTES);
- nbytes = SDATA_SIZE (nbytes);
- from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
+ nbytes = SDATA_SIZE (nbytes);
+ sdata *from_end = (sdata *) ((char *) from
+ + nbytes + GC_STRING_EXTRA);
#ifdef GC_CHECK_STRING_OVERRUN
- if (memcmp (string_overrun_cookie,
- (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
- GC_STRING_OVERRUN_COOKIE_SIZE))
- emacs_abort ();
+ if (memcmp (string_overrun_cookie,
+ (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
+ GC_STRING_OVERRUN_COOKIE_SIZE))
+ emacs_abort ();
#endif
- /* Non-NULL S means it's alive. Copy its data. */
- if (s)
- {
- /* If TB is full, proceed with the next sblock. */
- to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
- if (to_end > tb_end)
+ /* Non-NULL S means it's alive. Copy its data. */
+ if (s)
{
- tb->next_free = to;
- tb = tb->next;
- tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = tb->data;
- to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
- }
+ /* If TB is full, proceed with the next sblock. */
+ sdata *to_end = (sdata *) ((char *) to
+ + nbytes + GC_STRING_EXTRA);
+ if (to_end > tb_end)
+ {
+ tb->next_free = to;
+ tb = tb->next;
+ tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
+ to = tb->data;
+ to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
+ }
- /* Copy, and update the string's `data' pointer. */
- if (from != to)
- {
- eassert (tb != b || to < from);
- memmove (to, from, nbytes + GC_STRING_EXTRA);
- to->string->data = SDATA_DATA (to);
- }
+ /* Copy, and update the string's `data' pointer. */
+ if (from != to)
+ {
+ eassert (tb != b || to < from);
+ memmove (to, from, nbytes + GC_STRING_EXTRA);
+ to->string->data = SDATA_DATA (to);
+ }
- /* Advance past the sdata we copied to. */
- to = to_end;
+ /* Advance past the sdata we copied to. */
+ to = to_end;
+ }
+ from = from_end;
}
+ b = b->next;
}
- }
+ while (b);
- /* The rest of the sblocks following TB don't contain live data, so
- we can free them. */
- for (b = tb->next; b; b = next)
- {
- next = b->next;
- lisp_free (b);
+ /* The rest of the sblocks following TB don't contain live data, so
+ we can free them. */
+ for (b = tb->next; b; )
+ {
+ struct sblock *next = b->next;
+ lisp_free (b);
+ b = next;
+ }
+
+ tb->next_free = to;
+ tb->next = NULL;
}
- tb->next_free = to;
- tb->next = NULL;
current_sblock = tb;
}
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
See also the function `vector'. */)
- (register Lisp_Object length, Lisp_Object init)
+ (Lisp_Object length, Lisp_Object init)
{
- Lisp_Object vector;
- register ptrdiff_t sizei;
- register ptrdiff_t i;
- register struct Lisp_Vector *p;
-
CHECK_NATNUM (length);
-
- p = allocate_vector (XFASTINT (length));
- sizei = XFASTINT (length);
- for (i = 0; i < sizei; i++)
+ struct Lisp_Vector *p = allocate_vector (XFASTINT (length));
+ for (ptrdiff_t i = 0; i < XFASTINT (length); i++)
p->contents[i] = init;
-
- XSETVECTOR (vector, p);
- return vector;
+ return make_lisp_ptr (p, Lisp_Vectorlike);
}
DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
usage: (vector &rest OBJECTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t i;
- register Lisp_Object val = make_uninit_vector (nargs);
- register struct Lisp_Vector *p = XVECTOR (val);
-
- for (i = 0; i < nargs; i++)
- p->contents[i] = args[i];
+ Lisp_Object val = make_uninit_vector (nargs);
+ struct Lisp_Vector *p = XVECTOR (val);
+ memcpy (p->contents, args, nargs * sizeof *args);
return val;
}
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t i;
- register Lisp_Object val = make_uninit_vector (nargs);
- register struct Lisp_Vector *p = XVECTOR (val);
+ Lisp_Object val = make_uninit_vector (nargs);
+ 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). */
- for (i = 0; i < nargs; i++)
- p->contents[i] = args[i];
+ memcpy (p->contents, args, nargs * sizeof *args);
make_byte_code (p);
XSETCOMPILED (val, p);
return val;
}
else
{
- Lisp_Object fmt = build_pure_c_string ("Don't know how to purify: %S");
+ AUTO_STRING (fmt, "Don't know how to purify: %S");
Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj)));
}
return Qnil;
/* Record this function, so it appears on the profiler's backtraces. */
- record_in_backtrace (Qautomatic_gc, 0, 0);
+ record_in_backtrace (QAutomatic_GC, 0, 0);
check_cons_list ();
int i, j;
for (i = 0; i < c->used; ++i)
{
- struct face *face = FACE_FROM_ID (c->f, i);
+ struct face *face = FACE_OPT_FROM_ID (c->f, i);
if (face)
{
#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
-/* Debugging check whether STR is ASCII-only. */
-
-const char *
-verify_ascii (const char *str)
-{
- const unsigned char *ptr = (unsigned char *) str, *end = ptr + strlen (str);
- while (ptr < end)
- {
- int c = STRING_CHAR_ADVANCE (ptr);
- if (!ASCII_CHAR_P (c))
- emacs_abort ();
- }
- return str;
-}
-
/* Stress alloca with inconveniently sized requests and check
whether all allocated areas may be used for Lisp_Object. */
DEFSYM (Qstring_bytes, "string-bytes");
DEFSYM (Qvector_slots, "vector-slots");
DEFSYM (Qheap, "heap");
- DEFSYM (Qautomatic_gc, "Automatic GC");
+ DEFSYM (QAutomatic_GC, "Automatic GC");
DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");