alloc.c 164 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, 1994, 1995, 1997, 1998, 1999,
Glenn Morris's avatar
Glenn Morris committed
3
      2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007  Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
4 5 6 7 8

This file is part of GNU Emacs.

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

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
along with GNU Emacs; see the file COPYING.  If not, write to
Lute Kamstra's avatar
Lute Kamstra committed
19 20
the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */
Jim Blandy's avatar
Jim Blandy committed
21

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

26 27 28 29
#ifdef STDC_HEADERS
#include <stddef.h>		/* For offsetof, used by PSEUDOVECSIZE. */
#endif

30 31 32 33
#ifdef ALLOC_DEBUG
#undef INLINE
#endif

34
/* Note that this declares bzero on OSF/1.  How dumb.  */
35

36
#include <signal.h>
37

38 39 40 41
#ifdef HAVE_GTK_AND_PTHREAD
#include <pthread.h>
#endif

42 43 44
/* 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.  */
45

46
#undef HIDE_LISP_IMPLEMENTATION
Jim Blandy's avatar
Jim Blandy committed
47
#include "lisp.h"
48
#include "process.h"
49
#include "intervals.h"
Jim Blandy's avatar
Jim Blandy committed
50
#include "puresize.h"
Jim Blandy's avatar
Jim Blandy committed
51 52
#include "buffer.h"
#include "window.h"
53
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
54
#include "frame.h"
55
#include "blockinput.h"
56
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
57
#include "syssignal.h"
58
#include "termhooks.h"		/* For struct terminal.  */
59
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
60

61 62 63 64 65 66 67
/* 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

68 69 70 71 72
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
extern POINTER_TYPE *sbrk ();
#endif
Karl Heuer's avatar
Karl Heuer committed
73

74 75 76 77 78 79 80 81
#ifdef HAVE_FCNTL_H
#define INCLUDED_FCNTL
#include <fcntl.h>
#endif
#ifndef O_WRONLY
#define O_WRONLY 1
#endif

82 83
#ifdef WINDOWSNT
#include <fcntl.h>
Eli Zaretskii's avatar
Eli Zaretskii committed
84
#include "w32.h"
85 86
#endif

87
#ifdef DOUG_LEA_MALLOC
88

89
#include <malloc.h>
90 91
/* malloc.h #defines this as size_t, at least in glibc2.  */
#ifndef __malloc_size_t
92
#define __malloc_size_t int
93
#endif
94

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

98 99
#define MMAP_MAX_AREAS 100000000

100 101
#else /* not DOUG_LEA_MALLOC */

102 103 104 105
/* The following come from gmalloc.c.  */

#define	__malloc_size_t		size_t
extern __malloc_size_t _bytes_used;
106
extern __malloc_size_t __malloc_extra_blocks;
107 108

#endif /* not DOUG_LEA_MALLOC */
109

110 111
#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)

112 113 114 115 116 117 118 119
/* 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
120
   end up in an inconsistent state.  So we have a mutex to prevent that (note
121 122 123
   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).

124
   When UNBLOCK_INPUT is called, reinvoke_input_signal may be called.  If this
125 126 127 128
   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.  */

129 130
static pthread_mutex_t alloc_mutex;

131 132 133 134
#define BLOCK_INPUT_ALLOC                               \
  do                                                    \
    {                                                   \
      if (pthread_equal (pthread_self (), main_thread)) \
135
        BLOCK_INPUT;					\
136 137
      pthread_mutex_lock (&alloc_mutex);                \
    }                                                   \
138
  while (0)
139 140 141 142 143
#define UNBLOCK_INPUT_ALLOC                             \
  do                                                    \
    {                                                   \
      pthread_mutex_unlock (&alloc_mutex);              \
      if (pthread_equal (pthread_self (), main_thread)) \
144
        UNBLOCK_INPUT;					\
145
    }                                                   \
146 147 148 149 150 151 152 153 154
  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 */

155
/* Value of _bytes_used, when spare_memory was freed.  */
156

157 158
static __malloc_size_t bytes_used_when_full;

159 160
static __malloc_size_t bytes_used_when_reconsidered;

161 162 163
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

164 165
#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)
166
#define STRING_MARKED_P(S)	(((S)->size & ARRAY_MARK_FLAG) != 0)
167

168 169
#define VECTOR_MARK(V)		((V)->size |= ARRAY_MARK_FLAG)
#define VECTOR_UNMARK(V)	((V)->size &= ~ARRAY_MARK_FLAG)
170
#define VECTOR_MARKED_P(V)	(((V)->size & ARRAY_MARK_FLAG) != 0)
171

