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

Paul Eggert's avatar
Paul Eggert committed
3
Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 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 <errno.h>
24
#include <stdio.h>
25
#include <limits.h>		/* For CHAR_BIT.  */
26
#include <signal.h>		/* For SIGABRT, SIGDANGER.  */
27

28
#ifdef HAVE_PTHREAD
29 30 31
#include <pthread.h>
#endif

Jim Blandy's avatar
Jim Blandy committed
32
#include "lisp.h"
33
#include "dispextern.h"
34
#include "intervals.h"
Jim Blandy's avatar
Jim Blandy committed
35
#include "puresize.h"
36
#include "sheap.h"
37
#include "systime.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
#ifdef HAVE_MALLOC_H
# include <malloc.h>
#endif

64 65 66 67 68 69
#if (defined ENABLE_CHECKING			\
     && defined HAVE_VALGRIND_VALGRIND_H	\
     && !defined USE_VALGRIND)
# define USE_VALGRIND 1
#endif

70 71 72
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
73
static bool valgrind_p;
74 75
#endif

76
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.  */
77

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
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
83
     || defined HYBRID_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

Paul Eggert's avatar
Paul Eggert committed
98 99 100 101 102 103 104 105 106 107 108 109
#if defined DOUG_LEA_MALLOC || defined GNU_LINUX
/* The address where the heap starts.  */
void *
my_heap_start (void)
{
  static void *start;
  if (! start)
    start = sbrk (0);
  return start;
}
#endif

110
#ifdef DOUG_LEA_MALLOC
111 112 113 114

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

115 116
#define MMAP_MAX_AREAS 100000000

Paul Eggert's avatar
Paul Eggert committed
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
/* A pointer to the memory allocated that copies that static data
   inside glibc's malloc.  */
static void *malloc_state_ptr;

/* Restore the dumped malloc state.  Because malloc can be invoked
   even before main (e.g. by the dynamic linker), the dumped malloc
   state must be restored as early as possible using this special hook.  */
static void
malloc_initialize_hook (void)
{
  static bool malloc_using_checking;

  if (! initialized)
    {
      my_heap_start ();
      malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL;
    }
  else
    {
      if (!malloc_using_checking)
	{
	  /* Work around a bug in glibc's malloc.  MALLOC_CHECK_ must be
	     ignored if the heap to be restored was constructed without
	     malloc checking.  Can't use unsetenv, since that calls malloc.  */
	  char **p = environ;
	  if (p)
	    for (; *p; p++)
	      if (strncmp (*p, "MALLOC_CHECK_=", 14) == 0)
		{
		  do
		    *p = p[1];
		  while (*++p);

		  break;
		}
	}

154 155
      if (malloc_set_state (malloc_state_ptr) != 0)
	emacs_abort ();
Paul Eggert's avatar
Paul Eggert committed
156 157 158 159 160 161
# ifndef XMALLOC_OVERRUN_CHECK
      alloc_unexec_post ();
# endif
    }
}

Paul Eggert's avatar
Paul Eggert committed
162 163
/* Declare the malloc initialization hook, which runs before 'main' starts.
   EXTERNALLY_VISIBLE works around Bug#22522.  */
Paul Eggert's avatar
Paul Eggert committed
164 165 166
# ifndef __MALLOC_HOOK_VOLATILE
#  define __MALLOC_HOOK_VOLATILE
# endif
Paul Eggert's avatar
Paul Eggert committed
167
voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
Paul Eggert's avatar
Paul Eggert committed
168 169 170
  = malloc_initialize_hook;

#endif
171

172 173 174 175 176 177 178
/* Allocator-related actions to do just before and after unexec.  */

void
alloc_unexec_pre (void)
{
#ifdef DOUG_LEA_MALLOC
  malloc_state_ptr = malloc_get_state ();
179 180
  if (!malloc_state_ptr)
    fatal ("malloc_get_state: %s", strerror (errno));
181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
#endif
#ifdef HYBRID_MALLOC
  bss_sbrk_did_unexec = true;
#endif
}

