alloc.c 203 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-2019 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 <https://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

21
#include <config.h>
22

23
#include <errno.h>
24
#include <stdint.h>
25
#include <stdio.h>
Paul Eggert's avatar
Paul Eggert committed
26
#include <stdlib.h>
27
#include <limits.h>		/* For CHAR_BIT.  */
28
#include <signal.h>		/* For SIGABRT, SIGDANGER.  */
29

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

Jim Blandy's avatar
Jim Blandy committed
34
#include "lisp.h"
Paul Eggert's avatar
Paul Eggert committed
35
#include "bignum.h"
36
#include "dispextern.h"
37
#include "intervals.h"
38
#include "ptr-bounds.h"
Jim Blandy's avatar
Jim Blandy committed
39
#include "puresize.h"
40
#include "sheap.h"
41
#include "systime.h"
42
#include "character.h"
Jim Blandy's avatar
Jim Blandy committed
43 44
#include "buffer.h"
#include "window.h"
45
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
46
#include "frame.h"
47
#include "blockinput.h"
Daniel Colascione's avatar
Daniel Colascione committed
48
#include "pdumper.h"
49
#include "termhooks.h"		/* For struct terminal.  */
50 51 52
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
53

54
#include <flexmember.h>
55
#include <verify.h>
56
#include <execinfo.h>           /* For backtrace.  */
57

58 59 60 61
#ifdef HAVE_LINUX_SYSINFO
#include <sys/sysinfo.h>
#endif

62 63 64 65
#ifdef MSDOS
#include "dosfns.h"		/* For dos_memory_info.  */
#endif

66 67 68 69
#ifdef HAVE_MALLOC_H
# include <malloc.h>
#endif

Daniel Colascione's avatar
Daniel Colascione committed
70
#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND
71 72 73
# define USE_VALGRIND 1
#endif

74 75 76 77 78
#if USE_VALGRIND
#include <valgrind/valgrind.h>
#include <valgrind/memcheck.h>
#endif

79 80 81 82 83 84 85
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
   We turn that on by default when ENABLE_CHECKING is defined;
   define GC_CHECK_MARKED_OBJECTS to zero to disable.  */

#if defined ENABLE_CHECKING && !defined GC_CHECK_MARKED_OBJECTS
# define GC_CHECK_MARKED_OBJECTS 1
#endif
86

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

91
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
92
     || defined HYBRID_MALLOC || GC_CHECK_MARKED_OBJECTS)
Kenichi Handa's avatar
Kenichi Handa committed
93 94 95
#undef GC_MALLOC_CHECK
#endif

96
#include <unistd.h>
97 98
#include <fcntl.h>

Paul Eggert's avatar
Paul Eggert committed
99 100 101
#ifdef USE_GTK
# include "gtkutil.h"
#endif
102
#ifdef WINDOWSNT
Eli Zaretskii's avatar
Eli Zaretskii committed
103
#include "w32.h"
104
#include "w32heap.h"	/* for sbrk */
105 106
#endif

107
#ifdef DOUG_LEA_MALLOC
108 109 110 111

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

112
# define MMAP_MAX_AREAS 100000000
113

Paul Eggert's avatar
Paul Eggert committed
114 115 116 117 118 119 120 121 122 123 124 125 126 127
/* 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)
    {
128
# ifdef GNU_LINUX
Paul Eggert's avatar
Paul Eggert committed
129
      my_heap_start ();
130
# endif
Paul Eggert's avatar
Paul Eggert committed
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
      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;
		}
	}

153 154
      if (malloc_set_state (malloc_state_ptr) != 0)
	emacs_abort ();
Paul Eggert's avatar
Paul Eggert committed
155 156 157 158
      alloc_unexec_post ();
    }
}

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

#endif
169

170
#if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC
171

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

void
alloc_unexec_pre (void)
{
177
# ifdef DOUG_LEA_MALLOC
178
  malloc_state_ptr = malloc_get_state ();
179 180
  if (!malloc_state_ptr)
    fatal ("malloc_get_state: %s", strerror (errno));
181
# endif
182 183 184 185 186
}

void
alloc_unexec_post (void)
{
187
# ifdef DOUG_LEA_MALLOC
188
  free (malloc_state_ptr);
189
# endif
190
}
191 192 193 194 195 196 197 198 199 200 201 202 203 204

# ifdef GNU_LINUX

/* The address where the heap starts.  */
void *
my_heap_start (void)
{
  static void *start;
  if (! start)
    start = sbrk (0);
  return start;
}
# endif