172 173 174 175 176
/* 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.  */

177
#define GC_STRING_BYTES(S)	(STRING_BYTES (S))
178
#define GC_STRING_CHARS(S)	((S)->size & ~ARRAY_MARK_FLAG)
179 180 181

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

Jim Blandy's avatar
Jim Blandy committed
182 183
int consing_since_gc;

184
/* Count the amount of consing of various sorts of space.  */
185

186 187 188 189 190 191 192 193
EMACS_INT cons_cells_consed;
EMACS_INT floats_consed;
EMACS_INT vector_cells_consed;
EMACS_INT symbols_consed;
EMACS_INT string_chars_consed;
EMACS_INT misc_objects_consed;
EMACS_INT intervals_consed;
EMACS_INT strings_consed;
194

195
/* Minimum number of bytes of consing since GC before next GC. */
196

197
EMACS_INT gc_cons_threshold;
Jim Blandy's avatar
Jim Blandy committed
198

199 200 201
/* Similar minimum, computed from Vgc_cons_percentage.  */

EMACS_INT gc_relative_threshold;
202

203
static Lisp_Object Vgc_cons_percentage;
Jim Blandy's avatar
Jim Blandy committed
204

205 206 207 208 209
/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

EMACS_INT memory_full_cons_threshold;

210 211
/* Nonzero during GC.  */

Jim Blandy's avatar
Jim Blandy committed
212 213
int gc_in_progress;

214 215 216 217 218 219
/* 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;

220
/* Nonzero means display messages at beginning and end of GC.  */
221

222 223
int garbage_collection_messages;

Jim Blandy's avatar
Jim Blandy committed
224 225 226
#ifndef VIRT_ADDR_VARIES
extern
#endif /* VIRT_ADDR_VARIES */
227
int malloc_sbrk_used;
Jim Blandy's avatar
Jim Blandy committed
228 229 230 231

#ifndef VIRT_ADDR_VARIES
extern
#endif /* VIRT_ADDR_VARIES */
232
int malloc_sbrk_unused;
Jim Blandy's avatar
Jim Blandy committed
233

234 235 236 237 238
/* 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;
239

240
/* Points to memory space allocated as "spare", to be freed if we run
241 242
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */
243

244
char *spare_memory[7];
245

246
/* Amount of spare memory to keep in large reserve block.  */
247

248 249 250
#define SPARE_MEMORY (1 << 14)

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

252 253
static int malloc_hysteresis;

254 255
/* Non-nil means defun should do purecopy on the function definition.  */

Jim Blandy's avatar
Jim Blandy committed
256 257
Lisp_Object Vpurify_flag;

258 259 260 261
/* Non-nil means we are handling a memory-full error.  */

Lisp_Object Vmemory_full;

Jim Blandy's avatar
Jim Blandy committed
262
#ifndef HAVE_SHM
263

Richard M. Stallman's avatar
Richard M. Stallman committed
264 265 266 267 268
/* 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.  */
269

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

273
#else /* HAVE_SHM */
274

Jim Blandy's avatar
Jim Blandy committed
275 276
#define pure PURE_SEG_BITS   /* Use shared memory segment */
#define PUREBEG (char *)PURE_SEG_BITS
Jim Blandy's avatar
Jim Blandy committed
277

278
#endif /* HAVE_SHM */
279

280
/* Pointer to the pure area, and its size.  */
281

282 283 284 285 286 287 288
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
289

290 291 292 293
/* Value is non-zero if P points into pure space.  */

#define PURE_POINTER_P(P)					\
     (((PNTR_COMPARISON_TYPE) (P)				\
294
       < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size))	\
295
      && ((PNTR_COMPARISON_TYPE) (P)				\
296
	  >= (PNTR_COMPARISON_TYPE) purebeg))
297

298
/* Total number of bytes allocated in pure storage. */
299

300
EMACS_INT pure_bytes_used;
Jim Blandy's avatar
Jim Blandy committed
301

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

310 311 312
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

Jim Blandy's avatar
Jim Blandy committed
313 314
char *pending_malloc_warning;

315
/* Pre-computed signal argument for use when memory is exhausted.  */
316

317
Lisp_Object Vmemory_signal_data;
318

Jim Blandy's avatar
Jim Blandy committed
319 320 321 322 323 324 325 326 327 328 329
/* 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.  */

char *stack_copy;
int stack_copy_size;

330 331 332
/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