void
alloc_unexec_post (void)
{
#ifdef DOUG_LEA_MALLOC
  free (malloc_state_ptr);
#endif
#ifdef HYBRID_MALLOC
  bss_sbrk_did_unexec = false;
#endif
}

198 199 200
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

201 202
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
203
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
204

205 206 207
#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)
208

209 210
/* Default value of gc_cons_threshold (see below).  */

211
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
212

213 214 215
/* Global variables.  */
struct emacs_globals globals;

216 217
/* Number of bytes of consing done since the last gc.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
218
EMACS_INT consing_since_gc;
Jim Blandy's avatar
Jim Blandy committed
219

220 221
/* Similar minimum, computed from Vgc_cons_percentage.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
222
EMACS_INT gc_relative_threshold;
223

224 225 226
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

Dmitry Antipov's avatar
Dmitry Antipov committed
227
EMACS_INT memory_full_cons_threshold;
228

229
/* True during GC.  */
230

231
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
232

233
/* True means abort if try to GC.
234 235 236
   This is for code which is written on the assumption that
   no GC will happen, so as to verify that assumption.  */

237
bool abort_on_gc;
238

239 240
/* Number of live and free conses etc.  */

241
static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
242
static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
243
static EMACS_INT total_free_floats, total_floats;
244

245
/* Points to memory space allocated as "spare", to be freed if we run
246 247
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
248

249
static char *spare_memory[7];
250

251 252
/* 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.  */
253

254
#define SPARE_MEMORY (1 << 14)
255

Richard M. Stallman's avatar
Richard M. Stallman committed
256 257 258 259 260
/* 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.  */
261

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

265
/* Pointer to the pure area, and its size.  */
266

267
static char *purebeg;
268
static ptrdiff_t pure_size;
269 270 271 272

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

273
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
274

275
/* Index in pure at which next pure Lisp object will be allocated..  */
276

277
static ptrdiff_t pure_bytes_used_lisp;
278 279 280

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

281
static ptrdiff_t pure_bytes_used_non_lisp;
282

283 284 285
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

286
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
287

288 289 290 291 292 293 294 295 296 297 298
#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
299 300
struct suspicious_free_record
{
301 302
  void *suspicious_object;
  void *backtrace[128];
303
};
304
static void *suspicious_objects[32];
305
static int suspicious_object_index;
306
struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
307 308 309
static int suspicious_free_history_index;
/* Find the first currently-monitored suspicious pointer in range
   [begin,end) or NULL if no such pointer exists.  */
310 311
static void *find_suspicious_object_in_range (void *begin, void *end);
static void detect_suspicious_free (void *ptr);
312
#else
313 314
# define find_suspicious_object_in_range(begin, end) NULL
# define detect_suspicious_free(ptr) (void)
315 316
#endif

Jim Blandy's avatar
Jim Blandy committed
317 318 319 320 321 322 323 324
/* 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.  */

325
#if MAX_SAVE_STACK > 0
326
static char *stack_copy;
327
static ptrdiff_t stack_copy_size;
328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348

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

350 351
static void mark_terminals (void);
static void gc_sweep (void);
352
static Lisp_Object make_pure_vector (ptrdiff_t);
353
static void mark_buffer (struct buffer *);
354

355
#if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
356 357
static void refill_memory_reserve (void);
#endif
358 359
static void compact_small_strings (void);
static void free_large_strings (void);
360
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
361

362 363 364
/* 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.  */
365 366 367 368 369 370 371 372 373 374

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,
375 376 377
  /* 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.  */
378 379
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
380 381 382
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
383 384
};

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

388
static Lisp_Object Vdead;
389
#define DEADP(x) EQ (x, Vdead)
390

