alloc.c 124 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 30 31
/* 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.  */
32

33
#undef HIDE_LISP_IMPLEMENTATION
Jim Blandy's avatar
Jim Blandy committed
34
#include "lisp.h"
35
#include "intervals.h"
Jim Blandy's avatar
Jim Blandy committed
36
#include "puresize.h"
Jim Blandy's avatar
Jim Blandy committed
37 38
#include "buffer.h"
#include "window.h"
39
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
40
#include "frame.h"
41
#include "blockinput.h"
42
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
43
#include "syssignal.h"
44
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
45

46 47 48 49 50
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
extern POINTER_TYPE *sbrk ();
#endif
Karl Heuer's avatar
Karl Heuer committed
51

52
#ifdef DOUG_LEA_MALLOC
53

54 55
#include <malloc.h>
#define __malloc_size_t int
56

57 58 59
/* Specify maximum number of areas to mmap.  It would be nice to use a
   value that explicitly means "no limit".  */

60 61
#define MMAP_MAX_AREAS 100000000

62 63
#else /* not DOUG_LEA_MALLOC */

64 65
/* The following come from gmalloc.c.  */

66
#if defined (STDC_HEADERS)
67 68 69 70 71 72 73
#include <stddef.h>
#define	__malloc_size_t		size_t
#else
#define	__malloc_size_t		unsigned int
#endif
extern __malloc_size_t _bytes_used;
extern int __malloc_extra_blocks;
74 75

#endif /* not DOUG_LEA_MALLOC */
76

Jim Blandy's avatar
Jim Blandy committed
77
#define max(A,B) ((A) > (B) ? (A) : (B))
78
#define min(A,B) ((A) < (B) ? (A) : (B))
Jim Blandy's avatar
Jim Blandy committed
79 80 81 82 83

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

Jim Blandy's avatar
Jim Blandy committed
85 86 87 88
#define VALIDATE_LISP_STORAGE(address, size)			\
do								\
  {								\
    Lisp_Object val;						\
89
    XSETCONS (val, (char *) address + size);		\
Jim Blandy's avatar
Jim Blandy committed
90 91
    if ((char *) XCONS (val) != (char *) address + size)	\
      {								\
92
	xfree (address);					\
Jim Blandy's avatar
Jim Blandy committed
93 94 95 96
	memory_full ();						\
      }								\
  } while (0)

97
/* Value of _bytes_used, when spare_memory was freed.  */
98

99 100
static __malloc_size_t bytes_used_when_full;

101 102 103
/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

104 105 106
#define MARK_STRING(S)		((S)->size |= MARKBIT)
#define UNMARK_STRING(S)	((S)->size &= ~MARKBIT)
#define STRING_MARKED_P(S)	((S)->size & MARKBIT)
107 108 109 110 111 112 113 114 115 116 117

/* 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
118 119
int consing_since_gc;

120
/* Count the amount of consing of various sorts of space.  */
121

122 123 124 125 126 127 128
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;
129 130 131
int strings_consed;

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

133
int gc_cons_threshold;
Jim Blandy's avatar
Jim Blandy committed
134

135 136
/* Nonzero during GC.  */

Jim Blandy's avatar
Jim Blandy committed
137 138
int gc_in_progress;

139
/* Nonzero means display messages at beginning and end of GC.  */
140

141 142
int garbage_collection_messages;

Jim Blandy's avatar
Jim Blandy committed
143 144 145
#ifndef VIRT_ADDR_VARIES
extern
#endif /* VIRT_ADDR_VARIES */
146
int malloc_sbrk_used;
Jim Blandy's avatar
Jim Blandy committed
147 148 149 150

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

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

Jim Blandy's avatar
Jim Blandy committed
155 156
int undo_limit;
int undo_strong_limit;
Jim Blandy's avatar
Jim Blandy committed
157

158 159 160 161 162
/* 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;
163

164 165 166
/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  */

167 168 169
static char *spare_memory;

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

171 172 173
#define SPARE_MEMORY (1 << 14)

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

175 176
static int malloc_hysteresis;

177 178
/* Non-nil means defun should do purecopy on the function definition.  */

Jim Blandy's avatar
Jim Blandy committed
179 180 181
Lisp_Object Vpurify_flag;

#ifndef HAVE_SHM
182 183 184 185

/* Force it into data space! */

EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,};
Jim Blandy's avatar
Jim Blandy committed
186
#define PUREBEG (char *) pure
187 188 189

#else /* not HAVE_SHM */

