alloc.c 162 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 (HAVE_GTK_AND_PTHREAD)

97 98 99 100 101 102 103 104
/* 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
105
   end up in an inconsistent state.  So we have a mutex to prevent that (note
106 107 108
   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).

109
   When UNBLOCK_INPUT is called, reinvoke_input_signal may be called.  If this
110 111 112 113
   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.  */

114 115
static pthread_mutex_t alloc_mutex;

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

#else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */

#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT

#endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */

140
/* Value of _bytes_used, when spare_memory was freed.  */
141

142 143
static __malloc_size_t bytes_used_when_full;

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

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

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

155 156 157 158 159
/* Value is the number of bytes/chars of S, a pointer to a struct
   Lisp_String.  This must be used instead of STRING_BYTES (S) or
   S->size during GC, because S->size contains the mark bit for
   strings.  */

160
#define GC_STRING_BYTES(S)	(STRING_BYTES (S))
161
#define GC_STRING_CHARS(S)	((S)->size & ~ARRAY_MARK_FLAG)
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 276
static void mark_buffer (Lisp_Object);
static void mark_terminals (void);
extern void mark_backtrace (void);
static void gc_sweep (void);
static void mark_glyph_matrix (struct glyph_matrix *);
static void mark_face_cache (struct face_cache *);
277

278 279 280 281
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
282 283

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

/* 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,
298 299 300 301 302
  /* 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
303 304
};

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

308

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

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

318
static Lisp_Object Vdead;
319

320 321 322
#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
323
static int dont_register_blocks;
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 352

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

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

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

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

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

static void *min_heap_address, *max_heap_address;

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

static struct mem_node mem_z;
#define MEM_NIL &mem_z

387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406
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 *);
407 408 409


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

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

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

struct gcpro *gcprolist;

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

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

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

427
static int staticidx = 0;
428

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


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

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

439

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

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

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

453

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

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

466

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

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

#ifndef REL_ALLOC
  memory_full ();
#endif

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

494

495 496
#ifdef XMALLOC_OVERRUN_CHECK

Kim F. Storm's avatar
Kim F. Storm committed
497 498 499 500 501 502 503 504 505 506 507 508
/* 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.
*/


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

511 512 513 514 515 516 517 518 519 520 521
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
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
/* 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
537 538 539 540 541 542 543 544 545
/* 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)
546
      add overhead again, return 10032
Jan Djärv's avatar
Jan Djärv committed
547
   xmalloc returns 10032.
548 549 550

   (time passes).

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

static int check_depth;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

664 665 666 667 668 669 670 671 672
#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
673

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

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

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

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

690 691 692

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

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

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

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

711

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

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

727

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

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


740 741 742
/* Unwind for SAFE_ALLOCA */

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

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


755 756 757 758
/* 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, ...).  */

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

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

768
  MALLOC_BLOCK_INPUT;
769 770 771 772

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
773

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

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

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

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

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

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

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

822 823 824
/* 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).  */
825 826 827
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
828 829 830 831 832 833 834

/* 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.
835 836 837
   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
838 839 840 841
   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.  */
842 843
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
Stefan Monnier's avatar
Stefan Monnier committed
844
  (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
845 846 847

/* Internal data structures and constants.  */

848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
#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.  */
870 871
#if BLOCK_PADDING
  char padding[BLOCK_PADDING];
872
#endif
873 874 875 876 877 878 879 880 881
};

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

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

#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.  */
893
#ifdef USE_POSIX_MEMALIGN
894 895
#define ABLOCKS_BASE(abase) (abase)
#else
896
#define ABLOCKS_BASE(abase) \
Dave Love's avatar
Dave Love committed
897
  (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
898
#endif
899 900 901 902 903 904 905 906

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

  eassert (nbytes <= BLOCK_BYTES);

914
  MALLOC_BLOCK_INPUT;
915 916 917 918 919 920 921

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

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

#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

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

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

      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
959
#ifndef USE_LSB_TAG
Kenichi Handa's avatar
Kenichi Handa committed
960 961 962 963 964 965 966 967 968 969 970 971
      /* 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);
972
	      MALLOC_UNBLOCK_INPUT;
Kenichi Handa's avatar
Kenichi Handa committed
973 974 975
	      memory_full ();
	    }
	}
Kenichi Handa's avatar
Kenichi Handa committed
976
#endif
Kenichi Handa's avatar
Kenichi Handa committed
977

978 979 980 981 982 983 984 985
      /* 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
986
      ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
987

988
      eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
989 990 991
      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
992
      eassert (aligned == (long) ABLOCKS_BUSY (abase));
993 994 995
    }

  abase = ABLOCK_ABASE (free_ablock);
Dave Love's avatar
Dave Love committed
996
  ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
997 998 999 1000 </