205
#endif
206

207 208 209
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

Daniel Colascione's avatar
Daniel Colascione committed
210 211 212
#define XMARK_STRING(S)		((S)->u.s.size |= ARRAY_MARK_FLAG)
#define XUNMARK_STRING(S)	((S)->u.s.size &= ~ARRAY_MARK_FLAG)
#define XSTRING_MARKED_P(S)	(((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
213

Daniel Colascione's avatar
Daniel Colascione committed
214 215 216
#define XMARK_VECTOR(V)		((V)->header.size |= ARRAY_MARK_FLAG)
#define XUNMARK_VECTOR(V)	((V)->header.size &= ~ARRAY_MARK_FLAG)
#define XVECTOR_MARKED_P(V)	(((V)->header.size & ARRAY_MARK_FLAG) != 0)
217

218 219
/* Default value of gc_cons_threshold (see below).  */

220
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
221

222 223 224
/* Global variables.  */
struct emacs_globals globals;

225 226
/* Number of bytes of consing done since the last gc.  */

227
byte_ct consing_since_gc;
Jim Blandy's avatar
Jim Blandy committed
228

229 230
/* Similar minimum, computed from Vgc_cons_percentage.  */

231
byte_ct gc_relative_threshold;
232

Daniel Colascione's avatar
Daniel Colascione committed
233 234 235 236 237 238
#ifdef HAVE_PDUMPER
/* Number of finalizers run: used to loop over GC until we stop
   generating garbage.  */
int number_finalizers_run;
#endif

239
/* True during GC.  */
240

241
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
242

243 244 245 246 247
/* Type of object counts reported by GC.  Unlike byte_ct, this can be
   signed, e.g., it is less than 2**31 on a typical 32-bit machine.  */

typedef intptr_t object_ct;

248 249
/* Number of live and free conses etc.  */

250
static struct gcstat
251 252 253 254 255 256 257 258 259 260
{
  object_ct total_conses, total_free_conses;
  object_ct total_symbols, total_free_symbols;
  object_ct total_strings, total_free_strings;
  byte_ct total_string_bytes;
  object_ct total_vectors, total_vector_slots, total_free_vector_slots;
  object_ct total_floats, total_free_floats;
  object_ct total_intervals, total_free_intervals;
  object_ct total_buffers;
} gcstat;
261

262
/* Points to memory space allocated as "spare", to be freed if we run
263 264
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
265

266
static char *spare_memory[7];
267

268 269
/* 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.  */
270

271
#define SPARE_MEMORY (1 << 14)
272

Richard M. Stallman's avatar
Richard M. Stallman committed
273 274 275 276 277
/* 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.  */
278

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

282
/* Pointer to the pure area, and its size.  */
283

284
static char *purebeg;
285
static ptrdiff_t pure_size;
286 287 288 289

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

290
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
291

292
/* Index in pure at which next pure Lisp object will be allocated..  */
293

294
static ptrdiff_t pure_bytes_used_lisp;
295 296 297

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

298
static ptrdiff_t pure_bytes_used_non_lisp;
299

300 301 302
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

303
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
304

