alloc.c 209 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-2020 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>
Paul Eggert's avatar
Paul Eggert committed
25
#include <stdlib.h>
26
#include <limits.h>		/* For CHAR_BIT.  */
27
#include <signal.h>		/* For SIGABRT, SIGDANGER.  */
28

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

Jim Blandy's avatar
Jim Blandy committed
33
#include "lisp.h"
Paul Eggert's avatar
Paul Eggert committed
34
#include "bignum.h"
35
#include "dispextern.h"
36
#include "intervals.h"
37
#include "ptr-bounds.h"
Jim Blandy's avatar
Jim Blandy committed
38
#include "puresize.h"
39
#include "sheap.h"
40
#include "sysstdio.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 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when
   allocating a block of memory with size close to N bytes.
   For best results N should be a power of 2.

   When calculating how much memory to allocate, GNU malloc (SIZE)
   adds sizeof (size_t) to SIZE for internal overhead, and then rounds
   up to a multiple of MALLOC_ALIGNMENT.  Emacs can improve
   performance a bit on GNU platforms by arranging for the resulting
   size to be a power of two.  This heuristic is good for glibc 2.0
   (1997) through at least glibc 2.31 (2020), and does not affect
   correctness on other platforms.  */

#define MALLOC_SIZE_NEAR(n) \
  (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t))
#ifdef __i386
enum { MALLOC_ALIGNMENT = 16 };
#else
enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) };
#endif

127
#ifdef DOUG_LEA_MALLOC
128 129 130 131

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

132
# define MMAP_MAX_AREAS 100000000
133

Paul Eggert's avatar
Paul Eggert committed
134 135 136 137 138 139 140 141 142 143 144 145 146 147
/* 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)
    {
148
# ifdef GNU_LINUX
Paul Eggert's avatar
Paul Eggert committed
149
      my_heap_start ();
150
# endif
Paul Eggert's avatar
Paul Eggert committed
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
      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;
		}
	}

173 174
      if (malloc_set_state (malloc_state_ptr) != 0)
	emacs_abort ();
Paul Eggert's avatar
Paul Eggert committed
175 176 177 178
      alloc_unexec_post ();
    }
}

179 180
/* Declare the malloc initialization hook, which runs before 'main' starts.
   EXTERNALLY_VISIBLE works around Bug#22522.  */
Paul Eggert's avatar
Paul Eggert committed
181
typedef void (*voidfuncptr) (void);
Paul Eggert's avatar
Paul Eggert committed
182 183 184
# ifndef __MALLOC_HOOK_VOLATILE
#  define __MALLOC_HOOK_VOLATILE
# endif
185
voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
Paul Eggert's avatar
Paul Eggert committed
186 187 188
  = malloc_initialize_hook;

#endif
189

190
#if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC
191

192 193 194 195 196
/* Allocator-related actions to do just before and after unexec.  */

void
alloc_unexec_pre (void)
{
197
# ifdef DOUG_LEA_MALLOC
198
  malloc_state_ptr = malloc_get_state ();
199 200
  if (!malloc_state_ptr)
    fatal ("malloc_get_state: %s", strerror (errno));
201
# endif
202 203 204 205 206
}

void
alloc_unexec_post (void)
{
207
# ifdef DOUG_LEA_MALLOC
208
  free (malloc_state_ptr);
209
# endif
210
}
211 212 213 214 215 216 217 218 219 220 221 222 223 224

# 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

225
#endif
226

227 228 229
/* 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
230 231 232
#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)
233

Daniel Colascione's avatar
Daniel Colascione committed
234 235 236
#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)
237

238 239
/* Default value of gc_cons_threshold (see below).  */

240
#define GC_DEFAULT_THRESHOLD (100000 * word_size)
241

242 243 244
/* Global variables.  */
struct emacs_globals globals;

245
/* maybe_gc collects garbage if this goes negative.  */
246

247
EMACS_INT consing_until_gc;
248

Daniel Colascione's avatar
Daniel Colascione committed
249 250 251 252 253 254
#ifdef HAVE_PDUMPER
/* Number of finalizers run: used to loop over GC until we stop
   generating garbage.  */
int number_finalizers_run;
#endif

255
/* True during GC.  */
256

257
bool gc_in_progress;
Jim Blandy's avatar
Jim Blandy committed
258

259
/* System byte and object counts reported by GC.  */
260

261 262
/* Assume byte counts fit in uintptr_t and object counts fit into
   intptr_t.  */
263
typedef uintptr_t byte_ct;
264
typedef intptr_t object_ct;
265

