alloc.c 129 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2
   Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
Richard M. Stallman's avatar
Richard M. Stallman committed
3
      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 2, 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
19 20
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */
Jim Blandy's avatar
Jim Blandy committed
21

22
#include <config.h>
23
#include <stdio.h>
24

25
/* Note that this declares bzero on OSF/1.  How dumb.  */
26

27
#include <signal.h>
28

29
/* Define this temporarily to hunt a bug.  If defined, the size of
30 31
   strings is redundantly recorded in sdata structures so that it can
   be compared to the sizes recorded in Lisp strings.  */
32 33 34

#define GC_CHECK_STRING_BYTES 1

35 36 37 38 39 40 41
/* 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

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 "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 "charset.h"
Jim Blandy's avatar
Jim Blandy committed
56
#include "syssignal.h"
57
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
58

59 60 61 62 63
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
extern POINTER_TYPE *sbrk ();
#endif
Karl Heuer's avatar
Karl Heuer committed
64

65
#ifdef DOUG_LEA_MALLOC
66

67
#include <malloc.h>
68 69
/* malloc.h #defines this as size_t, at least in glibc2.  */
#ifndef __malloc_size_t
70
#define __malloc_size_t int
71
#endif
72

73 74 75
/* Specify maximum number of areas to mmap.  It would be nice to use a
   value that explicitly means "no limit".  */

76 77
#define MMAP_MAX_AREAS 100000000

78 79
#else /* not DOUG_LEA_MALLOC */

80 81 82 83
/* The following come from gmalloc.c.  */

#define	__malloc_size_t		size_t
extern __malloc_size_t _bytes_used;
84
extern __malloc_size_t __malloc_extra_blocks;
85 86

#endif /* not DOUG_LEA_MALLOC */
87

Jim Blandy's avatar
Jim Blandy committed
88
#define max(A,B) ((A) > (B) ? (A) : (B))
89
#define min(A,B) ((A) < (B) ? (A) : (B))
Jim Blandy's avatar
Jim Blandy committed
90 91 92 93 94

/* Macro to verify that storage intended for Lisp objects is not
   out of range to fit in the space for a pointer.
   ADDRESS is the start of the block, and SIZE
   is the amount of space within which objects can start.  */
95

Jim Blandy's avatar
Jim Blandy committed
96 97 98 99
#define VALIDATE_LISP_STORAGE(address, size)			\
do								\
  {								\
    Lisp_Object val;						\
100
    XSETCONS (val, (char *) address + size);		\
Jim Blandy's avatar
Jim Blandy committed
101 102
    if ((char *) XCONS (val) != (char *) address + size)	\
      {								\
103
	xfree (address);					\
Jim Blandy's avatar
Jim Blandy committed
104 105 106 107
	memory_full ();						\
      }								\
  } while (0)

108
/* Value of _bytes_used, when spare_memory was freed.  */
109

110 111
static __malloc_size_t bytes_used_when_full;

112 113 114
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

115 116 117
#define MARK_STRING(S)		((S)->size |= MARKBIT)
#define UNMARK_STRING(S)	((S)->size &= ~MARKBIT)
#define STRING_MARKED_P(S)	((S)->size & MARKBIT)
118 119 120 121 122 123 124 125 126 127 128

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

#define GC_STRING_BYTES(S)	(STRING_BYTES (S) & ~MARKBIT)
#define GC_STRING_CHARS(S)	((S)->size & ~MARKBIT)

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

Jim Blandy's avatar
Jim Blandy committed
129 130
int consing_since_gc;

131
/* Count the amount of consing of various sorts of space.  */
132

133 134 135 136 137 138 139
int cons_cells_consed;
int floats_consed;
int vector_cells_consed;
int symbols_consed;
int string_chars_consed;
int misc_objects_consed;
int intervals_consed;
140 141 142
int strings_consed;

/* Number of bytes of consing since GC before another GC should be done. */
143

144
int gc_cons_threshold;
Jim Blandy's avatar
Jim Blandy committed
145

146 147
/* Nonzero during GC.  */

Jim Blandy's avatar
Jim Blandy committed
148 149
int gc_in_progress;

150
/* Nonzero means display messages at beginning and end of GC.  */
151