305 306 307 308 309 310 311 312 313 314 315
#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
316 317
struct suspicious_free_record
{
318 319
  void *suspicious_object;
  void *backtrace[128];
320
};
321
static void *suspicious_objects[32];
322
static int suspicious_object_index;
323
struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
324 325 326
static int suspicious_free_history_index;
/* Find the first currently-monitored suspicious pointer in range
   [begin,end) or NULL if no such pointer exists.  */
327 328
static void *find_suspicious_object_in_range (void *begin, void *end);
static void detect_suspicious_free (void *ptr);
329
#else
330 331
# define find_suspicious_object_in_range(begin, end) NULL
# define detect_suspicious_free(ptr) (void)
332 333
#endif

Jim Blandy's avatar
Jim Blandy committed
334 335 336 337 338 339 340 341
/* 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.  */

342
#if MAX_SAVE_STACK > 0
343
static char *stack_copy;
344
static ptrdiff_t stack_copy_size;
345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365

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

367
static void unchain_finalizer (struct Lisp_Finalizer *);
368 369
static void mark_terminals (void);
static void gc_sweep (void);
370
static Lisp_Object make_pure_vector (ptrdiff_t);
371
static void mark_buffer (struct buffer *);
372

373
#if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
374 375
static void refill_memory_reserve (void);
#endif
376 377
static void compact_small_strings (void);
static void free_large_strings (void);
378
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
379

Daniel Colascione's avatar
Daniel Colascione committed
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
/* Forward declare mark accessor functions: they're used all over the
   place.  */

inline static bool vector_marked_p (const struct Lisp_Vector *v);
inline static void set_vector_marked (struct Lisp_Vector *v);

inline static bool vectorlike_marked_p (const union vectorlike_header *v);
inline static void set_vectorlike_marked (union vectorlike_header *v);

inline static bool cons_marked_p (const struct Lisp_Cons *c);
inline static void set_cons_marked (struct Lisp_Cons *c);

inline static bool string_marked_p (const struct Lisp_String *s);
inline static void set_string_marked (struct Lisp_String *s);

inline static bool symbol_marked_p (const struct Lisp_Symbol *s);
inline static void set_symbol_marked (struct Lisp_Symbol *s);

inline static bool interval_marked_p (INTERVAL i);
inline static void set_interval_marked (INTERVAL i);

401 402 403
/* 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.  */
404 405 406 407 408 409 410 411 412

enum mem_type
{
  MEM_TYPE_NON_LISP,
  MEM_TYPE_BUFFER,
  MEM_TYPE_CONS,
  MEM_TYPE_STRING,
  MEM_TYPE_SYMBOL,
  MEM_TYPE_FLOAT,
413 414 415
  /* 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.  */
416 417
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
418 419 420
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
421 422
};

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

Daniel Colascione's avatar
Daniel Colascione committed
426 427 428 429
#ifndef ENABLE_CHECKING
static
#endif
Lisp_Object Vdead;
430
#define DEADP(x) EQ (x, Vdead)
431

432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
#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
464 465 466 467 468 469
  /* 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;
470 471 472 473 474 475

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

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

477 478 479 480 481 482 483 484
  /* Memory type.  */
  enum mem_type type;
};

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

static struct mem_node *mem_root;

485 486 487 488
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

489 490 491 492 493
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

494 495 496 497 498 499
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 *);
500
static struct mem_node *mem_find (void *);
501

502 503 504 505
#ifndef DEADP
# define DEADP(x) 0
#endif

506
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
507
   value if we might unexec; otherwise some compilers put it into
Daniel Colascione's avatar
Daniel Colascione committed
508
   BSS.  */
509

510
Lisp_Object const *staticvec[NSTATICS]
511
#ifdef HAVE_UNEXEC
Daniel Colascione's avatar
Daniel Colascione committed
512 513 514
= {&Vpurify_flag}
#endif
  ;
515 516 517

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

Daniel Colascione's avatar
Daniel Colascione committed
518
int staticidx;
519

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

