alloc.c 193 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2

3
Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
4
Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7

This file is part of GNU Emacs.

8
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
9
it under the terms of the GNU General Public License as published by
10 11
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
12 13 14 15 16 17 18

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

21
#include <config.h>
22

23
#include <stdio.h>
24
#include <limits.h>		/* For CHAR_BIT.  */
25

26
#ifdef ENABLE_CHECKING
27
#include <signal.h>		/* For SIGABRT.  */
28 29
#endif

30
#ifdef HAVE_PTHREAD
31 32 33
#include <pthread.h>
#endif

Jim Blandy's avatar
Jim Blandy committed
34
#include "lisp.h"
35
#include "process.h"
36
#include "intervals.h"
Jim Blandy's avatar
Jim Blandy committed
37
#include "puresize.h"
38
#include "character.h"
Jim Blandy's avatar
Jim Blandy committed
39 40
#include "buffer.h"
#include "window.h"
41
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
42
#include "frame.h"
43
#include "blockinput.h"
44
#include "termhooks.h"		/* For struct terminal.  */
45 46 47
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
48

49
#include <verify.h>
50
#include <execinfo.h>           /* For backtrace.  */
51

52 53 54 55 56 57
#if (defined ENABLE_CHECKING			\
     && defined HAVE_VALGRIND_VALGRIND_H	\
     && !defined USE_VALGRIND)
# define USE_VALGRIND 1
#endif

58 59 60
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
61
static bool valgrind_p;
62 63
#endif

64 65 66 67 68 69
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
   Doable only if GC_MARK_STACK.  */
#if ! GC_MARK_STACK
# undef GC_CHECK_MARKED_OBJECTS
#endif

Kenichi Handa's avatar
Kenichi Handa committed
70
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
71 72
   memory.  Can do this only if using gmalloc.c and if not checking
   marked objects.  */
Kenichi Handa's avatar
Kenichi Handa committed
73

74 75
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
     || defined GC_CHECK_MARKED_OBJECTS)
Kenichi Handa's avatar
Kenichi Handa committed
76 77 78
#undef GC_MALLOC_CHECK
#endif

79
#include <unistd.h>
80 81
#include <fcntl.h>

Paul Eggert's avatar
Paul Eggert committed
82 83 84
#ifdef USE_GTK
# include "gtkutil.h"
#endif
85
#ifdef WINDOWSNT
Eli Zaretskii's avatar
Eli Zaretskii committed
86
#include "w32.h"
87
#include "w32heap.h"	/* for sbrk */
88 89
#endif

90
#ifdef DOUG_LEA_MALLOC
91

92
#include <malloc.h>
93

94 95 96
/* Specify maximum number of areas to mmap.  It would be nice to use a
   value that explicitly means "no limit".  */

97 98
#define MMAP_MAX_AREAS 100000000

99
#endif /* not DOUG_LEA_MALLOC */
100

101 102 103
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

104 105
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
106
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
107

108 109 110
#define VECTOR_MARK(V)		((V)->header.size |= ARRAY_MARK_FLAG)
#define VECTOR_UNMARK(V)	((V)->header.size &= ~ARRAY_MARK_FLAG)
#define VECTOR_MARKED_P(V)	(((V)->header.size & ARRAY_MARK_FLAG) != 0)
111

112 113
/* Default value of gc_cons_threshold (see below).  */

114
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
115

116 117 118
/* Global variables.  */
struct emacs_globals globals;

119 120
/* Number of bytes of consing done since the last gc.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
121
EMACS_INT consing_since_gc;
Jim Blandy's avatar
Jim Blandy committed
122

123 124
/* Similar minimum, computed from Vgc_cons_percentage.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
125
EMACS_INT gc_relative_threshold;
126

127 128 129
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
130
EMACS_INT memory_full_cons_threshold;
131

132
/* True during GC.  */
133

134
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
135

136
/* True means abort if try to GC.
137 138 139
   This is for code which is written on the assumption that
   no GC will happen, so as to verify that assumption.  */

140
bool abort_on_gc;
141

142 143
/* Number of live and free conses etc.  */

144
static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
145
static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
146
static EMACS_INT total_free_floats, total_floats;
147