Jim Blandy's avatar
Jim Blandy committed
333
int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
334

335
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
336

337 338 339 340
/* Hook run after GC has finished.  */

Lisp_Object Vpost_gc_hook, Qpost_gc_hook;

341 342 343
Lisp_Object Vgc_elapsed;	/* accumulated elapsed time in GC  */
EMACS_INT gcs_done;		/* accumulated GCs  */

344
static void mark_buffer P_ ((Lisp_Object));
345
static void mark_terminals P_ ((void));
346
extern void mark_kboards P_ ((void));
347
extern void mark_ttys P_ ((void));
Stefan Monnier's avatar
Stefan Monnier committed
348
extern void mark_backtrace P_ ((void));
349
static void gc_sweep P_ ((void));
350 351 352 353
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));

#ifdef HAVE_WINDOW_SYSTEM
354
extern void mark_fringe_data P_ ((void));
355 356 357 358
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */

359 360 361 362
static struct Lisp_String *allocate_string P_ ((void));
static void compact_small_strings P_ ((void));
static void free_large_strings P_ ((void));
static void sweep_strings P_ ((void));
Richard M. Stallman's avatar
Richard M. Stallman committed
363 364

extern int message_enable_multibyte;
365 366 367 368 369 370 371 372 373 374 375 376 377 378

/* 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,
379 380 381 382 383
  /* 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
384 385
};

386 387
static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
388 389
void refill_memory_reserve ();

390

391
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
392 393 394 395 396 397 398 399 400 401

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

Lisp_Object Vdead;

402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434
#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
int dont_register_blocks;

#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
435 436 437 438 439 440
  /* 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;
441 442 443 444 445 446

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

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

448 449 450 451 452 453 454 455 456 457 458 459
  /* 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;

460 461 462 463
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

464 465 466 467 468
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

469
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
470
static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
471
static void lisp_free P_ ((POINTER_TYPE *));
472 473 474 475 476 477 478 479
static void mark_stack P_ ((void));
static int live_vector_p P_ ((struct mem_node *, void *));
static int live_buffer_p P_ ((struct mem_node *, void *));
static int live_string_p P_ ((struct mem_node *, void *));
static int live_cons_p P_ ((struct mem_node *, void *));
static int live_symbol_p P_ ((struct mem_node *, void *));
static int live_float_p P_ ((struct mem_node *, void *));
static int live_misc_p P_ ((struct mem_node *, void *));
480
static void mark_maybe_object P_ ((Lisp_Object));
481
static void mark_memory P_ ((void *, void *, int));
482 483 484 485 486 487 488 489 490 491 492 493 494 495
static void mem_init P_ ((void));
static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
static void mem_insert_fixup P_ ((struct mem_node *));
static void mem_rotate_left P_ ((struct mem_node *));
static void mem_rotate_right P_ ((struct mem_node *));
static void mem_delete P_ ((struct mem_node *));
static void mem_delete_fixup P_ ((struct mem_node *));
static INLINE struct mem_node *mem_find P_ ((void *));


#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
static void check_gcpros P_ ((void));
#endif

496
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
497

498 499 500 501
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

502 503
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
504

Andreas Schwab's avatar
Andreas Schwab committed
505
#define NSTATICS 1280
506
Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
507 508 509 510 511 512 513 514 515 516 517

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

int staticidx = 0;

static POINTER_TYPE *pure_alloc P_ ((size_t, int));


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

518 519 520
#define ALIGN(ptr, ALIGNMENT) \
  ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
		     & ~((ALIGNMENT) - 1)))
521

522

Jim Blandy's avatar
Jim Blandy committed
523

524 525 526 527
/************************************************************************
				Malloc
 ************************************************************************/

528
/* Function malloc calls this if it finds we are near exhausting storage.  */
529 530

void
Jim Blandy's avatar
Jim Blandy committed
531 532 533 534 535 536
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}

537

538
/* Display an already-pending malloc warning.  */
539

540
void
Jim Blandy's avatar
Jim Blandy committed
541 542
display_malloc_warning ()
{
543 544 545 546
  call3 (intern ("display-warning"),
	 intern ("alloc"),
	 build_string (pending_malloc_warning),
	 intern ("emergency"));
Jim Blandy's avatar
Jim Blandy committed
547 548 549
  pending_malloc_warning = 0;
}

550

551
#ifdef DOUG_LEA_MALLOC
552
#  define BYTES_USED (mallinfo ().uordblks)
553
#else
554
#  define BYTES_USED _bytes_used
555
#endif
556