522 523 524
/* Return PTR rounded up to the next multiple of ALIGNMENT.  */

static void *
Paul Eggert's avatar
Paul Eggert committed
525
pointer_align (void *ptr, int alignment)
526 527 528
{
  return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
529

530
/* Extract the pointer hidden within O.  */
531

532
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
Paul Eggert's avatar
Paul Eggert committed
533 534
XPNTR (Lisp_Object a)
{
Paul Eggert's avatar
Paul Eggert committed
535 536 537
  return (SYMBOLP (a)
	  ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
	  : (char *) XLP (a) - (XLI (a) & ~VALMASK));
Paul Eggert's avatar
Paul Eggert committed
538 539
}

540 541 542 543 544
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
545

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

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

/* 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.  */
Daniel Colascione's avatar
Daniel Colascione committed
572
struct Lisp_Finalizer doomed_finalizers;
573

Jim Blandy's avatar
Jim Blandy committed
574

575 576 577 578
/************************************************************************
				Malloc
 ************************************************************************/

579 580
#if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)

581
/* Function malloc calls this if it finds we are near exhausting storage.  */
582 583

void
584
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
585 586 587 588
{
  pending_malloc_warning = str;
}

589
#endif
590

591
/* Display an already-pending malloc warning.  */
592

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

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

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

624 625 626 627 628 629
/* 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))

630 631 632 633 634 635
/* LISP_ALIGNMENT is the alignment of Lisp objects.  It must be at
   least GCALIGNMENT so that pointers can be tagged.  It also must be
   at least as strict as the alignment of all the C types used to
   implement Lisp objects; since pseudovectors can contain any C type,
   this is max_align_t.  On recent GNU/Linux x86 and x86-64 this can
   often waste up to 8 bytes, since alignof (max_align_t) is 16 but
Paul Eggert's avatar
Paul Eggert committed
636 637 638 639 640
   typical vectors need only an alignment of 8.  Although shrinking
   the alignment to 8 would save memory, it cost a 20% hit to Emacs
   CPU performance on Fedora 28 x86-64 when compiled with gcc -m32.  */
enum { LISP_ALIGNMENT = alignof (union { max_align_t x;
					 GCALIGNED_UNION_MEMBER }) };
641 642 643 644 645 646 647 648 649 650 651 652
verify (LISP_ALIGNMENT % GCALIGNMENT == 0);

/* True if malloc (N) is known to return storage suitably aligned for
   Lisp objects whenever N is a multiple of LISP_ALIGNMENT.  In
   practice this is true whenever alignof (max_align_t) is also a
   multiple of LISP_ALIGNMENT.  This works even for x86, where some
   platform combinations (e.g., GCC 7 and later, glibc 2.25 and
   earlier) have bugs where alignof (max_align_t) is 16 even though
   the malloc alignment is only 8, and where Emacs still works because
   it never does anything that requires an alignment of 16.  */
enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 };

653 654 655 656 657 658 659 660 661 662 663 664 665 666
/* 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)
667
    block_input ();
668 669 670 671 672
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
673
    unblock_input ();
674 675 676
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
677
#else
678 679
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
680
#endif
681

Stefan Monnier's avatar
Stefan Monnier committed
682 683 684 685 686 687
#define MALLOC_PROBE(size)			\
  do {						\
    if (profiler_memory_running)		\
      malloc_probe (size);			\
  } while (0)

688 689
static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
static void *lrealloc (void *, size_t);
Stefan Monnier's avatar
Stefan Monnier committed
690

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

Paul Eggert's avatar
Paul Eggert committed
693
void *
694
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
695
{
Paul Eggert's avatar
Paul Eggert committed
696
  void *val;
Jim Blandy's avatar
Jim Blandy committed
697

698
  MALLOC_BLOCK_INPUT;
699
  val = lmalloc (size);
700
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
701

702
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
703
    memory_full (size);
704
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
705 706 707
  return val;
}

Dmitry Antipov's avatar
Dmitry Antipov committed
708 709 710 711 712 713 714 715
/* Like the above, but zeroes out the memory just allocated.  */

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

  MALLOC_BLOCK_INPUT;