148
/* Points to memory space allocated as "spare", to be freed if we run
149 150
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
151

152
static char *spare_memory[7];
153

154 155
/* Amount of spare memory to keep in large reserve block, or to see
   whether this much is available when malloc fails on a larger request.  */
156

157
#define SPARE_MEMORY (1 << 14)
158

Richard M. Stallman's avatar
Richard M. Stallman committed
159 160 161 162 163
/* Initialize it to a nonzero value to force it into data space
   (rather than bss space).  That way unexec will remap it into text
   space (pure), on some systems.  We have not implemented the
   remapping on more recent systems because this is less important
   nowadays than in the days of small memories and timesharing.  */
164

Andreas Schwab's avatar
Andreas Schwab committed
165
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
Jim Blandy's avatar
Jim Blandy committed
166
#define PUREBEG (char *) pure
167

168
/* Pointer to the pure area, and its size.  */
169

170
static char *purebeg;
171
static ptrdiff_t pure_size;
172 173 174 175

/* Number of bytes of pure storage used before pure storage overflowed.
   If this is non-zero, this implies that an overflow occurred.  */

176
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
177

178
/* True if P points into pure space.  */
179 180

#define PURE_POINTER_P(P)					\
181
  ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
182

183
/* Index in pure at which next pure Lisp object will be allocated..  */
184

185
static ptrdiff_t pure_bytes_used_lisp;
186 187 188

/* Number of bytes allocated for non-Lisp objects in pure storage.  */

189
static ptrdiff_t pure_bytes_used_non_lisp;
190

191 192 193
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

194
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
195

196 197 198 199 200 201 202 203 204 205 206
#if 0 /* Normally, pointer sanity only on request... */
#ifdef ENABLE_CHECKING
#define SUSPICIOUS_OBJECT_CHECKING 1
#endif
#endif

/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
   bug is unresolved.  */
#define SUSPICIOUS_OBJECT_CHECKING 1

#ifdef SUSPICIOUS_OBJECT_CHECKING
207 208
struct suspicious_free_record
{
209 210
  void *suspicious_object;
  void *backtrace[128];
211
};
212
static void *suspicious_objects[32];
213
static int suspicious_object_index;
214
struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
215 216 217
static int suspicious_free_history_index;
/* Find the first currently-monitored suspicious pointer in range
   [begin,end) or NULL if no such pointer exists.  */
218 219
static void *find_suspicious_object_in_range (void *begin, void *end);
static void detect_suspicious_free (void *ptr);
220
#else
221 222
# define find_suspicious_object_in_range(begin, end) NULL
# define detect_suspicious_free(ptr) (void)
223 224
#endif

Jim Blandy's avatar
Jim Blandy committed
225 226 227 228 229 230 231 232
/* Maximum amount of C stack to save when a GC happens.  */

#ifndef MAX_SAVE_STACK
#define MAX_SAVE_STACK 16000
#endif

/* Buffer in which we save a copy of the C stack at each GC.  */

233
#if MAX_SAVE_STACK > 0
234
static char *stack_copy;
235
static ptrdiff_t stack_copy_size;
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256

/* Copy to DEST a block of memory from SRC of size SIZE bytes,
   avoiding any address sanitization.  */

static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
no_sanitize_memcpy (void *dest, void const *src, size_t size)
{
  if (! ADDRESS_SANITIZER)
    return memcpy (dest, src, size);
  else
    {
      size_t i;
      char *d = dest;
      char const *s = src;
      for (i = 0; i < size; i++)
	d[i] = s[i];
      return dest;
    }
}

#endif /* MAX_SAVE_STACK > 0 */
Jim Blandy's avatar
Jim Blandy committed
257

258 259 260 261 262 263 264 265
static Lisp_Object Qconses;
static Lisp_Object Qsymbols;
static Lisp_Object Qmiscs;
static Lisp_Object Qstrings;
static Lisp_Object Qvectors;
static Lisp_Object Qfloats;
static Lisp_Object Qintervals;
static Lisp_Object Qbuffers;
266
static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
267
static Lisp_Object Qgc_cons_threshold;
268
Lisp_Object Qautomatic_gc;
269
Lisp_Object Qchar_table_extra_slots;
270

