alloc.c 194 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
#ifdef HAVE_LINUX_SYSINFO
#include <sys/sysinfo.h>
#endif

56 57 58 59
#ifdef MSDOS
#include "dosfns.h"		/* For dos_memory_info.  */
#endif

60 61 62 63 64 65
#if (defined ENABLE_CHECKING			\
     && defined HAVE_VALGRIND_VALGRIND_H	\
     && !defined USE_VALGRIND)
# define USE_VALGRIND 1
#endif

66 67 68
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
69
static bool valgrind_p;
70 71
#endif

72 73 74 75 76 77
/* 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
78
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
79 80
   memory.  Can do this only if using gmalloc.c and if not checking
   marked objects.  */
Kenichi Handa's avatar
Kenichi Handa committed
81

82 83
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
     || defined GC_CHECK_MARKED_OBJECTS)
Kenichi Handa's avatar
Kenichi Handa committed
84 85 86
#undef GC_MALLOC_CHECK
#endif

87
#include <unistd.h>
88 89
#include <fcntl.h>

Paul Eggert's avatar
Paul Eggert committed
90 91 92
#ifdef USE_GTK
# include "gtkutil.h"
#endif
93
#ifdef WINDOWSNT
Eli Zaretskii's avatar
Eli Zaretskii committed
94
#include "w32.h"
95
#include "w32heap.h"	/* for sbrk */
96 97
#endif

98
#ifdef DOUG_LEA_MALLOC
99

100
#include <malloc.h>
101

102 103 104
/* Specify maximum number of areas to mmap.  It would be nice to use a
   value that explicitly means "no limit".  */

105 106
#define MMAP_MAX_AREAS 100000000

107
#endif /* not DOUG_LEA_MALLOC */
108

109 110 111
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

112 113
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
114
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
115

116 117 118
#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)
119

120 121
/* Default value of gc_cons_threshold (see below).  */

122
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
123

124 125 126
/* Global variables.  */
struct emacs_globals globals;

127 128
/* Number of bytes of consing done since the last gc.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
129
EMACS_INT consing_since_gc;
Jim Blandy's avatar
Jim Blandy committed
130

131 132
/* Similar minimum, computed from Vgc_cons_percentage.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
133
EMACS_INT gc_relative_threshold;
134

135 136 137
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
138
EMACS_INT memory_full_cons_threshold;
139

140
/* True during GC.  */
141

142
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
143

144
/* True means abort if try to GC.
145 146 147
   This is for code which is written on the assumption that
   no GC will happen, so as to verify that assumption.  */

148
bool abort_on_gc;
149

150 151
/* Number of live and free conses etc.  */

152
static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
153
static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
154
static EMACS_INT total_free_floats, total_floats;
155

156
/* Points to memory space allocated as "spare", to be freed if we run
157 158
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
159

160
static char *spare_memory[7];
161

162 163
/* 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.  */
164

165
#define SPARE_MEMORY (1 << 14)
166

Richard M. Stallman's avatar
Richard M. Stallman committed
167 168 169 170 171
/* 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.  */
172

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

176
/* Pointer to the pure area, and its size.  */
177

178
static char *purebeg;
179
static ptrdiff_t pure_size;
180 181 182 183

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

184
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
185

186
/* True if P points into pure space.  */
187 188

#define PURE_POINTER_P(P)					\
189
  ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
190

191
/* Index in pure at which next pure Lisp object will be allocated..  */
192

193
static ptrdiff_t pure_bytes_used_lisp;
194 195 196

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

197
static ptrdiff_t pure_bytes_used_non_lisp;
198

199 200 201
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

202
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
203

204 205 206 207 208 209 210 211 212 213 214
#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
215 216
struct suspicious_free_record
{
217 218
  void *suspicious_object;
  void *backtrace[128];
219
};
220
static void *suspicious_objects[32];
221
static int suspicious_object_index;
222
struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
223 224 225
static int suspicious_free_history_index;
/* Find the first currently-monitored suspicious pointer in range
   [begin,end) or NULL if no such pointer exists.  */
