alloc.c 161 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2
   Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
Glenn Morris's avatar
Glenn Morris committed
3
      Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
4 5 6

This file is part of GNU Emacs.

7
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
8
it under the terms of the GNU General Public License as published by
9 10
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
11 12 13 14 15 16 17

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
18
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
19

20
#include <config.h>
21
#include <stdio.h>
22
#include <limits.h>		/* For CHAR_BIT.  */
23
#include <setjmp.h>
24

25 26 27 28
#ifdef ALLOC_DEBUG
#undef INLINE
#endif

29
#include <signal.h>
30

31 32 33 34
#ifdef HAVE_GTK_AND_PTHREAD
#include <pthread.h>
#endif

35 36 37
/* This file is part of the core Lisp implementation, and thus must
   deal with the real data structures.  If the Lisp implementation is
   replaced, this file likely will not be used.  */
38

39
#undef HIDE_LISP_IMPLEMENTATION
Jim Blandy's avatar
Jim Blandy committed
40
#include "lisp.h"
41
#include "process.h"
42
#include "intervals.h"
Jim Blandy's avatar
Jim Blandy committed
43
#include "puresize.h"
Jim Blandy's avatar
Jim Blandy committed
44 45
#include "buffer.h"
#include "window.h"
46
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
47
#include "frame.h"
48
#include "blockinput.h"
49
#include "character.h"
Jim Blandy's avatar
Jim Blandy committed
50
#include "syssignal.h"
51
#include "termhooks.h"		/* For struct terminal.  */
52
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
53

Kenichi Handa's avatar
Kenichi Handa committed
54 55 56 57 58 59 60
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
   memory.  Can do this only if using gmalloc.c.  */

#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
#undef GC_MALLOC_CHECK
#endif

61
#include <unistd.h>
Paul Eggert's avatar
Paul Eggert committed
62
#ifndef HAVE_UNISTD_H
63 64
extern POINTER_TYPE *sbrk ();
#endif
Karl Heuer's avatar
Karl Heuer committed
65

66 67
#include <fcntl.h>

68
#ifdef WINDOWSNT
Eli Zaretskii's avatar
Eli Zaretskii committed
69
#include "w32.h"
70 71
#endif

72
#ifdef DOUG_LEA_MALLOC
73

74
#include <malloc.h>
75 76
/* malloc.h #defines this as size_t, at least in glibc2.  */
#ifndef __malloc_size_t
77
#define __malloc_size_t int
78
#endif
79

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

83 84
#define MMAP_MAX_AREAS 100000000

85 86
#else /* not DOUG_LEA_MALLOC */

87 88 89 90
/* The following come from gmalloc.c.  */

#define	__malloc_size_t		size_t
extern __malloc_size_t _bytes_used;
91
extern __malloc_size_t __malloc_extra_blocks;
92 93

#endif /* not DOUG_LEA_MALLOC */
94

95 96
#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
#ifdef HAVE_GTK_AND_PTHREAD
97

98 99 100 101 102 103 104 105
/* When GTK uses the file chooser dialog, different backends can be loaded
   dynamically.  One such a backend is the Gnome VFS backend that gets loaded
   if you run Gnome.  That backend creates several threads and also allocates
   memory with malloc.

   If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
   functions below are called from malloc, there is a chance that one
   of these threads preempts the Emacs main thread and the hook variables
106
   end up in an inconsistent state.  So we have a mutex to prevent that (note
107 108 109
   that the backend handles concurrent access to malloc within its own threads
   but Emacs code running in the main thread is not included in that control).

110
   When UNBLOCK_INPUT is called, reinvoke_input_signal may be called.  If this
111 112 113 114
   happens in one of the backend threads we will have two threads that tries
   to run Emacs code at once, and the code is not prepared for that.
   To prevent that, we only call BLOCK/UNBLOCK from the main thread.  */

115 116
static pthread_mutex_t alloc_mutex;