391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
#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
423 424 425 426 427 428
  /* 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;
429 430 431 432 433 434

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

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

436 437 438 439 440 441 442 443 444 445 446 447
  /* 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;

448 449 450 451
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

452 453 454 455 456
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

457 458 459 460 461 462
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 *);
463
static struct mem_node *mem_find (void *);
464

465 466 467 468
#ifndef DEADP
# define DEADP(x) 0
#endif

469 470
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
471

472
enum { NSTATICS = 2048 };
473
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
474 475 476

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

477
static int staticidx;
478

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

Paul Eggert's avatar
Paul Eggert committed
481
/* True if N is a power of 2.  N should be positive.  */
482

Paul Eggert's avatar
Paul Eggert committed
483 484 485 486 487 488 489 490 491 492
#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)

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

#define ROUNDUP(x, y) (POWER_OF_2 (y)					\
		       ? ((y) - 1 + (x)) & ~ ((y) - 1)			\
		       : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
493

494 495 496
/* Return PTR rounded up to the next multiple of ALIGNMENT.  */

static void *
Paul Eggert's avatar
Paul Eggert committed
497
pointer_align (void *ptr, int alignment)
498 499 500
{
  return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
501

Paul Eggert's avatar
Paul Eggert committed
502 503 504 505
/* Extract the pointer hidden within A, if A is not a symbol.
   If A is a symbol, extract the hidden pointer's offset from lispsym,
   converted to void *.  */

506 507
#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
  ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
Paul Eggert's avatar
Paul Eggert committed
508 509 510

/* Extract the pointer hidden within A.  */

511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526
#define macro_XPNTR(a) \
  ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
	     + (SYMBOLP (a) ? (char *) lispsym : NULL)))

/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
   functions, as functions are cleaner and can be used in debuggers.
   Also, define them as macros if being compiled with GCC without
   optimization, for performance in that case.  The macro_* names are
   private to this section of code.  */

static ATTRIBUTE_UNUSED void *
XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
{
  return macro_XPNTR_OR_SYMBOL_OFFSET (a);
}
static ATTRIBUTE_UNUSED void *
Paul Eggert's avatar
Paul Eggert committed
527 528
XPNTR (Lisp_Object a)
{
529
  return macro_XPNTR (a);
Paul Eggert's avatar
Paul Eggert committed
530 531
}

532 533 534 535 536
#if DEFINE_KEY_OPS_AS_MACROS
# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
# define XPNTR(a) macro_XPNTR (a)
#endif

537 538 539 540 541
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
542

543
#ifdef DOUG_LEA_MALLOC
544 545 546 547 548 549 550 551 552 553 554 555
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
Paul Eggert's avatar
Paul Eggert committed
556
     if we might dump: unexec doesn't preserve the contents of mmapped
557 558 559
     regions.  */
  return pointers_fit_in_lispobj_p () && !might_dump;
}
560
#endif
561

Daniel Colascione's avatar
Daniel Colascione committed
562 563 564 565 566 567 568 569 570
/* Head of a circularly-linked list of extant finalizers. */
static struct Lisp_Finalizer finalizers;

/* Head of a circularly-linked list of finalizers that must be invoked
   because we deemed them unreachable.  This list must be global, and
   not a local inside garbage_collect_1, in case we GC again while
   running finalizers.  */
static struct Lisp_Finalizer doomed_finalizers;

Jim Blandy's avatar
Jim Blandy committed
571

572 573 574 575
/************************************************************************
				Malloc
 ************************************************************************/

576 577
#if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)

578
/* Function malloc calls this if it finds we are near exhausting storage.  */
579 580

void
581
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
582 583 584 585
{
  pending_malloc_warning = str;
}

586
#endif
587

588
/* Display an already-pending malloc warning.  */
589

590
void
591
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
592
{
593 594 595 596
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
597 598
  pending_malloc_warning = 0;
}
599

600 601 602
/* Called if we can't allocate relocatable space for a buffer.  */