271 272
/* Hook run after GC has finished.  */

273
static Lisp_Object Qpost_gc_hook;
274

275 276
static void mark_terminals (void);
static void gc_sweep (void);
277
static Lisp_Object make_pure_vector (ptrdiff_t);
278
static void mark_buffer (struct buffer *);
279

280 281 282
#if !defined REL_ALLOC || defined SYSTEM_MALLOC
static void refill_memory_reserve (void);
#endif
283 284
static void compact_small_strings (void);
static void free_large_strings (void);
285
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
286

287 288 289
/* When scanning the C stack for live Lisp objects, Emacs keeps track of
   what memory allocated via lisp_malloc and lisp_align_malloc is intended
   for what purpose.  This enumeration specifies the type of memory.  */
290 291 292 293 294 295 296 297 298 299

enum mem_type
{
  MEM_TYPE_NON_LISP,
  MEM_TYPE_BUFFER,
  MEM_TYPE_CONS,
  MEM_TYPE_STRING,
  MEM_TYPE_MISC,
  MEM_TYPE_SYMBOL,
  MEM_TYPE_FLOAT,
300 301 302
  /* Since all non-bool pseudovectors are small enough to be
     allocated from vector blocks, this memory type denotes
     large regular vectors and large bool pseudovectors.  */
303 304
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
305 306 307
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
308 309
};

310
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
311 312 313 314

/* A unique object in pure space used to make some Lisp objects
   on free lists recognizable in O(1).  */

315
static Lisp_Object Vdead;
316
#define DEADP(x) EQ (x, Vdead)
317

318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;

#endif /* GC_MALLOC_CHECK */

/* A node in the red-black tree describing allocated memory containing
   Lisp data.  Each such block is recorded with its start and end
   address when it is allocated, and removed from the tree when it
   is freed.

   A red-black tree is a balanced binary tree with the following
   properties:

   1. Every node is either red or black.
   2. Every leaf is black.
   3. If a node is red, then both of its children are black.
   4. Every simple path from a node to a descendant leaf contains
   the same number of black nodes.
   5. The root is always black.

   When nodes are inserted into the tree, or deleted from the tree,
   the tree is "fixed" so that these properties are always true.

   A red-black tree with N internal nodes has height at most 2
   log(N+1).  Searches, insertions and deletions are done in O(log N).
   Please see a text book about data structures for a detailed
   description of red-black trees.  Any book worth its salt should
   describe them.  */

struct mem_node
{
Richard M. Stallman's avatar
Richard M. Stallman committed
350 351 352 353 354 355
  /* Children of this node.  These pointers are never NULL.  When there
     is no child, the value is MEM_NIL, which points to a dummy node.  */
  struct mem_node *left, *right;

  /* The parent of this node.  In the root node, this is NULL.  */
  struct mem_node *parent;
356 357 358 359 360 361

  /* Start and end of allocated region.  */
  void *start, *end;

  /* Node color.  */
  enum {MEM_BLACK, MEM_RED} color;
362

363 364 365 366 367 368 369 370 371 372 373 374
  /* Memory type.  */
  enum mem_type type;
};

/* Base address of stack.  Set in main.  */

Lisp_Object *stack_base;

/* Root of the tree describing allocated Lisp memory.  */

static struct mem_node *mem_root;

375 376 377 378
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

379 380 381 382 383
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

384 385 386 387 388 389
static struct mem_node *mem_insert (void *, void *, enum mem_type);
static void mem_insert_fixup (struct mem_node *);
static void mem_rotate_left (struct mem_node *);
static void mem_rotate_right (struct mem_node *);
static void mem_delete (struct mem_node *);
static void mem_delete_fixup (struct mem_node *);
390
static struct mem_node *mem_find (void *);
391

392
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
393

394 395 396 397
#ifndef DEADP
# define DEADP(x) 0
#endif

398 399 400 401
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

402 403
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
404

405
enum { NSTATICS = 2048 };
406
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
407 408 409

/* Index of next unused slot in staticvec.  */

410
static int staticidx;
411