226 227
static void *find_suspicious_object_in_range (void *begin, void *end);
static void detect_suspicious_free (void *ptr);
228
#else
229 230
# define find_suspicious_object_in_range(begin, end) NULL
# define detect_suspicious_free(ptr) (void)
231 232
#endif

Jim Blandy's avatar
Jim Blandy committed
233 234 235 236 237 238 239 240
/* 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.  */

241
#if MAX_SAVE_STACK > 0
242
static char *stack_copy;
243
static ptrdiff_t stack_copy_size;
244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264

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

266 267 268 269 270 271 272 273
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;
274
static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
275
static Lisp_Object Qgc_cons_threshold;
276
Lisp_Object Qautomatic_gc;
277
Lisp_Object Qchar_table_extra_slots;
278

279 280
/* Hook run after GC has finished.  */

281
static Lisp_Object Qpost_gc_hook;
282

283 284
static void mark_terminals (void);
static void gc_sweep (void);
285
static Lisp_Object make_pure_vector (ptrdiff_t);
286
static void mark_buffer (struct buffer *);
287

288 289 290
#if !defined REL_ALLOC || defined SYSTEM_MALLOC
static void refill_memory_reserve (void);
#endif
291 292
static void compact_small_strings (void);
static void free_large_strings (void);
293
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
294

295 296 297
/* 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.  */
298 299 300 301 302 303 304 305 306 307

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,
308 309 310
  /* 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.  */
311 312
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
313 314 315
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
316 317
};

318
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
319 320 321 322

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

323
static Lisp_Object Vdead;
324
#define DEADP(x) EQ (x, Vdead)
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 350 351 352 353 354 355 356 357
#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
358 359 360 361 362 363
  /* 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;
364 365 366 367 368 369

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

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

371 372 373 374 375 376 377 378 379 380 381 382
  /* 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;

383 384 385 386
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

387 388 389 390 391
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

392 393 394 395 396 397
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 *);
398
static struct mem_node *mem_find (void *);
399

400
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
401

402 403 404 405
#ifndef DEADP
# define DEADP(x) 0
#endif

406 407 408 409
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

410 411
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
412

413
enum { NSTATICS = 2048 };
414
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
415 416 417

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

418
static int staticidx;
419

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

422 423 424
/* 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.  */
425

426 427 428
#define ROUNDUP(x, y) ((y) & ((y) - 1)					\
		       ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y)	\
		       : ((x) + (y) - 1) & ~ ((y) - 1))
429

430 431 432 433 434 435 436
/* Return PTR rounded up to the next multiple of ALIGNMENT.  */

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

438 439 440 441 442
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
443

444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460
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
461

462 463 464 465
/************************************************************************
				Malloc
 ************************************************************************/

466
/* Function malloc calls this if it finds we are near exhausting storage.  */
467 468

void
469
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
470 471 472 473
{
  pending_malloc_warning = str;
}

474

475
/* Display an already-pending malloc warning.  */
476

477
void
478
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
479
{
480 481 482 483
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
484 485
  pending_malloc_warning = 0;
}
486

487 488 489
/* Called if we can't allocate relocatable space for a buffer.  */

void
490
buffer_memory_full (ptrdiff_t nbytes)
491
{
492 493 494 495 496 497
  /* 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.  */
498 499

#ifndef REL_ALLOC
Paul Eggert's avatar
Paul Eggert committed
500
  memory_full (nbytes);
Paul Eggert's avatar
Paul Eggert committed
501
#else
502 503
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
504
  xsignal (Qnil, Vmemory_signal_data);
Paul Eggert's avatar
Paul Eggert committed
505
#endif
Jim Blandy's avatar
Jim Blandy committed
506 507
}