117 118 119 120
#define BLOCK_INPUT_ALLOC                               \
  do                                                    \
    {                                                   \
      if (pthread_equal (pthread_self (), main_thread)) \
121
        BLOCK_INPUT;					\
122 123
      pthread_mutex_lock (&alloc_mutex);                \
    }                                                   \
124
  while (0)
125 126 127 128 129
#define UNBLOCK_INPUT_ALLOC                             \
  do                                                    \
    {                                                   \
      pthread_mutex_unlock (&alloc_mutex);              \
      if (pthread_equal (pthread_self (), main_thread)) \
130
        UNBLOCK_INPUT;					\
131
    }                                                   \
132 133
  while (0)

134
#else /* ! defined HAVE_GTK_AND_PTHREAD */
135 136 137 138

#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT

139 140
#endif /* ! defined HAVE_GTK_AND_PTHREAD */
#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
141

142
/* Value of _bytes_used, when spare_memory was freed.  */
143

144 145
static __malloc_size_t bytes_used_when_full;

146 147 148
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

149 150
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
151
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
152

153 154
#define VECTOR_MARK(V)		((V)->size |= ARRAY_MARK_FLAG)
#define VECTOR_UNMARK(V)	((V)->size &= ~ARRAY_MARK_FLAG)
155
#define VECTOR_MARKED_P(V)	(((V)->size & ARRAY_MARK_FLAG) != 0)
156

157 158
/* Value is the number of bytes of S, a pointer to a struct Lisp_String.
   Be careful during GC, because S->size contains the mark bit for
159 160
   strings.  */

161
#define GC_STRING_BYTES(S)	(STRING_BYTES (S))
162

163 164 165
/* Global variables.  */
struct emacs_globals globals;

166 167
/* Number of bytes of consing done since the last gc.  */

Jim Blandy's avatar
Jim Blandy committed
168 169
int consing_since_gc;

170 171 172
/* Similar minimum, computed from Vgc_cons_percentage.  */

EMACS_INT gc_relative_threshold;
173

174 175 176 177 178
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

EMACS_INT memory_full_cons_threshold;

179 180
/* Nonzero during GC.  */

Jim Blandy's avatar
Jim Blandy committed
181 182
int gc_in_progress;

183 184 185 186 187 188
/* Nonzero means abort if try to GC.
   This is for code which is written on the assumption that
   no GC will happen, so as to verify that assumption.  */

int abort_on_gc;

189 190 191 192 193
/* Number of live and free conses etc.  */

static int total_conses, total_markers, total_symbols, total_vector_size;
static int total_free_conses, total_free_markers, total_free_symbols;
static int total_free_floats, total_floats;
194

195
/* Points to memory space allocated as "spare", to be freed if we run
196 197
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
198

199
static char *spare_memory[7];
200

201
/* Amount of spare memory to keep in large reserve block.  */
202

203 204 205
#define SPARE_MEMORY (1 << 14)

/* Number of extra blocks malloc should get when it needs more core.  */
206

207 208
static int malloc_hysteresis;

Richard M. Stallman's avatar
Richard M. Stallman committed
209 210 211 212 213
/* 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.  */
214

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

218
/* Pointer to the pure area, and its size.  */
219

220 221 222 223 224 225 226
static char *purebeg;
static size_t pure_size;

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

static size_t pure_bytes_used_before_overflow;
Jim Blandy's avatar
Jim Blandy committed
227

228 229 230 231
/* Value is non-zero if P points into pure space.  */

#define PURE_POINTER_P(P)					\
     (((PNTR_COMPARISON_TYPE) (P)				\
232
       < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size))	\
233
      && ((PNTR_COMPARISON_TYPE) (P)				\
234
	  >= (PNTR_COMPARISON_TYPE) purebeg))
235

236 237 238 239 240 241 242 243
/* Index in pure at which next pure Lisp object will be allocated.. */

static EMACS_INT pure_bytes_used_lisp;

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