152 153
int garbage_collection_messages;

Jim Blandy's avatar
Jim Blandy committed
154 155 156
#ifndef VIRT_ADDR_VARIES
extern
#endif /* VIRT_ADDR_VARIES */
157
int malloc_sbrk_used;
Jim Blandy's avatar
Jim Blandy committed
158 159 160 161

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

Jim Blandy's avatar
Jim Blandy committed
164
/* Two limits controlling how much undo information to keep.  */
165

Jim Blandy's avatar
Jim Blandy committed
166 167
int undo_limit;
int undo_strong_limit;
Jim Blandy's avatar
Jim Blandy committed
168

169 170 171 172 173
/* 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;
174

175 176 177
/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  */

178 179 180
static char *spare_memory;

/* Amount of spare memory to keep in reserve.  */
181

182 183 184
#define SPARE_MEMORY (1 << 14)

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

186 187
static int malloc_hysteresis;

188 189
/* Non-nil means defun should do purecopy on the function definition.  */

Jim Blandy's avatar
Jim Blandy committed
190 191 192
Lisp_Object Vpurify_flag;

#ifndef HAVE_SHM
193 194 195 196

/* Force it into data space! */

EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,};
Jim Blandy's avatar
Jim Blandy committed
197
#define PUREBEG (char *) pure
198 199 200

#else /* not HAVE_SHM */

Jim Blandy's avatar
Jim Blandy committed
201 202
#define pure PURE_SEG_BITS   /* Use shared memory segment */
#define PUREBEG (char *)PURE_SEG_BITS
Jim Blandy's avatar
Jim Blandy committed
203 204 205

/* This variable is used only by the XPNTR macro when HAVE_SHM is
   defined.  If we used the PURESIZE macro directly there, that would
206
   make most of Emacs dependent on puresize.h, which we don't want -
Jim Blandy's avatar
Jim Blandy committed
207 208 209
   you should be able to change that without too much recompilation.
   So map_in_data initializes pure_size, and the dependencies work
   out.  */
210

211
EMACS_INT pure_size;
212

Jim Blandy's avatar
Jim Blandy committed
213 214
#endif /* not HAVE_SHM */

215 216 217 218 219 220 221 222
/* Value is non-zero if P points into pure space.  */

#define PURE_POINTER_P(P)					\
     (((PNTR_COMPARISON_TYPE) (P)				\
       < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE))	\
      && ((PNTR_COMPARISON_TYPE) (P)				\
	  >= (PNTR_COMPARISON_TYPE) pure))

223 224
/* Index in pure at which next pure object will be allocated.. */

225
int pure_bytes_used;
Jim Blandy's avatar
Jim Blandy committed
226

227 228 229
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

Jim Blandy's avatar
Jim Blandy committed
230 231
char *pending_malloc_warning;

232
/* Pre-computed signal argument for use when memory is exhausted.  */
233

234
Lisp_Object memory_signal_data;
235

Jim Blandy's avatar
Jim Blandy committed
236 237 238 239 240 241 242 243 244 245 246
/* 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;

247 248 249
/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

Jim Blandy's avatar
Jim Blandy committed
250
int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
251

252
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
253

254 255 256
static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
257 258 259 260 261 262 263 264
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));

#ifdef HAVE_WINDOW_SYSTEM
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */

265 266 267 268
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
269 270

extern int message_enable_multibyte;
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287

/* 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,
  MEM_TYPE_VECTOR
};

288
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
289 290 291 292 293 294 295 296 297 298

#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;

299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
#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
{
  struct mem_node *left, *right, *parent;

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

  /* Node color.  */
  enum {MEM_BLACK, MEM_RED} color;
  
  /* 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;

/* Sentinel node of the tree.  */

static struct mem_node mem_z;
#define MEM_NIL &mem_z

357
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
358
static void lisp_free P_ ((POINTER_TYPE *));
359 360 361 362 363 364 365 366 367
static void mark_stack P_ ((void));
static void init_stack P_ ((Lisp_Object *));
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 *));
368
static void mark_maybe_object P_ ((Lisp_Object));
369 370 371 372 373 374 375 376 377 378 379 380 381 382
static void mark_memory P_ ((void *, void *));
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