508 509 510 511 512
/* 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))
513

514
#ifndef XMALLOC_OVERRUN_CHECK
515
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
516
#else
517

518 519
/* 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
520

521 522 523 524
   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
525 526

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

530
#define XMALLOC_OVERRUN_CHECK_SIZE 16
531
#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
532 533 534
  (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)

/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
535 536 537
   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				\
538
  alignof (union { long double d; intmax_t i; void *p; })
539

540
#if USE_LSB_TAG
541
# define XMALLOC_HEADER_ALIGNMENT \
542
    COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
543 544 545 546
#else
# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
#endif
#define XMALLOC_OVERRUN_SIZE_SIZE				\
547 548 549 550
   (((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
551

552 553 554 555 556
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' };
557

558 559 560 561 562
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' };
563

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

566 567 568 569
static void
xmalloc_put_size (unsigned char *ptr, size_t size)
{
  int i;
570
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
571
    {
572
      *--ptr = size & ((1 << CHAR_BIT) - 1);
573 574 575
      size >>= CHAR_BIT;
    }
}
Kim F. Storm's avatar
Kim F. Storm committed
576

577 578 579 580 581
static size_t
xmalloc_get_size (unsigned char *ptr)
{
  size_t size = 0;
  int i;
582 583
  ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
584 585 586 587 588 589
    {
      size <<= CHAR_BIT;
      size += *ptr++;
    }
  return size;
}
Kim F. Storm's avatar
Kim F. Storm committed
590 591 592 593


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

Paul Eggert's avatar
Paul Eggert committed
594
static void *
595
overrun_check_malloc (size_t size)
596
{
Kim F. Storm's avatar
Kim F. Storm committed
597
  register unsigned char *val;
598
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
599
    emacs_abort ();
600

601 602
  val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
  if (val)
603
    {
604
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
605
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
606
      xmalloc_put_size (val, size);
607 608
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
609
    }
Paul Eggert's avatar
Paul Eggert committed
610
  return val;
611 612
}

Kim F. Storm's avatar
Kim F. Storm committed
613 614 615 616

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

Paul Eggert's avatar
Paul Eggert committed
617 618
static void *
overrun_check_realloc (void *block, size_t size)
619
{
620
  register unsigned char *val = (unsigned char *) block;
621
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
622
    emacs_abort ();
623 624

  if (val
625
      && memcmp (xmalloc_overrun_check_header,
626
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
627
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
628
    {
629
      size_t osize = xmalloc_get_size (val);
630 631
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
632
	emacs_abort ();
633
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
634 635
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
636 637
    }

638
  val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
639

640
  if (val)
641
    {
642
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
643
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
644
      xmalloc_put_size (val, size);
645 646
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
647
    }
Paul Eggert's avatar
Paul Eggert committed
648
  return val;
649 650
}

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

653
static void
Paul Eggert's avatar
Paul Eggert committed
654
overrun_check_free (void *block)
655
{
656
  unsigned char *val = (unsigned char *) block;
657 658

  if (val
659
      && memcmp (xmalloc_overrun_check_header,
660
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
661
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
662
    {
663
      size_t osize = xmalloc_get_size (val);
664 665
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
666
	emacs_abort ();
667
#ifdef XMALLOC_CLEAR_FREE_MEMORY
668
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
669
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
670
#else
671
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
672 673
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
674
#endif
675 676 677 678 679 680 681 682 683 684 685 686 687
    }

  free (val);
}

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

688 689 690 691 692 693 694 695 696 697 698 699 700 701
/* 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)
702
    block_input ();
703 704 705 706 707
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
708
    unblock_input ();
709 710 711
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
712
#else
713 714
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
715
#endif
Kim F. Storm's avatar
Kim F. Storm committed
716

Stefan Monnier's avatar
Stefan Monnier committed
717 718 719 720 721 722 723
#define MALLOC_PROBE(size)			\
  do {						\
    if (profiler_memory_running)		\
      malloc_probe (size);			\
  } while (0)


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

Paul Eggert's avatar
Paul Eggert committed
726
void *
727
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
728
{
Paul Eggert's avatar
Paul Eggert committed
729
  void *val;
Jim Blandy's avatar
Jim Blandy committed
730

731
  MALLOC_BLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
732
  val = malloc (size);
733
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
734

735
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
736
    memory_full (size);
737
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
738 739 740
  return val;
}

Dmitry Antipov's avatar
Dmitry Antipov committed
741 742 743 744 745 746 747 748 749 750 751 752 753 754
/* 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);
755
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
756 757
  return val;
}
758 759 760

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

Paul Eggert's avatar
Paul Eggert committed
761 762
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
763
{
Paul Eggert's avatar
Paul Eggert committed
764
  void *val;
Jim Blandy's avatar
Jim Blandy committed
765

766
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
767 768 769
  /* 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
770
    val = malloc (size);
Noah Friedman's avatar
Noah Friedman committed
771
  else
Paul Eggert's avatar
Paul Eggert committed
772
    val = realloc (block, size);
773
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
774

Paul Eggert's avatar
Paul Eggert committed
775 776
  if (!val && size)
    memory_full (size);
777
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
778 779
  return val;
}
780

781

Dave Love's avatar
Dave Love committed
782
/* Like free but block interrupt input.  */
783