266 267 268 269 270
/* Large-magnitude value for a threshold count, which fits in EMACS_INT.
   Using only half the EMACS_INT range avoids overflow hassles.
   There is no need to fit these counts into fixnums.  */
#define HI_THRESHOLD (EMACS_INT_MAX / 2)

271
/* Number of live and free conses etc. counted by the most-recent GC.  */
272

273
static struct gcstat
274 275 276 277 278 279 280 281 282 283
{
  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;
284

285
/* Points to memory space allocated as "spare", to be freed if we run
286 287
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
288

289
static char *spare_memory[7];
290

291 292
/* 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.  */
293

294
#define SPARE_MEMORY (1 << 14)
295

Richard M. Stallman's avatar
Richard M. Stallman committed
296 297 298 299 300
/* 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.  */
301

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

305
/* Pointer to the pure area, and its size.  */
306

307
static char *purebeg;
308
static ptrdiff_t pure_size;
309 310 311 312

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

313
static ptrdiff_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
314

315
/* Index in pure at which next pure Lisp object will be allocated..  */
316

317
static ptrdiff_t pure_bytes_used_lisp;
318 319 320

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

321
static ptrdiff_t pure_bytes_used_non_lisp;
322

323 324 325 326
/* If positive, garbage collection is inhibited.  Otherwise, zero.  */

static intptr_t garbage_collection_inhibited;

327 328
/* The GC threshold in bytes, the last time it was calculated
   from gc-cons-threshold and gc-cons-percentage.  */
329
static EMACS_INT gc_threshold;
330

331 332 333
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

334
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
335

Paul Eggert's avatar
Paul Eggert committed
336 337
/* Pointer sanity only on request.  FIXME: Code depending on
   SUSPICIOUS_OBJECT_CHECKING is obsolete; remove it entirely.  */
338 339 340 341 342
#ifdef ENABLE_CHECKING
#define SUSPICIOUS_OBJECT_CHECKING 1
#endif

#ifdef SUSPICIOUS_OBJECT_CHECKING
343 344
struct suspicious_free_record
{
345 346
  void *suspicious_object;
  void *backtrace[128];
347
};
348
static void *suspicious_objects[32];
349
static int suspicious_object_index;
350
struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
351 352 353
static int suspicious_free_history_index;
/* Find the first currently-monitored suspicious pointer in range
   [begin,end) or NULL if no such pointer exists.  */
354 355
static void *find_suspicious_object_in_range (void *begin, void *end);
static void detect_suspicious_free (void *ptr);
356
#else
Paul Eggert's avatar
Paul Eggert committed
357 358
# define find_suspicious_object_in_range(begin, end) ((void *) NULL)
# define detect_suspicious_free(ptr) ((void) 0)
359 360
#endif

Jim Blandy's avatar
Jim Blandy committed
361 362 363 364 365 366 367 368
/* 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.  */

369
#if MAX_SAVE_STACK > 0
370
static char *stack_copy;
371
static ptrdiff_t stack_copy_size;
372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392

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

394
static void unchain_finalizer (struct Lisp_Finalizer *);
395 396
static void mark_terminals (void);
static void gc_sweep (void);
397
static Lisp_Object make_pure_vector (ptrdiff_t);
398
static void mark_buffer (struct buffer *);
399

400
#if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
401 402
static void refill_memory_reserve (void);
#endif
403 404
static void compact_small_strings (void);
static void free_large_strings (void);
405
extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
406

Daniel Colascione's avatar
Daniel Colascione committed
407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
/* 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);

428 429 430
/* 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.  */
431 432 433 434 435 436 437 438 439

enum mem_type
{
  MEM_TYPE_NON_LISP,
  MEM_TYPE_BUFFER,
  MEM_TYPE_CONS,
  MEM_TYPE_STRING,
  MEM_TYPE_SYMBOL,
  MEM_TYPE_FLOAT,
440 441 442
  /* 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.  */
443 444
  MEM_TYPE_VECTORLIKE,
  /* Special type to denote vector blocks.  */
445 446 447
  MEM_TYPE_VECTOR_BLOCK,
  /* Special type to denote reserved memory.  */
  MEM_TYPE_SPARE
448 449
};

450 451 452 453 454
static bool
deadp (Lisp_Object x)
{
  return EQ (x, dead_object ());
}
455

456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487
#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
488 489 490 491 492 493
  /* 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;
494 495 496 497 498 499

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

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

501 502 503 504 505 506 507 508
  /* Memory type.  */
  enum mem_type type;
};

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

static struct mem_node *mem_root;

509 510 511 512
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

513 514 515 516 517
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