static EMACS_INT pure_bytes_used_non_lisp;

244 245 246
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

247
const char *pending_malloc_warning;
Jim Blandy's avatar
Jim Blandy committed
248 249 250 251 252 253 254 255 256

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

257 258
static char *stack_copy;
static int stack_copy_size;
Jim Blandy's avatar
Jim Blandy committed
259

260 261 262
/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

263
static int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
264

265
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
266

267 268
/* Hook run after GC has finished.  */

269
Lisp_Object Qpost_gc_hook;
270

271 272 273 274 275
static void mark_buffer (Lisp_Object);
static void mark_terminals (void);
static void gc_sweep (void);
static void mark_glyph_matrix (struct glyph_matrix *);
static void mark_face_cache (struct face_cache *);
276

277 278 279 280
static struct Lisp_String *allocate_string (void);
static void compact_small_strings (void);
static void free_large_strings (void);
static void sweep_strings (void);
Richard M. Stallman's avatar
Richard M. Stallman committed
281 282

extern int message_enable_multibyte;
283 284 285 286 287 288 289 290 291 292 293 294 295 296

/* When scanning the C stack for live Lisp objects, Emacs keeps track
   of what memory allocated via lisp_malloc is intended for what
   purpose.  This enumeration specifies the type of memory.  */

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,
297 298 299 300 301
  /* We used to keep separate mem_types for subtypes of vectors such as
     process, hash_table, frame, terminal, and window, but we never made
     use of the distinction, so it only caused source-code complexity
     and runtime slowdown.  Minor but pointless.  */
  MEM_TYPE_VECTORLIKE
302 303
};

304 305
static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
306

307

308
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
309 310 311 312 313 314 315 316

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
#include <stdio.h>		/* For fprintf.  */
#endif

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

317
static Lisp_Object Vdead;
318

319 320 321
#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
322
static int dont_register_blocks;
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351

#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
352 353 354 355 356 357
  /* 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;
358 359 360 361 362 363

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

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

365 366 367 368 369 370 371 372 373 374 375 376
  /* 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;

377 378 379 380
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

381 382 383 384 385
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
static struct Lisp_Vector *allocate_vectorlike (EMACS_INT);
static void lisp_free (POINTER_TYPE *);
static void mark_stack (void);
static int live_vector_p (struct mem_node *, void *);
static int live_buffer_p (struct mem_node *, void *);
static int live_string_p (struct mem_node *, void *);
static int live_cons_p (struct mem_node *, void *);
static int live_symbol_p (struct mem_node *, void *);
static int live_float_p (struct mem_node *, void *);
static int live_misc_p (struct mem_node *, void *);
static void mark_maybe_object (Lisp_Object);
static void mark_memory (void *, void *, int);
static void mem_init (void);
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 *);
static INLINE struct mem_node *mem_find (void *);
406 407 408


#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
409
static void check_gcpros (void);
410 411
#endif

412
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
413

414 415 416 417
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

418 419
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
420

Eli Zaretskii's avatar
Eli Zaretskii committed
421
#define NSTATICS 0x640
422
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
423 424 425

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

426
static int staticidx = 0;
427

428
static POINTER_TYPE *pure_alloc (size_t, int);
429 430 431 432 433


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

434 435 436
#define ALIGN(ptr, ALIGNMENT) \
  ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
		     & ~((ALIGNMENT) - 1)))
437

438

Jim Blandy's avatar
Jim Blandy committed
439

440 441 442 443
/************************************************************************
				Malloc
 ************************************************************************/

444
/* Function malloc calls this if it finds we are near exhausting storage.  */
445 446

void
447
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
448 449 450 451
{
  pending_malloc_warning = str;
}

452

453
/* Display an already-pending malloc warning.  */
454

455
void
456
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
457
{
458 459 460 461
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
462 463 464
  pending_malloc_warning = 0;
}

465