784
void
Paul Eggert's avatar
Paul Eggert committed
785
xfree (void *block)
786
{
787 788
  if (!block)
    return;
789
  MALLOC_BLOCK_INPUT;
790
  free (block);
791
  MALLOC_UNBLOCK_INPUT;
792
  /* We don't call refill_memory_reserve here
793
     because in practice the call in r_alloc_free seems to suffice.  */
794 795
}

796

797 798 799 800 801 802 803 804 805 806 807 808
/* 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)
{
809 810
  eassert (nitems >= 0 && item_size > 0);
  if (nitems > min (PTRDIFF_MAX, SIZE_MAX) / item_size)
811 812 813 814 815 816 817 818 819 820 821
    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)
{
822 823
  eassert (nitems >= 0 && item_size > 0);
  if (nitems > min (PTRDIFF_MAX, SIZE_MAX) / item_size)
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839
    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
840
   the old one.
841 842 843

   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
844 845 846 847 848 849 850
   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.  */
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875

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

876
  eassert (item_size > 0 && nitems_incr_min > 0 && n >= 0 && nitems_max >= -1);
877 878
  if (! pa)
    *nitems = 0;
879
  if (incr > nitems_incr_max)
880 881 882 883 884 885 886 887
    memory_full (SIZE_MAX);
  n += incr;
  pa = xrealloc (pa, n * item_size);
  *nitems = n;
  return pa;
}


888 889 890
/* Like strdup, but uses xmalloc.  */

char *
891
xstrdup (const char *s)
892
{
Paul Eggert's avatar
Paul Eggert committed
893
  ptrdiff_t size;
894
  eassert (s);
Paul Eggert's avatar
Paul Eggert committed
895 896
  size = strlen (s) + 1;
  return memcpy (xmalloc (size), s, size);
897 898
}

899 900 901 902 903 904 905 906 907
/* 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);
}

908 909 910 911 912 913 914 915 916 917 918 919 920 921
/* 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);
}


922 923 924 925 926 927 928 929 930
/* 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);
}
931

932 933 934 935 936 937
/* 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);
938
  record_unwind_protect_ptr (xfree, p);
939 940 941
  return p;
}

942

943 944
/* 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
945
   allocated memory block (for strings, for conses, ...).  */
946

947 948
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
949
#endif
950

Paul Eggert's avatar
Paul Eggert committed
951
static void *
952
lisp_malloc (size_t nbytes, enum mem_type type)
953
{
954
  register void *val;
955