716
  val = lmalloc (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
717 718 719 720 721
  MALLOC_UNBLOCK_INPUT;

  if (!val && size)
    memory_full (size);
  memset (val, 0, size);
722
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
723 724
  return val;
}
725

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

Paul Eggert's avatar
Paul Eggert committed
728 729
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
730
{
Paul Eggert's avatar
Paul Eggert committed
731
  void *val;
Jim Blandy's avatar
Jim Blandy committed
732

733
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
734 735 736
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
737
    val = lmalloc (size);
Noah Friedman's avatar
Noah Friedman committed
738
  else
739
    val = lrealloc (block, size);
740
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
741

Paul Eggert's avatar
Paul Eggert committed
742 743
  if (!val && size)
    memory_full (size);
744
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
745 746
  return val;
}
747

748

Dave Love's avatar
Dave Love committed
749
/* Like free but block interrupt input.  */
750

751
void
Paul Eggert's avatar
Paul Eggert committed
752
xfree (void *block)
753
{
754 755
  if (!block)
    return;
Daniel Colascione's avatar
Daniel Colascione committed
756 757
  if (pdumper_object_p (block))
    return;
758
  MALLOC_BLOCK_INPUT;
759
  free (block);
760
  MALLOC_UNBLOCK_INPUT;
761
  /* We don't call refill_memory_reserve here
762
     because in practice the call in r_alloc_free seems to suffice.  */
763 764
}

765

766 767 768 769 770 771 772 773 774 775 776 777
/* 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
778
  eassert (0 <= nitems && 0 < item_size);
779 780
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
781
    memory_full (SIZE_MAX);
782
  return xmalloc (nbytes);
783 784 785 786 787 788 789 790 791
}


/* 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
792
  eassert (0 <= nitems && 0 < item_size);
793 794
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
795
    memory_full (SIZE_MAX);
796
  return xrealloc (pa, nbytes);
797 798 799 800 801 802 803 804 805 806 807 808 809 810
}


/* 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
811
   the old one.
812 813 814

   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
815 816 817 818 819 820 821
   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.  */
822 823 824 825 826

void *
xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
	 ptrdiff_t nitems_max, ptrdiff_t item_size)
{
827 828 829
  ptrdiff_t n0 = *nitems;
  eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);

830 831 832 833 834 835
  /* 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)
836 837
     DEFAULT_MXFAST bytes.  Otherwise, grow it by about 50%.
     Adjust the growth according to three constraints: NITEMS_INCR_MIN,
838 839
     NITEMS_MAX, and what the C language can represent safely.  */

840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855
  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;
    }

856 857
  if (! pa)
    *nitems = 0;
858 859 860 861
  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)))
862
    memory_full (SIZE_MAX);
863
  pa = xrealloc (pa, nbytes);
864 865 866 867 868
  *nitems = n;
  return pa;
}


869 870 871
/* Like strdup, but uses xmalloc.  */

char *
872
xstrdup (const char *s)
873
{
874
  ptrdiff_t size;
875
  eassert (s);
876 877
  size = strlen (s) + 1;
  return memcpy (xmalloc (size), s, size);
878 879
}

880 881 882 883 884 885 886 887 888
/* 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);
}

889 890 891 892 893 894 895 896 897 898 899 900 901 902
/* 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);
}


903 904 905 906 907 908 909 910 911
/* 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);
}
912

913 914 915 916 917 918
/* 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);
919
  record_unwind_protect_ptr (xfree, p);
920 921 922
  return p;
}

923

924 925
/* 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
926
   allocated memory block (for strings, for conses, ...).  */
927

928 929
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
930
#endif
931