518 519 520 521 522 523
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 *);
524
static struct mem_node *mem_find (void *);
525

526
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
527
   value if we might unexec; otherwise some compilers put it into
Daniel Colascione's avatar
Daniel Colascione committed
528
   BSS.  */
529

530
Lisp_Object const *staticvec[NSTATICS]
531
#ifdef HAVE_UNEXEC
Daniel Colascione's avatar
Daniel Colascione committed
532 533 534
= {&Vpurify_flag}
#endif
  ;
535 536 537

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

Daniel Colascione's avatar
Daniel Colascione committed
538
int staticidx;
539

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

542 543 544
/* Return PTR rounded up to the next multiple of ALIGNMENT.  */

static void *
Paul Eggert's avatar
Paul Eggert committed
545
pointer_align (void *ptr, int alignment)
546 547 548
{
  return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
549

550
/* Extract the pointer hidden within O.  */
551

552
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
Paul Eggert's avatar
Paul Eggert committed
553 554
XPNTR (Lisp_Object a)
{
Paul Eggert's avatar
Paul Eggert committed
555 556 557
  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
558 559
}

560 561 562 563 564
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
  XFLOAT (f)->u.data = n;
}
565

566 567 568 569 570 571 572 573 574
/* Account for allocation of NBYTES in the heap.  This is a separate
   function to avoid hassles with implementation-defined conversion
   from unsigned to signed types.  */
static void
tally_consing (ptrdiff_t nbytes)
{
  consing_until_gc -= nbytes;
}

575
#ifdef DOUG_LEA_MALLOC
576 577 578 579 580 581 582 583 584 585 586 587
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
588
     if we might dump: unexec doesn't preserve the contents of mmapped
589
     regions.  */
Daniel Colascione's avatar
Daniel Colascione committed
590
  return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p ();
591
}
592
#endif
593

594
/* Head of a circularly-linked list of extant finalizers. */
Daniel Colascione's avatar
Daniel Colascione committed
595
struct Lisp_Finalizer finalizers;
596 597 598

/* Head of a circularly-linked list of finalizers that must be invoked
   because we deemed them unreachable.  This list must be global, and
599
   not a local inside garbage_collect, in case we GC again while
600
   running finalizers.  */
Daniel Colascione's avatar
Daniel Colascione committed
601
struct Lisp_Finalizer doomed_finalizers;
602

Jim Blandy's avatar
Jim Blandy committed
603

604 605 606 607
/************************************************************************
				Malloc
 ************************************************************************/

608 609
#if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)

610
/* Function malloc calls this if it finds we are near exhausting storage.  */
611 612

void
613
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
614 615 616 617
{
  pending_malloc_warning = str;
}

618
#endif
619

620
/* Display an already-pending malloc warning.  */
621

622
void
623
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
624
{
625 626 627 628
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
629 630
  pending_malloc_warning = 0;
}
631

632 633 634
/* Called if we can't allocate relocatable space for a buffer.  */

void
635
buffer_memory_full (ptrdiff_t nbytes)
636
{
637 638 639 640 641 642
  /* 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.  */
643 644

#ifndef REL_ALLOC
Paul Eggert's avatar
Paul Eggert committed
645
  memory_full (nbytes);
Paul Eggert's avatar
Paul Eggert committed
646
#else
647 648
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
649
  xsignal (Qnil, Vmemory_signal_data);
Paul Eggert's avatar
Paul Eggert committed
650
#endif
Jim Blandy's avatar
Jim Blandy committed
651 652
}