Jim Blandy's avatar
Jim Blandy committed
190 191
#define pure PURE_SEG_BITS   /* Use shared memory segment */
#define PUREBEG (char *)PURE_SEG_BITS
Jim Blandy's avatar
Jim Blandy committed
192 193 194

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

200
EMACS_INT pure_size;
201

Jim Blandy's avatar
Jim Blandy committed
202 203
#endif /* not HAVE_SHM */

204 205 206 207 208 209 210 211
/* 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))

212 213
/* Index in pure at which next pure object will be allocated.. */

Jim Blandy's avatar
Jim Blandy committed
214 215
int pureptr;

216 217 218
/* If nonzero, this is a warning delivered by malloc and not yet
   displayed.  */

Jim Blandy's avatar
Jim Blandy committed
219 220
char *pending_malloc_warning;

221
/* Pre-computed signal argument for use when memory is exhausted.  */
222

223
Lisp_Object memory_signal_data;
224

Jim Blandy's avatar
Jim Blandy committed
225 226 227 228 229 230 231 232 233 234 235
/* 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;

236 237 238
/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

Jim Blandy's avatar
Jim Blandy committed
239
int ignore_warnings;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
240

241
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
242

243 244 245
static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
246 247 248 249 250 251 252 253
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 */

254 255 256 257
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
258 259

extern int message_enable_multibyte;
260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276

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

277 278 279 280 281 282 283 284 285 286 287
#if GC_MARK_STACK

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

288
struct mem_node;
289
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
290
static void lisp_free P_ ((POINTER_TYPE *));
291 292 293 294 295 296 297 298 299
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 *));
300
static void mark_maybe_object P_ ((Lisp_Object));
301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316
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

#endif /* GC_MARK_STACK != 0 */

Jim Blandy's avatar
Jim Blandy committed
317

318 319 320 321 322 323
/************************************************************************
				Malloc
 ************************************************************************/

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

Jim Blandy's avatar
Jim Blandy committed
325 326 327 328 329 330 331 332 333 334 335
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;
}

336 337 338

/* Function malloc calls this if it finds we are near exhausting
   storage.  */
339 340

void
Jim Blandy's avatar
Jim Blandy committed
341 342 343 344 345 346
malloc_warning (str)
     char *str;
{
  pending_malloc_warning = str;
}

347 348 349

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

350
void
Jim Blandy's avatar
Jim Blandy committed
351 352 353 354 355 356 357 358 359
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);
}

360

361
#ifdef DOUG_LEA_MALLOC
362
#  define BYTES_USED (mallinfo ().arena)
363
#else
364
#  define BYTES_USED _bytes_used
365 366
#endif

367

368
/* Called if malloc returns zero.  */
369

370
void
Jim Blandy's avatar
Jim Blandy committed
371 372
memory_full ()
{
373
#ifndef SYSTEM_MALLOC
374
  bytes_used_when_full = BYTES_USED;
375 376 377 378 379 380 381 382 383
#endif

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

384 385
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
386
  while (1)
387
    Fsignal (Qnil, memory_signal_data);
388 389
}

390

391 392 393 394 395
/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()
{
396 397 398 399 400 401
  /* 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.  */
402 403 404 405 406

#ifndef REL_ALLOC
  memory_full ();
#endif

407 408
  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
409 410
  while (1)
    Fsignal (Qerror, memory_signal_data);
Jim Blandy's avatar
Jim Blandy committed
411 412
}

413 414

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

416
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
417
xmalloc (size)
418
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
419
{
420
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
421

422
  BLOCK_INPUT;
423
  val = (POINTER_TYPE *) malloc (size);
424
  UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
425

426 427
  if (!val && size)
    memory_full ();
Jim Blandy's avatar
Jim Blandy committed
428 429 430
  return val;
}

431 432 433

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

434
POINTER_TYPE *
Jim Blandy's avatar
Jim Blandy committed
435
xrealloc (block, size)
436
     POINTER_TYPE *block;
437
     size_t size;
Jim Blandy's avatar
Jim Blandy committed
438
{
439
  register POINTER_TYPE *val;
Jim Blandy's avatar
Jim Blandy committed
440

441
  BLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
442 443 444
  /* We must call malloc explicitly when BLOCK is 0, since some
     reallocs don't do this.  */
  if (! block)
445
    val = (POINTER_TYPE *) malloc (size);
Noah Friedman's avatar
Noah Friedman committed
446
  else
447
    val = (POINTER_TYPE *) realloc (block, size);
448
  UNBLOCK_INPUT;
Jim Blandy's avatar
Jim Blandy committed
449 450 451 452

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

454 455 456

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

457 458
void
xfree (block)
459
     POINTER_TYPE *block;
460 461 462 463 464 465
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
}