383
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
384

385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406
/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

/* Addresses of staticpro'd variables.  */

#define NSTATICS 1024
Lisp_Object *staticvec[NSTATICS] = {0};

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

#define ALIGN(SZ, ALIGNMENT) \
  (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1))

Jim Blandy's avatar
Jim Blandy committed
407

408 409 410 411 412 413
/************************************************************************
				Malloc
 ************************************************************************/

/* Write STR to Vstandard_output plus some advice on how to free some
   memory.  Called when memory gets low.  */
414

Jim Blandy's avatar
Jim Blandy committed
415 416 417 418 419 420 421 422 423 424 425
Lisp_Object
malloc_warning_1 (str)
     Lisp_Object str;
{
  Fprinc (str, Vstandard_output);
  write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
  write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
  write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
  return Qnil;
}

426 427 428

/* Function malloc calls this if it finds we are near exhausting
   storage.  */
429 430

void
Jim Blandy's avatar
Jim Blandy committed
431 432 433 434 435 436
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}

437 438 439

/* Display a malloc warning in buffer *Danger*.  */

440
void
Jim Blandy's avatar
Jim Blandy committed
441 442 443 444 445 446 447 448 449
display_malloc_warning ()
{
  register Lisp_Object val;

  val = build_string (pending_malloc_warning);
  pending_malloc_warning = 0;
  internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}

450

451
#ifdef DOUG_LEA_MALLOC
452
#  define BYTES_USED (mallinfo ().arena)
453
#else
454
#  define BYTES_USED _bytes_used
455 456
#endif

457

458
/* Called if malloc returns zero.  */
459

460
void
Jim Blandy's avatar
Jim Blandy committed
461 462
memory_full ()
{
463
#ifndef SYSTEM_MALLOC
464
  bytes_used_when_full = BYTES_USED;
465 466 467 468 469 470 471 472 473
#endif

  /* The first time we get here, free the spare memory.  */
  if (spare_memory)
    {
      free (spare_memory);
      spare_memory = 0;
    }

474 475
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
476
  while (1)
477
    Fsignal (Qnil, memory_signal_data);
478 479
}

480

481 482 483 484 485
/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()
{
486 487 488 489 490 491
  /* 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.  */
492 493 494 495 496

#ifndef REL_ALLOC
  memory_full ();
#endif

497 498
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
499 500
  while (1)
    Fsignal (Qerror, memory_signal_data);
Jim Blandy's avatar
Jim Blandy committed
501 502
}

503 504

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

506
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
507
xmalloc (size)
508
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
509
{
510
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
511

512
  BLOCK_INPUT;
513
  val = (POINTER_TYPE *) malloc (size);
514
  UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
515

516 517
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
518 519 520
  return val;
}

521 522 523

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

524
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
525
xrealloc (block, size)
526
     POINTER_TYPE *block;
527
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
528
{
529
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
530

531
  BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
532 533 534
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
535
    val = (POINTER_TYPE *) malloc (size);
Noah Friedman's avatar
Noah Friedman committed
536
  else
537
    val = (POINTER_TYPE *) realloc (block, size);
538
  UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
539 540 541 542

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

544 545 546

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

547 548
void
xfree (block)
549
     POINTER_TYPE *block;
550 551 552 553 554 555
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
}

556

557 558 559 560 561 562
/* Like strdup, but uses xmalloc.  */

char *
xstrdup (s)
     char *s;
{
563
  size_t len = strlen (s) + 1;
564 565 566 567 568 569
  char *p = (char *) xmalloc (len);
  bcopy (s, p, len);
  return p;
}


570 571 572 573
/* 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, ...).  */

574
static POINTER_TYPE *
575
lisp_malloc (nbytes, type)
576
     size_t nbytes;
577
     enum mem_type type;
578
{
579
  register void *val;
580 581

  BLOCK_INPUT;
582 583 584 585 586

#ifdef GC_MALLOC_CHECK
  allocated_mem_type = type;
#endif
  
587
  val = (void *) malloc (nbytes);
588

589
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
590
  if (val && type != MEM_TYPE_NON_LISP)
591 592
    mem_insert (val, (char *) val + nbytes, type);
#endif
593
   
594 595 596
  UNBLOCK_INPUT;
  if (!val && nbytes)
    memory_full ();
597 598 599
  return val;
}