Paul Eggert's avatar
Paul Eggert committed
412
static void *pure_alloc (size_t, int);
413

414 415 416
/* Return X rounded to the next multiple of Y.  Arguments should not
   have side effects, as they are evaluated more than once.  Assume X
   + Y - 1 does not overflow.  Tune for Y being a power of 2.  */
417

418 419 420
#define ROUNDUP(x, y) ((y) & ((y) - 1)					\
		       ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y)	\
		       : ((x) + (y) - 1) & ~ ((y) - 1))
421

422 423 424 425 426 427 428
/* Return PTR rounded up to the next multiple of ALIGNMENT.  */

static void *
ALIGN (void *ptr, int alignment)
{
  return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
429

430 431 432 433 434
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
435

436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
static bool
pointers_fit_in_lispobj_p (void)
{
  return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG;
}

static bool
mmap_lisp_allowed_p (void)
{
  /* If we can't store all memory addresses in our lisp objects, it's
     risky to let the heap use mmap and give us addresses from all
     over our address space.  We also can't use mmap for lisp objects
     if we might dump: unexec doesn't preserve the contents of mmaped
     regions.  */
  return pointers_fit_in_lispobj_p () && !might_dump;
}

Jim Blandy's avatar
Jim Blandy committed
453

454 455 456 457
/************************************************************************
				Malloc
 ************************************************************************/

458
/* Function malloc calls this if it finds we are near exhausting storage.  */
459 460

void
461
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
462 463 464 465
{
  pending_malloc_warning = str;
}

466

467
/* Display an already-pending malloc warning.  */
468

469
void
470
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
471
{
472 473 474 475
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
476 477
  pending_malloc_warning = 0;
}
478

479 480 481
/* Called if we can't allocate relocatable space for a buffer.  */

void
482
buffer_memory_full (ptrdiff_t nbytes)
483
{
484 485 486 487 488 489
  /* If buffers use the relocating allocator, no need to free
     spare_memory, because we may have plenty of malloc space left
     that we could get, and if we don't, the malloc that fails will
     itself cause spare_memory to be freed.  If buffers don't use the
     relocating allocator, treat this like any other failing
     malloc.  */
490 491

#ifndef REL_ALLOC
Paul Eggert's avatar
Paul Eggert committed
492
  memory_full (nbytes);
Paul Eggert's avatar
Paul Eggert committed
493
#else
494 495
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
496
  xsignal (Qnil, Vmemory_signal_data);
Paul Eggert's avatar
Paul Eggert committed
497
#endif
Jim Blandy's avatar
Jim Blandy committed
498 499
}

500 501 502 503 504
/* A common multiple of the positive integers A and B.  Ideally this
   would be the least common multiple, but there's no way to do that
   as a constant expression in C, so do the best that we can easily do.  */
#define COMMON_MULTIPLE(a, b) \
  ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
505

506
#ifndef XMALLOC_OVERRUN_CHECK
507
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
508
#else
509

510 511
/* Check for overrun in malloc'ed buffers by wrapping a header and trailer
   around each block.
Kim F. Storm's avatar
Kim F. Storm committed
512

513 514 515 516
   The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
   followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
   block size in little-endian order.  The trailer consists of
   XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
Kim F. Storm's avatar
Kim F. Storm committed
517 518

   The header is used to detect whether this block has been allocated
519 520
   through these functions, as some low-level libc functions may
   bypass the malloc hooks.  */
Kim F. Storm's avatar
Kim F. Storm committed
521

522
#define XMALLOC_OVERRUN_CHECK_SIZE 16
523
#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
524 525 526
  (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)

/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
527 528 529
   hold a size_t value and (2) the header size is a multiple of the
   alignment that Emacs needs for C types and for USE_LSB_TAG.  */
#define XMALLOC_BASE_ALIGNMENT				\
530
  alignof (union { long double d; intmax_t i; void *p; })
531

532
#if USE_LSB_TAG
533
# define XMALLOC_HEADER_ALIGNMENT \
534
    COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
535 536 537 538
#else
# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
#endif
#define XMALLOC_OVERRUN_SIZE_SIZE				\
539 540 541 542
   (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t)		\
      + XMALLOC_HEADER_ALIGNMENT - 1)				\
     / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT)	\
    - XMALLOC_OVERRUN_CHECK_SIZE)