466

467 468 469 470 471 472
/* Like strdup, but uses xmalloc.  */

char *
xstrdup (s)
     char *s;
{
473
  size_t len = strlen (s) + 1;
474 475 476 477 478 479
  char *p = (char *) xmalloc (len);
  bcopy (s, p, len);
  return p;
}


480 481 482 483
/* 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, ...).  */

484
static POINTER_TYPE *
485
lisp_malloc (nbytes, type)
486
     size_t nbytes;
487
     enum mem_type type;
488
{
489
  register void *val;
490 491

  BLOCK_INPUT;
492
  val = (void *) malloc (nbytes);
493

494
#if GC_MARK_STACK
495
  if (val && type != MEM_TYPE_NON_LISP)
496 497 498
    mem_insert (val, (char *) val + nbytes, type);
#endif
  
499 500 501
  UNBLOCK_INPUT;
  if (!val && nbytes)
    memory_full ();
502 503 504
  return val;
}

505 506 507 508 509 510 511 512 513 514 515 516 517 518 519

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

520
static void
521
lisp_free (block)
522
     POINTER_TYPE *block;
523 524 525
{
  BLOCK_INPUT;
  free (block);
526 527 528
#if GC_MARK_STACK
  mem_delete (mem_find (block));
#endif
529 530
  UNBLOCK_INPUT;
}
531

532 533 534 535 536 537 538 539 540 541 542 543

/* 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
544 545 546 547 548 549
#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 */
550 551 552
static void * (*old_malloc_hook) ();
static void * (*old_realloc_hook) ();
static void (*old_free_hook) ();
553

554 555
/* This function is used as the hook for free to call.  */

556 557 558 559 560 561 562
static void
emacs_blocked_free (ptr)
     void *ptr;
{
  BLOCK_INPUT;
  __free_hook = old_free_hook;
  free (ptr);
563 564 565 566 567 568 569 570 571
  /* 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
572
	  > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
573
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
574

575
  __free_hook = emacs_blocked_free;
576 577 578
  UNBLOCK_INPUT;
}

579

580 581 582 583 584 585 586 587 588 589
/* 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)
590
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
591 592
}

593

594 595
/* This function is the malloc hook that Emacs uses.  */

596 597
static void *
emacs_blocked_malloc (size)
598
     size_t size;
599 600 601 602 603
{
  void *value;

  BLOCK_INPUT;
  __malloc_hook = old_malloc_hook;
604
#ifdef DOUG_LEA_MALLOC
605
    mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
606
#else
607
    __malloc_extra_blocks = malloc_hysteresis;
608
#endif
609
  value = (void *) malloc (size);
610
  __malloc_hook = emacs_blocked_malloc;
611 612 613 614 615
  UNBLOCK_INPUT;

  return value;
}

616 617 618

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

619 620 621
static void *
emacs_blocked_realloc (ptr, size)
     void *ptr;
622
     size_t size;
623 624 625 626 627
{
  void *value;

  BLOCK_INPUT;
  __realloc_hook = old_realloc_hook;
628
  value = (void *) realloc (ptr, size);
629
  __realloc_hook = emacs_blocked_realloc;
630 631 632 633 634
  UNBLOCK_INPUT;

  return value;
}

635 636 637

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

638 639 640
void
uninterrupt_malloc ()
{
641 642
  if (__free_hook != emacs_blocked_free)
    old_free_hook = __free_hook;
643
  __free_hook = emacs_blocked_free;
644

645 646
  if (__malloc_hook != emacs_blocked_malloc)
    old_malloc_hook = __malloc_hook;
647
  __malloc_hook = emacs_blocked_malloc;
648

649 650
  if (__realloc_hook != emacs_blocked_realloc)
    old_realloc_hook = __realloc_hook;
651
  __realloc_hook = emacs_blocked_realloc;
652
}
653 654 655 656

#endif /* not SYSTEM_MALLOC */


Jim Blandy's avatar
Jim Blandy committed
657

658 659 660
/***********************************************************************
			 Interval Allocation
 ***********************************************************************/
661

662 663 664
/* Number of intervals allocated in an interval_block structure.
   The 1020 is 1024 minus malloc overhead.  */

665 666 667
#define INTERVAL_BLOCK_SIZE \
  ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))

668 669 670
/* Intervals are allocated in chunks in form of an interval_block
   structure.  */

671
struct interval_block
672 673 674 675
{
  struct interval_block *next;
  struct interval intervals[INTERVAL_BLOCK_SIZE];
};
676