Paul Eggert's avatar
Paul Eggert committed
932
static void *
933
lisp_malloc (size_t nbytes, enum mem_type type)
934
{
935
  register void *val;
936

937
  MALLOC_BLOCK_INPUT;
938 939 940 941

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
942

943
  val = lmalloc (nbytes);
944

945
#if ! USE_LSB_TAG
946 947 948 949 950 951 952 953 954 955 956 957 958 959
  /* 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
960
#endif
961

962
#ifndef GC_MALLOC_CHECK
963
  if (val && type != MEM_TYPE_NON_LISP)
964 965
    mem_insert (val, (char *) val + nbytes, type);
#endif
966

967
  MALLOC_UNBLOCK_INPUT;
968
  if (!val && nbytes)
Paul Eggert's avatar
Paul Eggert committed
969
    memory_full (nbytes);
970
  MALLOC_PROBE (nbytes);
971 972 973
  return val;
}

974 975 976
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

977
static void
Paul Eggert's avatar
Paul Eggert committed
978
lisp_free (void *block)
979
{
Daniel Colascione's avatar
Daniel Colascione committed
980 981 982
  if (pdumper_object_p (block))
    return;

983
  MALLOC_BLOCK_INPUT;
984
  free (block);
985
#ifndef GC_MALLOC_CHECK
986 987
  mem_delete (mem_find (block));
#endif
988
  MALLOC_UNBLOCK_INPUT;
989
}
990

991 992 993 994
/*****  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.  */
995

996 997 998 999
/* Byte alignment of storage blocks.  */
#define BLOCK_ALIGN (1 << 10)
verify (POWER_OF_2 (BLOCK_ALIGN));

1000
/* Use aligned_alloc if it or a simple substitute is available.
1001
   Aligned allocation is incompatible with unexmacosx.c, so don't use
1002
   it on Darwin if HAVE_UNEXEC.  */
1003

1004
#if ! (defined DARWIN_OS && defined HAVE_UNEXEC)
Paul Eggert's avatar
Paul Eggert committed
1005 1006 1007 1008
# if (defined HAVE_ALIGNED_ALLOC					\
      || (defined HYBRID_MALLOC						\
	  ? defined HAVE_POSIX_MEMALIGN					\
	  : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
1009
#  define USE_ALIGNED_ALLOC 1
Paul Eggert's avatar
Paul Eggert committed
1010
# elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
1011
#  define USE_ALIGNED_ALLOC 1
1012
#  define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h.  */
1013 1014 1015
static void *
aligned_alloc (size_t alignment, size_t size)
{
1016 1017 1018 1019
  /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *).
     Verify this for all arguments this function is given.  */
  verify (BLOCK_ALIGN % sizeof (void *) == 0
	  && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *)));
1020 1021 1022 1023 1024
  verify (MALLOC_IS_LISP_ALIGNED
	  || (LISP_ALIGNMENT % sizeof (void *) == 0
	      && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *))));
  eassert (alignment == BLOCK_ALIGN
	   || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT));
1025

1026 1027 1028
  void *p;
  return posix_memalign (&p, alignment, size) == 0 ? p : 0;
}
1029
# endif
1030
#endif
1031 1032 1033 1034

/* Padding to leave at the end of a malloc'd block.  This is to give
   malloc a chance to minimize the amount of memory wasted to alignment.
   It should be tuned to the particular malloc library used.
1035
   On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1036
   aligned_alloc on the other hand would ideally prefer a value of 4
1037
   because otherwise, there's 1020 bytes wasted between each ablocks.
1038 1039 1040 1041
   In Emacs, testing shows that those 1020 can most of the time be
   efficiently used by malloc to place other objects, so a value of 0 can
   still preferable unless you have a lot of aligned blocks and virtually
   nothing else.  */
