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

3 4
Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
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 24

#define LISP_INLINE EXTERN_INLINE

25
#include <stdio.h>
26
#include <limits.h>		/* For CHAR_BIT.  */
27

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

32
#ifdef HAVE_PTHREAD
33 34 35
#include <pthread.h>
#endif

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

48
#include <verify.h>
Jim Blandy's avatar
Jim Blandy committed
49

50 51 52 53 54 55
/* 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
56
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 58
   memory.  Can do this only if using gmalloc.c and if not checking
   marked objects.  */
Kenichi Handa's avatar
Kenichi Handa committed
59

60 61
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
     || defined GC_CHECK_MARKED_OBJECTS)
Kenichi Handa's avatar
Kenichi Handa committed
62 63 64
#undef GC_MALLOC_CHECK
#endif

65
#include <unistd.h>
66 67
#include <fcntl.h>

Paul Eggert's avatar
Paul Eggert committed
68 69 70
#ifdef USE_GTK
# include "gtkutil.h"
#endif
71
#ifdef WINDOWSNT
Eli Zaretskii's avatar
Eli Zaretskii committed
72
#include "w32.h"
73
#include "w32heap.h"	/* for sbrk */
74 75
#endif

76
#ifdef DOUG_LEA_MALLOC
77

78
#include <malloc.h>
79

80 81 82
/* Specify maximum number of areas to mmap.  It would be nice to use a
   value that explicitly means "no limit".  */

83 84
#define MMAP_MAX_AREAS 100000000

85
#endif /* not DOUG_LEA_MALLOC */
86

87 88 89
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

90 91
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
92
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
93

94 95 96
#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)
97

98 99
/* Default value of gc_cons_threshold (see below).  */

100
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
101

102 103 104
/* Global variables.  */
struct emacs_globals globals;

105 106
/* Number of bytes of consing done since the last gc.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
107
EMACS_INT consing_since_gc;
Jim Blandy's avatar
Jim Blandy committed
108

109 110
/* Similar minimum, computed from Vgc_cons_percentage.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
111
EMACS_INT gc_relative_threshold;
112

113 114 115
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
116
EMACS_INT memory_full_cons_threshold;
117

118
/* True during GC.  */
119

120
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
121

122
/* True means abort if try to GC.
123 124 125
   This is for code which is written on the assumption that
   no GC will happen, so as to verify that assumption.  */

126
bool abort_on_gc;
127

128 129
/* Number of live and free conses etc.  */

130
static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
131
static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
132
static EMACS_INT total_free_floats, total_floats;
133

134
/* Points to memory space allocated as "spare", to be freed if we run
135 136
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
137

138
static char *spare_memory[7];
139

140 141
/* 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.  */
142

143
#define SPARE_MEMORY (1 << 14)
144

Richard M. Stallman's avatar
Richard M. Stallman committed
145 146 147 148 149
/* 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.  */
150

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

154
/* Pointer to the pure area, and its size.  */
155

156
static char *purebeg;
157
static ptrdiff_t pure_size;
158 159 160 161

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

162
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
163

164
/* True if P points into pure space.  */
165 166

#define PURE_POINTER_P(P)					\
167
  ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
168

169
/* Index in pure at which next pure Lisp object will be allocated..  */
170

171
static ptrdiff_t pure_bytes_used_lisp;
172 173 174

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

175
static ptrdiff_t pure_bytes_used_non_lisp;
176

177 178 179
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

180
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
181 182 183 184 185 186 187 188 189

/* 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.  */

190
#if MAX_SAVE_STACK > 0
191
static char *stack_copy;
192
static ptrdiff_t stack_copy_size;
193
#endif
Jim Blandy's avatar
Jim Blandy committed
194

195 196 197 198 199 200 201 202
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;
203
static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
204
static Lisp_Object Qgc_cons_threshold;
205
Lisp_Object Qautomatic_gc;
206
Lisp_Object Qchar_table_extra_slots;
207

208 209
/* Hook run after GC has finished.  */

210
static Lisp_Object Qpost_gc_hook;
211

212 213
static void mark_terminals (void);
static void gc_sweep (void);
214
static Lisp_Object make_pure_vector (ptrdiff_t);
215
static void mark_buffer (struct buffer *);
216

217 218 219
#if !defined REL_ALLOC || defined SYSTEM_MALLOC
static void refill_memory_reserve (void);
#endif
220 221
static void compact_small_strings (void);
static void free_large_strings (void);
222
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
223

224 225 226
/* 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.  */
227 228 229 230 231 232 233 234 235 236

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,
237 238 239
  /* 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.  */
240 241
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
242 243 244
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
245 246
};

247
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
248 249 250 251

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

252
static Lisp_Object Vdead;
253
#define DEADP(x) EQ (x, Vdead)
254