Kim F. Storm's avatar
Kim F. Storm committed
543

544 545 546 547 548
static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
  { '\x9a', '\x9b', '\xae', '\xaf',
    '\xbf', '\xbe', '\xce', '\xcf',
    '\xea', '\xeb', '\xec', '\xed',
    '\xdf', '\xde', '\x9c', '\x9d' };
549

550 551 552 553 554
static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
  { '\xaa', '\xab', '\xac', '\xad',
    '\xba', '\xbb', '\xbc', '\xbd',
    '\xca', '\xcb', '\xcc', '\xcd',
    '\xda', '\xdb', '\xdc', '\xdd' };
555

556
/* Insert and extract the block size in the header.  */
Kim F. Storm's avatar
Kim F. Storm committed
557

558 559 560 561
static void
xmalloc_put_size (unsigned char *ptr, size_t size)
{
  int i;
562
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
563
    {
564
      *--ptr = size & ((1 << CHAR_BIT) - 1);
565 566 567
      size >>= CHAR_BIT;
    }
}
Kim F. Storm's avatar
Kim F. Storm committed
568

569 570 571 572 573
static size_t
xmalloc_get_size (unsigned char *ptr)
{
  size_t size = 0;
  int i;
574 575
  ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
576 577 578 579 580 581
    {
      size <<= CHAR_BIT;
      size += *ptr++;
    }
  return size;
}
Kim F. Storm's avatar
Kim F. Storm committed
582 583 584 585


/* Like malloc, but wraps allocated block with header and trailer.  */

Paul Eggert's avatar
Paul Eggert committed
586
static void *
587
overrun_check_malloc (size_t size)
588
{
Kim F. Storm's avatar
Kim F. Storm committed
589
  register unsigned char *val;
590
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
591
    emacs_abort ();
592

593 594
  val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
  if (val)
595
    {
596
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
597
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
598
      xmalloc_put_size (val, size);
599 600
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
601
    }
Paul Eggert's avatar
Paul Eggert committed
602
  return val;
603 604
}

Kim F. Storm's avatar
Kim F. Storm committed
605 606 607 608

/* Like realloc, but checks old block for overrun, and wraps new block
   with header and trailer.  */