1042 1043
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
1044
  (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1045 1046 1047

/* Internal data structures and constants.  */

1048 1049 1050 1051 1052 1053 1054 1055 1056 1057
#define ABLOCKS_SIZE 16

/* An aligned block of memory.  */
struct ablock
{
  union
  {
    char payload[BLOCK_BYTES];
    struct ablock *next_free;
  } x;
1058 1059 1060 1061 1062 1063 1064 1065 1066 1067

  /* ABASE is the aligned base of the ablocks.  It is overloaded to
     hold a virtual "busy" field that counts twice the number of used
     ablock values in the parent ablocks, plus one if the real base of
     the parent ablocks is ABASE (if the "busy" field is even, the
     word before the first ablock holds a pointer to the real base).
     The first ablock has a "busy" ABASE, and the others have an
     ordinary pointer ABASE.  To tell the difference, the code assumes
     that pointers, when cast to uintptr_t, are at least 2 *
     ABLOCKS_SIZE + 1.  */
1068
  struct ablocks *abase;
1069

1070 1071
  /* The padding of all but the last ablock is unused.  The padding of
     the last ablock in an ablocks is not allocated.  */
1072 1073
#if BLOCK_PADDING
  char padding[BLOCK_PADDING];
1074
#endif
1075 1076 1077 1078 1079 1080 1081 1082
};

/* A bunch of consecutive aligned blocks.  */
struct ablocks
{
  struct ablock blocks[ABLOCKS_SIZE];
};

1083
/* Size of the block requested from malloc or aligned_alloc.  */
1084
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1085 1086

#define ABLOCK_ABASE(block) \
1087
  (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE)	\
1088
   ? (struct ablocks *) (block)					\
1089 1090 1091
   : (block)->abase)

/* Virtual `busy' field.  */
1092
#define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
1093 1094

/* Pointer to the (not necessarily aligned) malloc block.  */
1095
#ifdef USE_ALIGNED_ALLOC
1096 1097
#define ABLOCKS_BASE(abase) (abase)
#else
1098
#define ABLOCKS_BASE(abase) \
1099
  (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
1100
#endif
1101 1102 1103 1104 1105 1106 1107

/* The list of free ablock.   */
static struct ablock *free_ablock;

/* Allocate an aligned block of nbytes.
   Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
   smaller or equal to BLOCK_BYTES.  */
Paul Eggert's avatar
Paul Eggert committed
1108
static void *
1109
lisp_align_malloc (size_t nbytes, enum mem_type type)
1110 1111 1112 1113 1114 1115
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

1116
  MALLOC_BLOCK_INPUT;
1117 1118 1119 1120 1121 1122 1123

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  if (!free_ablock)
    {
Dave Love's avatar
Dave Love committed
1124
      int i;
1125
      bool aligned;
1126 1127

#ifdef DOUG_LEA_MALLOC
1128 1129
      if (!mmap_lisp_allowed_p ())
        mallopt (M_MMAP_MAX, 0);
1130 1131
#endif

1132
#ifdef USE_ALIGNED_ALLOC
1133
      verify (ABLOCKS_BYTES % BLOCK_ALIGN == 0);
1134
      abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES);
1135
#else
1136
      base = malloc (ABLOCKS_BYTES);
Paul Eggert's avatar
Paul Eggert committed
1137
      abase = pointer_align (base, BLOCK_ALIGN);
1138 1139
#endif

Kenichi Handa's avatar
Kenichi Handa committed
1140 1141
      if (base == 0)
	{
1142
	  MALLOC_UNBLOCK_INPUT;
Paul Eggert's avatar
Paul Eggert committed
1143
	  memory_full (ABLOCKS_BYTES);
Kenichi Handa's avatar
Kenichi Handa committed
1144
	}
1145 1146 1147

      aligned = (base == abase);
      if (!aligned)
1148
	((void **) abase)[-1] = base;
1149 1150

#ifdef DOUG_LEA_MALLOC
Daniel Colascione's avatar