557 558 559 560 561
/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()
{
562 563 564 565 566 567
  /* 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.  */
568 569 570 571 572

#ifndef REL_ALLOC
  memory_full ();
#endif

573 574
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
575
  xsignal (Qnil, Vmemory_signal_data);
Jim Blandy's avatar
Jim Blandy committed
576 577
}

578

579 580
#ifdef XMALLOC_OVERRUN_CHECK

Kim F. Storm's avatar
Kim F. Storm committed
581 582 583 584 585 586 587 588 589 590 591 592
/* 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.
*/


593
#define XMALLOC_OVERRUN_CHECK_SIZE 16
Kim F. Storm's avatar
Kim F. Storm committed
594

595 596 597 598 599 600 601 602 603 604 605
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
606 607 608 609 610 611 612 613 614 615 616 617 618 619 620
/* 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
621 622 623 624 625 626 627 628 629
/* 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)
630
      add overhead again, return 10032
Jan Djärv's avatar
Jan Djärv committed
631
   xmalloc returns 10032.
632 633 634

   (time passes).

Jan Djärv's avatar
Jan Djärv committed
635 636 637 638
   xfree(10032)
     overrun_check_free(10032)
       decrease overhed
       free(10016)  <-  crash, because 10000 is the original pointer.  */
639 640 641

static int check_depth;

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

644 645 646 647
POINTER_TYPE *
overrun_check_malloc (size)
     size_t size;
{
Kim F. Storm's avatar
Kim F. Storm committed
648
  register unsigned char *val;
649
  size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
650

651 652
  val = (unsigned char *) malloc (size + overhead);
  if (val && check_depth == 1)
653 654 655
    {
      bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
      val += XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
656
      XMALLOC_PUT_SIZE(val, size);
657 658
      bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
    }
659
  --check_depth;
660 661 662
  return (POINTER_TYPE *)val;
}

Kim F. Storm's avatar
Kim F. Storm committed
663 664 665 666

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