255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
#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
287 288 289 290 291 292
  /* 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;
293 294 295 296 297 298

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

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

300 301 302 303 304 305 306 307 308 309 310 311
  /* 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;

312 313 314 315
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

316 317 318 319 320
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

321
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
322 323 324 325 326 327
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 *);
328
static struct mem_node *mem_find (void *);
329
#endif
330

331
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
332

333 334 335 336
#ifndef DEADP
# define DEADP(x) 0
#endif

337 338 339 340
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

341 342
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
343

344
enum { NSTATICS = 2048 };
345
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
346 347 348

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

349
static int staticidx;
350

Paul Eggert's avatar
Paul Eggert committed
351
static void *pure_alloc (size_t, int);
352 353 354 355 356


/* Value is SZ rounded up to the next multiple of ALIGNMENT.
   ALIGNMENT must be a power of 2.  */

357
#define ALIGN(ptr, ALIGNMENT) \
Paul Eggert's avatar
Paul Eggert committed
358 359
  ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
	     & ~ ((ALIGNMENT) - 1)))
360

361 362 363 364 365
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
366

Jim Blandy's avatar
Jim Blandy committed
367

368 369 370 371
/************************************************************************
				Malloc
 ************************************************************************/

372
/* Function malloc calls this if it finds we are near exhausting storage.  */
373 374

void
375
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
376 377 378 379
{
  pending_malloc_warning = str;
}

380

381
/* Display an already-pending malloc warning.  */
382

383
void
384
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
385
{
386 387 388 389
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
390 391
  pending_malloc_warning = 0;
}
392

393 394 395
/* Called if we can't allocate relocatable space for a buffer.  */

void
396
buffer_memory_full (ptrdiff_t nbytes)
397
{
398 399 400 401 402 403
  /* 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.  */
404 405

#ifndef REL_ALLOC
Paul Eggert's avatar
Paul Eggert committed
406
  memory_full (nbytes);
Paul Eggert's avatar
Paul Eggert committed
407
#else
408 409
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
410
  xsignal (Qnil, Vmemory_signal_data);
Paul Eggert's avatar
Paul Eggert committed
411
#endif
Jim Blandy's avatar
Jim Blandy committed
412 413
}

414 415 416 417 418
/* 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))
419

420
#ifndef XMALLOC_OVERRUN_CHECK
421
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
422
#else
423

424 425
/* 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
426

427 428 429 430
   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
431 432

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

436
#define XMALLOC_OVERRUN_CHECK_SIZE 16
437
#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
438 439 440
  (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)

/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
441 442 443
   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				\
444
  alignof (union { long double d; intmax_t i; void *p; })
445

446
#if USE_LSB_TAG
447
# define XMALLOC_HEADER_ALIGNMENT \
448
    COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
449 450 451 452
#else
# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
#endif
#define XMALLOC_OVERRUN_SIZE_SIZE				\
453 454 455 456
   (((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
457

458 459 460 461 462
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' };
463

464 465 466 467 468
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' };
469

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

472 473 474 475
static void
xmalloc_put_size (unsigned char *ptr, size_t size)
{
  int i;
476
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
477
    {
478
      *--ptr = size & ((1 << CHAR_BIT) - 1);
479 480 481
      size >>= CHAR_BIT;
    }
}
Kim F. Storm's avatar
Kim F. Storm committed
482

483 484 485 486 487
static size_t
xmalloc_get_size (unsigned char *ptr)
{
  size_t size = 0;
  int i;
488 489
  ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
490 491 492 493 494 495
    {
      size <<= CHAR_BIT;
      size += *ptr++;
    }
  return size;
}
Kim F. Storm's avatar
Kim F. Storm committed
496 497 498 499


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

Paul Eggert's avatar
Paul Eggert committed
500
static void *
501
overrun_check_malloc (size_t size)
502
{
Kim F. Storm's avatar
Kim F. Storm committed
503
  register unsigned char *val;
504
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
505
    emacs_abort ();
506

507 508
  val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
  if (val)
509
    {
510
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
511
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
512
      xmalloc_put_size (val, size);
513 514
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
515
    }
Paul Eggert's avatar
Paul Eggert committed
516
  return val;
517 518
}

Kim F. Storm's avatar
Kim F. Storm committed
519 520 521 522

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

Paul Eggert's avatar
Paul Eggert committed
523 524
static void *
overrun_check_realloc (void *block, size_t size)
525
{
526
  register unsigned char *val = (unsigned char *) block;
527
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
528
    emacs_abort ();
529 530

  if (val
531
      && memcmp (xmalloc_overrun_check_header,
532
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
533
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
534
    {
535
      size_t osize = xmalloc_get_size (val);
536 537
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
538
	emacs_abort ();
539
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
540 541
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
542 543
    }

544
  val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
545

546
  if (val)
547
    {
548
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
549
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
550
      xmalloc_put_size (val, size);
551 552
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
553
    }
Paul Eggert's avatar
Paul Eggert committed
554
  return val;
555 556
}

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

559
static void
Paul Eggert's avatar
Paul Eggert committed
560
overrun_check_free (void *block)
561
{
562
  unsigned char *val = (unsigned char *) block;
563 564

  if (val
565
      && memcmp (xmalloc_overrun_check_header,
566
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
567
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
568
    {
569
      size_t osize = xmalloc_get_size (val);
570 571
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
572
	emacs_abort ();
573
#ifdef XMALLOC_CLEAR_FREE_MEMORY
574
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
575
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
576
#else
577
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
578 579
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
580
#endif
581 582 583 584 585 586 587 588 589 590 591 592 593
    }

  free (val);
}

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

594 595 596 597 598 599 600 601 602 603 604 605 606 607
/* 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)
608
    block_input ();
609 610 611 612 613
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
614
    unblock_input ();
615 616 617
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
618
#else
619 620
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
621
#endif
Kim F. Storm's avatar
Kim F. Storm committed
622

Stefan Monnier's avatar
Stefan Monnier committed
623 624 625 626 627 628 629
#define MALLOC_PROBE(size)			\
  do {						\
    if (profiler_memory_running)		\
      malloc_probe (size);			\
  } while (0)


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

Paul Eggert's avatar
Paul Eggert committed
632
void *
633
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
634
{
Paul Eggert's avatar
Paul Eggert committed
635
  void *val;
Jim Blandy's avatar
Jim Blandy committed
636

637
  MALLOC_BLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
638
  val = malloc (size);
639
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
640

641
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
642
    memory_full (size);
643
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
644 645 646
  return val;
}

Dmitry Antipov's avatar
Dmitry Antipov committed
647 648 649 650 651 652 653 654 655 656 657 658 659 660
/* 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);
661
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
662 663
  return val;
}
664 665 666

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

Paul Eggert's avatar
Paul Eggert committed
667 668
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
669
{
Paul Eggert's avatar
Paul Eggert committed
670
  void *val;
Jim Blandy's avatar
Jim Blandy committed
671

672
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
673 674 675
  /* 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
676
    val = malloc (size);
Noah Friedman's avatar
Noah Friedman committed
677
  else
Paul Eggert's avatar
Paul Eggert committed
678
    val = realloc (block, size);
679
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
680

Paul Eggert's avatar
Paul Eggert committed
681 682
  if (!val && size)
    memory_full (size);
683
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
684 685
  return val;
}
686

687

Dave Love's avatar
Dave Love committed
688
/* Like free but block interrupt input.  */
689