600 601 602 603 604 605 606 607 608 609 610 611 612 613 614

/* Return a new buffer structure allocated from the heap with
   a call to lisp_malloc.  */

struct buffer *
allocate_buffer ()
{
  return (struct buffer *) lisp_malloc (sizeof (struct buffer),
					MEM_TYPE_BUFFER);
}


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

615
static void
616
lisp_free (block)
617
     POINTER_TYPE *block;
618 619 620
{
  BLOCK_INPUT;
  free (block);
621
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
622 623
  mem_delete (mem_find (block));
#endif
624 625
  UNBLOCK_INPUT;
}
626

627 628 629 630 631 632 633 634 635 636 637 638

/* Arranging to disable input signals while we're in malloc.

   This only works with GNU malloc.  To help out systems which can't
   use GNU malloc, all the calls to malloc, realloc, and free
   elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
   pairs; unfortunately, we have no idea what C library functions
   might call malloc, so we can't really protect them unless you're
   using GNU malloc.  Fortunately, most of the major operating can use
   GNU malloc.  */

#ifndef SYSTEM_MALLOC
639 640 641 642 643 644
#ifndef DOUG_LEA_MALLOC
extern void * (*__malloc_hook) P_ ((size_t));
extern void * (*__realloc_hook) P_ ((void *, size_t));
extern void (*__free_hook) P_ ((void *));
/* Else declared in malloc.h, perhaps with an extra arg.  */
#endif /* DOUG_LEA_MALLOC */
645 646 647
static void * (*old_malloc_hook) ();
static void * (*old_realloc_hook) ();
static void (*old_free_hook) ();
648

649 650
/* This function is used as the hook for free to call.  */