void
603
buffer_memory_full (ptrdiff_t nbytes)
604
{
605 606 607 608 609 610
  /* 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.  */
611 612

#ifndef REL_ALLOC
Paul Eggert's avatar
Paul Eggert committed
613
  memory_full (nbytes);
Paul Eggert's avatar
Paul Eggert committed
614
#else
615 616
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
617
  xsignal (Qnil, Vmemory_signal_data);
Paul Eggert's avatar
Paul Eggert committed
618
#endif
Jim Blandy's avatar
Jim Blandy committed
619 620
}

621 622 623 624 625
/* 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))
626

627
#ifndef XMALLOC_OVERRUN_CHECK
628
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
629
#else
630

631 632
/* 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
633

634 635 636 637
   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
638 639

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

643
#define XMALLOC_OVERRUN_CHECK_SIZE 16
644
#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
645 646
  (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)

647
#define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
648

649 650
#define XMALLOC_HEADER_ALIGNMENT \
   COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
Paul Eggert's avatar
Paul Eggert committed
651 652 653 654

/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
   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.  */
655
#define XMALLOC_OVERRUN_SIZE_SIZE				\
656 657 658 659
   (((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
660

661 662 663 664 665
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' };
666

667 668 669 670 671
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' };
672

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

675 676 677 678
static void
xmalloc_put_size (unsigned char *ptr, size_t size)
{
  int i;
679
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
680
    {
681
      *--ptr = size & ((1 << CHAR_BIT) - 1);
682 683 684
      size >>= CHAR_BIT;
    }
}
Kim F. Storm's avatar
Kim F. Storm committed
685

686 687 688 689 690
static size_t
xmalloc_get_size (unsigned char *ptr)
{
  size_t size = 0;
  int i;
691 692
  ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
  for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
693 694 695 696 697 698
    {
      size <<= CHAR_BIT;
      size += *ptr++;
    }
  return size;
}
Kim F. Storm's avatar
Kim F. Storm committed
699 700 701 702


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

Paul Eggert's avatar
Paul Eggert committed
703
static void *
704
overrun_check_malloc (size_t size)
705
{
Kim F. Storm's avatar
Kim F. Storm committed
706
  register unsigned char *val;
707
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
708
    emacs_abort ();
709

710 711
  val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
  if (val)
712
    {
713
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
714
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
715
      xmalloc_put_size (val, size);
716 717
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
718
    }
Paul Eggert's avatar
Paul Eggert committed
719
  return val;
720 721
}

Kim F. Storm's avatar
Kim F. Storm committed
722 723 724 725

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

Paul Eggert's avatar
Paul Eggert committed
726 727
static void *
overrun_check_realloc (void *block, size_t size)
728
{
729
  register unsigned char *val = (unsigned char *) block;
730
  if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
731
    emacs_abort ();
732 733

  if (val
734
      && memcmp (xmalloc_overrun_check_header,
735
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
736
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
737
    {
738
      size_t osize = xmalloc_get_size (val);
739 740
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
741
	emacs_abort ();
742
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
743 744
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
745 746
    }

747
  val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
748

749
  if (val)
750
    {
751
      memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
752
      val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
753
      xmalloc_put_size (val, size);
754 755
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
756
    }
Paul Eggert's avatar
Paul Eggert committed
757
  return val;
758 759
}

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

762
static void
Paul Eggert's avatar
Paul Eggert committed
763
overrun_check_free (void *block)
764
{
765
  unsigned char *val = (unsigned char *) block;
766 767

  if (val
768
      && memcmp (xmalloc_overrun_check_header,
769
		 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
770
		 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
771
    {
772
      size_t osize = xmalloc_get_size (val);
773 774
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
775
	emacs_abort ();
776
#ifdef XMALLOC_CLEAR_FREE_MEMORY
777
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
778
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
779
#else
780
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
781 782
      val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
783
#endif
784 785 786 787 788 789 790 791 792 793 794 795 796
    }

  free (val);
}

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

797 798 799 800 801 802 803 804 805 806 807 808 809 810
/* 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)
811
    block_input ();
812 813 814 815 816
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
817
    unblock_input ();
818 819 820
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
821
#else
822 823
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
824
#endif
Kim F. Storm's avatar
Kim F. Storm committed
825

Stefan Monnier's avatar
Stefan Monnier committed
826 827 828 829 830 831
#define MALLOC_PROBE(size)			\
  do {						\
    if (profiler_memory_running)		\
      malloc_probe (size);			\
  } while (0)

Paul Eggert's avatar
Paul Eggert committed
832 833
static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
static void *lrealloc (void *, size_t);
Stefan Monnier's avatar
Stefan Monnier committed
834

Paul Eggert's avatar
Paul Eggert committed
835
/* Like malloc but check for no memory and block interrupt input.  */
Jim Blandy's avatar
Jim Blandy committed
836

Paul Eggert's avatar
Paul Eggert committed
837
void *
838
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
839
{
Paul Eggert's avatar
Paul Eggert committed
840
  void *val;
Jim Blandy's avatar
Jim Blandy committed
841

842
  MALLOC_BLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
843
  val = lmalloc (size);
844
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
845

846
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
847
    memory_full (size);
848
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
849 850 851
  return val;
}

Dmitry Antipov's avatar
Dmitry Antipov committed
852 853 854 855 856 857 858 859
/* Like the above, but zeroes out the memory just allocated.  */

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

  MALLOC_BLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
860
  val = lmalloc (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
861 862 863 864 865
  MALLOC_UNBLOCK_INPUT;

  if (!val && size)
    memory_full (size);
  memset (val, 0, size);
866
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
867 868
  return val;
}
869 870 871

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

Paul Eggert's avatar
Paul Eggert committed
872 873
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
874
{
Paul Eggert's avatar
Paul Eggert committed
875
  void *val;
Jim Blandy's avatar
Jim Blandy committed
876

877
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
878 879 880
  /* 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
881
    val = lmalloc (size);
Noah Friedman's avatar
Noah Friedman committed
882
  else
Paul Eggert's avatar
Paul Eggert committed
883
    val = lrealloc (block, size);
884
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
885

Paul Eggert's avatar
Paul Eggert committed
886 887
  if (!val && size)
    memory_full (size);
888
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
889 890
  return val;
}
891

892

Dave Love's avatar
Dave Love committed
893
/* Like free but block interrupt input.  */
894

895
void
Paul Eggert's avatar
Paul Eggert committed
896
xfree (void *block)
897
{
898 899
  if (!block)
    return;
900
  MALLOC_BLOCK_INPUT;
901
  free (block);
902
  MALLOC_UNBLOCK_INPUT;
903
  /* We don't call refill_memory_reserve here
904
     because in practice the call in r_alloc_free seems to suffice.  */
905 906
}

907

908 909 910 911 912 913 914 915 916 917 918 919
/* 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)
{
Paul Eggert's avatar
Paul Eggert committed
920
  eassert (0 <= nitems && 0 < item_size);
921 922
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
923
    memory_full (SIZE_MAX);
924
  return xmalloc (nbytes);
925 926 927 928 929 930 931 932 933
}


/* 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)
{
Paul Eggert's avatar
Paul Eggert committed
934
  eassert (0 <= nitems && 0 < item_size);
935 936
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
937
    memory_full (SIZE_MAX);
938
  return xrealloc (pa, nbytes);
939 940 941 942 943 944 945 946 947 948 949 950 951 952
}


/* 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
953
   the old one.
954 955 956

   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
957 958 959 960 961 962 963
   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.  */
964 965 966 967 968

void *
xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
	 ptrdiff_t nitems_max, ptrdiff_t item_size)
{
969 970 971
  ptrdiff_t n0 = *nitems;
  eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);

972 973 974 975 976 977
  /* 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)
978 979
     DEFAULT_MXFAST bytes.  Otherwise, grow it by about 50%.
     Adjust the growth according to three constraints: NITEMS_INCR_MIN,
980 981
     NITEMS_MAX, and what the C language can represent safely.  */

982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997
  ptrdiff_t n, nbytes;
  if (INT_ADD_WRAPV (n0, n0 >> 1, &n))
    n = PTRDIFF_MAX;
  if (0 <= nitems_max && nitems_max < n)
    n = nitems_max;

  ptrdiff_t adjusted_nbytes
    = ((INT_MULTIPLY_WRAPV (n, item_size, &nbytes) || SIZE_MAX < nbytes)
       ? min (PTRDIFF_MAX, SIZE_MAX)
       : nbytes < DEFAULT_MXFAST ? DEFAULT_MXFAST : 0);
  if (adjusted_nbytes)
    {
      n = adjusted_nbytes / item_size;
      nbytes = adjusted_nbytes - adjusted_nbytes % item_size;
    }

998 999
  if (! pa)
    *nitems = 0;
1000 1001 1002 1003
  if (n - n0 < nitems_incr_min
      && (INT_ADD_WRAPV (n0, nitems_incr_min, &n)
	  || (0 <= nitems_max && nitems_max < n)
	  || INT_MULTIPLY_WRAPV (n, item_size, &nbytes)))
1004
    memory_full (SIZE_MAX);
1005
  pa = xrealloc (pa, nbytes);
1006 1007 1008 1009 1010
  *nitems = n;
  return pa;
}


1011 1012 1013
/* Like strdup, but uses xmalloc.  */

char *
1014
xstrdup (const char *s)
1015
{
Paul Eggert's avatar
Paul Eggert committed
1016
  ptrdiff_t size;
1017
  eassert (s);
Paul Eggert's avatar
Paul Eggert committed
1018 1019
  size = strlen (s) + 1;
  return memcpy (xmalloc (size), s, size);
1020 1021
}

1022 1023 1024 1025 1026 1027 1028 1029 1030
/* 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);
}

1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044
/* 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);
}


1045 1046 1047 1048 1049 1050 1051 1052 1053
/* 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);
}
1054

1055 1056 1057 1058 1059 1060
/* 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);
1061
  record_unwind_protect_ptr (xfree, p);
1062 1063 1064
  return p;
}

1065

1066 1067
/* 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
1068
   allocated memory block (for strings, for conses, ...).  */
1069

1070 1071
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
1072
#endif
1073

Paul Eggert's avatar
Paul Eggert committed
1074
static void *
1075
lisp_malloc (size_t nbytes, enum mem_type type)
1076
{
1077
  register void *val;
1078

1079
  MALLOC_BLOCK_INPUT;
1080 1081 1082 1083

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
1084

Paul Eggert's avatar
Paul Eggert committed
1085
  val = lmalloc (nbytes);
1086

1087
#if ! USE_LSB_TAG
1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101
  /* 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
1102
#endif
1103

1104
#ifndef GC_MALLOC_CHECK
1105
  if (val && type != MEM_TYPE_NON_LISP)
1106 1107
    mem_insert (val, (char *) val + nbytes, type);
#endif
1108

1109
  MALLOC_UNBLOCK_INPUT;
1110
  if (!val && nbytes)
Paul Eggert's avatar
Paul Eggert committed
1111
    memory_full (nbytes);
1112
  MALLOC_PROBE (nbytes);
1113 1114 1115
  return val;
}

1116 1117 1118
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

1119
static void
Paul Eggert's avatar
Paul Eggert committed
1120
lisp_free (void *block)
1121
{
1122
  MALLOC_BLOCK_INPUT;
1123
  free (block);
1124
#ifndef GC_MALLOC_CHECK
1125 1126
  mem_delete (mem_find (block));
#endif
1127
  MALLOC_UNBLOCK_INPUT;
1128
}
1129

1130 1131 1132 1133
/*****  Allocation of aligned blocks of memory to store Lisp data.  *****/

/* The entry point is lisp_align_malloc which returns blocks of at most
   BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary.  */