466
#ifdef DOUG_LEA_MALLOC
467
#  define BYTES_USED (mallinfo ().uordblks)
468
#else
469
#  define BYTES_USED _bytes_used
470
#endif
471

472 473 474
/* Called if we can't allocate relocatable space for a buffer.  */

void
475
buffer_memory_full (void)
476
{
477 478 479 480 481 482
  /* 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.  */
483 484 485 486 487

#ifndef REL_ALLOC
  memory_full ();
#endif

488 489
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
490
  xsignal (Qnil, Vmemory_signal_data);
Jim Blandy's avatar
Jim Blandy committed
491 492
}

493

494 495
#ifdef XMALLOC_OVERRUN_CHECK

Kim F. Storm's avatar
Kim F. Storm committed
496 497 498 499 500 501 502 503 504 505 506 507
/* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
   and a 16 byte trailer around each block.

   The header consists of 12 fixed bytes + a 4 byte integer contaning the
   original block size, while the trailer consists of 16 fixed bytes.

   The header is used to detect whether this block has been allocated
   through these functions -- as it seems that some low-level libc
   functions may bypass the malloc hooks.
*/


508
#define XMALLOC_OVERRUN_CHECK_SIZE 16
Kim F. Storm's avatar
Kim F. Storm committed
509

510 511 512 513 514 515 516 517 518 519 520
static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
  { 0x9a, 0x9b, 0xae, 0xaf,
    0xbf, 0xbe, 0xce, 0xcf,
    0xea, 0xeb, 0xec, 0xed };

static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
  { 0xaa, 0xab, 0xac, 0xad,
    0xba, 0xbb, 0xbc, 0xbd,
    0xca, 0xcb, 0xcc, 0xcd,
    0xda, 0xdb, 0xdc, 0xdd };

Kim F. Storm's avatar
Kim F. Storm committed
521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
/* Macros to insert and extract the block size in the header.  */

#define XMALLOC_PUT_SIZE(ptr, size)	\
  (ptr[-1] = (size & 0xff),		\
   ptr[-2] = ((size >> 8) & 0xff),	\
   ptr[-3] = ((size >> 16) & 0xff),	\
   ptr[-4] = ((size >> 24) & 0xff))

#define XMALLOC_GET_SIZE(ptr)			\
  (size_t)((unsigned)(ptr[-1])		|	\
	   ((unsigned)(ptr[-2]) << 8)	|	\
	   ((unsigned)(ptr[-3]) << 16)	|	\
	   ((unsigned)(ptr[-4]) << 24))


Jan Djärv's avatar
Jan Djärv committed
536 537 538 539 540 541 542 543 544
/* The call depth in overrun_check functions.  For example, this might happen:
   xmalloc()
     overrun_check_malloc()
       -> malloc -> (via hook)_-> emacs_blocked_malloc
          -> overrun_check_malloc
             call malloc  (hooks are NULL, so real malloc is called).
             malloc returns 10000.
             add overhead, return 10016.
      <- (back in overrun_check_malloc)
545
      add overhead again, return 10032
Jan Djärv's avatar
Jan Djärv committed
546
   xmalloc returns 10032.
547 548 549

   (time passes).

Jan Djärv's avatar
Jan Djärv committed
550 551 552 553
   xfree(10032)
     overrun_check_free(10032)
       decrease overhed
       free(10016)  <-  crash, because 10000 is the original pointer.  */
554 555 556

static int check_depth;

Kim F. Storm's avatar
Kim F. Storm committed
557 558
/* Like malloc, but wraps allocated block with header and trailer.  */

559 560 561 562
POINTER_TYPE *
overrun_check_malloc (size)
     size_t size;
{
Kim F. Storm's avatar
Kim F. Storm committed
563
  register unsigned char *val;
564
  size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
565

566 567
  val = (unsigned char *) malloc (size + overhead);
  if (val && check_depth == 1)
568
    {
569 570
      memcpy (val, xmalloc_overrun_check_header,
	      XMALLOC_OVERRUN_CHECK_SIZE - 4);
571
      val += XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
572
      XMALLOC_PUT_SIZE(val, size);
573 574
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
575
    }
576
  --check_depth;
577 578 579
  return (POINTER_TYPE *)val;
}