651 652 653 654 655
static void
emacs_blocked_free (ptr)
     void *ptr;
{
  BLOCK_INPUT;
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675

#ifdef GC_MALLOC_CHECK
  {
    struct mem_node *m;
  
    m = mem_find (ptr);
    if (m == MEM_NIL || m->start != ptr)
      {
	fprintf (stderr,
		 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
	abort ();
      }
    else
      {
	/* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
	mem_delete (m);
      }
  }
#endif /* GC_MALLOC_CHECK */
  
676 677
  __free_hook = old_free_hook;
  free (ptr);
678
  
679 680 681 682 683 684 685 686 687
  /* If we released our reserve (due to running out of memory),
     and we have a fair amount free once again,
     try to set aside another reserve in case we run out once more.  */
  if (spare_memory == 0
      /* Verify there is enough space that even with the malloc
	 hysteresis this call won't run out again.
	 The code here is correct as long as SPARE_MEMORY
	 is substantially larger than the block size malloc uses.  */
      && (bytes_used_when_full
688
	  > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
689
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
690

691
  __free_hook = emacs_blocked_free;
692 693 694
  UNBLOCK_INPUT;
}

695

696 697 698 699 700 701 702 703 704 705
/* If we released our reserve (due to running out of memory),
   and we have a fair amount free once again,
   try to set aside another reserve in case we run out once more.

   This is called when a relocatable block is freed in ralloc.c.  */

void
refill_memory_reserve ()
{
  if (spare_memory == 0)
706
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
707 708
}

709

710 711
/* This function is the malloc hook that Emacs uses.  */

712 713
static void *
emacs_blocked_malloc (size)
714
     size_t size;
715 716 717 718 719
{
  void *value;

  BLOCK_INPUT;
  __malloc_hook = old_malloc_hook;
720
#ifdef DOUG_LEA_MALLOC
721
    mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
722
#else
723
    __malloc_extra_blocks = malloc_hysteresis;
724
#endif
725

726
  value = (void *) malloc (size);
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748

#ifdef GC_MALLOC_CHECK
  {
    struct mem_node *m = mem_find (value);
    if (m != MEM_NIL)
      {
	fprintf (stderr, "Malloc returned %p which is already in use\n",
		 value);
	fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
		 m->start, m->end, (char *) m->end - (char *) m->start,
		 m->type);
	abort ();
      }

    if (!dont_register_blocks)
      {
	mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
	allocated_mem_type = MEM_TYPE_NON_LISP;
      }
  }
#endif /* GC_MALLOC_CHECK */
  
749
  __malloc_hook = emacs_blocked_malloc;
750 751
  UNBLOCK_INPUT;

752
  /* fprintf (stderr, "%p malloc\n", value); */
753 754 755
  return value;
}

756 757 758

/* This function is the realloc hook that Emacs uses.  */

759 760 761
static void *
emacs_blocked_realloc (ptr, size)
     void *ptr;
762
     size_t size;
763 764 765 766 767
{
  void *value;

  BLOCK_INPUT;
  __realloc_hook = old_realloc_hook;
768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789

#ifdef GC_MALLOC_CHECK
  if (ptr)
    {
      struct mem_node *m = mem_find (ptr);
      if (m == MEM_NIL || m->start != ptr)
	{
	  fprintf (stderr,
		   "Realloc of %p which wasn't allocated with malloc\n",
		   ptr);
	  abort ();
	}

      mem_delete (m);
    }
  
  /* fprintf (stderr, "%p -> realloc\n", ptr); */
  
  /* Prevent malloc from registering blocks.  */
  dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */

790
  value = (void *) realloc (ptr, size);
791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809

#ifdef GC_MALLOC_CHECK
  dont_register_blocks = 0;

  {
    struct mem_node *m = mem_find (value);
    if (m != MEM_NIL)
      {
	fprintf (stderr, "Realloc returns memory that is already in use\n");
	abort ();
      }

    /* Can't handle zero size regions in the red-black tree.  */
    mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
  }
  
  /* fprintf (stderr, "%p <- realloc\n", value); */
#endif /* GC_MALLOC_CHECK */
  
810
  __realloc_hook = emacs_blocked_realloc;
811 812 813 814 815
  UNBLOCK_INPUT;

  return value;
}

816 817 818

/* Called from main to set up malloc to use our hooks.  */

819 820 821
void
uninterrupt_malloc ()
{
822 823
  if (__free_hook != emacs_blocked_free)
    old_free_hook = __free_hook;
824
  __free_hook = emacs_blocked_free;
825

826 827
  if (__malloc_hook != emacs_blocked_malloc)
    old_malloc_hook = __malloc_hook;
828
  __malloc_hook = emacs_blocked_malloc;
829

830 831
  if (__realloc_hook != emacs_blocked_realloc)
    old_realloc_hook = __realloc_hook;
832
  __realloc_hook = emacs_blocked_realloc;
833
}
834 835 836 837

#endif /* not SYSTEM_MALLOC */


Jim Blandy's avatar
Jim Blandy committed
838

839 840 841
/***********************************************************************
			 Interval Allocation
 ***********************************************************************/
842

843 844 845
/* Number of intervals allocated in an interval_block structure.
   The 1020 is 1024 minus malloc overhead.  */

846 847 848
#define INTERVAL_BLOCK_SIZE \
  ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))

849 850 851
/* Intervals are allocated in chunks in form of an interval_block
   structure.  */

852
struct interval_block
853 854 855 856
{
  struct interval_block *next;
  struct interval intervals[INTERVAL_BLOCK_SIZE];
};
857

858 859 860
/* Current interval block.  Its `next' pointer points to older
   blocks.  */

861
struct interval_block *interval_block;
862 863 864 865

/* Index in interval_block above of the next unused interval
   structure.  */

866
static int interval_block_index;
867 868 869

/* Number of free and live intervals.  */

870
static int total_free_intervals, total_intervals;
871

872 873
/* List of free intervals.  */

874 875
INTERVAL interval_free_list;

876
/* Total number of interval blocks now in use.  */
877

878 879
int n_interval_blocks;

880 881 882

/* Initialize interval allocation.  */

883 884 885 886
static void
init_intervals ()
{
  interval_block
887 888
    = (struct interval_block *) lisp_malloc (sizeof *interval_block,
					     MEM_TYPE_NON_LISP);
889
  interval_block->next = 0;
Richard M. Stallman's avatar
Richard M. Stallman committed
890
  bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
891 892
  interval_block_index = 0;
  interval_free_list = 0;
893
  n_interval_blocks = 1;
894 895
}

896 897

/* Return a new interval.  */
898 899 900 901 902 903 904 905 906

INTERVAL
make_interval ()
{
  INTERVAL val;

  if (interval_free_list)
    {
      val = interval_free_list;
907
      interval_free_list = INTERVAL_PARENT (interval_free_list);
908 909 910 911 912
    }
  else
    {
      if (interval_block_index == INTERVAL_BLOCK_SIZE)
	{
Karl Heuer's avatar
Karl Heuer committed
913 914
	  register struct interval_block *newi;

915 916
	  newi = (struct interval_block *) lisp_malloc (sizeof *newi,
							MEM_TYPE_NON_LISP);
917 918 919 920 921

	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
	  newi->next = interval_block;
	  interval_block = newi;
	  interval_block_index = 0;
922
	  n_interval_blocks++;
923 924 925 926
	}
      val = &interval_block->intervals[interval_block_index++];
    }
  consing_since_gc += sizeof (struct interval);
927
  intervals_consed++;
928 929 930 931
  RESET_INTERVAL (val);
  return val;
}

932 933

/* Mark Lisp objects in interval I. */
934 935

static void
936
mark_interval (i, dummy)
937
     register INTERVAL i;
938
     Lisp_Object dummy;
939 940 941 942 943 944 945
{
  if (XMARKBIT (i->plist))
    abort ();
  mark_object (&i->plist);
  XMARK (i->plist);
}

946 947 948 949

/* Mark the interval tree rooted in TREE.  Don't call this directly;
   use the macro MARK_INTERVAL_TREE instead.  */

950 951 952 953
static void
mark_interval_tree (tree)
     register INTERVAL tree;
{
954 955 956 957 958 959
  /* No need to test if this tree has been marked already; this
     function is always called through the MARK_INTERVAL_TREE macro,
     which takes care of that.  */

  /* XMARK expands to an assignment; the LHS of an assignment can't be
     a cast.  */
960
  XMARK (tree->up.obj);
961

962
  traverse_intervals (tree, 1, 0, mark_interval, Qnil);
963 964
}

965 966 967

/* Mark the interval tree rooted in I.  */

968 969 970
#define MARK_INTERVAL_TREE(i)				\
  do {							\
    if (!NULL_INTERVAL_P (i)				\
971
	&& ! XMARKBIT (i->up.obj))			\
972 973
      mark_interval_tree (i);				\
  } while (0)
974

975

976
/* The oddity in the call to XUNMARK is necessary because XUNMARK
977 978 979 980 981 982 983
   expands to an assignment to its argument, and most C compilers
   don't support casts on the left operand of `='.  */

#define UNMARK_BALANCE_INTERVALS(i)			\
  do {							\
   if (! NULL_INTERVAL_P (i))				\
     {							\
984
       XUNMARK ((i)->up.obj);				\
985 986 987
       (i) = balance_intervals (i);			\
     }							\
  } while (0)
988

989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002

/* Number support.  If NO_UNION_TYPE isn't in effect, we
   can't create number objects in macros.  */
#ifndef make_number
Lisp_Object
make_number (n)
     int n;
{
  Lisp_Object obj;
  obj.s.val = n;
  obj.s.type = Lisp_Int;
  return obj;
}
#endif
1003

1004 1005 1006
/***********************************************************************
			  String Allocation
 ***********************************************************************/
1007

1008 1009 1010 1011 1012 1013
/* Lisp_Strings are allocated in string_block structures.  When a new
   string_block is allocated, all the Lisp_Strings it contains are
   added to a free-list stiing_free_list.  When a new Lisp_String is
   needed, it is taken from that list.  During the sweep phase of GC,
   string_blocks that are entirely free are freed, except two which
   we keep.
Jim Blandy's avatar
Jim Blandy committed
1014

1015 1016 1017
   String data is allocated from sblock structures.  Strings larger
   than LARGE_STRING_BYTES, get their own sblock, data for smaller
   strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
Jim Blandy's avatar
Jim Blandy committed
1018

1019 1020 1021 1022
   Sblocks consist internally of sdata structures, one for each
   Lisp_String.  The sdata structure points to the Lisp_String it
   belongs to.  The Lisp_String points back to the `u.data' member of
   its sdata structure.
Jim Blandy's avatar
Jim Blandy committed
1023

1024 1025 1026 1027 1028 1029
   When a Lisp_String is freed during GC, it is put back on
   string_free_list, and its `data' member and its sdata's `string'
   pointer is set to null.  The size of the string is recorded in the
   `u.nbytes' member of the sdata.  So, sdata structures that are no
   longer used, can be easily recognized, and it's easy to compact the
   sblocks of small strings which we do in compact_small_strings.  */
Jim Blandy's avatar
Jim Blandy committed
1030

1031 1032
/* Size in bytes of an sblock structure used for small strings.  This
   is 8192 minus malloc overhead.  */
Jim Blandy's avatar
Jim Blandy committed
1033

1034
#define SBLOCK_SIZE 8188
1035

1036 1037
/* Strings larger than this are considered large strings.  String data
   for large strings is allocated from individual sblocks.  */
Jim Blandy's avatar
Jim Blandy committed
1038

1039 1040 1041 1042 1043 1044
#define LARGE_STRING_BYTES 1024

/* Structure describing string memory sub-allocated from an sblock.
   This is where the contents of Lisp strings are stored.  */

struct sdata
Jim Blandy's avatar
Jim Blandy committed
1045
{
1046 1047
  /* Back-pointer to the string this sdata belongs to.  If null, this
     structure is free, and the NBYTES member of the union below
1048
     contains the string's byte size (the same value that STRING_BYTES
1049 1050 1051 1052
     would return if STRING were non-null).  If non-null, STRING_BYTES
     (STRING) is the size of the data, and DATA contains the string's
     contents.  */
  struct Lisp_String *string;
Jim Blandy's avatar
Jim Blandy committed
1053

1054 1055 1056 1057 1058 1059 1060 1061 1062 1063
#ifdef GC_CHECK_STRING_BYTES
  
  EMACS_INT nbytes;
  unsigned char data[1];
  
#define SDATA_NBYTES(S)	(S)->nbytes
#define SDATA_DATA(S)	(S)->data
  
#else /* not GC_CHECK_STRING_BYTES */

1064 1065 1066 1067 1068 1069 1070 1071
  union
  {
    /* When STRING in non-null.  */
    unsigned char data[1];

    /* When STRING is null.  */
    EMACS_INT nbytes;
  } u;
1072 1073 1074 1075 1076 1077
  

#define SDATA_NBYTES(S)	(S)->u.nbytes
#define SDATA_DATA(S)	(S)->u.data

#endif /* not GC_CHECK_STRING_BYTES */
1078 1079
};

1080

1081 1082 1083 1084 1085 1086
/* Structure describing a block of memory which is sub-allocated to
   obtain string data memory for strings.  Blocks for small strings
   are of fixed size SBLOCK_SIZE.  Blocks for large strings are made
   as large as needed.  */

struct sblock
Jim Blandy's avatar
Jim Blandy committed
1087
{
1088 1089
  /* Next in list.  */
  struct sblock *next;
Jim Blandy's avatar
Jim Blandy committed
1090

1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108
  /* Pointer to the next free sdata block.  This points past the end
     of the sblock if there isn't any space left in this block.  */
  struct sdata *next_free;

  /* Start of data.  */
  struct sdata first_data;
};

/* Number of Lisp strings in a string_block structure.  The 1020 is
   1024 minus malloc overhead.  */

#define STRINGS_IN_STRING_BLOCK \
  ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))

/* Structure describing a block from which Lisp_String structures
   are allocated.  */

struct string_block
Jim Blandy's avatar
Jim Blandy committed
1109
{
1110 1111 1112
  struct string_block *next;
  struct Lisp_String strings[STRINGS_IN_STRING_BLOCK];
};
Jim Blandy's avatar
Jim Blandy committed
1113

1114 1115 1116
/* Head and tail of the list of sblock structures holding Lisp string
   data.  We always allocate from current_sblock.  The NEXT pointers
   in the sblock structures go from oldest_sblock to current_sblock.  */