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 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 143 144
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

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

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

153 154
/* 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
155 156
   strings.  */

157
#define GC_STRING_BYTES(S)	(STRING_BYTES (S))
158

159 160 161
/* Global variables.  */
struct emacs_globals globals;

162 163
/* Number of bytes of consing done since the last gc.  */

Jim Blandy's avatar
Jim Blandy committed
164 165
int consing_since_gc;

166 167 168
/* Similar minimum, computed from Vgc_cons_percentage.  */

EMACS_INT gc_relative_threshold;
169

170 171 172 173 174
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

EMACS_INT memory_full_cons_threshold;

175 176
/* Nonzero during GC.  */

Jim Blandy's avatar
Jim Blandy committed
177 178
int gc_in_progress;

179 180 181 182 183 184
/* 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;

185 186 187 188 189
/* 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;
190

191
/* Points to memory space allocated as "spare", to be freed if we run
192 193
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
194

195
static char *spare_memory[7];
196

197
#ifndef SYSTEM_MALLOC
198
/* Amount of spare memory to keep in large reserve block.  */
199

200
#define SPARE_MEMORY (1 << 14)
201
#endif
202 203

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

205 206
static int malloc_hysteresis;

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

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

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

221 222 223 224 225 226 227
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
228

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

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

237 238 239 240 241 242 243 244
/* 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;

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

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

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

258
#if MAX_SAVE_STACK > 0
259
static char *stack_copy;
260 261
static size_t stack_copy_size;
#endif
Jim Blandy's avatar
Jim Blandy committed
262

263 264 265
/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

266
static int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
267

268 269
static Lisp_Object Qgc_cons_threshold;
Lisp_Object Qchar_table_extra_slots;
270

271 272
/* Hook run after GC has finished.  */

273
static Lisp_Object Qpost_gc_hook;
274

275 276 277 278 279
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 *);
280

281 282 283
#if !defined REL_ALLOC || defined SYSTEM_MALLOC
static void refill_memory_reserve (void);
#endif
284 285 286 287
static struct Lisp_String *allocate_string (void);
static void compact_small_strings (void);
static void free_large_strings (void);
static void sweep_strings (void);
288
static void free_misc (Lisp_Object);
289 290 291 292 293 294 295 296 297 298 299 300 301 302

/* 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,
303 304 305 306 307
  /* 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
308 309
};

310 311
static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
312

313

314
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
315 316 317 318 319 320 321 322

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

323
static Lisp_Object Vdead;
324

325 326 327
#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
328
static int dont_register_blocks;
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357

#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
358 359 360 361 362 363
  /* 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;
364 365 366 367 368 369

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

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

371 372 373 374 375 376 377 378 379 380 381 382
  /* 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;

383 384 385 386
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

387 388 389 390 391
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
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 *);
412 413 414


#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
415
static void check_gcpros (void);
416 417
#endif

418
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
419

420 421 422 423
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

424 425
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
426

Eli Zaretskii's avatar
Eli Zaretskii committed
427
#define NSTATICS 0x640
428
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
429 430 431

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

432
static int staticidx = 0;
433

434
static POINTER_TYPE *pure_alloc (size_t, int);
435 436 437 438 439


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

440 441 442
#define ALIGN(ptr, ALIGNMENT) \
  ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
		     & ~((ALIGNMENT) - 1)))
443

444

Jim Blandy's avatar
Jim Blandy committed
445

446 447 448 449
/************************************************************************
				Malloc
 ************************************************************************/

450
/* Function malloc calls this if it finds we are near exhausting storage.  */
451 452

void
453
malloc_warning (const char *str)
Jim Blandy's avatar
Jim Blandy committed
454 455 456 457
{
  pending_malloc_warning = str;
}

458

459
/* Display an already-pending malloc warning.  */
460

461
void
462
display_malloc_warning (void)
Jim Blandy's avatar
Jim Blandy committed
463
{
464 465 466 467
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
468 469
  pending_malloc_warning = 0;
}
470

471 472 473
/* Called if we can't allocate relocatable space for a buffer.  */

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

#ifndef REL_ALLOC
  memory_full ();
#endif

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

492

493 494
#ifdef XMALLOC_OVERRUN_CHECK

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


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

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

   (time passes).

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

static int check_depth;

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

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

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

Kim F. Storm's avatar
Kim F. Storm committed
578 579 580 581

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