667 668 669 670 671
POINTER_TYPE *
overrun_check_realloc (block, size)
     POINTER_TYPE *block;
     size_t size;
{
Kim F. Storm's avatar
Kim F. Storm committed
672
  register unsigned char *val = (unsigned char *)block;
673
  size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
674 675

  if (val
676
      && check_depth == 1
677 678 679 680
      && bcmp (xmalloc_overrun_check_header,
	       val - XMALLOC_OVERRUN_CHECK_SIZE,
	       XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
    {
Kim F. Storm's avatar
Kim F. Storm committed
681
      size_t osize = XMALLOC_GET_SIZE (val);
682 683 684 685
      if (bcmp (xmalloc_overrun_check_trailer,
		val + osize,
		XMALLOC_OVERRUN_CHECK_SIZE))
	abort ();
Kim F. Storm's avatar
Kim F. Storm committed
686
      bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
687
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
688
      bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
689 690
    }

691
  val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
692

693
  if (val && check_depth == 1)
694 695 696
    {
      bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
      val += XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
697
      XMALLOC_PUT_SIZE(val, size);
698 699
      bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
    }
700
  --check_depth;
701 702 703
  return (POINTER_TYPE *)val;
}

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

706 707 708 709
void
overrun_check_free (block)
     POINTER_TYPE *block;
{
Kim F. Storm's avatar
Kim F. Storm committed
710
  unsigned char *val = (unsigned char *)block;
711

712
  ++check_depth;
713
  if (val
714
      && check_depth == 1
715 716 717 718
      && bcmp (xmalloc_overrun_check_header,
	       val - XMALLOC_OVERRUN_CHECK_SIZE,
	       XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
    {
Kim F. Storm's avatar
Kim F. Storm committed
719
      size_t osize = XMALLOC_GET_SIZE (val);
720 721 722 723
      if (bcmp (xmalloc_overrun_check_trailer,
		val + osize,
		XMALLOC_OVERRUN_CHECK_SIZE))
	abort ();
724 725 726 727
#ifdef XMALLOC_CLEAR_FREE_MEMORY
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
      memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
#else
Kim F. Storm's avatar
Kim F. Storm committed
728
      bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
729
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
730
      bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
731
#endif
732 733 734
    }

  free (val);
735
  --check_depth;
736 737 738 739 740 741 742 743 744 745
}

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

746 747 748 749 750 751 752 753 754
#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
755

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

758
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
759
xmalloc (size)
760
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
761
{
762
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
763

764
  MALLOC_BLOCK_INPUT;
765
  val = (POINTER_TYPE *) malloc (size);
766
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
767

768 769
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
770 771 772
  return val;
}

773 774 775

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

776
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
777
xrealloc (block, size)
778
     POINTER_TYPE *block;
779
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
780
{
781
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
782

783
  MALLOC_BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
784 785 786
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
787
    val = (POINTER_TYPE *) malloc (size);
Noah Friedman's avatar
Noah Friedman committed
788
  else
789
    val = (POINTER_TYPE *) realloc (block, size);
790
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
791 792 793 794

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

796

797
/* Like free but block interrupt input.  */
798

799 800
void
xfree (block)
801
     POINTER_TYPE *block;
802
{
803
  MALLOC_BLOCK_INPUT;
804
  free (block);
805
  MALLOC_UNBLOCK_INPUT;
806 807 808
  /* We don't call refill_memory_reserve here
     because that duplicates doing so in emacs_blocked_free
     and the criterion should go there.  */
809 810
}

811

812 813 814 815
/* Like strdup, but uses xmalloc.  */

char *
xstrdup (s)
816
     const char *s;
817
{
818
  size_t len = strlen (s) + 1;
819 820 821 822 823 824
  char *p = (char *) xmalloc (len);
  bcopy (s, p, len);
  return p;
}


825 826 827 828 829 830
/* Unwind for SAFE_ALLOCA */

Lisp_Object
safe_alloca_unwind (arg)
     Lisp_Object arg;
{
831 832 833 834 835
  register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);

  p->dogc = 0;
  xfree (p->pointer);
  p->pointer = 0;
836
  free_misc (arg);
837 838 839 840
  return Qnil;
}


841 842 843 844
/* 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, ...).  */

845
#ifndef USE_LSB_TAG
846
static void *lisp_malloc_loser;
847
#endif
848

849
static POINTER_TYPE *
850
lisp_malloc (nbytes, type)
851
     size_t nbytes;
852
     enum mem_type type;
853
{
854
  register void *val;
855

856
  MALLOC_BLOCK_INPUT;
857 858 859 860

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
861

862
  val = (void *) malloc (nbytes);
863

864
#ifndef USE_LSB_TAG
865 866 867 868 869 870 871 872 873 874 875 876 877 878
  /* 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;
	}
    }
879
#endif
880

881
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
882
  if (val && type != MEM_TYPE_NON_LISP)
883 884
    mem_insert (val, (char *) val + nbytes, type);
#endif
885

886
  MALLOC_UNBLOCK_INPUT;
887 888
  if (!val && nbytes)
    memory_full ();
889 890 891
  return val;
}

892 893 894
/* Free BLOCK.  This must be called to free memory allocated with a
   call to lisp_malloc.  */

895
static void
896
lisp_free (block)
897
     POINTER_TYPE *block;
898
{
899
  MALLOC_BLOCK_INPUT;
900
  free (block);
901
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
902 903
  mem_delete (mem_find (block));
#endif
904
  MALLOC_UNBLOCK_INPUT;
905
}
906

907 908 909 910
/* 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.  */

911 912 913
/* 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).  */
914 915 916
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
917 918 919 920 921 922 923

/* 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.
924 925 926
   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
927 928 929 930
   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.  */
931 932
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
Stefan Monnier's avatar
Stefan Monnier committed
933
  (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
934 935 936

/* Internal data structures and constants.  */

937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958
#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.  */
959 960
#if BLOCK_PADDING
  char padding[BLOCK_PADDING];
961
#endif
962 963 964 965 966 967 968 969 970
};

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

/* Size of the block requested from malloc or memalign.  */
971
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
972 973 974 975 976 977 978 979 980 981

#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.  */
982
#ifdef USE_POSIX_MEMALIGN
983 984
#define ABLOCKS_BASE(abase) (abase)
#else
985
#define ABLOCKS_BASE(abase) \
986
  (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
987
#endif
988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004

/* 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 *
lisp_align_malloc (nbytes, type)
     size_t nbytes;
     enum mem_type type;
{
  void *base, *val;
  struct ablocks *abase;

  eassert (nbytes <= BLOCK_BYTES);

1005
  MALLOC_BLOCK_INPUT;
1006 1007 1008 1009 1010 1011 1012

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif

  if (!free_ablock)
    {
1013 1014
      int i;
      EMACS_INT aligned; /* int gets warning casting to 64-bit pointer.  */
1015 1016 1017 1018 1019 1020 1021 1022

#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

1023
#ifdef USE_POSIX_MEMALIGN