Kim F. Storm's avatar
Kim F. Storm committed
580 581 582 583

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

584 585 586 587 588
POINTER_TYPE *
overrun_check_realloc (block, size)
     POINTER_TYPE *block;
     size_t size;
{
Kim F. Storm's avatar
Kim F. Storm committed
589
  register unsigned char *val = (unsigned char *)block;
590
  size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
591 592

  if (val
593
      && check_depth == 1
594 595 596
      && memcmp (xmalloc_overrun_check_header,
		 val - XMALLOC_OVERRUN_CHECK_SIZE,
		 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
597
    {
Kim F. Storm's avatar
Kim F. Storm committed
598
      size_t osize = XMALLOC_GET_SIZE (val);
599 600
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
601
	abort ();
602
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
603
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
604
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE);
605 606
    }

607
  val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
608

609
  if (val && check_depth == 1)
610
    {
611 612
      memcpy (val, xmalloc_overrun_check_header,
	      XMALLOC_OVERRUN_CHECK_SIZE - 4);
613
      val += XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
614
      XMALLOC_PUT_SIZE(val, size);
615 616
      memcpy (val + size, xmalloc_overrun_check_trailer,
	      XMALLOC_OVERRUN_CHECK_SIZE);
617
    }
618
  --check_depth;
619 620 621
  return (POINTER_TYPE *)val;
}

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

624 625 626 627
void
overrun_check_free (block)
     POINTER_TYPE *block;
{
Kim F. Storm's avatar
Kim F. Storm committed
628
  unsigned char *val = (unsigned char *)block;
629

630
  ++check_depth;
631
  if (val
632
      && check_depth == 1
633 634 635
      && memcmp (xmalloc_overrun_check_header,
		 val - XMALLOC_OVERRUN_CHECK_SIZE,
		 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
636
    {
Kim F. Storm's avatar
Kim F. Storm committed
637
      size_t osize = XMALLOC_GET_SIZE (val);
638 639
      if (memcmp (xmalloc_overrun_check_trailer, val + osize,
		  XMALLOC_OVERRUN_CHECK_SIZE))
640
	abort ();
641 642 643 644
#ifdef XMALLOC_CLEAR_FREE_MEMORY
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
#else
645
      memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
646
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
647
      memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE);
648
#endif
649 650 651
    }

  free (val);
652
  --check_depth;
653 654 655 656 657 658 659 660 661 662
}

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

663 664 665 666 667 668 669 670 671
#ifdef SYNC_INPUT
/* When using SYNC_INPUT, we don't call malloc from a signal handler, so
   there's no need to block input around malloc.  */
#define MALLOC_BLOCK_INPUT   ((void)0)
#define MALLOC_UNBLOCK_INPUT ((void)0)
#else
#define MALLOC_BLOCK_INPUT   BLOCK_INPUT
#define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
#endif
Kim F. Storm's avatar
Kim F. Storm committed
672

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

675
POINTER_TYPE *
676
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
677
{
678
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
679

680
  MALLOC_BLOCK_INPUT;
681
  val = (POINTER_TYPE *) malloc (size);
682
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
683

684 685
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
686 687 688
  return val;
}

689 690 691

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

692
POINTER_TYPE *
693
xrealloc (POINTER_TYPE *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
694
{
695
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
696

697
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
698 699 700
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
701
    val = (POINTER_TYPE *) malloc (size);
Noah Friedman's avatar
Noah Friedman committed
702
  else
703
    val = (POINTER_TYPE *) realloc (block, size);
704
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
705 706 707 708

  if (!val && size) memory_full ();
  return val;
}
709

710

Dave Love's avatar
Dave Love committed
711
/* Like free but block interrupt input.  */
712

713
void
714
xfree (POINTER_TYPE *block)
715
{
716 717
  if (!block)
    return;
718
  MALLOC_BLOCK_INPUT;
719
  free (block);
720
  MALLOC_UNBLOCK_INPUT;
721 722 723
  /* We don't call refill_memory_reserve here
     because that duplicates doing so in emacs_blocked_free
     and the criterion should go there.  */
724 725
}

726

727 728 729
/* Like strdup, but uses xmalloc.  */

char *
730
xstrdup (const char *s)
731
{
732
  size_t len = strlen (s) + 1;
733
  char *p = (char *) xmalloc (len);
734
  memcpy (p, s, len);
735 736 737 738
  return p;
}


739 740 741
/* Unwind for SAFE_ALLOCA */

Lisp_Object
742
safe_alloca_unwind (Lisp_Object arg)
743
{
744 745 746 747 748
  register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);

  p->dogc = 0;
  xfree (p->pointer);
  p->pointer = 0;
749
  free_misc (arg);
750 751 752 753
  return Qnil;
}


754 755 756 757
/* Like malloc but used for allocating Lisp data.  NBYTES is the
   number of bytes to allocate, TYPE describes the intended use of the
   allcated memory block (for strings, for conses, ...).  */

758
#ifndef USE_LSB_TAG
759
static void *lisp_malloc_loser;
760
#endif
761

762
static POINTER_TYPE *
763
lisp_malloc (size_t nbytes, enum mem_type type)
764
{
765
  register void *val;
766

767
  MALLOC_BLOCK_INPUT;
768 769 770 771

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
772

773
  val = (void *) malloc (nbytes);
774

Kenichi Handa's avatar
Kenichi Handa committed
775
#ifndef USE_LSB_TAG
776 777 778 779 780 781 782 783 784 785 786 787 788 789
  /* 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
790
#endif
791

792
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
793
  if (val && type != MEM_TYPE_NON_LISP)
794 795
    mem_insert (val, (char *) val + nbytes, type);
#endif
796

797
  MALLOC_UNBLOCK_INPUT;
798 799
  if (!val && nbytes)
    memory_full ();
800 801 802
  return val;
}

803 804 805
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

806
static void
807
lisp_free (POINTER_TYPE *block)
808
{
809
  MALLOC_BLOCK_INPUT;
810
  free (block);
811
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
812 813
  mem_delete (mem_find (block));
#endif
814
  MALLOC_UNBLOCK_INPUT;
815
}
816

817 818 819 820
/* 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.  */

821 822 823
/* Use posix_memalloc if the system has it and we're using the system's
   malloc (because our gmalloc.c routines don't have posix_memalign although
   its memalloc could be used).  */
824 825 826
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
827 828 829 830 831 832 833

/* BLOCK_ALIGN has to be a power of 2.  */
#define BLOCK_ALIGN (1 << 10)

/* 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.
834 835 836
   On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
   posix_memalign on the other hand would ideally prefer a value of 4
   because otherwise, there's 1020 bytes wasted between each ablocks.
Stefan Monnier's avatar
Stefan Monnier committed
837 838 839 840
   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.  */
841 842
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
Stefan Monnier's avatar
Stefan Monnier committed
843
  (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
844 845 846

/* Internal data structures and constants.  */

847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868
#define ABLOCKS_SIZE 16

/* An aligned block of memory.  */
struct ablock
{
  union
  {
    char payload[BLOCK_BYTES];
    struct ablock *next_free;
  } x;
  /* `abase' is the aligned base of the ablocks.  */
  /* It is overloaded to hold the virtual `busy' field that counts
     the number of used ablock in the parent ablocks.
     The first ablock has the `busy' field, the others have the `abase'
     field.  To tell the difference, we assume that pointers will have
     integer values larger than 2 * ABLOCKS_SIZE.  The lowest bit of `busy'
     is used to tell whether the real base of the parent ablocks is `abase'
     (if not, the word before the first ablock holds a pointer to the
     real base).  */
  struct ablocks *abase;
  /* The padding of all but the last ablock is unused.  The padding of
     the last ablock in an ablocks is not allocated.  */
869 870
#if BLOCK_PADDING
  char padding[BLOCK_PADDING];
871
#endif
872 873 874 875 876 877 878 879 880
};

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

/* Size of the block requested from malloc or memalign.  */
881
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
882 883 884 885 886 887 888 889 890 891

#define ABLOCK_ABASE(block) \
  (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE)   \
   ? (struct ablocks *)(block)					\
   : (block)->abase)

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

/* Pointer to the (not necessarily aligned) malloc block.  */
892
#ifdef USE_POSIX_MEMALIGN
893 894
#define ABLOCKS_BASE(abase) (abase)
#else
895
#define ABLOCKS_BASE(abase) \
Dave Love's avatar
Dave Love committed
896
  (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
897
#endif
898 899 900 901 902 903 904 905

/* 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.  */
static POINTER_TYPE *
906
lisp_align_malloc (size_t nbytes, enum mem_type type)
907 908 909 910 911 912
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

913
  MALLOC_BLOCK_INPUT;
914 915 916 917 918 919 920

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  if (!free_ablock)
    {
Dave Love's avatar
Dave Love committed
921 922
      int i;
      EMACS_INT aligned; /* int gets warning casting to 64-bit pointer.  */
923 924 925 926 927 928 929 930

#ifdef DOUG_LEA_MALLOC
      /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
	 because mapped region contents are not preserved in
	 a dumped Emacs.  */
      mallopt (M_MMAP_MAX, 0);
#endif

931
#ifdef USE_POSIX_MEMALIGN
932 933
      {
	int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
934 935 936
	if (err)
	  base = NULL;
	abase = base;
937 938
      }
#else
939 940
      base = malloc (ABLOCKS_BYTES);
      abase = ALIGN (base, BLOCK_ALIGN);
941 942
#endif

Kenichi Handa's avatar
Kenichi Handa committed
943 944
      if (base == 0)
	{
945
	  MALLOC_UNBLOCK_INPUT;
Kenichi Handa's avatar
Kenichi Handa committed
946 947
	  memory_full ();
	}
948 949 950 951 952 953 954 955 956 957

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

#ifdef DOUG_LEA_MALLOC
      /* Back to a reasonable maximum of mmap'ed areas.  */
      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif

Kenichi Handa's avatar
Kenichi Handa committed
958
#ifndef USE_LSB_TAG
Kenichi Handa's avatar
Kenichi Handa committed
959 960 961 962 963 964 965 966 967 968 969 970
      /* 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 (type != MEM_TYPE_NON_LISP)
	{
	  Lisp_Object tem;
	  char *end = (char *) base + ABLOCKS_BYTES - 1;
	  XSETCONS (tem, end);
	  if ((char *) XCONS (tem) != end)
	    {
	      lisp_malloc_loser = base;
	      free (base);
971
	      MALLOC_UNBLOCK_INPUT;
Kenichi Handa's avatar
Kenichi Handa committed
972 973 974
	      memory_full ();
	    }
	}
Kenichi Handa's avatar
Kenichi Handa committed
975
#endif
Kenichi Handa's avatar
Kenichi Handa committed
976

977 978 979 980 981 982 983 984
      /* Initialize the blocks and put them on the free list.
	 Is `base' was not properly aligned, we can't use the last block.  */
      for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
	{
	  abase->blocks[i].abase = abase;
	  abase->blocks[i].x.next_free = free_ablock;
	  free_ablock = &abase->blocks[i];
	}
Dave Love's avatar
Dave Love committed
985
      ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
986

987
      eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
988 989 990
      eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
      eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
      eassert (ABLOCKS_BASE (abase) == base);
Dave Love's avatar
Dave Love committed
991
      eassert (aligned == (long) ABLOCKS_BUSY (abase));