Paul Eggert's avatar
Paul Eggert committed
609 610
static void *
overrun_check_realloc (void *block, size_t size)
611
{
612
  register unsigned char *val = (unsigned char *) block;
613
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
614
    emacs_abort ();
615 616

  if (val
617
      && memcmp (xmalloc_overrun_check_header,
618
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
619
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
620
    {
621
      size_t osize = xmalloc_get_size (val);
622 623
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
624
	emacs_abort ();
625
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
626 627
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
628 629
    }

630
  val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
631

632
  if (val)
633
    {
634
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
635
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
636
      xmalloc_put_size (val, size);
637 638
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
639
    }
Paul Eggert's avatar
Paul Eggert committed
640
  return val;
641 642
}

Kim F. Storm's avatar
Kim F. Storm committed
643 644
/* Like free, but checks block for overrun.  */

645
static void
Paul Eggert's avatar
Paul Eggert committed
646
overrun_check_free (void *block)
647
{
648
  unsigned char *val = (unsigned char *) block;
649 650

  if (val
651
      && memcmp (xmalloc_overrun_check_header,
652
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
653
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
654
    {
655
      size_t osize = xmalloc_get_size (val);
656 657
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
658
	emacs_abort ();
659
#ifdef XMALLOC_CLEAR_FREE_MEMORY
660
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
661
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
662
#else
663
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
664 665
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
666
#endif
667 668 669 670 671 672 673 674 675 676 677 678 679
    }

  free (val);
}

#undef malloc
#undef realloc
#undef free
#define malloc overrun_check_malloc
#define realloc overrun_check_realloc
#define free overrun_check_free
#endif

680 681 682 683 684 685 686 687 688 689 690 691 692 693
/* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
   BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
   If that variable is set, block input while in one of Emacs's memory
   allocation functions.  There should be no need for this debugging
   option, since signal handlers do not allocate memory, but Emacs
   formerly allocated memory in signal handlers and this compile-time
   option remains as a way to help debug the issue should it rear its
   ugly head again.  */
#ifdef XMALLOC_BLOCK_INPUT_CHECK
bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
static void
malloc_block_input (void)
{
  if (block_input_in_memory_allocators)
694
    block_input ();
695 696 697 698 699
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
700
    unblock_input ();
701 702 703
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
704
#else
705 706
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
707
#endif
Kim F. Storm's avatar
Kim F. Storm committed
708

Stefan Monnier's avatar
Stefan Monnier committed
709 710 711 712 713 714 715
#define MALLOC_PROBE(size)			\
  do {						\
    if (profiler_memory_running)		\
      malloc_probe (size);			\
  } while (0)


716
/* Like malloc but check for no memory and block interrupt input..  */
Jim Blandy's avatar
Jim Blandy committed
717

Paul Eggert's avatar
Paul Eggert committed
718
void *
719
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
720
{
Paul Eggert's avatar
Paul Eggert committed
721
  void *val;
Jim Blandy's avatar
Jim Blandy committed
722

723
  MALLOC_BLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
724
  val = malloc (size);
725
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
726

727
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
728
    memory_full (size);
729
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
730 731 732
  return val;
}

Dmitry Antipov's avatar
Dmitry Antipov committed
733 734 735 736 737 738 739 740 741 742 743 744 745 746
/* Like the above, but zeroes out the memory just allocated.  */

void *
xzalloc (size_t size)
{
  void *val;

  MALLOC_BLOCK_INPUT;
  val = malloc (size);
  MALLOC_UNBLOCK_INPUT;

  if (!val && size)
    memory_full (size);
  memset (val, 0, size);
747
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
748 749
  return val;
}
750 751 752

/* Like realloc but check for no memory and block interrupt input..  */

Paul Eggert's avatar
Paul Eggert committed
753 754
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
755
{
Paul Eggert's avatar
Paul Eggert committed
756
  void *val;
Jim Blandy's avatar
Jim Blandy committed
757

758
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
759 760 761
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
Paul Eggert's avatar
Paul Eggert committed
762
    val = malloc (size);
Noah Friedman's avatar
Noah Friedman committed
763
  else
Paul Eggert's avatar
Paul Eggert committed
764
    val = realloc (block, size);
765
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
766

Paul Eggert's avatar
Paul Eggert committed
767 768
  if (!val && size)
    memory_full (size);
769
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
770 771
  return val;
}
772

773

Dave Love's avatar
Dave Love committed
774
/* Like free but block interrupt input.  */
775

776
void
Paul Eggert's avatar
Paul Eggert committed
777
xfree (void *block)
778
{
779 780
  if (!block)
    return;
781
  MALLOC_BLOCK_INPUT;
782
  free (block);
783
  MALLOC_UNBLOCK_INPUT;
784
  /* We don't call refill_memory_reserve here
785
     because in practice the call in r_alloc_free seems to suffice.  */
786 787
}

788

789 790 791 792 793 794 795 796 797 798 799 800
/* Other parts of Emacs pass large int values to allocator functions
   expecting ptrdiff_t.  This is portable in practice, but check it to
   be safe.  */
verify (INT_MAX <= PTRDIFF_MAX);


/* Allocate an array of NITEMS items, each of size ITEM_SIZE.
   Signal an error on memory exhaustion, and block interrupt input.  */

void *
xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
{
801
  eassert (0 <= nitems && 0 < item_size);
802 803 804 805 806 807 808 809 810 811 812 813
  if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
    memory_full (SIZE_MAX);
  return xmalloc (nitems * item_size);
}


/* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
   Signal an error on memory exhaustion, and block interrupt input.  */

void *
xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
{
814
  eassert (0 <= nitems && 0 < item_size);
815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831
  if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
    memory_full (SIZE_MAX);
  return xrealloc (pa, nitems * item_size);
}


/* Grow PA, which points to an array of *NITEMS items, and return the
   location of the reallocated array, updating *NITEMS to reflect its
   new size.  The new array will contain at least NITEMS_INCR_MIN more
   items, but will not contain more than NITEMS_MAX items total.
   ITEM_SIZE is the size of each item, in bytes.

   ITEM_SIZE and NITEMS_INCR_MIN must be positive.  *NITEMS must be
   nonnegative.  If NITEMS_MAX is -1, it is treated as if it were
   infinity.

   If PA is null, then allocate a new array instead of reallocating
832
   the old one.
833 834 835

   Block interrupt input as needed.  If memory exhaustion occurs, set
   *NITEMS to zero if PA is null, and signal an error (i.e., do not
836 837 838 839 840 841 842
   return).

   Thus, to grow an array A without saving its old contents, do
   { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
   The A = NULL avoids a dangling pointer if xpalloc exhausts memory
   and signals an error, and later this code is reexecuted and
   attempts to free A.  */
843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867

void *
xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
	 ptrdiff_t nitems_max, ptrdiff_t item_size)
{
  /* The approximate size to use for initial small allocation
     requests.  This is the largest "small" request for the GNU C
     library malloc.  */
  enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };

  /* If the array is tiny, grow it to about (but no greater than)
     DEFAULT_MXFAST bytes.  Otherwise, grow it by about 50%.  */
  ptrdiff_t n = *nitems;
  ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n;
  ptrdiff_t half_again = n >> 1;
  ptrdiff_t incr_estimate = max (tiny_max, half_again);

  /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
     NITEMS_MAX, and what the C language can represent safely.  */
  ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size;
  ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
		     ? nitems_max : C_language_max);
  ptrdiff_t nitems_incr_max = n_max - n;
  ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));

868
  eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
869 870 871 872 873 874 875 876 877 878 879
  if (! pa)
    *nitems = 0;
  if (nitems_incr_max < incr)
    memory_full (SIZE_MAX);
  n += incr;
  pa = xrealloc (pa, n * item_size);
  *nitems = n;
  return pa;
}