653 654 655 656 657 658
/* 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))

659 660 661 662 663 664
/* 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
665 666 667 668 669
   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 }) };
670 671 672 673 674 675 676 677 678 679 680 681
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 };

682 683 684 685 686 687 688 689 690 691 692 693 694 695
/* 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)
696
    block_input ();
697 698 699 700 701
}
static void
malloc_unblock_input (void)
{
  if (block_input_in_memory_allocators)
702
    unblock_input ();
703 704 705
}
# define MALLOC_BLOCK_INPUT malloc_block_input ()
# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
706
#else
707 708
# define MALLOC_BLOCK_INPUT ((void) 0)
# define MALLOC_UNBLOCK_INPUT ((void) 0)
709
#endif
710

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

717
static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1));
718
static void *lrealloc (void *, size_t);
Stefan Monnier's avatar
Stefan Monnier committed
719

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

Paul Eggert's avatar
Paul Eggert committed
722
void *
723
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
724
{
Paul Eggert's avatar
Paul Eggert committed
725
  void *val;
Jim Blandy's avatar
Jim Blandy committed
726

727
  MALLOC_BLOCK_INPUT;
728
  val = lmalloc (size, false);
729
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
730

731
  if (!val && size)
Paul Eggert's avatar
Paul Eggert committed
732
    memory_full (size);
733
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
734 735 736
  return val;
}

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

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

  MALLOC_BLOCK_INPUT;
745
  val = lmalloc (size, true);
Dmitry Antipov's avatar
Dmitry Antipov committed
746 747 748 749
  MALLOC_UNBLOCK_INPUT;

  if (!val && size)
    memory_full (size);
750
  MALLOC_PROBE (size);
Dmitry Antipov's avatar
Dmitry Antipov committed
751 752
  return val;
}
753

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

Paul Eggert's avatar
Paul Eggert committed
756 757
void *
xrealloc (void *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
758
{
Paul Eggert's avatar
Paul Eggert committed
759
  void *val;
Jim Blandy's avatar
Jim Blandy committed
760

761
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
762 763 764
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
765
    val = lmalloc (size, false);
Noah Friedman's avatar
Noah Friedman committed
766
  else
767
    val = lrealloc (block, size);
768
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
769

Paul Eggert's avatar
Paul Eggert committed
770 771
  if (!val && size)
    memory_full (size);
772
  MALLOC_PROBE (size);
Jim Blandy's avatar
Jim Blandy committed
773 774
  return val;
}
775

776

Dave Love's avatar
Dave Love committed
777
/* Like free but block interrupt input.  */
778

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

793

794 795 796 797 798 799 800 801 802 803 804 805
/* 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
806
  eassert (0 <= nitems && 0 < item_size);
807 808
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
809
    memory_full (SIZE_MAX);
810
  return xmalloc (nbytes);
811 812 813 814 815 816 817 818 819
}


/* 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
820
  eassert (0 <= nitems && 0 < item_size);
821 822
  ptrdiff_t nbytes;
  if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
823
    memory_full (SIZE_MAX);
824
  return xrealloc (pa, nbytes);
825 826 827 828 829 830 831 832 833 834 835 836 837 838
}


/* 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
839
   the old one.
840 841 842

   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
843 844 845 846 847 848 849
   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.  */
850 851 852 853 854

void *
xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
	 ptrdiff_t nitems_max, ptrdiff_t item_size)
{
855 856 857
  ptrdiff_t n0 = *nitems;
  eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);

858 859 860 861 862 863
  /* 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)
864 865
     DEFAULT_MXFAST bytes.  Otherwise, grow it by about 50%.
     Adjust the growth according to three constraints: NITEMS_INCR_MIN,
866 867
     NITEMS_MAX, and what the C language can represent safely.  */

868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883
  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;
    }

884 885
  if (! pa)
    *nitems = 0;
886 887 888 889
  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)))
890
    memory_full (SIZE_MAX);
891
  pa = xrealloc (pa, nbytes);
892 893 894 895 896
  *nitems = n;
  return pa;
}


897 898 899
/* Like strdup, but uses xmalloc.  */

char *
900
xstrdup (const char *s)
901
{
902
  ptrdiff_t size;
903
  eassert (s);
904 905
  size = strlen (s) + 1;
  return memcpy (xmalloc (size), s, size);
906 907
}

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

917 918 919 920 921 922 923 924 925 926 927 928 929 930
/* 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);
}


931 932 933 934 935 936 937 938 939
/* 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);
}
940

941 942 943 944 945 946
/* 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);
947
  record_unwind_protect_ptr (xfree, p);
948 949 950
  return p;
}

951

952 953
/* 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
954
   allocated memory block (for strings, for conses, ...).  */
955

956 957
#if ! USE_LSB_TAG
void *lisp_malloc_loser EXTERNALLY_VISIBLE;
958
#endif
959

