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

This file is part of GNU Emacs.

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

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

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

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

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

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

35
#include <signal.h>
36

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

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

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

Kenichi Handa's avatar
Kenichi Handa committed
60 61 62 63 64 65 66
/* 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

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

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

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

86
#ifdef DOUG_LEA_MALLOC
87

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

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

97 98
#define MMAP_MAX_AREAS 100000000

99 100
#else /* not DOUG_LEA_MALLOC */

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

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

#endif /* not DOUG_LEA_MALLOC */
108

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

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

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

128 129
static pthread_mutex_t alloc_mutex;

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

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

156 157
static __malloc_size_t bytes_used_when_full;

158 159
static __malloc_size_t bytes_used_when_reconsidered;

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

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

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

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

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

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

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

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

185 186 187 188 189 190 191 192
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;
193

194 195 196 197 198 199 200
/* Minimum number of bytes of consing since GC before next GC. */

EMACS_INT gc_cons_threshold;

/* Similar minimum, computed from Vgc_cons_percentage.  */

EMACS_INT gc_relative_threshold;
201

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

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

EMACS_INT memory_full_cons_threshold;

209 210
/* Nonzero during GC.  */

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

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

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

221 222
int garbage_collection_messages;

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

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

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

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

243
static char *spare_memory[7];
244

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

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

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

251 252
static int malloc_hysteresis;

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

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

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

Lisp_Object Vmemory_full;

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

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

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

272
#else /* HAVE_SHM */
273

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

277
#endif /* HAVE_SHM */
278

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

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

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

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

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

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

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

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

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

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

316
Lisp_Object Vmemory_signal_data;
317

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

326 327
static char *stack_copy;
static int stack_copy_size;
Jim Blandy's avatar
Jim Blandy committed
328

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

332
static int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
333

334
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
335

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

Lisp_Object Vpost_gc_hook, Qpost_gc_hook;

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

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

#ifdef HAVE_WINDOW_SYSTEM
353
extern void mark_fringe_data P_ ((void));
354 355
#endif /* HAVE_WINDOW_SYSTEM */

356 357 358 359
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
360 361

extern int message_enable_multibyte;
362 363 364 365 366 367 368 369 370 371 372 373 374 375

/* 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,
376 377 378 379 380
  /* 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
381 382
};

383 384
static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
385 386
void refill_memory_reserve ();

387

388
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
389 390 391 392 393 394 395 396

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

397
static Lisp_Object Vdead;
398

399 400 401
#ifdef GC_MALLOC_CHECK

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

#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
432 433 434 435 436 437
  /* 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;
438 439 440 441 442 443

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

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

445 446 447 448 449 450 451 452 453 454 455 456
  /* 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;

457 458 459 460
/* Lowest and highest known address in the heap.  */

static void *min_heap_address, *max_heap_address;

461 462 463 464 465
/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

466
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
467
static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
468
static void lisp_free P_ ((POINTER_TYPE *));
469 470 471 472 473 474 475 476
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 *));
477
static void mark_maybe_object P_ ((Lisp_Object));
478
static void mark_memory P_ ((void *, void *, int));
479 480 481 482 483 484 485 486 487 488 489 490 491 492
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

493
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
494

495 496 497 498
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

499 500
/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */
501

502
#define NSTATICS 0x600
503
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
504 505 506

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

507
static int staticidx = 0;
508 509 510 511 512 513 514

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

515 516 517
#define ALIGN(ptr, ALIGNMENT) \
  ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
		     & ~((ALIGNMENT) - 1)))
518

519

Jim Blandy's avatar
Jim Blandy committed
520

521 522 523 524
/************************************************************************
				Malloc
 ************************************************************************/

525
/* Function malloc calls this if it finds we are near exhausting storage.  */
526 527

void
Jim Blandy's avatar
Jim Blandy committed
528 529 530 531 532 533
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}

534

535
/* Display an already-pending malloc warning.  */
536

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

547

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

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

#ifndef REL_ALLOC
  memory_full ();
#endif

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

575

576 577
#ifdef XMALLOC_OVERRUN_CHECK

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


590
#define XMALLOC_OVERRUN_CHECK_SIZE 16
Kim F. Storm's avatar
Kim F. Storm committed
591

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

   (time passes).

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

static int check_depth;

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

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

648 649
  val = (unsigned char *) malloc (size + overhead);
  if (val && check_depth == 1)
650 651 652
    {
      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
653
      XMALLOC_PUT_SIZE(val, size);
654 655
      bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
    }
656
  --check_depth;
657 658 659
  return (POINTER_TYPE *)val;
}

Kim F. Storm's avatar
Kim F. Storm committed
660 661 662 663

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

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

  if (val
673
      && check_depth == 1
674 675 676 677
      && 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
678
      size_t osize = XMALLOC_GET_SIZE (val);
679 680 681 682
      if (bcmp (xmalloc_overrun_check_trailer,
		val + osize,
		XMALLOC_OVERRUN_CHECK_SIZE))
	abort ();
Kim F. Storm's avatar
Kim F. Storm committed
683
      bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
684
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
685
      bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
686 687
    }

688
  val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
689

690
  if (val && check_depth == 1)
691 692 693
    {
      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
694
      XMALLOC_PUT_SIZE(val, size);
695 696
      bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
    }
697
  --check_depth;
698 699 700
  return (POINTER_TYPE *)val;
}

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

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

709
  ++check_depth;
710
  if (val
711
      && check_depth == 1
712 713 714 715
      && 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
716
      size_t osize = XMALLOC_GET_SIZE (val);
717 718 719 720
      if (bcmp (xmalloc_overrun_check_trailer,
		val + osize,
		XMALLOC_OVERRUN_CHECK_SIZE))
	abort ();
721 722 723 724
#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
725
      bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
726
      val -= XMALLOC_OVERRUN_CHECK_SIZE;
Kim F. Storm's avatar
Kim F. Storm committed
727
      bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
728
#endif
729 730 731
    }

  free (val);
732
  --check_depth;
733 734 735 736 737 738 739 740 741 742
}

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

743 744 745 746 747 748 749 750 751
#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
752

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

755
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
756
xmalloc (size)
757
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
758
{
759
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
760

761
  MALLOC_BLOCK_INPUT;
762
  val = (POINTER_TYPE *) malloc (size);
763
  MALLOC_UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
764

765 766
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
767 768 769
  return val;
}

770 771 772

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

773
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
774
xrealloc (block, size)
775
     POINTER_TYPE *block;
776
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
777
{
778
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
779

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

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

793

Dave Love's avatar
Dave Love committed
794
/* Like free but block interrupt input.  */
795

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

810

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

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


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

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

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


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

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

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

855
  MALLOC_BLOCK_INPUT;
856 857 858 859

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
860

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

Kenichi Handa's avatar
Kenichi Handa committed
863
#ifndef USE_LSB_TAG
864 865 866 867 868 869 870 871 872 873 874 875 876 877
  /* 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
878
#endif
879

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

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

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

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

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

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

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

/* Internal data structures and constants.  */

936