677 678 679
/* Current interval block.  Its `next' pointer points to older
   blocks.  */

680
struct interval_block *interval_block;
681 682 683 684

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

685
static int interval_block_index;
686 687 688

/* Number of free and live intervals.  */

689
static int total_free_intervals, total_intervals;
690

691 692
/* List of free intervals.  */

693 694
INTERVAL interval_free_list;

695
/* Total number of interval blocks now in use.  */
696

697 698
int n_interval_blocks;

699 700 701

/* Initialize interval allocation.  */

702 703 704 705
static void
init_intervals ()
{
  interval_block
706 707
    = (struct interval_block *) lisp_malloc (sizeof *interval_block,
					     MEM_TYPE_NON_LISP);
708
  interval_block->next = 0;
Richard M. Stallman's avatar
Richard M. Stallman committed
709
  bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
710 711
  interval_block_index = 0;
  interval_free_list = 0;
712
  n_interval_blocks = 1;
713 714
}

715 716

/* Return a new interval.  */
717 718 719 720 721 722 723 724 725

INTERVAL
make_interval ()
{
  INTERVAL val;

  if (interval_free_list)
    {
      val = interval_free_list;
726
      interval_free_list = INTERVAL_PARENT (interval_free_list);
727 728 729 730 731
    }
  else
    {
      if (interval_block_index == INTERVAL_BLOCK_SIZE)
	{
Karl Heuer's avatar
Karl Heuer committed
732 733
	  register struct interval_block *newi;

734 735
	  newi = (struct interval_block *) lisp_malloc (sizeof *newi,
							MEM_TYPE_NON_LISP);
736 737 738 739 740

	  VALIDATE_LISP_STORAGE (newi, sizeof *newi);
	  newi->next = interval_block;
	  interval_block = newi;
	  interval_block_index = 0;
741
	  n_interval_blocks++;
742 743 744 745
	}
      val = &interval_block->intervals[interval_block_index++];
    }
  consing_since_gc += sizeof (struct interval);
746
  intervals_consed++;
747 748 749 750
  RESET_INTERVAL (val);
  return val;
}

751 752

/* Mark Lisp objects in interval I. */
753 754

static void
755
mark_interval (i, dummy)
756
     register INTERVAL i;
757
     Lisp_Object dummy;
758 759 760 761 762 763 764
{
  if (XMARKBIT (i->plist))
    abort ();
  mark_object (&i->plist);
  XMARK (i->plist);
}

765 766 767 768

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

769 770 771 772
static void
mark_interval_tree (tree)
     register INTERVAL tree;
{
773 774 775 776 777 778
  /* 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.  */
779
  XMARK (tree->up.obj);
780

781
  traverse_intervals (tree, 1, 0, mark_interval, Qnil);
782 783
}

784 785 786

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

787 788 789
#define MARK_INTERVAL_TREE(i)				\
  do {							\
    if (!NULL_INTERVAL_P (i)				\
790
	&& ! XMARKBIT (i->up.obj))			\
791 792
      mark_interval_tree (i);				\
  } while (0)
793

794

795
/* The oddity in the call to XUNMARK is necessary because XUNMARK
796 797 798 799 800 801 802
   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))				\
     {							\
803
       XUNMARK ((i)->up.obj);				\
804 805 806
       (i) = balance_intervals (i);			\
     }							\
  } while (0)
807

808 809 810 811 812 813 814 815 816 817 818 819 820 821

/* 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
822

823 824 825
/***********************************************************************
			  String Allocation
 ***********************************************************************/
826

827 828 829 830 831 832
/* 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
833

834 835 836
   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
837

838 839 840 841
   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
842

843 844 845 846 847 848
   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
849

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

853
#define SBLOCK_SIZE 8188
854

855 856
/* 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
857

858 859 860 861 862 863
#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
864
{
865 866
  /* Back-pointer to the string this sdata belongs to.  If null, this
     structure is free, and the NBYTES member of the union below
867
     contains the string's byte size (the same value that STRING_BYTES
868 869 870 871
     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
872

873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888
  union
  {
    /* When STRING in non-null.  */
    unsigned char data[1];

    /* When STRING is null.  */
    EMACS_INT nbytes;
  } u;
};

/* 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
889
{
890 891
  /* Next in list.  */
  struct sblock *next;
Jim Blandy's avatar
Jim Blandy committed
892