880 881 882
/* Like strdup, but uses xmalloc.  */

char *
883
xstrdup (const char *s)
884
{
Paul Eggert's avatar
Paul Eggert committed
885
  ptrdiff_t size;
886
  eassert (s);
Paul Eggert's avatar
Paul Eggert committed
887 888
  size = strlen (s) + 1;
  return memcpy (xmalloc (size), s, size);
889 890
}

891 892 893 894 895 896 897 898 899
/* Like above, but duplicates Lisp string to C string.  */

char *
xlispstrdup (Lisp_Object string)
{
  ptrdiff_t size = SBYTES (string) + 1;
  return memcpy (xmalloc (size), SSDATA (string), size);
}

900 901 902 903 904 905 906 907 908 909 910 911 912 913
/* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
   pointed to.  If STRING is null, assign it without copying anything.
   Allocate before freeing, to avoid a dangling pointer if allocation
   fails.  */

void
dupstring (char **ptr, char const *string)
{
  char *old = *ptr;
  *ptr = string ? xstrdup (string) : 0;
  xfree (old);
}


914 915 916 917 918 919 920 921 922
/* Like putenv, but (1) use the equivalent of xmalloc and (2) the
   argument is a const pointer.  */

void
xputenv (char const *string)
{
  if (putenv ((char *) string) != 0)
    memory_full (0);
}
923

924 925 926 927 928 929
/* Return a newly allocated memory block of SIZE bytes, remembering
   to free it when unwinding.  */
void *
record_xmalloc (size_t size)
{
  void *p = xmalloc (size);
930
  record_unwind_protect_ptr (xfree, p);
931 932 933
  return p;
}

934

935 936
/* Like malloc but used for allocating Lisp data.  NBYTES is the
   number of bytes to allocate, TYPE describes the intended use of the
Paul Eggert's avatar
Paul Eggert committed
937
   allocated memory block (for strings, for conses, ...).  */
938

939 940
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
941
#endif
942

Paul Eggert's avatar
Paul Eggert committed
943
static void *
944
lisp_malloc (size_t nbytes, enum mem_type type)
945
{
946
  register void *val;
947

948
  MALLOC_BLOCK_INPUT;
949 950 951 952

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
953

954
  val = malloc (nbytes);