690
void
Paul Eggert's avatar
Paul Eggert committed
691
xfree (void *block)
692
{
693 694
  if (!block)
    return;
695
  MALLOC_BLOCK_INPUT;
696
  free (block);
697
  MALLOC_UNBLOCK_INPUT;
698
  /* We don't call refill_memory_reserve here
699
     because in practice the call in r_alloc_free seems to suffice.  */
700 701
}

702

703 704 705 706 707 708 709 710 711 712 713 714
/* 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)
{
715
  eassert (0 <= nitems && 0 < item_size);
716 717 718 719 720 721 722 723 724 725 726 727
  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)
{
728
  eassert (0 <= nitems && 0 < item_size);
729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
  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
746
   the old one.
747 748 749

   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
750 751 752 753 754 755 756
   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.  */
757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781

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));

782
  eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
783 784 785 786 787 788 789 790 791 792 793
  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;
}


794 795 796
/* Like strdup, but uses xmalloc.  */

char *
797
xstrdup (const char *s)
798
{
799
  size_t len = strlen (s) + 1;
Dmitry Antipov's avatar
Dmitry Antipov committed
800
  char *p = xmalloc (len);
801
  memcpy (p, s, len);
802 803 804
  return p;
}

805 806 807 808 809 810 811 812 813
/* 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);
}
814

815 816 817 818 819 820
/* 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);
821
  record_unwind_protect_ptr (xfree, p);
822 823 824
  return p;
}

825

826 827
/* 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
828
   allocated memory block (for strings, for conses, ...).  */
829

830 831
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
832
#endif
833

Paul Eggert's avatar
Paul Eggert committed
834
static void *
835
lisp_malloc (size_t nbytes, enum mem_type type)
836
{
837
  register void *val;
838

839
  MALLOC_BLOCK_INPUT;
840 841 842 843

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
844

845
  val = malloc (nbytes);
846

847
#if ! USE_LSB_TAG
848 849 850 851 852 853 854 855 856 857 858 859 860 861
  /* 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;
	}
    }
Kenichi Handa's avatar
Kenichi Handa committed
862
#endif
863

864
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
865
  if (val && type != MEM_TYPE_NON_LISP)
866 867
    mem_insert (val, (char *) val + nbytes, type);
#endif
868

869
  MALLOC_UNBLOCK_INPUT;
870
  if (!val && nbytes)
Paul Eggert's avatar
Paul Eggert committed
871
    memory_full (nbytes);