Paul Eggert's avatar
Paul Eggert committed
960
static void *
961
lisp_malloc (size_t nbytes, bool clearit, enum mem_type type)
962
{
963
  register void *val;
964

965
  MALLOC_BLOCK_INPUT;
966 967 968 969

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
970

971
  val = lmalloc (nbytes, clearit);
972

973
#if ! USE_LSB_TAG
974 975 976 977 978 979 980 981 982 983 984 985 986 987
  /* 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
988
#endif
989

990
#ifndef GC_MALLOC_CHECK
991
  if (val && type != MEM_TYPE_NON_LISP)
992 993
    mem_insert (val, (char *) val + nbytes, type);
#endif
994

995
  MALLOC_UNBLOCK_INPUT;
996
  if (!val && nbytes)
Paul Eggert's avatar
Paul Eggert committed
997
    memory_full (nbytes);
998
  MALLOC_PROBE (nbytes);
999 1000 1001
  return val;
}

1002 1003 1004
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

1005
static void
Paul Eggert's avatar
Paul Eggert committed
1006
lisp_free (void *block)
1007
{
Daniel Colascione's avatar
Daniel Colascione committed
1008 1009 1010
  if (pdumper_object_p (block))
    return;

1011
  MALLOC_BLOCK_INPUT;
1012
  free (block);
1013
#ifndef GC_MALLOC_CHECK
1014 1015
  mem_delete (mem_find (block));
#endif
1016
  MALLOC_UNBLOCK_INPUT;
1017
}
1018

1019 1020 1021 1022
/*****  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.  */
1023

1024 1025 1026 1027
/* Byte alignment of storage blocks.  */
#define BLOCK_ALIGN (1 << 10)
verify (POWER_OF_2 (BLOCK_ALIGN));

1028
/* Use aligned_alloc if it or a simple substitute is available.
1029
   Aligned allocation is incompatible with unexmacosx.c, so don't use
1030
   it on Darwin if HAVE_UNEXEC.  */
1031

1032
#if ! (defined DARWIN_OS && defined HAVE_UNEXEC)
Paul Eggert's avatar
Paul Eggert committed
1033 1034 1035 1036
# if (defined HAVE_ALIGNED_ALLOC					\
      || (defined HYBRID_MALLOC						\
	  ? defined HAVE_POSIX_MEMALIGN					\
	  : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
1037
#  define USE_ALIGNED_ALLOC 1
Paul Eggert's avatar
Paul Eggert committed
1038
# elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
1039
#  define USE_ALIGNED_ALLOC 1
1040
#  define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h.  */
1041 1042 1043
static void *
aligned_alloc (size_t alignment, size_t size)
{
1044 1045 1046 1047
  /* 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 *)));
1048 1049 1050 1051 1052
  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));
1053

1054 1055 1056
  void *p;
  return posix_memalign (&p, alignment, size) == 0 ? p : 0;
}
1057
# endif
1058
#endif
1059 1060 1061 1062

/* 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.
1063
   On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1064
   aligned_alloc on the other hand would ideally prefer a value of 4
1065
   because otherwise, there's 1020 bytes wasted between each ablocks.
1066 1067 1068 1069
   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.  */
1070 1071
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
1072
  (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1073 1074 1075

/* Internal data structures and constants.  */

1076 1077 1078 1079 1080 1081 1082 1083 1084 1085
#define ABLOCKS_SIZE 16

/* An aligned block of memory.  */
struct ablock
{
  union
  {
    char payload[BLOCK_BYTES];
    struct ablock *next_free;
  } x;
1086 1087 1088 1089 1090 1091 1092 1093 1094 1095

  /* 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.  */
1096
  struct ablocks *abase;
1097

1098 1099
  /* The padding of all but the last ablock is unused.  The padding of
     the last ablock in an ablocks is not allocated.  */
1100 1101
#if BLOCK_PADDING
  char padding[BLOCK_PADDING];
1102
#endif
1103 1104 1105 1106 1107 1108 1109 1110
};

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

1111
/* Size of the block requested from malloc or aligned_alloc.  */
1112
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1113 1114

#define ABLOCK_ABASE(block) \
1115
  (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE)	\
1116
   ? (struct ablocks *) (block)					\
1117 1118 1119
   : (block)->abase)

/* Virtual `busy' field.  */
1120
#define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
1121 1122

/* Pointer to the (not necessarily aligned) malloc block.  */
1123
#ifdef USE_ALIGNED_ALLOC
1124 1125
#define ABLOCKS_BASE(abase) (abase)
#else
1126
#define ABLOCKS_BASE(abase) \
1127
  (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
1128
#endif
1129 1130 1131 1132 1133 1134 1135

/* 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
1136
static void *
1137
lisp_align_malloc (size_t nbytes, enum mem_type type)
1138 1139 1140 1141 1142 1143
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

1144
  MALLOC_BLOCK_INPUT;
1145 1146 1147 1148 1149 1150 1151

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  if (!free_ablock)
    {
Dave Love's avatar
Dave Love committed
1152
      int i;
1153
      bool aligned;
1154 1155

#ifdef DOUG_LEA_MALLOC
1156 1157
      if (!mmap_lisp_allowed_p ())
        mallopt (M_MMAP_MAX, 0);
1158 1159
#endif

1160
#ifdef USE_ALIGNED_ALLOC
1161
      verify (ABLOCKS_BYTES % BLOCK_ALIGN == 0);