582
POINTER_TYPE *
583
overrun_check_realloc (POINTER_TYPE *block, size_t size)
584
{
585
  register unsigned char *val = (unsigned char *) block;
586
  size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
587 588

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

603
  val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
604

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

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

620
void
621
overrun_check_free (POINTER_TYPE *block)
622
{
623
  unsigned char *val = (unsigned char *) block;
624

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

  free (val);
647
  --check_depth;
648 649 650 651 652 653 654 655 656 657
}

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

658 659 660 661 662 663 664 665 666
#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
667

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

670
POINTER_TYPE *
671
xmalloc (size_t size)
Jim Blandy's avatar
Jim Blandy committed
672
{
673
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
674

675
  MALLOC_BLOCK_INPUT;
676
  val = (POINTER_TYPE *) malloc (size);
677
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
678

679 680
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
681 682 683
  return val;
}

684 685 686

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

687
POINTER_TYPE *
688
xrealloc (POINTER_TYPE *block, size_t size)
Jim Blandy's avatar
Jim Blandy committed
689
{
690
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
691

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

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

705

Dave Love's avatar
Dave Love committed
706
/* Like free but block interrupt input.  */
707

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

721

722 723 724
/* Like strdup, but uses xmalloc.  */

char *
725
xstrdup (const char *s)
726
{
727
  size_t len = strlen (s) + 1;
728
  char *p = (char *) xmalloc (len);
729
  memcpy (p, s, len);
730 731 732 733
  return p;
}


734 735 736
/* Unwind for SAFE_ALLOCA */

Lisp_Object
737
safe_alloca_unwind (Lisp_Object arg)
738
{
739 740 741 742 743
  register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);

  p->dogc = 0;
  xfree (p->pointer);
  p->pointer = 0;
744
  free_misc (arg);
745 746 747 748
  return Qnil;
}


749 750 751 752
/* 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, ...).  */

753
#ifndef USE_LSB_TAG
754
static void *lisp_malloc_loser;
755
#endif
756

757
static POINTER_TYPE *
758
lisp_malloc (size_t nbytes, enum mem_type type)
759
{
760
  register void *val;
761

762
  MALLOC_BLOCK_INPUT;
763 764 765 766

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
767

768
  val = (void *) malloc (nbytes);
769

Kenichi Handa's avatar
Kenichi Handa committed
770
#ifndef USE_LSB_TAG
771 772 773 774 775 776 777 778 779 780 781 782 783 784
  /* 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
785
#endif
786

787
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
788
  if (val && type != MEM_TYPE_NON_LISP)
789 790
    mem_insert (val, (char *) val + nbytes, type);
#endif
791

792
  MALLOC_UNBLOCK_INPUT;
793 794
  if (!val && nbytes)
    memory_full ();
795 796 797
  return val;
}

798 799 800
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

801
static void
802
lisp_free (POINTER_TYPE *block)
803
{
804
  MALLOC_BLOCK_INPUT;
805
  free (block);
806
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
807 808
  mem_delete (mem_find (block));
#endif
809
  MALLOC_UNBLOCK_INPUT;
810
}
811

812 813 814 815
/* 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.  */

816 817 818
/* 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).  */
819 820 821
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
822 823 824 825 826 827 828

/* 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.
829 830 831
   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
832 833 834 835
   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.  */
836 837
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
838
  (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
839 840 841

/* Internal data structures and constants.  */

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

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

/* Size of the block requested from malloc or memalign.  */
876
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
877 878 879 880 881 882 883 884 885 886

#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.  */
887
#ifdef USE_POSIX_MEMALIGN
888 889
#define ABLOCKS_BASE(abase) (abase)
#else
890
#define ABLOCKS_BASE(abase) \
Dave Love's avatar
Dave Love committed
891
  (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
892
#endif
893 894 895 896 897 898 899 900

/* 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 *
901
lisp_align_malloc (size_t nbytes, enum mem_type type)
902 903 904 905 906 907
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

908
  MALLOC_BLOCK_INPUT;
909 910 911 912 913 914 915

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  if (!free_ablock)
    {
Dave Love's avatar
Dave Love committed
916 917
      int i;
      EMACS_INT aligned; /* int gets warning casting to 64-bit pointer.  */
918 919 920 921 922 923 924 925

#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

926
#ifdef USE_POSIX_MEMALIGN