893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910
  /* 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
911
{
912 913 914
  struct string_block *next;
  struct Lisp_String strings[STRINGS_IN_STRING_BLOCK];
};
Jim Blandy's avatar
Jim Blandy committed
915

916 917 918
/* 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.  */
Karl Heuer's avatar
Karl Heuer committed
919

920
static struct sblock *oldest_sblock, *current_sblock;
Jim Blandy's avatar
Jim Blandy committed
921

922
/* List of sblocks for large strings.  */
Jim Blandy's avatar
Jim Blandy committed
923

924
static struct sblock *large_sblocks;
Jim Blandy's avatar
Jim Blandy committed
925

926
/* List of string_block structures, and how many there are.  */
Jim Blandy's avatar
Jim Blandy committed
927

928 929
static struct string_block *string_blocks;
static int n_string_blocks;
Jim Blandy's avatar
Jim Blandy committed
930

931
/* Free-list of Lisp_Strings.  */
Jim Blandy's avatar
Jim Blandy committed
932

933
static struct Lisp_String *string_free_list;
Jim Blandy's avatar
Jim Blandy committed
934

935
/* Number of live and free Lisp_Strings.  */
936

937
static int total_strings, total_free_strings;
Jim Blandy's avatar
Jim Blandy committed
938

939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968
/* Number of bytes used by live strings.  */

static int total_string_size;

/* Given a pointer to a Lisp_String S which is on the free-list
   string_free_list, return a pointer to its successor in the
   free-list.  */

#define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))

/* Return a pointer to the sdata structure belonging to Lisp string S.
   S must be live, i.e. S->data must not be null.  S->data is actually
   a pointer to the `u.data' member of its sdata structure; the
   structure starts at a constant offset in front of that.  */
   
#define SDATA_OF_STRING(S) \
     ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))

/* Value is the size of an sdata structure large enough to hold NBYTES
   bytes of string data.  The value returned includes a terminating
   NUL byte, the size of the sdata structure, and padding.  */

#define SDATA_SIZE(NBYTES)			\
     ((sizeof (struct Lisp_String *)		\
       + (NBYTES) + 1				\
       + sizeof (EMACS_INT) - 1)		\
      & ~(sizeof (EMACS_INT) - 1))


/* Initialize string allocation.  Called from init_alloc_once.  */
969 970

void
971
init_strings ()
Jim Blandy's avatar
Jim Blandy committed
972
{
973 974 975 976 977
  total_strings = total_free_strings = total_string_size = 0;
  oldest_sblock = current_sblock = large_sblocks = NULL;
  string_blocks = NULL;
  n_string_blocks = 0;
  string_free_list = NULL;
Jim Blandy's avatar
Jim Blandy committed
978 979
}

980 981 982 983 984

/* Return a new Lisp_String.  */

static struct Lisp_String *
allocate_string ()
Jim Blandy's avatar
Jim Blandy committed
985
{
986
  struct Lisp_String *s;
Jim Blandy's avatar
Jim Blandy committed
987

988 989 990
  /* If the free-list is empty, allocate a new string_block, and
     add all the Lisp_Strings in it to the free-list.  */
  if (string_free_list == NULL)
Jim Blandy's avatar
Jim Blandy committed
991
    {
992 993 994
      struct string_block *b;
      int i;

995
      b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
996 997 998 999 1000 1001 1002
      VALIDATE_LISP_STORAGE (b, sizeof *b);
      bzero (b, sizeof *b);
      b->next = string_blocks;
      string_blocks = b;
      ++n_string_blocks;

      for (i = STRINGS_IN_STRING_BLOCK - 1; i >= 0; --i)
Jim Blandy's avatar
Jim Blandy committed
1003
	{
1004 1005 1006
	  s = b->strings + i;
	  NEXT_FREE_LISP_STRING (s) = string_free_list;
	  string_free_list = s;
Jim Blandy's avatar
Jim Blandy committed
1007
	}
1008 1009

      total_free_strings += STRINGS_IN_STRING_BLOCK;
Jim Blandy's avatar
Jim Blandy committed
1010
    }
1011

1012 1013 1014
  /* Pop a Lisp_String off the free-list.  */
  s = string_free_list;
  string_free_list = NEXT_FREE_LISP_STRING (s);
1015

1016 1017
  /* Probably not strictly necessary, but play it safe.  */
  bzero (s, sizeof *s);
1018

1019 1020 1021 1022
  --total_free_strings;
  ++total_strings;
  ++strings_consed;
  consing_since_gc += sizeof *s;
1023

1024
  return s;
1025
}
Jim Blandy's avatar
Jim Blandy committed
1026 1027


1028 1029 1030 1031 1032