1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
   3       2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4       Free Software Foundation, Inc.
   5 
   6 This file is part of GNU Emacs.
   7 
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12 
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17 
  18 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/>.  */
  20 
  21 #include <config.h>
  22 #include <stdio.h>
  23 #include <limits.h>             /* For CHAR_BIT.  */
  24 #include <setjmp.h>
  25 
  26 #ifdef STDC_HEADERS
  27 #include <stddef.h>             /* For offsetof, used by PSEUDOVECSIZE. */
  28 #endif
  29 
  30 #ifdef ALLOC_DEBUG
  31 #undef INLINE
  32 #endif
  33 
  34 #include <signal.h>
  35 
  36 #ifdef HAVE_GTK_AND_PTHREAD
  37 #include <pthread.h>
  38 #endif
  39 
  40 /* This file is part of the core Lisp implementation, and thus must
  41    deal with the real data structures.  If the Lisp implementation is
  42    replaced, this file likely will not be used.  */
  43 
  44 #undef HIDE_LISP_IMPLEMENTATION
  45 #include "lisp.h"
  46 #include "process.h"
  47 #include "intervals.h"
  48 #include "puresize.h"
  49 #include "buffer.h"
  50 #include "window.h"
  51 #include "keyboard.h"
  52 #include "frame.h"
  53 #include "blockinput.h"
  54 #include "character.h"
  55 #include "syssignal.h"
  56 #include "termhooks.h"          /* For struct terminal.  */
  57 #include <setjmp.h>
  58 
  59 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
  60    memory.  Can do this only if using gmalloc.c.  */
  61 
  62 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
  63 #undef GC_MALLOC_CHECK
  64 #endif
  65 
  66 #ifdef HAVE_UNISTD_H
  67 #include <unistd.h>
  68 #else
  69 extern POINTER_TYPE *sbrk ();
  70 #endif
  71 
  72 #ifdef HAVE_FCNTL_H
  73 #define INCLUDED_FCNTL
  74 #include <fcntl.h>
  75 #endif
  76 #ifndef O_WRONLY
  77 #define O_WRONLY 1
  78 #endif
  79 
  80 #ifdef WINDOWSNT
  81 #include <fcntl.h>
  82 #include "w32.h"
  83 #endif
  84 
  85 #ifdef DOUG_LEA_MALLOC
  86 
  87 #include <malloc.h>
  88 /* malloc.h #defines this as size_t, at least in glibc2.  */
  89 #ifndef __malloc_size_t
  90 #define __malloc_size_t int
  91 #endif
  92 
  93 /* Specify maximum number of areas to mmap.  It would be nice to use a
  94    value that explicitly means "no limit".  */
  95 
  96 #define MMAP_MAX_AREAS 100000000
  97 
  98 #else /* not DOUG_LEA_MALLOC */
  99 
 100 /* The following come from gmalloc.c.  */
 101 
 102 #define __malloc_size_t         size_t
 103 extern __malloc_size_t _bytes_used;
 104 extern __malloc_size_t __malloc_extra_blocks;
 105 
 106 #endif /* not DOUG_LEA_MALLOC */
 107 
 108 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
 109 
 110 /* When GTK uses the file chooser dialog, different backends can be loaded
 111    dynamically.  One such a backend is the Gnome VFS backend that gets loaded
 112    if you run Gnome.  That backend creates several threads and also allocates
 113    memory with malloc.
 114 
 115    If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
 116    functions below are called from malloc, there is a chance that one
 117    of these threads preempts the Emacs main thread and the hook variables
 118    end up in an inconsistent state.  So we have a mutex to prevent that (note
 119    that the backend handles concurrent access to malloc within its own threads
 120    but Emacs code running in the main thread is not included in that control).
 121 
 122    When UNBLOCK_INPUT is called, reinvoke_input_signal may be called.  If this
 123    happens in one of the backend threads we will have two threads that tries
 124    to run Emacs code at once, and the code is not prepared for that.
 125    To prevent that, we only call BLOCK/UNBLOCK from the main thread.  */
 126 
 127 static pthread_mutex_t alloc_mutex;
 128 
 129 #define BLOCK_INPUT_ALLOC                               \
 130   do                                                    \
 131     {                                                   \
 132       if (pthread_equal (pthread_self (), main_thread)) \
 133         BLOCK_INPUT;                                    \
 134       pthread_mutex_lock (&alloc_mutex);                \
 135     }                                                   \
 136   while (0)
 137 #define UNBLOCK_INPUT_ALLOC                             \
 138   do                                                    \
 139     {                                                   \
 140       pthread_mutex_unlock (&alloc_mutex);              \
 141       if (pthread_equal (pthread_self (), main_thread)) \
 142         UNBLOCK_INPUT;                                  \
 143     }                                                   \
 144   while (0)
 145 
 146 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
 147 
 148 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
 149 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
 150 
 151 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
 152 
 153 /* Value of _bytes_used, when spare_memory was freed.  */
 154 
 155 static __malloc_size_t bytes_used_when_full;
 156 
 157 static __malloc_size_t bytes_used_when_reconsidered;
 158 
 159 /* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
 160    to a struct Lisp_String.  */
 161 
 162 #define MARK_STRING(S)          ((S)->size |= ARRAY_MARK_FLAG)
 163 #define UNMARK_STRING(S)        ((S)->size &= ~ARRAY_MARK_FLAG)
 164 #define STRING_MARKED_P(S)      (((S)->size & ARRAY_MARK_FLAG) != 0)
 165 
 166 #define VECTOR_MARK(V)          ((V)->size |= ARRAY_MARK_FLAG)
 167 #define VECTOR_UNMARK(V)        ((V)->size &= ~ARRAY_MARK_FLAG)
 168 #define VECTOR_MARKED_P(V)      (((V)->size & ARRAY_MARK_FLAG) != 0)
 169 
 170 /* Value is the number of bytes/chars of S, a pointer to a struct
 171    Lisp_String.  This must be used instead of STRING_BYTES (S) or
 172    S->size during GC, because S->size contains the mark bit for
 173    strings.  */
 174 
 175 #define GC_STRING_BYTES(S)      (STRING_BYTES (S))
 176 #define GC_STRING_CHARS(S)      ((S)->size & ~ARRAY_MARK_FLAG)
 177 
 178 /* Number of bytes of consing done since the last gc.  */
 179 
 180 int consing_since_gc;
 181 
 182 /* Count the amount of consing of various sorts of space.  */
 183 
 184 EMACS_INT cons_cells_consed;
 185 EMACS_INT floats_consed;
 186 EMACS_INT vector_cells_consed;
 187 EMACS_INT symbols_consed;
 188 EMACS_INT string_chars_consed;
 189 EMACS_INT misc_objects_consed;
 190 EMACS_INT intervals_consed;
 191 EMACS_INT strings_consed;
 192 
 193 /* Minimum number of bytes of consing since GC before next GC. */
 194 
 195 EMACS_INT gc_cons_threshold;
 196 
 197 /* Similar minimum, computed from Vgc_cons_percentage.  */
 198 
 199 EMACS_INT gc_relative_threshold;
 200 
 201 static Lisp_Object Vgc_cons_percentage;
 202 
 203 /* Minimum number of bytes of consing since GC before next GC,
 204    when memory is full.  */
 205 
 206 EMACS_INT memory_full_cons_threshold;
 207 
 208 /* Nonzero during GC.  */
 209 
 210 int gc_in_progress;
 211 
 212 /* Nonzero means abort if try to GC.
 213    This is for code which is written on the assumption that
 214    no GC will happen, so as to verify that assumption.  */
 215 
 216 int abort_on_gc;
 217 
 218 /* Nonzero means display messages at beginning and end of GC.  */
 219 
 220 int garbage_collection_messages;
 221 
 222 #ifndef VIRT_ADDR_VARIES
 223 extern
 224 #endif /* VIRT_ADDR_VARIES */
 225 int malloc_sbrk_used;
 226 
 227 #ifndef VIRT_ADDR_VARIES
 228 extern
 229 #endif /* VIRT_ADDR_VARIES */
 230 int malloc_sbrk_unused;
 231 
 232 /* Number of live and free conses etc.  */
 233 
 234 static int total_conses, total_markers, total_symbols, total_vector_size;
 235 static int total_free_conses, total_free_markers, total_free_symbols;
 236 static int total_free_floats, total_floats;
 237 
 238 /* Points to memory space allocated as "spare", to be freed if we run
 239    out of memory.  We keep one large block, four cons-blocks, and
 240    two string blocks.  */
 241 
 242 static char *spare_memory[7];
 243 
 244 /* Amount of spare memory to keep in large reserve block.  */
 245 
 246 #define SPARE_MEMORY (1 << 14)
 247 
 248 /* Number of extra blocks malloc should get when it needs more core.  */
 249 
 250 static int malloc_hysteresis;
 251 
 252 /* Non-nil means defun should do purecopy on the function definition.  */
 253 
 254 Lisp_Object Vpurify_flag;
 255 
 256 /* Non-nil means we are handling a memory-full error.  */
 257 
 258 Lisp_Object Vmemory_full;
 259 
 260 /* Initialize it to a nonzero value to force it into data space
 261    (rather than bss space).  That way unexec will remap it into text
 262    space (pure), on some systems.  We have not implemented the
 263    remapping on more recent systems because this is less important
 264    nowadays than in the days of small memories and timesharing.  */
 265 
 266 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
 267 #define PUREBEG (char *) pure
 268 
 269 /* Pointer to the pure area, and its size.  */
 270 
 271 static char *purebeg;
 272 static size_t pure_size;
 273 
 274 /* Number of bytes of pure storage used before pure storage overflowed.
 275    If this is non-zero, this implies that an overflow occurred.  */
 276 
 277 static size_t pure_bytes_used_before_overflow;
 278 
 279 /* Value is non-zero if P points into pure space.  */
 280 
 281 #define PURE_POINTER_P(P)                                       \
 282      (((PNTR_COMPARISON_TYPE) (P)                               \
 283        < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
 284       && ((PNTR_COMPARISON_TYPE) (P)                            \
 285           >= (PNTR_COMPARISON_TYPE) purebeg))
 286 
 287 /* Total number of bytes allocated in pure storage. */
 288 
 289 EMACS_INT pure_bytes_used;
 290 
 291 /* Index in pure at which next pure Lisp object will be allocated.. */
 292 
 293 static EMACS_INT pure_bytes_used_lisp;
 294 
 295 /* Number of bytes allocated for non-Lisp objects in pure storage.  */
 296 
 297 static EMACS_INT pure_bytes_used_non_lisp;
 298 
 299 /* If nonzero, this is a warning delivered by malloc and not yet
 300    displayed.  */
 301 
 302 char *pending_malloc_warning;
 303 
 304 /* Pre-computed signal argument for use when memory is exhausted.  */
 305 
 306 Lisp_Object Vmemory_signal_data;
 307 
 308 /* Maximum amount of C stack to save when a GC happens.  */
 309 
 310 #ifndef MAX_SAVE_STACK
 311 #define MAX_SAVE_STACK 16000
 312 #endif
 313 
 314 /* Buffer in which we save a copy of the C stack at each GC.  */
 315 
 316 static char *stack_copy;
 317 static int stack_copy_size;
 318 
 319 /* Non-zero means ignore malloc warnings.  Set during initialization.
 320    Currently not used.  */
 321 
 322 static int ignore_warnings;
 323 
 324 Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
 325 
 326 /* Hook run after GC has finished.  */
 327 
 328 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
 329 
 330 Lisp_Object Vgc_elapsed;        /* accumulated elapsed time in GC  */
 331 EMACS_INT gcs_done;             /* accumulated GCs  */
 332 
 333 static void mark_buffer P_ ((Lisp_Object));
 334 static void mark_terminals P_ ((void));
 335 extern void mark_kboards P_ ((void));
 336 extern void mark_ttys P_ ((void));
 337 extern void mark_backtrace P_ ((void));
 338 static void gc_sweep P_ ((void));
 339 static void mark_glyph_matrix P_ ((struct glyph_matrix *));
 340 static void mark_face_cache P_ ((struct face_cache *));
 341 
 342 #ifdef HAVE_WINDOW_SYSTEM
 343 extern void mark_fringe_data P_ ((void));
 344 #endif /* HAVE_WINDOW_SYSTEM */
 345 
 346 static struct Lisp_String *allocate_string P_ ((void));
 347 static void compact_small_strings P_ ((void));
 348 static void free_large_strings P_ ((void));
 349 static void sweep_strings P_ ((void));
 350 
 351 extern int message_enable_multibyte;
 352 
 353 /* When scanning the C stack for live Lisp objects, Emacs keeps track
 354    of what memory allocated via lisp_malloc is intended for what
 355    purpose.  This enumeration specifies the type of memory.  */
 356 
 357 enum mem_type
 358 {
 359   MEM_TYPE_NON_LISP,
 360   MEM_TYPE_BUFFER,
 361   MEM_TYPE_CONS,
 362   MEM_TYPE_STRING,
 363   MEM_TYPE_MISC,
 364   MEM_TYPE_SYMBOL,
 365   MEM_TYPE_FLOAT,
 366   /* We used to keep separate mem_types for subtypes of vectors such as
 367      process, hash_table, frame, terminal, and window, but we never made
 368      use of the distinction, so it only caused source-code complexity
 369      and runtime slowdown.  Minor but pointless.  */
 370   MEM_TYPE_VECTORLIKE
 371 };
 372 
 373 static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
 374 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
 375 void refill_memory_reserve ();
 376 
 377 
 378 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
 379 
 380 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
 381 #include <stdio.h>              /* For fprintf.  */
 382 #endif
 383 
 384 /* A unique object in pure space used to make some Lisp objects
 385    on free lists recognizable in O(1).  */
 386 
 387 static Lisp_Object Vdead;
 388 
 389 #ifdef GC_MALLOC_CHECK
 390 
 391 enum mem_type allocated_mem_type;
 392 static int dont_register_blocks;
 393 
 394 #endif /* GC_MALLOC_CHECK */
 395 
 396 /* A node in the red-black tree describing allocated memory containing
 397    Lisp data.  Each such block is recorded with its start and end
 398    address when it is allocated, and removed from the tree when it
 399    is freed.
 400 
 401    A red-black tree is a balanced binary tree with the following
 402    properties:
 403 
 404    1. Every node is either red or black.
 405    2. Every leaf is black.
 406    3. If a node is red, then both of its children are black.
 407    4. Every simple path from a node to a descendant leaf contains
 408    the same number of black nodes.
 409    5. The root is always black.
 410 
 411    When nodes are inserted into the tree, or deleted from the tree,
 412    the tree is "fixed" so that these properties are always true.
 413 
 414    A red-black tree with N internal nodes has height at most 2
 415    log(N+1).  Searches, insertions and deletions are done in O(log N).
 416    Please see a text book about data structures for a detailed
 417    description of red-black trees.  Any book worth its salt should
 418    describe them.  */
 419 
 420 struct mem_node
 421 {
 422   /* Children of this node.  These pointers are never NULL.  When there
 423      is no child, the value is MEM_NIL, which points to a dummy node.  */
 424   struct mem_node *left, *right;
 425 
 426   /* The parent of this node.  In the root node, this is NULL.  */
 427   struct mem_node *parent;
 428 
 429   /* Start and end of allocated region.  */
 430   void *start, *end;
 431 
 432   /* Node color.  */
 433   enum {MEM_BLACK, MEM_RED} color;
 434 
 435   /* Memory type.  */
 436   enum mem_type type;
 437 };
 438 
 439 /* Base address of stack.  Set in main.  */
 440 
 441 Lisp_Object *stack_base;
 442 
 443 /* Root of the tree describing allocated Lisp memory.  */
 444 
 445 static struct mem_node *mem_root;
 446 
 447 /* Lowest and highest known address in the heap.  */
 448 
 449 static void *min_heap_address, *max_heap_address;
 450 
 451 /* Sentinel node of the tree.  */
 452 
 453 static struct mem_node mem_z;
 454 #define MEM_NIL &mem_z
 455 
 456 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
 457 static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
 458 static void lisp_free P_ ((POINTER_TYPE *));
 459 static void mark_stack P_ ((void));
 460 static int live_vector_p P_ ((struct mem_node *, void *));
 461 static int live_buffer_p P_ ((struct mem_node *, void *));
 462 static int live_string_p P_ ((struct mem_node *, void *));
 463 static int live_cons_p P_ ((struct mem_node *, void *));
 464 static int live_symbol_p P_ ((struct mem_node *, void *));
 465 static int live_float_p P_ ((struct mem_node *, void *));
 466 static int live_misc_p P_ ((struct mem_node *, void *));
 467 static void mark_maybe_object P_ ((Lisp_Object));
 468 static void mark_memory P_ ((void *, void *, int));
 469 static void mem_init P_ ((void));
 470 static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
 471 static void mem_insert_fixup P_ ((struct mem_node *));
 472 static void mem_rotate_left P_ ((struct mem_node *));
 473 static void mem_rotate_right P_ ((struct mem_node *));
 474 static void mem_delete P_ ((struct mem_node *));
 475 static void mem_delete_fixup P_ ((struct mem_node *));
 476 static INLINE struct mem_node *mem_find P_ ((void *));
 477 
 478 
 479 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
 480 static void check_gcpros P_ ((void));
 481 #endif
 482 
 483 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
 484 
 485 /* Recording what needs to be marked for gc.  */
 486 
 487 struct gcpro *gcprolist;
 488 
 489 /* Addresses of staticpro'd variables.  Initialize it to a nonzero
 490    value; otherwise some compilers put it into BSS.  */
 491 
 492 #define NSTATICS 0x640
 493 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
 494 
 495 /* Index of next unused slot in staticvec.  */
 496 
 497 static int staticidx = 0;
 498 
 499 static POINTER_TYPE *pure_alloc P_ ((size_t, int));
 500 
 501 
 502 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
 503    ALIGNMENT must be a power of 2.  */
 504 
 505 #define ALIGN(ptr, ALIGNMENT) \
 506   ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
 507                      & ~((ALIGNMENT) - 1)))
 508 
 509 
 510 
 511 /************************************************************************
 512                                 Malloc
 513  ************************************************************************/
 514 
 515 /* Function malloc calls this if it finds we are near exhausting storage.  */
 516 
 517 void
 518 malloc_warning (str)
 519      char *str;
 520 {
 521   pending_malloc_warning = str;
 522 }
 523 
 524 
 525 /* Display an already-pending malloc warning.  */
 526 
 527 void
 528 display_malloc_warning ()
 529 {
 530   call3 (intern ("display-warning"),
 531          intern ("alloc"),
 532          build_string (pending_malloc_warning),
 533          intern ("emergency"));
 534   pending_malloc_warning = 0;
 535 }
 536 
 537 
 538 #ifdef DOUG_LEA_MALLOC
 539 #  define BYTES_USED (mallinfo ().uordblks)
 540 #else
 541 #  define BYTES_USED _bytes_used
 542 #endif
 543 
 544 /* Called if we can't allocate relocatable space for a buffer.  */
 545 
 546 void
 547 buffer_memory_full ()
 548 {
 549   /* If buffers use the relocating allocator, no need to free
 550      spare_memory, because we may have plenty of malloc space left
 551      that we could get, and if we don't, the malloc that fails will
 552      itself cause spare_memory to be freed.  If buffers don't use the
 553      relocating allocator, treat this like any other failing
 554      malloc.  */
 555 
 556 #ifndef REL_ALLOC
 557   memory_full ();
 558 #endif
 559 
 560   /* This used to call error, but if we've run out of memory, we could
 561      get infinite recursion trying to build the string.  */
 562   xsignal (Qnil, Vmemory_signal_data);
 563 }
 564 
 565 
 566 #ifdef XMALLOC_OVERRUN_CHECK
 567 
 568 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
 569    and a 16 byte trailer around each block.
 570 
 571    The header consists of 12 fixed bytes + a 4 byte integer contaning the
 572    original block size, while the trailer consists of 16 fixed bytes.
 573 
 574    The header is used to detect whether this block has been allocated
 575    through these functions -- as it seems that some low-level libc
 576    functions may bypass the malloc hooks.
 577 */
 578 
 579 
 580 #define XMALLOC_OVERRUN_CHECK_SIZE 16
 581 
 582 static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
 583   { 0x9a, 0x9b, 0xae, 0xaf,
 584     0xbf, 0xbe, 0xce, 0xcf,
 585     0xea, 0xeb, 0xec, 0xed };
 586 
 587 static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
 588   { 0xaa, 0xab, 0xac, 0xad,
 589     0xba, 0xbb, 0xbc, 0xbd,
 590     0xca, 0xcb, 0xcc, 0xcd,
 591     0xda, 0xdb, 0xdc, 0xdd };
 592 
 593 /* Macros to insert and extract the block size in the header.  */
 594 
 595 #define XMALLOC_PUT_SIZE(ptr, size)     \
 596   (ptr[-1] = (size & 0xff),             \
 597    ptr[-2] = ((size >> 8) & 0xff),      \
 598    ptr[-3] = ((size >> 16) & 0xff),     \
 599    ptr[-4] = ((size >> 24) & 0xff))
 600 
 601 #define XMALLOC_GET_SIZE(ptr)                   \
 602   (size_t)((unsigned)(ptr[-1])          |       \
 603            ((unsigned)(ptr[-2]) << 8)   |       \
 604            ((unsigned)(ptr[-3]) << 16)  |       \
 605            ((unsigned)(ptr[-4]) << 24))
 606 
 607 
 608 /* The call depth in overrun_check functions.  For example, this might happen:
 609    xmalloc()
 610      overrun_check_malloc()
 611        -> malloc -> (via hook)_-> emacs_blocked_malloc
 612           -> overrun_check_malloc
 613              call malloc  (hooks are NULL, so real malloc is called).
 614              malloc returns 10000.
 615              add overhead, return 10016.
 616       <- (back in overrun_check_malloc)
 617       add overhead again, return 10032
 618    xmalloc returns 10032.
 619 
 620    (time passes).
 621 
 622    xfree(10032)
 623      overrun_check_free(10032)
 624        decrease overhed
 625        free(10016)  <-  crash, because 10000 is the original pointer.  */
 626 
 627 static int check_depth;
 628 
 629 /* Like malloc, but wraps allocated block with header and trailer.  */
 630 
 631 POINTER_TYPE *
 632 overrun_check_malloc (size)
 633      size_t size;
 634 {
 635   register unsigned char *val;
 636   size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
 637 
 638   val = (unsigned char *) malloc (size + overhead);
 639   if (val && check_depth == 1)
 640     {
 641       bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
 642       val += XMALLOC_OVERRUN_CHECK_SIZE;
 643       XMALLOC_PUT_SIZE(val, size);
 644       bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
 645     }
 646   --check_depth;
 647   return (POINTER_TYPE *)val;
 648 }
 649 
 650 
 651 /* Like realloc, but checks old block for overrun, and wraps new block
 652    with header and trailer.  */
 653 
 654 POINTER_TYPE *
 655 overrun_check_realloc (block, size)
 656      POINTER_TYPE *block;
 657      size_t size;
 658 {
 659   register unsigned char *val = (unsigned char *)block;
 660   size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
 661 
 662   if (val
 663       && check_depth == 1
 664       && bcmp (xmalloc_overrun_check_header,
 665                val - XMALLOC_OVERRUN_CHECK_SIZE,
 666                XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
 667     {
 668       size_t osize = XMALLOC_GET_SIZE (val);
 669       if (bcmp (xmalloc_overrun_check_trailer,
 670                 val + osize,
 671                 XMALLOC_OVERRUN_CHECK_SIZE))
 672         abort ();
 673       bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
 674       val -= XMALLOC_OVERRUN_CHECK_SIZE;
 675       bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
 676     }
 677 
 678   val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
 679 
 680   if (val && check_depth == 1)
 681     {
 682       bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
 683       val += XMALLOC_OVERRUN_CHECK_SIZE;
 684       XMALLOC_PUT_SIZE(val, size);
 685       bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
 686     }
 687   --check_depth;
 688   return (POINTER_TYPE *)val;
 689 }
 690 
 691 /* Like free, but checks block for overrun.  */
 692 
 693 void
 694 overrun_check_free (block)
 695      POINTER_TYPE *block;
 696 {
 697   unsigned char *val = (unsigned char *)block;
 698 
 699   ++check_depth;
 700   if (val
 701       && check_depth == 1
 702       && bcmp (xmalloc_overrun_check_header,
 703                val - XMALLOC_OVERRUN_CHECK_SIZE,
 704                XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
 705     {
 706       size_t osize = XMALLOC_GET_SIZE (val);
 707       if (bcmp (xmalloc_overrun_check_trailer,
 708                 val + osize,
 709                 XMALLOC_OVERRUN_CHECK_SIZE))
 710         abort ();
 711 #ifdef XMALLOC_CLEAR_FREE_MEMORY
 712       val -= XMALLOC_OVERRUN_CHECK_SIZE;
 713       memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
 714 #else
 715       bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
 716       val -= XMALLOC_OVERRUN_CHECK_SIZE;
 717       bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
 718 #endif
 719     }
 720 
 721   free (val);
 722   --check_depth;
 723 }
 724 
 725 #undef malloc
 726 #undef realloc
 727 #undef free
 728 #define malloc overrun_check_malloc
 729 #define realloc overrun_check_realloc
 730 #define free overrun_check_free
 731 #endif
 732 
 733 #ifdef SYNC_INPUT
 734 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
 735    there's no need to block input around malloc.  */
 736 #define MALLOC_BLOCK_INPUT   ((void)0)
 737 #define MALLOC_UNBLOCK_INPUT ((void)0)
 738 #else
 739 #define MALLOC_BLOCK_INPUT   BLOCK_INPUT
 740 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
 741 #endif
 742 
 743 /* Like malloc but check for no memory and block interrupt input..  */
 744 
 745 POINTER_TYPE *
 746 xmalloc (size)
 747      size_t size;
 748 {
 749   register POINTER_TYPE *val;
 750 
 751   MALLOC_BLOCK_INPUT;
 752   val = (POINTER_TYPE *) malloc (size);
 753   MALLOC_UNBLOCK_INPUT;
 754 
 755   if (!val && size)
 756     memory_full ();
 757   return val;
 758 }
 759 
 760 
 761 /* Like realloc but check for no memory and block interrupt input..  */
 762 
 763 POINTER_TYPE *
 764 xrealloc (block, size)
 765      POINTER_TYPE *block;
 766      size_t size;
 767 {
 768   register POINTER_TYPE *val;
 769 
 770   MALLOC_BLOCK_INPUT;
 771   /* We must call malloc explicitly when BLOCK is 0, since some
 772      reallocs don't do this.  */
 773   if (! block)
 774     val = (POINTER_TYPE *) malloc (size);
 775   else
 776     val = (POINTER_TYPE *) realloc (block, size);
 777   MALLOC_UNBLOCK_INPUT;
 778 
 779   if (!val && size) memory_full ();
 780   return val;
 781 }
 782 
 783 
 784 /* Like free but block interrupt input.  */
 785 
 786 void
 787 xfree (block)
 788      POINTER_TYPE *block;
 789 {
 790   if (!block)
 791     return;
 792   MALLOC_BLOCK_INPUT;
 793   free (block);
 794   MALLOC_UNBLOCK_INPUT;
 795   /* We don't call refill_memory_reserve here
 796      because that duplicates doing so in emacs_blocked_free
 797      and the criterion should go there.  */
 798 }
 799 
 800 
 801 /* Like strdup, but uses xmalloc.  */
 802 
 803 char *
 804 xstrdup (s)
 805      const char *s;
 806 {
 807   size_t len = strlen (s) + 1;
 808   char *p = (char *) xmalloc (len);
 809   bcopy (s, p, len);
 810   return p;
 811 }
 812 
 813 
 814 /* Unwind for SAFE_ALLOCA */
 815 
 816 Lisp_Object
 817 safe_alloca_unwind (arg)
 818      Lisp_Object arg;
 819 {
 820   register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
 821 
 822   p->dogc = 0;
 823   xfree (p->pointer);
 824   p->pointer = 0;
 825   free_misc (arg);
 826   return Qnil;
 827 }
 828 
 829 
 830 /* Like malloc but used for allocating Lisp data.  NBYTES is the
 831    number of bytes to allocate, TYPE describes the intended use of the
 832    allcated memory block (for strings, for conses, ...).  */
 833 
 834 #ifndef USE_LSB_TAG
 835 static void *lisp_malloc_loser;
 836 #endif
 837 
 838 static POINTER_TYPE *
 839 lisp_malloc (nbytes, type)
 840      size_t nbytes;
 841      enum mem_type type;
 842 {
 843   register void *val;
 844 
 845   MALLOC_BLOCK_INPUT;
 846 
 847 #ifdef GC_MALLOC_CHECK
 848   allocated_mem_type = type;
 849 #endif
 850 
 851   val = (void *) malloc (nbytes);
 852 
 853 #ifndef USE_LSB_TAG
 854   /* If the memory just allocated cannot be addressed thru a Lisp
 855      object's pointer, and it needs to be,
 856      that's equivalent to running out of memory.  */
 857   if (val && type != MEM_TYPE_NON_LISP)
 858     {
 859       Lisp_Object tem;
 860       XSETCONS (tem, (char *) val + nbytes - 1);
 861       if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
 862         {
 863           lisp_malloc_loser = val;
 864           free (val);
 865           val = 0;
 866         }
 867     }
 868 #endif
 869 
 870 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
 871   if (val && type != MEM_TYPE_NON_LISP)
 872     mem_insert (val, (char *) val + nbytes, type);
 873 #endif
 874 
 875   MALLOC_UNBLOCK_INPUT;
 876   if (!val && nbytes)
 877     memory_full ();
 878   return val;
 879 }
 880 
 881 /* Free BLOCK.  This must be called to free memory allocated with a
 882    call to lisp_malloc.  */
 883 
 884 static void
 885 lisp_free (block)
 886      POINTER_TYPE *block;
 887 {
 888   MALLOC_BLOCK_INPUT;
 889   free (block);
 890 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
 891   mem_delete (mem_find (block));
 892 #endif
 893   MALLOC_UNBLOCK_INPUT;
 894 }
 895 
 896 /* Allocation of aligned blocks of memory to store Lisp data.              */
 897 /* The entry point is lisp_align_malloc which returns blocks of at most    */
 898 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary.  */
 899 
 900 /* Use posix_memalloc if the system has it and we're using the system's
 901    malloc (because our gmalloc.c routines don't have posix_memalign although
 902    its memalloc could be used).  */
 903 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
 904 #define USE_POSIX_MEMALIGN 1
 905 #endif
 906 
 907 /* BLOCK_ALIGN has to be a power of 2.  */
 908 #define BLOCK_ALIGN (1 << 10)
 909 
 910 /* Padding to leave at the end of a malloc'd block.  This is to give
 911    malloc a chance to minimize the amount of memory wasted to alignment.
 912    It should be tuned to the particular malloc library used.
 913    On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
 914    posix_memalign on the other hand would ideally prefer a value of 4
 915    because otherwise, there's 1020 bytes wasted between each ablocks.
 916    In Emacs, testing shows that those 1020 can most of the time be
 917    efficiently used by malloc to place other objects, so a value of 0 can
 918    still preferable unless you have a lot of aligned blocks and virtually
 919    nothing else.  */
 920 #define BLOCK_PADDING 0
 921 #define BLOCK_BYTES \
 922   (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
 923 
 924 /* Internal data structures and constants.  */
 925 
 926 #define ABLOCKS_SIZE 16
 927 
 928 /* An aligned block of memory.  */
 929 struct ablock
 930 {
 931   union
 932   {
 933     char payload[BLOCK_BYTES];
 934     struct ablock *next_free;
 935   } x;
 936   /* `abase' is the aligned base of the ablocks.  */
 937   /* It is overloaded to hold the virtual `busy' field that counts
 938      the number of used ablock in the parent ablocks.
 939      The first ablock has the `busy' field, the others have the `abase'
 940      field.  To tell the difference, we assume that pointers will have
 941      integer values larger than 2 * ABLOCKS_SIZE.  The lowest bit of `busy'
 942      is used to tell whether the real base of the parent ablocks is `abase'
 943      (if not, the word before the first ablock holds a pointer to the
 944      real base).  */
 945   struct ablocks *abase;
 946   /* The padding of all but the last ablock is unused.  The padding of
 947      the last ablock in an ablocks is not allocated.  */
 948 #if BLOCK_PADDING
 949   char padding[BLOCK_PADDING];
 950 #endif
 951 };
 952 
 953 /* A bunch of consecutive aligned blocks.  */
 954 struct ablocks
 955 {
 956   struct ablock blocks[ABLOCKS_SIZE];
 957 };
 958 
 959 /* Size of the block requested from malloc or memalign.  */
 960 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
 961 
 962 #define ABLOCK_ABASE(block) \
 963   (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE)   \
 964    ? (struct ablocks *)(block)                                  \
 965    : (block)->abase)
 966 
 967 /* Virtual `busy' field.  */
 968 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
 969 
 970 /* Pointer to the (not necessarily aligned) malloc block.  */
 971 #ifdef USE_POSIX_MEMALIGN
 972 #define ABLOCKS_BASE(abase) (abase)
 973 #else
 974 #define ABLOCKS_BASE(abase) \
 975   (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
 976 #endif
 977 
 978 /* The list of free ablock.   */
 979 static struct ablock *free_ablock;
 980 
 981 /* Allocate an aligned block of nbytes.
 982    Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
 983    smaller or equal to BLOCK_BYTES.  */
 984 static POINTER_TYPE *
 985 lisp_align_malloc (nbytes, type)
 986      size_t nbytes;
 987      enum mem_type type;
 988 {
 989   void *base, *val;
 990   struct ablocks *abase;
 991 
 992   eassert (nbytes <= BLOCK_BYTES);
 993 
 994   MALLOC_BLOCK_INPUT;
 995 
 996 #ifdef GC_MALLOC_CHECK
 997   allocated_mem_type = type;
 998 #endif
 999 
1000   if (!free_ablock)
1001     {
1002       int i;
1003       EMACS_INT aligned; /* int gets warning casting to 64-bit pointer.  */
1004 
1005 #ifdef DOUG_LEA_MALLOC
1006       /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
1007          because mapped region contents are not preserved in
1008          a dumped Emacs.  */
1009       mallopt (M_MMAP_MAX, 0);
1010 #endif
1011 
1012 #ifdef USE_POSIX_MEMALIGN
1013       {
1014         int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
1015         if (err)
1016           base = NULL;
1017         abase = base;
1018       }
1019 #else
1020       base = malloc (ABLOCKS_BYTES);
1021       abase = ALIGN (base, BLOCK_ALIGN);
1022 #endif
1023 
1024       if (base == 0)
1025         {
1026           MALLOC_UNBLOCK_INPUT;
1027           memory_full ();
1028         }
1029 
1030       aligned = (base == abase);
1031       if (!aligned)
1032         ((void**)abase)[-1] = base;
1033 
1034 #ifdef DOUG_LEA_MALLOC
1035       /* Back to a reasonable maximum of mmap'ed areas.  */
1036       mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1037 #endif
1038 
1039 #ifndef USE_LSB_TAG
1040       /* If the memory just allocated cannot be addressed thru a Lisp
1041          object's pointer, and it needs to be, that's equivalent to
1042          running out of memory.  */
1043       if (type != MEM_TYPE_NON_LISP)
1044         {
1045           Lisp_Object tem;
1046           char *end = (char *) base + ABLOCKS_BYTES - 1;
1047           XSETCONS (tem, end);
1048           if ((char *) XCONS (tem) != end)
1049             {
1050               lisp_malloc_loser = base;
1051               free (base);
1052               MALLOC_UNBLOCK_INPUT;
1053               memory_full ();
1054             }
1055         }
1056 #endif
1057 
1058       /* Initialize the blocks and put them on the free list.
1059          Is `base' was not properly aligned, we can't use the last block.  */
1060       for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1061         {
1062           abase->blocks[i].abase = abase;
1063           abase->blocks[i].x.next_free = free_ablock;
1064           free_ablock = &abase->blocks[i];
1065         }
1066       ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
1067 
1068       eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
1069       eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
1070       eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1071       eassert (ABLOCKS_BASE (abase) == base);
1072       eassert (aligned == (long) ABLOCKS_BUSY (abase));
1073     }
1074 
1075   abase = ABLOCK_ABASE (free_ablock);
1076   ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
1077   val = free_ablock;
1078   free_ablock = free_ablock->x.next_free;
1079 
1080 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1081   if (val && type != MEM_TYPE_NON_LISP)
1082     mem_insert (val, (char *) val + nbytes, type);
1083 #endif
1084 
1085   MALLOC_UNBLOCK_INPUT;
1086   if (!val && nbytes)
1087     memory_full ();
1088 
1089   eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
1090   return val;
1091 }
1092 
1093 static void
1094 lisp_align_free (block)
1095      POINTER_TYPE *block;
1096 {
1097   struct ablock *ablock = block;
1098   struct ablocks *abase = ABLOCK_ABASE (ablock);
1099 
1100   MALLOC_BLOCK_INPUT;
1101 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1102   mem_delete (mem_find (block));
1103 #endif
1104   /* Put on free list.  */
1105   ablock->x.next_free = free_ablock;
1106   free_ablock = ablock;
1107   /* Update busy count.  */
1108   ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
1109 
1110   if (2 > (long) ABLOCKS_BUSY (abase))
1111     { /* All the blocks are free.  */
1112       int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
1113       struct ablock **tem = &free_ablock;
1114       struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1115 
1116       while (*tem)
1117         {
1118           if (*tem >= (struct ablock *) abase && *tem < atop)
1119             {
1120               i++;
1121               *tem = (*tem)->x.next_free;
1122             }
1123           else
1124             tem = &(*tem)->x.next_free;
1125         }
1126       eassert ((aligned & 1) == aligned);
1127       eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1128 #ifdef USE_POSIX_MEMALIGN
1129       eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1130 #endif
1131       free (ABLOCKS_BASE (abase));
1132     }
1133   MALLOC_UNBLOCK_INPUT;
1134 }
1135 
1136 /* Return a new buffer structure allocated from the heap with
1137    a call to lisp_malloc.  */
1138 
1139 struct buffer *
1140 allocate_buffer ()
1141 {
1142   struct buffer *b
1143     = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1144                                      MEM_TYPE_BUFFER);
1145   b->size = sizeof (struct buffer) / sizeof (EMACS_INT);
1146   XSETPVECTYPE (b, PVEC_BUFFER);
1147   return b;
1148 }
1149 
1150 
1151 #ifndef SYSTEM_MALLOC
1152 
1153 /* Arranging to disable input signals while we're in malloc.
1154 
1155    This only works with GNU malloc.  To help out systems which can't
1156    use GNU malloc, all the calls to malloc, realloc, and free
1157    elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1158    pair; unfortunately, we have no idea what C library functions
1159    might call malloc, so we can't really protect them unless you're
1160    using GNU malloc.  Fortunately, most of the major operating systems
1161    can use GNU malloc.  */
1162 
1163 #ifndef SYNC_INPUT
1164 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1165    there's no need to block input around malloc.  */
1166 
1167 #ifndef DOUG_LEA_MALLOC
1168 extern void * (*__malloc_hook) P_ ((size_t, const void *));
1169 extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
1170 extern void (*__free_hook) P_ ((void *, const void *));
1171 /* Else declared in malloc.h, perhaps with an extra arg.  */
1172 #endif /* DOUG_LEA_MALLOC */
1173 static void * (*old_malloc_hook) P_ ((size_t, const void *));
1174 static void * (*old_realloc_hook) P_ ((void *,  size_t, const void*));
1175 static void (*old_free_hook) P_ ((void*, const void*));
1176 
1177 /* This function is used as the hook for free to call.  */
1178 
1179 static void
1180 emacs_blocked_free (ptr, ptr2)
1181      void *ptr;
1182      const void *ptr2;
1183 {
1184   BLOCK_INPUT_ALLOC;
1185 
1186 #ifdef GC_MALLOC_CHECK
1187   if (ptr)
1188     {
1189       struct mem_node *m;
1190 
1191       m = mem_find (ptr);
1192       if (m == MEM_NIL || m->start != ptr)
1193         {
1194           fprintf (stderr,
1195                    "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1196           abort ();
1197         }
1198       else
1199         {
1200           /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1201           mem_delete (m);
1202         }
1203     }
1204 #endif /* GC_MALLOC_CHECK */
1205 
1206   __free_hook = old_free_hook;
1207   free (ptr);
1208 
1209   /* If we released our reserve (due to running out of memory),
1210      and we have a fair amount free once again,
1211      try to set aside another reserve in case we run out once more.  */
1212   if (! NILP (Vmemory_full)
1213       /* Verify there is enough space that even with the malloc
1214          hysteresis this call won't run out again.
1215          The code here is correct as long as SPARE_MEMORY
1216          is substantially larger than the block size malloc uses.  */
1217       && (bytes_used_when_full
1218           > ((bytes_used_when_reconsidered = BYTES_USED)
1219              + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1220     refill_memory_reserve ();
1221 
1222   __free_hook = emacs_blocked_free;
1223   UNBLOCK_INPUT_ALLOC;
1224 }
1225 
1226 
1227 /* This function is the malloc hook that Emacs uses.  */
1228 
1229 static void *
1230 emacs_blocked_malloc (size, ptr)
1231      size_t size;
1232      const void *ptr;
1233 {
1234   void *value;
1235 
1236   BLOCK_INPUT_ALLOC;
1237   __malloc_hook = old_malloc_hook;
1238 #ifdef DOUG_LEA_MALLOC
1239   /* Segfaults on my system.  --lorentey */
1240   /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1241 #else
1242     __malloc_extra_blocks = malloc_hysteresis;
1243 #endif
1244 
1245   value = (void *) malloc (size);
1246 
1247 #ifdef GC_MALLOC_CHECK
1248   {
1249     struct mem_node *m = mem_find (value);
1250     if (m != MEM_NIL)
1251       {
1252         fprintf (stderr, "Malloc returned %p which is already in use\n",
1253                  value);
1254         fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
1255                  m->start, m->end, (char *) m->end - (char *) m->start,
1256                  m->type);
1257         abort ();
1258       }
1259 
1260     if (!dont_register_blocks)
1261       {
1262         mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1263         allocated_mem_type = MEM_TYPE_NON_LISP;
1264       }
1265   }
1266 #endif /* GC_MALLOC_CHECK */
1267 
1268   __malloc_hook = emacs_blocked_malloc;
1269   UNBLOCK_INPUT_ALLOC;
1270 
1271   /* fprintf (stderr, "%p malloc\n", value); */
1272   return value;
1273 }
1274 
1275 
1276 /* This function is the realloc hook that Emacs uses.  */
1277 
1278 static void *
1279 emacs_blocked_realloc (ptr, size, ptr2)
1280      void *ptr;
1281      size_t size;
1282      const void *ptr2;
1283 {
1284   void *value;
1285 
1286   BLOCK_INPUT_ALLOC;
1287   __realloc_hook = old_realloc_hook;
1288 
1289 #ifdef GC_MALLOC_CHECK
1290   if (ptr)
1291     {
1292       struct mem_node *m = mem_find (ptr);
1293       if (m == MEM_NIL || m->start != ptr)
1294         {
1295           fprintf (stderr,
1296                    "Realloc of %p which wasn't allocated with malloc\n",
1297                    ptr);
1298           abort ();
1299         }
1300 
1301       mem_delete (m);
1302     }
1303 
1304   /* fprintf (stderr, "%p -> realloc\n", ptr); */
1305 
1306   /* Prevent malloc from registering blocks.  */
1307   dont_register_blocks = 1;
1308 #endif /* GC_MALLOC_CHECK */
1309 
1310   value = (void *) realloc (ptr, size);
1311 
1312 #ifdef GC_MALLOC_CHECK
1313   dont_register_blocks = 0;
1314 
1315   {
1316     struct mem_node *m = mem_find (value);
1317     if (m != MEM_NIL)
1318       {
1319         fprintf (stderr, "Realloc returns memory that is already in use\n");
1320         abort ();
1321       }
1322 
1323     /* Can't handle zero size regions in the red-black tree.  */
1324     mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1325   }
1326 
1327   /* fprintf (stderr, "%p <- realloc\n", value); */
1328 #endif /* GC_MALLOC_CHECK */
1329 
1330   __realloc_hook = emacs_blocked_realloc;
1331   UNBLOCK_INPUT_ALLOC;
1332 
1333   return value;
1334 }
1335 
1336 
1337 #ifdef HAVE_GTK_AND_PTHREAD
1338 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1339    normal malloc.  Some thread implementations need this as they call
1340    malloc before main.  The pthread_self call in BLOCK_INPUT_ALLOC then
1341    calls malloc because it is the first call, and we have an endless loop.  */
1342 
1343 void
1344 reset_malloc_hooks ()
1345 {
1346   __free_hook = old_free_hook;
1347   __malloc_hook = old_malloc_hook;
1348   __realloc_hook = old_realloc_hook;
1349 }
1350 #endif /* HAVE_GTK_AND_PTHREAD */
1351 
1352 
1353 /* Called from main to set up malloc to use our hooks.  */
1354 
1355 void
1356 uninterrupt_malloc ()
1357 {
1358 #ifdef HAVE_GTK_AND_PTHREAD
1359 #ifdef DOUG_LEA_MALLOC
1360   pthread_mutexattr_t attr;
1361 
1362   /*  GLIBC has a faster way to do this, but lets keep it portable.
1363       This is according to the Single UNIX Specification.  */
1364   pthread_mutexattr_init (&attr);
1365   pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1366   pthread_mutex_init (&alloc_mutex, &attr);
1367 #else  /* !DOUG_LEA_MALLOC */
1368   /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1369      and the bundled gmalloc.c doesn't require it.  */
1370   pthread_mutex_init (&alloc_mutex, NULL);
1371 #endif /* !DOUG_LEA_MALLOC */
1372 #endif /* HAVE_GTK_AND_PTHREAD */
1373 
1374   if (__free_hook != emacs_blocked_free)
1375     old_free_hook = __free_hook;
1376   __free_hook = emacs_blocked_free;
1377 
1378   if (__malloc_hook != emacs_blocked_malloc)
1379     old_malloc_hook = __malloc_hook;
1380   __malloc_hook = emacs_blocked_malloc;
1381 
1382   if (__realloc_hook != emacs_blocked_realloc)
1383     old_realloc_hook = __realloc_hook;
1384   __realloc_hook = emacs_blocked_realloc;
1385 }
1386 
1387 #endif /* not SYNC_INPUT */
1388 #endif /* not SYSTEM_MALLOC */
1389 
1390 
1391 
1392 /***********************************************************************
1393                          Interval Allocation
1394  ***********************************************************************/
1395 
1396 /* Number of intervals allocated in an interval_block structure.
1397    The 1020 is 1024 minus malloc overhead.  */
1398 
1399 #define INTERVAL_BLOCK_SIZE \
1400   ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1401 
1402 /* Intervals are allocated in chunks in form of an interval_block
1403    structure.  */
1404 
1405 struct interval_block
1406 {
1407   /* Place `intervals' first, to preserve alignment.  */
1408   struct interval intervals[INTERVAL_BLOCK_SIZE];
1409   struct interval_block *next;
1410 };
1411 
1412 /* Current interval block.  Its `next' pointer points to older
1413    blocks.  */
1414 
1415 static struct interval_block *interval_block;
1416 
1417 /* Index in interval_block above of the next unused interval
1418    structure.  */
1419 
1420 static int interval_block_index;
1421 
1422 /* Number of free and live intervals.  */
1423 
1424 static int total_free_intervals, total_intervals;
1425 
1426 /* List of free intervals.  */
1427 
1428 INTERVAL interval_free_list;
1429 
1430 /* Total number of interval blocks now in use.  */
1431 
1432 static int n_interval_blocks;
1433 
1434 
1435 /* Initialize interval allocation.  */
1436 
1437 static void
1438 init_intervals ()
1439 {
1440   interval_block = NULL;
1441   interval_block_index = INTERVAL_BLOCK_SIZE;
1442   interval_free_list = 0;
1443   n_interval_blocks = 0;
1444 }
1445 
1446 
1447 /* Return a new interval.  */
1448 
1449 INTERVAL
1450 make_interval ()
1451 {
1452   INTERVAL val;
1453 
1454   /* eassert (!handling_signal); */
1455 
1456   MALLOC_BLOCK_INPUT;
1457 
1458   if (interval_free_list)
1459     {
1460       val = interval_free_list;
1461       interval_free_list = INTERVAL_PARENT (interval_free_list);
1462     }
1463   else
1464     {
1465       if (interval_block_index == INTERVAL_BLOCK_SIZE)
1466         {
1467           register struct interval_block *newi;
1468 
1469           newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1470                                                         MEM_TYPE_NON_LISP);
1471 
1472           newi->next = interval_block;
1473           interval_block = newi;
1474           interval_block_index = 0;
1475           n_interval_blocks++;
1476         }
1477       val = &interval_block->intervals[interval_block_index++];
1478     }
1479 
1480   MALLOC_UNBLOCK_INPUT;
1481 
1482   consing_since_gc += sizeof (struct interval);
1483   intervals_consed++;
1484   RESET_INTERVAL (val);
1485   val->gcmarkbit = 0;
1486   return val;
1487 }
1488 
1489 
1490 /* Mark Lisp objects in interval I. */
1491 
1492 static void
1493 mark_interval (i, dummy)
1494      register INTERVAL i;
1495      Lisp_Object dummy;
1496 {
1497   eassert (!i->gcmarkbit);              /* Intervals are never shared.  */
1498   i->gcmarkbit = 1;
1499   mark_object (i->plist);
1500 }
1501 
1502 
1503 /* Mark the interval tree rooted in TREE.  Don't call this directly;
1504    use the macro MARK_INTERVAL_TREE instead.  */
1505 
1506 static void
1507 mark_interval_tree (tree)
1508      register INTERVAL tree;
1509 {
1510   /* No need to test if this tree has been marked already; this
1511      function is always called through the MARK_INTERVAL_TREE macro,
1512      which takes care of that.  */
1513 
1514   traverse_intervals_noorder (tree, mark_interval, Qnil);
1515 }
1516 
1517 
1518 /* Mark the interval tree rooted in I.  */
1519 
1520 #define MARK_INTERVAL_TREE(i)                           \
1521   do {                                                  \
1522     if (!NULL_INTERVAL_P (i) && !i->gcmarkbit)          \
1523       mark_interval_tree (i);                           \
1524   } while (0)
1525 
1526 
1527 #define UNMARK_BALANCE_INTERVALS(i)                     \
1528   do {                                                  \
1529    if (! NULL_INTERVAL_P (i))                           \
1530      (i) = balance_intervals (i);                       \
1531   } while (0)
1532 
1533 
1534 /* Number support.  If USE_LISP_UNION_TYPE is in effect, we
1535    can't create number objects in macros.  */
1536 #ifndef make_number
1537 Lisp_Object
1538 make_number (n)
1539      EMACS_INT n;
1540 {
1541   Lisp_Object obj;
1542   obj.s.val = n;
1543   obj.s.type = Lisp_Int;
1544   return obj;
1545 }
1546 #endif
1547 
1548 /***********************************************************************
1549                           String Allocation
1550  ***********************************************************************/
1551 
1552 /* Lisp_Strings are allocated in string_block structures.  When a new
1553    string_block is allocated, all the Lisp_Strings it contains are
1554    added to a free-list string_free_list.  When a new Lisp_String is
1555    needed, it is taken from that list.  During the sweep phase of GC,
1556    string_blocks that are entirely free are freed, except two which
1557    we keep.
1558 
1559    String data is allocated from sblock structures.  Strings larger
1560    than LARGE_STRING_BYTES, get their own sblock, data for smaller
1561    strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1562 
1563    Sblocks consist internally of sdata structures, one for each
1564    Lisp_String.  The sdata structure points to the Lisp_String it
1565    belongs to.  The Lisp_String points back to the `u.data' member of
1566    its sdata structure.
1567 
1568    When a Lisp_String is freed during GC, it is put back on
1569    string_free_list, and its `data' member and its sdata's `string'
1570    pointer is set to null.  The size of the string is recorded in the
1571    `u.nbytes' member of the sdata.  So, sdata structures that are no
1572    longer used, can be easily recognized, and it's easy to compact the
1573    sblocks of small strings which we do in compact_small_strings.  */
1574 
1575 /* Size in bytes of an sblock structure used for small strings.  This
1576    is 8192 minus malloc overhead.  */
1577 
1578 #define SBLOCK_SIZE 8188
1579 
1580 /* Strings larger than this are considered large strings.  String data
1581    for large strings is allocated from individual sblocks.  */
1582 
1583 #define LARGE_STRING_BYTES 1024
1584 
1585 /* Structure describing string memory sub-allocated from an sblock.
1586    This is where the contents of Lisp strings are stored.  */
1587 
1588 struct sdata
1589 {
1590   /* Back-pointer to the string this sdata belongs to.  If null, this
1591      structure is free, and the NBYTES member of the union below
1592      contains the string's byte size (the same value that STRING_BYTES
1593      would return if STRING were non-null).  If non-null, STRING_BYTES
1594      (STRING) is the size of the data, and DATA contains the string's
1595      contents.  */
1596   struct Lisp_String *string;
1597 
1598 #ifdef GC_CHECK_STRING_BYTES
1599 
1600   EMACS_INT nbytes;
1601   unsigned char data[1];
1602 
1603 #define SDATA_NBYTES(S) (S)->nbytes
1604 #define SDATA_DATA(S)   (S)->data
1605 
1606 #else /* not GC_CHECK_STRING_BYTES */
1607 
1608   union
1609   {
1610     /* When STRING in non-null.  */
1611     unsigned char data[1];
1612 
1613     /* When STRING is null.  */
1614     EMACS_INT nbytes;
1615   } u;
1616 
1617 
1618 #define SDATA_NBYTES(S) (S)->u.nbytes
1619 #define SDATA_DATA(S)   (S)->u.data
1620 
1621 #endif /* not GC_CHECK_STRING_BYTES */
1622 };
1623 
1624 
1625 /* Structure describing a block of memory which is sub-allocated to
1626    obtain string data memory for strings.  Blocks for small strings
1627    are of fixed size SBLOCK_SIZE.  Blocks for large strings are made
1628    as large as needed.  */
1629 
1630 struct sblock
1631 {
1632   /* Next in list.  */
1633   struct sblock *next;
1634 
1635   /* Pointer to the next free sdata block.  This points past the end
1636      of the sblock if there isn't any space left in this block.  */
1637   struct sdata *next_free;
1638 
1639   /* Start of data.  */
1640   struct sdata first_data;
1641 };
1642 
1643 /* Number of Lisp strings in a string_block structure.  The 1020 is
1644    1024 minus malloc overhead.  */
1645 
1646 #define STRING_BLOCK_SIZE \
1647   ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1648 
1649 /* Structure describing a block from which Lisp_String structures
1650    are allocated.  */
1651 
1652 struct string_block
1653 {
1654   /* Place `strings' first, to preserve alignment.  */
1655   struct Lisp_String strings[STRING_BLOCK_SIZE];
1656   struct string_block *next;
1657 };
1658 
1659 /* Head and tail of the list of sblock structures holding Lisp string
1660    data.  We always allocate from current_sblock.  The NEXT pointers
1661    in the sblock structures go from oldest_sblock to current_sblock.  */
1662 
1663 static struct sblock *oldest_sblock, *current_sblock;
1664 
1665 /* List of sblocks for large strings.  */
1666 
1667 static struct sblock *large_sblocks;
1668 
1669 /* List of string_block structures, and how many there are.  */
1670 
1671 static struct string_block *string_blocks;
1672 static int n_string_blocks;
1673 
1674 /* Free-list of Lisp_Strings.  */
1675 
1676 static struct Lisp_String *string_free_list;
1677 
1678 /* Number of live and free Lisp_Strings.  */
1679 
1680 static int total_strings, total_free_strings;
1681 
1682 /* Number of bytes used by live strings.  */
1683 
1684 static int total_string_size;
1685 
1686 /* Given a pointer to a Lisp_String S which is on the free-list
1687    string_free_list, return a pointer to its successor in the
1688    free-list.  */
1689 
1690 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1691 
1692 /* Return a pointer to the sdata structure belonging to Lisp string S.
1693    S must be live, i.e. S->data must not be null.  S->data is actually
1694    a pointer to the `u.data' member of its sdata structure; the
1695    structure starts at a constant offset in front of that.  */
1696 
1697 #ifdef GC_CHECK_STRING_BYTES
1698 
1699 #define SDATA_OF_STRING(S) \
1700      ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1701                         - sizeof (EMACS_INT)))
1702 
1703 #else /* not GC_CHECK_STRING_BYTES */
1704 
1705 #define SDATA_OF_STRING(S) \
1706      ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1707 
1708 #endif /* not GC_CHECK_STRING_BYTES */
1709 
1710 
1711 #ifdef GC_CHECK_STRING_OVERRUN
1712 
1713 /* We check for overrun in string data blocks by appending a small
1714    "cookie" after each allocated string data block, and check for the
1715    presence of this cookie during GC.  */
1716 
1717 #define GC_STRING_OVERRUN_COOKIE_SIZE   4
1718 static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1719   { 0xde, 0xad, 0xbe, 0xef };
1720 
1721 #else
1722 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1723 #endif
1724 
1725 /* Value is the size of an sdata structure large enough to hold NBYTES
1726    bytes of string data.  The value returned includes a terminating
1727    NUL byte, the size of the sdata structure, and padding.  */
1728 
1729 #ifdef GC_CHECK_STRING_BYTES
1730 
1731 #define SDATA_SIZE(NBYTES)                      \
1732      ((sizeof (struct Lisp_String *)            \
1733        + (NBYTES) + 1                           \
1734        + sizeof (EMACS_INT)                     \
1735        + sizeof (EMACS_INT) - 1)                \
1736       & ~(sizeof (EMACS_INT) - 1))
1737 
1738 #else /* not GC_CHECK_STRING_BYTES */
1739 
1740 #define SDATA_SIZE(NBYTES)                      \
1741      ((sizeof (struct Lisp_String *)            \
1742        + (NBYTES) + 1                           \
1743        + sizeof (EMACS_INT) - 1)                \
1744       & ~(sizeof (EMACS_INT) - 1))
1745 
1746 #endif /* not GC_CHECK_STRING_BYTES */
1747 
1748 /* Extra bytes to allocate for each string.  */
1749 
1750 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1751 
1752 /* Initialize string allocation.  Called from init_alloc_once.  */
1753 
1754 static void
1755 init_strings ()
1756 {
1757   total_strings = total_free_strings = total_string_size = 0;
1758   oldest_sblock = current_sblock = large_sblocks = NULL;
1759   string_blocks = NULL;
1760   n_string_blocks = 0;
1761   string_free_list = NULL;
1762   empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1763   empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1764 }
1765 
1766 
1767 #ifdef GC_CHECK_STRING_BYTES
1768 
1769 static int check_string_bytes_count;
1770 
1771 static void check_string_bytes P_ ((int));
1772 static void check_sblock P_ ((struct sblock *));
1773 
1774 #define CHECK_STRING_BYTES(S)   STRING_BYTES (S)
1775 
1776 
1777 /* Like GC_STRING_BYTES, but with debugging check.  */
1778 
1779 int
1780 string_bytes (s)
1781      struct Lisp_String *s;
1782 {
1783   int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1784   if (!PURE_POINTER_P (s)
1785       && s->data
1786       && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1787     abort ();
1788   return nbytes;
1789 }
1790 
1791 /* Check validity of Lisp strings' string_bytes member in B.  */
1792 
1793 static void
1794 check_sblock (b)
1795      struct sblock *b;
1796 {
1797   struct sdata *from, *end, *from_end;
1798 
1799   end = b->next_free;
1800 
1801   for (from = &b->first_data; from < end; from = from_end)
1802     {
1803       /* Compute the next FROM here because copying below may
1804          overwrite data we need to compute it.  */
1805       int nbytes;
1806 
1807       /* Check that the string size recorded in the string is the
1808          same as the one recorded in the sdata structure. */
1809       if (from->string)
1810         CHECK_STRING_BYTES (from->string);
1811 
1812       if (from->string)
1813         nbytes = GC_STRING_BYTES (from->string);
1814       else
1815         nbytes = SDATA_NBYTES (from);
1816 
1817       nbytes = SDATA_SIZE (nbytes);
1818       from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1819     }
1820 }
1821 
1822 
1823 /* Check validity of Lisp strings' string_bytes member.  ALL_P
1824    non-zero means check all strings, otherwise check only most
1825    recently allocated strings.  Used for hunting a bug.  */
1826 
1827 static void
1828 check_string_bytes (all_p)
1829      int all_p;
1830 {
1831   if (all_p)
1832     {
1833       struct sblock *b;
1834 
1835       for (b = large_sblocks; b; b = b->next)
1836         {
1837           struct Lisp_String *s = b->first_data.string;
1838           if (s)
1839             CHECK_STRING_BYTES (s);
1840         }
1841 
1842       for (b = oldest_sblock; b; b = b->next)
1843         check_sblock (b);
1844     }
1845   else
1846     check_sblock (current_sblock);
1847 }
1848 
1849 #endif /* GC_CHECK_STRING_BYTES */
1850 
1851 #ifdef GC_CHECK_STRING_FREE_LIST
1852 
1853 /* Walk through the string free list looking for bogus next pointers.
1854    This may catch buffer overrun from a previous string.  */
1855 
1856 static void
1857 check_string_free_list ()
1858 {
1859   struct Lisp_String *s;
1860 
1861   /* Pop a Lisp_String off the free-list.  */
1862   s = string_free_list;
1863   while (s != NULL)
1864     {
1865       if ((unsigned)s < 1024)
1866         abort();
1867       s = NEXT_FREE_LISP_STRING (s);
1868     }
1869 }
1870 #else
1871 #define check_string_free_list()
1872 #endif
1873 
1874 /* Return a new Lisp_String.  */
1875 
1876 static struct Lisp_String *
1877 allocate_string ()
1878 {
1879   struct Lisp_String *s;
1880 
1881   /* eassert (!handling_signal); */
1882 
1883   MALLOC_BLOCK_INPUT;
1884 
1885   /* If the free-list is empty, allocate a new string_block, and
1886      add all the Lisp_Strings in it to the free-list.  */
1887   if (string_free_list == NULL)
1888     {
1889       struct string_block *b;
1890       int i;
1891 
1892       b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1893       bzero (b, sizeof *b);
1894       b->next = string_blocks;
1895       string_blocks = b;
1896       ++n_string_blocks;
1897 
1898       for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1899         {
1900           s = b->strings + i;
1901           NEXT_FREE_LISP_STRING (s) = string_free_list;
1902           string_free_list = s;
1903         }
1904 
1905       total_free_strings += STRING_BLOCK_SIZE;
1906     }
1907 
1908   check_string_free_list ();
1909 
1910   /* Pop a Lisp_String off the free-list.  */
1911   s = string_free_list;
1912   string_free_list = NEXT_FREE_LISP_STRING (s);
1913 
1914   MALLOC_UNBLOCK_INPUT;
1915 
1916   /* Probably not strictly necessary, but play it safe.  */
1917   bzero (s, sizeof *s);
1918 
1919   --total_free_strings;
1920   ++total_strings;
1921   ++strings_consed;
1922   consing_since_gc += sizeof *s;
1923 
1924 #ifdef GC_CHECK_STRING_BYTES
1925   if (!noninteractive)
1926     {
1927       if (++check_string_bytes_count == 200)
1928         {
1929           check_string_bytes_count = 0;
1930           check_string_bytes (1);
1931         }
1932       else
1933         check_string_bytes (0);
1934     }
1935 #endif /* GC_CHECK_STRING_BYTES */
1936 
1937   return s;
1938 }
1939 
1940 
1941 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1942    plus a NUL byte at the end.  Allocate an sdata structure for S, and
1943    set S->data to its `u.data' member.  Store a NUL byte at the end of
1944    S->data.  Set S->size to NCHARS and S->size_byte to NBYTES.  Free
1945    S->data if it was initially non-null.  */
1946 
1947 void
1948 allocate_string_data (s, nchars, nbytes)
1949      struct Lisp_String *s;
1950      int nchars, nbytes;
1951 {
1952   struct sdata *data, *old_data;
1953   struct sblock *b;
1954   int needed, old_nbytes;
1955 
1956   /* Determine the number of bytes needed to store NBYTES bytes
1957      of string data.  */
1958   needed = SDATA_SIZE (nbytes);
1959   old_data = s->data ? SDATA_OF_STRING (s) : NULL;
1960   old_nbytes = GC_STRING_BYTES (s);
1961 
1962   MALLOC_BLOCK_INPUT;
1963 
1964   if (nbytes > LARGE_STRING_BYTES)
1965     {
1966       size_t size = sizeof *b - sizeof (struct sdata) + needed;
1967 
1968 #ifdef DOUG_LEA_MALLOC
1969       /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
1970          because mapped region contents are not preserved in
1971          a dumped Emacs.
1972 
1973          In case you think of allowing it in a dumped Emacs at the
1974          cost of not being able to re-dump, there's another reason:
1975          mmap'ed data typically have an address towards the top of the
1976          address space, which won't fit into an EMACS_INT (at least on
1977          32-bit systems with the current tagging scheme).  --fx  */
1978       mallopt (M_MMAP_MAX, 0);
1979 #endif
1980 
1981       b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
1982 
1983 #ifdef DOUG_LEA_MALLOC
1984       /* Back to a reasonable maximum of mmap'ed areas. */
1985       mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1986 #endif
1987 
1988       b->next_free = &b->first_data;
1989       b->first_data.string = NULL;
1990       b->next = large_sblocks;
1991       large_sblocks = b;
1992     }
1993   else if (current_sblock == NULL
1994            || (((char *) current_sblock + SBLOCK_SIZE
1995                 - (char *) current_sblock->next_free)
1996                < (needed + GC_STRING_EXTRA)))
1997     {
1998       /* Not enough room in the current sblock.  */
1999       b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2000       b->next_free = &b->first_data;
2001       b->first_data.string = NULL;
2002       b->next = NULL;
2003 
2004       if (current_sblock)
2005         current_sblock->next = b;
2006       else
2007         oldest_sblock = b;
2008       current_sblock = b;
2009     }
2010   else
2011     b = current_sblock;
2012 
2013   data = b->next_free;
2014   b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2015 
2016   MALLOC_UNBLOCK_INPUT;
2017 
2018   data->string = s;
2019   s->data = SDATA_DATA (data);
2020 #ifdef GC_CHECK_STRING_BYTES
2021   SDATA_NBYTES (data) = nbytes;
2022 #endif
2023   s->size = nchars;
2024   s->size_byte = nbytes;
2025   s->data[nbytes] = '\0';
2026 #ifdef GC_CHECK_STRING_OVERRUN
2027   bcopy (string_overrun_cookie, (char *) data + needed,
2028          GC_STRING_OVERRUN_COOKIE_SIZE);
2029 #endif
2030 
2031   /* If S had already data assigned, mark that as free by setting its
2032      string back-pointer to null, and recording the size of the data
2033      in it.  */
2034   if (old_data)
2035     {
2036       SDATA_NBYTES (old_data) = old_nbytes;
2037       old_data->string = NULL;
2038     }
2039 
2040   consing_since_gc += needed;
2041 }
2042 
2043 
2044 /* Sweep and compact strings.  */
2045 
2046 static void
2047 sweep_strings ()
2048 {
2049   struct string_block *b, *next;
2050   struct string_block *live_blocks = NULL;
2051 
2052   string_free_list = NULL;
2053   total_strings = total_free_strings = 0;
2054   total_string_size = 0;
2055 
2056   /* Scan strings_blocks, free Lisp_Strings that aren't marked.  */
2057   for (b = string_blocks; b; b = next)
2058     {
2059       int i, nfree = 0;
2060       struct Lisp_String *free_list_before = string_free_list;
2061 
2062       next = b->next;
2063 
2064       for (i = 0; i < STRING_BLOCK_SIZE; ++i)
2065         {
2066           struct Lisp_String *s = b->strings + i;
2067 
2068           if (s->data)
2069             {
2070               /* String was not on free-list before.  */
2071               if (STRING_MARKED_P (s))
2072                 {
2073                   /* String is live; unmark it and its intervals.  */
2074                   UNMARK_STRING (s);
2075 
2076                   if (!NULL_INTERVAL_P (s->intervals))
2077                     UNMARK_BALANCE_INTERVALS (s->intervals);
2078 
2079                   ++total_strings;
2080                   total_string_size += STRING_BYTES (s);
2081                 }
2082               else
2083                 {
2084                   /* String is dead.  Put it on the free-list.  */
2085                   struct sdata *data = SDATA_OF_STRING (s);
2086 
2087                   /* Save the size of S in its sdata so that we know
2088                      how large that is.  Reset the sdata's string
2089                      back-pointer so that we know it's free.  */
2090 #ifdef GC_CHECK_STRING_BYTES
2091                   if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
2092                     abort ();
2093 #else
2094                   data->u.nbytes = GC_STRING_BYTES (s);
2095 #endif
2096                   data->string = NULL;
2097 
2098                   /* Reset the strings's `data' member so that we
2099                      know it's free.  */
2100                   s->data = NULL;
2101 
2102                   /* Put the string on the free-list.  */
2103                   NEXT_FREE_LISP_STRING (s) = string_free_list;
2104                   string_free_list = s;
2105                   ++nfree;
2106                 }
2107             }
2108           else
2109             {
2110               /* S was on the free-list before.  Put it there again.  */
2111               NEXT_FREE_LISP_STRING (s) = string_free_list;
2112               string_free_list = s;
2113               ++nfree;
2114             }
2115         }
2116 
2117       /* Free blocks that contain free Lisp_Strings only, except
2118          the first two of them.  */
2119       if (nfree == STRING_BLOCK_SIZE
2120           && total_free_strings > STRING_BLOCK_SIZE)
2121         {
2122           lisp_free (b);
2123           --n_string_blocks;
2124           string_free_list = free_list_before;
2125         }
2126       else
2127         {
2128           total_free_strings += nfree;
2129           b->next = live_blocks;
2130           live_blocks = b;
2131         }
2132     }
2133 
2134   check_string_free_list ();
2135 
2136   string_blocks = live_blocks;
2137   free_large_strings ();
2138   compact_small_strings ();
2139 
2140   check_string_free_list ();
2141 }
2142 
2143 
2144 /* Free dead large strings.  */
2145 
2146 static void
2147 free_large_strings ()
2148 {
2149   struct sblock *b, *next;
2150   struct sblock *live_blocks = NULL;
2151 
2152   for (b = large_sblocks; b; b = next)
2153     {
2154       next = b->next;
2155 
2156       if (b->first_data.string == NULL)
2157         lisp_free (b);
2158       else
2159         {
2160           b->next = live_blocks;
2161           live_blocks = b;
2162         }
2163     }
2164 
2165   large_sblocks = live_blocks;
2166 }
2167 
2168 
2169 /* Compact data of small strings.  Free sblocks that don't contain
2170    data of live strings after compaction.  */
2171 
2172 static void
2173 compact_small_strings ()
2174 {
2175   struct sblock *b, *tb, *next;
2176   struct sdata *from, *to, *end, *tb_end;
2177   struct sdata *to_end, *from_end;
2178 
2179   /* TB is the sblock we copy to, TO is the sdata within TB we copy
2180      to, and TB_END is the end of TB.  */
2181   tb = oldest_sblock;
2182   tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2183   to = &tb->first_data;
2184 
2185   /* Step through the blocks from the oldest to the youngest.  We
2186      expect that old blocks will stabilize over time, so that less
2187      copying will happen this way.  */
2188   for (b = oldest_sblock; b; b = b->next)
2189     {
2190       end = b->next_free;
2191       xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2192 
2193       for (from = &b->first_data; from < end; from = from_end)
2194         {
2195           /* Compute the next FROM here because copying below may
2196              overwrite data we need to compute it.  */
2197           int nbytes;
2198 
2199 #ifdef GC_CHECK_STRING_BYTES
2200           /* Check that the string size recorded in the string is the
2201              same as the one recorded in the sdata structure. */
2202           if (from->string
2203               && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
2204             abort ();
2205 #endif /* GC_CHECK_STRING_BYTES */
2206 
2207           if (from->string)
2208             nbytes = GC_STRING_BYTES (from->string);
2209           else
2210             nbytes = SDATA_NBYTES (from);
2211 
2212           if (nbytes > LARGE_STRING_BYTES)
2213             abort ();
2214 
2215           nbytes = SDATA_SIZE (nbytes);
2216           from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
2217 
2218 #ifdef GC_CHECK_STRING_OVERRUN
2219           if (bcmp (string_overrun_cookie,
2220                     ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
2221                     GC_STRING_OVERRUN_COOKIE_SIZE))
2222             abort ();
2223 #endif
2224 
2225           /* FROM->string non-null means it's alive.  Copy its data.  */
2226           if (from->string)
2227             {
2228               /* If TB is full, proceed with the next sblock.  */
2229               to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2230               if (to_end > tb_end)
2231                 {
2232                   tb->next_free = to;
2233                   tb = tb->next;
2234                   tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2235                   to = &tb->first_data;
2236                   to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2237                 }
2238 
2239               /* Copy, and update the string's `data' pointer.  */
2240               if (from != to)
2241                 {
2242                   xassert (tb != b || to <= from);
2243                   safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
2244                   to->string->data = SDATA_DATA (to);
2245                 }
2246 
2247               /* Advance past the sdata we copied to.  */
2248               to = to_end;
2249             }
2250         }
2251     }
2252 
2253   /* The rest of the sblocks following TB don't contain live data, so
2254      we can free them.  */
2255   for (b = tb->next; b; b = next)
2256     {
2257       next = b->next;
2258       lisp_free (b);
2259     }
2260 
2261   tb->next_free = to;
2262   tb->next = NULL;
2263   current_sblock = tb;
2264 }
2265 
2266 
2267 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
2268        doc: /* Return a newly created string of length LENGTH, with INIT in each element.
2269 LENGTH must be an integer.
2270 INIT must be an integer that represents a character.  */)
2271      (length, init)
2272      Lisp_Object length, init;
2273 {
2274   register Lisp_Object val;
2275   register unsigned char *p, *end;
2276   int c, nbytes;
2277 
2278   CHECK_NATNUM (length);
2279   CHECK_NUMBER (init);
2280 
2281   c = XINT (init);
2282   if (ASCII_CHAR_P (c))
2283     {
2284       nbytes = XINT (length);
2285       val = make_uninit_string (nbytes);
2286       p = SDATA (val);
2287       end = p + SCHARS (val);
2288       while (p != end)
2289         *p++ = c;
2290     }
2291   else
2292     {
2293       unsigned char str[MAX_MULTIBYTE_LENGTH];
2294       int len = CHAR_STRING (c, str);
2295 
2296       nbytes = len * XINT (length);
2297       val = make_uninit_multibyte_string (XINT (length), nbytes);
2298       p = SDATA (val);
2299       end = p + nbytes;
2300       while (p != end)
2301         {
2302           bcopy (str, p, len);
2303           p += len;
2304         }
2305     }
2306 
2307   *p = 0;
2308   return val;
2309 }
2310 
2311 
2312 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2313        doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2314 LENGTH must be a number.  INIT matters only in whether it is t or nil.  */)
2315      (length, init)
2316      Lisp_Object length, init;
2317 {
2318   register Lisp_Object val;
2319   struct Lisp_Bool_Vector *p;
2320   int real_init, i;
2321   int length_in_chars, length_in_elts, bits_per_value;
2322 
2323   CHECK_NATNUM (length);
2324 
2325   bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2326 
2327   length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2328   length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2329                      / BOOL_VECTOR_BITS_PER_CHAR);
2330 
2331   /* We must allocate one more elements than LENGTH_IN_ELTS for the
2332      slot `size' of the struct Lisp_Bool_Vector.  */
2333   val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2334 
2335   /* Get rid of any bits that would cause confusion.  */
2336   XVECTOR (val)->size = 0;      /* No Lisp_Object to trace in there.  */
2337   /* Use  XVECTOR (val) rather than `p' because p->size is not TRT. */
2338   XSETPVECTYPE (XVECTOR (val), PVEC_BOOL_VECTOR);
2339 
2340   p = XBOOL_VECTOR (val);
2341   p->size = XFASTINT (length);
2342 
2343   real_init = (NILP (init) ? 0 : -1);
2344   for (i = 0; i < length_in_chars ; i++)
2345     p->data[i] = real_init;
2346 
2347   /* Clear the extraneous bits in the last byte.  */
2348   if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2349     p->data[length_in_chars - 1]
2350       &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2351 
2352   return val;
2353 }
2354 
2355 
2356 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2357    of characters from the contents.  This string may be unibyte or
2358    multibyte, depending on the contents.  */
2359 
2360 Lisp_Object
2361 make_string (contents, nbytes)
2362      const char *contents;
2363      int nbytes;
2364 {
2365   register Lisp_Object val;
2366   int nchars, multibyte_nbytes;
2367 
2368   parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
2369   if (nbytes == nchars || nbytes != multibyte_nbytes)
2370     /* CONTENTS contains no multibyte sequences or contains an invalid
2371        multibyte sequence.  We must make unibyte string.  */
2372     val = make_unibyte_string (contents, nbytes);
2373   else
2374     val = make_multibyte_string (contents, nchars, nbytes);
2375   return val;
2376 }
2377 
2378 
2379 /* Make an unibyte string from LENGTH bytes at CONTENTS.  */
2380 
2381 Lisp_Object
2382 make_unibyte_string (contents, length)
2383      const char *contents;
2384      int length;
2385 {
2386   register Lisp_Object val;
2387   val = make_uninit_string (length);
2388   bcopy (contents, SDATA (val), length);
2389   STRING_SET_UNIBYTE (val);
2390   return val;
2391 }
2392 
2393 
2394 /* Make a multibyte string from NCHARS characters occupying NBYTES
2395    bytes at CONTENTS.  */
2396 
2397 Lisp_Object
2398 make_multibyte_string (contents, nchars, nbytes)
2399      const char *contents;
2400      int nchars, nbytes;
2401 {
2402   register Lisp_Object val;
2403   val = make_uninit_multibyte_string (nchars, nbytes);
2404   bcopy (contents, SDATA (val), nbytes);
2405   return val;
2406 }
2407 
2408 
2409 /* Make a string from NCHARS characters occupying NBYTES bytes at
2410    CONTENTS.  It is a multibyte string if NBYTES != NCHARS.  */
2411 
2412 Lisp_Object
2413 make_string_from_bytes (contents, nchars, nbytes)
2414      const char *contents;
2415      int nchars, nbytes;
2416 {
2417   register Lisp_Object val;
2418   val = make_uninit_multibyte_string (nchars, nbytes);
2419   bcopy (contents, SDATA (val), nbytes);
2420   if (SBYTES (val) == SCHARS (val))
2421     STRING_SET_UNIBYTE (val);
2422   return val;
2423 }
2424 
2425 
2426 /* Make a string from NCHARS characters occupying NBYTES bytes at
2427    CONTENTS.  The argument MULTIBYTE controls whether to label the
2428    string as multibyte.  If NCHARS is negative, it counts the number of
2429    characters by itself.  */
2430 
2431 Lisp_Object
2432 make_specified_string (contents, nchars, nbytes, multibyte)
2433      const char *contents;
2434      int nchars, nbytes;
2435      int multibyte;
2436 {
2437   register Lisp_Object val;
2438 
2439   if (nchars < 0)
2440     {
2441       if (multibyte)
2442         nchars = multibyte_chars_in_text (contents, nbytes);
2443       else
2444         nchars = nbytes;
2445     }
2446   val = make_uninit_multibyte_string (nchars, nbytes);
2447   bcopy (contents, SDATA (val), nbytes);
2448   if (!multibyte)
2449     STRING_SET_UNIBYTE (val);
2450   return val;
2451 }
2452 
2453 
2454 /* Make a string from the data at STR, treating it as multibyte if the
2455    data warrants.  */
2456 
2457 Lisp_Object
2458 build_string (str)
2459      const char *str;
2460 {
2461   return make_string (str, strlen (str));
2462 }
2463 
2464 
2465 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2466    occupying LENGTH bytes.  */
2467 
2468 Lisp_Object
2469 make_uninit_string (length)
2470      int length;
2471 {
2472   Lisp_Object val;
2473 
2474   if (!length)
2475     return empty_unibyte_string;
2476   val = make_uninit_multibyte_string (length, length);
2477   STRING_SET_UNIBYTE (val);
2478   return val;
2479 }
2480 
2481 
2482 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2483    which occupy NBYTES bytes.  */
2484 
2485 Lisp_Object
2486 make_uninit_multibyte_string (nchars, nbytes)
2487      int nchars, nbytes;
2488 {
2489   Lisp_Object string;
2490   struct Lisp_String *s;
2491 
2492   if (nchars < 0)
2493     abort ();
2494   if (!nbytes)
2495     return empty_multibyte_string;
2496 
2497   s = allocate_string ();
2498   allocate_string_data (s, nchars, nbytes);
2499   XSETSTRING (string, s);
2500   string_chars_consed += nbytes;
2501   return string;
2502 }
2503 
2504 
2505 
2506 /***********************************************************************
2507                            Float Allocation
2508  ***********************************************************************/
2509 
2510 /* We store float cells inside of float_blocks, allocating a new
2511    float_block with malloc whenever necessary.  Float cells reclaimed
2512    by GC are put on a free list to be reallocated before allocating
2513    any new float cells from the latest float_block.  */
2514 
2515 #define FLOAT_BLOCK_SIZE                                        \
2516   (((BLOCK_BYTES - sizeof (struct float_block *)                \
2517      /* The compiler might add padding at the end.  */          \
2518      - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2519    / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2520 
2521 #define GETMARKBIT(block,n)                             \
2522   (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2523     >> ((n) % (sizeof(int) * CHAR_BIT)))                \
2524    & 1)
2525 
2526 #define SETMARKBIT(block,n)                             \
2527   (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)]   \
2528   |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2529 
2530 #define UNSETMARKBIT(block,n)                           \
2531   (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)]   \
2532   &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2533 
2534 #define FLOAT_BLOCK(fptr) \
2535   ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2536 
2537 #define FLOAT_INDEX(fptr) \
2538   ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2539 
2540 struct float_block
2541 {
2542   /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job.  */
2543   struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2544   int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2545   struct float_block *next;
2546 };
2547 
2548 #define FLOAT_MARKED_P(fptr) \
2549   GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2550 
2551 #define FLOAT_MARK(fptr) \
2552   SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2553 
2554 #define FLOAT_UNMARK(fptr) \
2555   UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2556 
2557 /* Current float_block.  */
2558 
2559 struct float_block *float_block;
2560 
2561 /* Index of first unused Lisp_Float in the current float_block.  */
2562 
2563 int float_block_index;
2564 
2565 /* Total number of float blocks now in use.  */
2566 
2567 int n_float_blocks;
2568 
2569 /* Free-list of Lisp_Floats.  */
2570 
2571 struct Lisp_Float *float_free_list;
2572 
2573 
2574 /* Initialize float allocation.  */
2575 
2576 static void
2577 init_float ()
2578 {
2579   float_block = NULL;
2580   float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block.   */
2581   float_free_list = 0;
2582   n_float_blocks = 0;
2583 }
2584 
2585 
2586 /* Explicitly free a float cell by putting it on the free-list.  */
2587 
2588 static void
2589 free_float (ptr)
2590      struct Lisp_Float *ptr;
2591 {
2592   ptr->u.chain = float_free_list;
2593   float_free_list = ptr;
2594 }
2595 
2596 
2597 /* Return a new float object with value FLOAT_VALUE.  */
2598 
2599 Lisp_Object
2600 make_float (float_value)
2601      double float_value;
2602 {
2603   register Lisp_Object val;
2604 
2605   /* eassert (!handling_signal); */
2606 
2607   MALLOC_BLOCK_INPUT;
2608 
2609   if (float_free_list)
2610     {
2611       /* We use the data field for chaining the free list
2612          so that we won't use the same field that has the mark bit.  */
2613       XSETFLOAT (val, float_free_list);
2614       float_free_list = float_free_list->u.chain;
2615     }
2616   else
2617     {
2618       if (float_block_index == FLOAT_BLOCK_SIZE)
2619         {
2620           register struct float_block *new;
2621 
2622           new = (struct float_block *) lisp_align_malloc (sizeof *new,
2623                                                           MEM_TYPE_FLOAT);
2624           new->next = float_block;
2625           bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2626           float_block = new;
2627           float_block_index = 0;
2628           n_float_blocks++;
2629         }
2630       XSETFLOAT (val, &float_block->floats[float_block_index]);
2631       float_block_index++;
2632     }
2633 
2634   MALLOC_UNBLOCK_INPUT;
2635 
2636   XFLOAT_INIT (val, float_value);
2637   eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2638   consing_since_gc += sizeof (struct Lisp_Float);
2639   floats_consed++;
2640   return val;
2641 }
2642 
2643 
2644 
2645 /***********************************************************************
2646                            Cons Allocation
2647  ***********************************************************************/
2648 
2649 /* We store cons cells inside of cons_blocks, allocating a new
2650    cons_block with malloc whenever necessary.  Cons cells reclaimed by
2651    GC are put on a free list to be reallocated before allocating
2652    any new cons cells from the latest cons_block.  */
2653 
2654 #define CONS_BLOCK_SIZE \
2655   (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2656    / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2657 
2658 #define CONS_BLOCK(fptr) \
2659   ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2660 
2661 #define CONS_INDEX(fptr) \
2662   ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2663 
2664 struct cons_block
2665 {
2666   /* Place `conses' at the beginning, to ease up CONS_INDEX's job.  */
2667   struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2668   int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2669   struct cons_block *next;
2670 };
2671 
2672 #define CONS_MARKED_P(fptr) \
2673   GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2674 
2675 #define CONS_MARK(fptr) \
2676   SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2677 
2678 #define CONS_UNMARK(fptr) \
2679   UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2680 
2681 /* Current cons_block.  */
2682 
2683 struct cons_block *cons_block;
2684 
2685 /* Index of first unused Lisp_Cons in the current block.  */
2686 
2687 int cons_block_index;
2688 
2689 /* Free-list of Lisp_Cons structures.  */
2690 
2691 struct Lisp_Cons *cons_free_list;
2692 
2693 /* Total number of cons blocks now in use.  */
2694 
2695 static int n_cons_blocks;
2696 
2697 
2698 /* Initialize cons allocation.  */
2699 
2700 static void
2701 init_cons ()
2702 {
2703   cons_block = NULL;
2704   cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block.  */
2705   cons_free_list = 0;
2706   n_cons_blocks = 0;
2707 }
2708 
2709 
2710 /* Explicitly free a cons cell by putting it on the free-list.  */
2711 
2712 void
2713 free_cons (ptr)
2714      struct Lisp_Cons *ptr;
2715 {
2716   ptr->u.chain = cons_free_list;
2717 #if GC_MARK_STACK
2718   ptr->car = Vdead;
2719 #endif
2720   cons_free_list = ptr;
2721 }
2722 
2723 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2724        doc: /* Create a new cons, give it CAR and CDR as components, and return it.  */)
2725      (car, cdr)
2726      Lisp_Object car, cdr;
2727 {
2728   register Lisp_Object val;
2729 
2730   /* eassert (!handling_signal); */
2731 
2732   MALLOC_BLOCK_INPUT;
2733 
2734   if (cons_free_list)
2735     {
2736       /* We use the cdr for chaining the free list
2737          so that we won't use the same field that has the mark bit.  */
2738       XSETCONS (val, cons_free_list);
2739       cons_free_list = cons_free_list->u.chain;
2740     }
2741   else
2742     {
2743       if (cons_block_index == CONS_BLOCK_SIZE)
2744         {
2745           register struct cons_block *new;
2746           new = (struct cons_block *) lisp_align_malloc (sizeof *new,
2747                                                          MEM_TYPE_CONS);
2748           bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2749           new->next = cons_block;
2750           cons_block = new;
2751           cons_block_index = 0;
2752           n_cons_blocks++;
2753         }
2754       XSETCONS (val, &cons_block->conses[cons_block_index]);
2755       cons_block_index++;
2756     }
2757 
2758   MALLOC_UNBLOCK_INPUT;
2759 
2760   XSETCAR (val, car);
2761   XSETCDR (val, cdr);
2762   eassert (!CONS_MARKED_P (XCONS (val)));
2763   consing_since_gc += sizeof (struct Lisp_Cons);
2764   cons_cells_consed++;
2765   return val;
2766 }
2767 
2768 /* Get an error now if there's any junk in the cons free list.  */
2769 void
2770 check_cons_list ()
2771 {
2772 #ifdef GC_CHECK_CONS_LIST
2773   struct Lisp_Cons *tail = cons_free_list;
2774 
2775   while (tail)
2776     tail = tail->u.chain;
2777 #endif
2778 }
2779 
2780 /* Make a list of 1, 2, 3, 4 or 5 specified objects.  */
2781 
2782 Lisp_Object
2783 list1 (arg1)
2784      Lisp_Object arg1;
2785 {
2786   return Fcons (arg1, Qnil);
2787 }
2788 
2789 Lisp_Object
2790 list2 (arg1, arg2)
2791      Lisp_Object arg1, arg2;
2792 {
2793   return Fcons (arg1, Fcons (arg2, Qnil));
2794 }
2795 
2796 
2797 Lisp_Object
2798 list3 (arg1, arg2, arg3)
2799      Lisp_Object arg1, arg2, arg3;
2800 {
2801   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2802 }
2803 
2804 
2805 Lisp_Object
2806 list4 (arg1, arg2, arg3, arg4)
2807      Lisp_Object arg1, arg2, arg3, arg4;
2808 {
2809   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2810 }
2811 
2812 
2813 Lisp_Object
2814 list5 (arg1, arg2, arg3, arg4, arg5)
2815      Lisp_Object arg1, arg2, arg3, arg4, arg5;
2816 {
2817   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2818                                                        Fcons (arg5, Qnil)))));
2819 }
2820 
2821 
2822 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2823        doc: /* Return a newly created list with specified arguments as elements.
2824 Any number of arguments, even zero arguments, are allowed.
2825 usage: (list &rest OBJECTS)  */)
2826      (nargs, args)
2827      int nargs;
2828      register Lisp_Object *args;
2829 {
2830   register Lisp_Object val;
2831   val = Qnil;
2832 
2833   while (nargs > 0)
2834     {
2835       nargs--;
2836       val = Fcons (args[nargs], val);
2837     }
2838   return val;
2839 }
2840 
2841 
2842 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2843        doc: /* Return a newly created list of length LENGTH, with each element being INIT.  */)
2844      (length, init)
2845      register Lisp_Object length, init;
2846 {
2847   register Lisp_Object val;
2848   register int size;
2849 
2850   CHECK_NATNUM (length);
2851   size = XFASTINT (length);
2852 
2853   val = Qnil;
2854   while (size > 0)
2855     {
2856       val = Fcons (init, val);
2857       --size;
2858 
2859       if (size > 0)
2860         {
2861           val = Fcons (init, val);
2862           --size;
2863 
2864           if (size > 0)
2865             {
2866               val = Fcons (init, val);
2867               --size;
2868 
2869               if (size > 0)
2870                 {
2871                   val = Fcons (init, val);
2872                   --size;
2873 
2874                   if (size > 0)
2875                     {
2876                       val = Fcons (init, val);
2877                       --size;
2878                     }
2879                 }
2880             }
2881         }
2882 
2883       QUIT;
2884     }
2885 
2886   return val;
2887 }
2888 
2889 
2890 
2891 /***********************************************************************
2892                            Vector Allocation
2893  ***********************************************************************/
2894 
2895 /* Singly-linked list of all vectors.  */
2896 
2897 static struct Lisp_Vector *all_vectors;
2898 
2899 /* Total number of vector-like objects now in use.  */
2900 
2901 static int n_vectors;
2902 
2903 
2904 /* Value is a pointer to a newly allocated Lisp_Vector structure
2905    with room for LEN Lisp_Objects.  */
2906 
2907 static struct Lisp_Vector *
2908 allocate_vectorlike (len)
2909      EMACS_INT len;
2910 {
2911   struct Lisp_Vector *p;
2912   size_t nbytes;
2913 
2914   MALLOC_BLOCK_INPUT;
2915 
2916 #ifdef DOUG_LEA_MALLOC
2917   /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
2918      because mapped region contents are not preserved in
2919      a dumped Emacs.  */
2920   mallopt (M_MMAP_MAX, 0);
2921 #endif
2922 
2923   /* This gets triggered by code which I haven't bothered to fix.  --Stef  */
2924   /* eassert (!handling_signal); */
2925 
2926   nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
2927   p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
2928 
2929 #ifdef DOUG_LEA_MALLOC
2930   /* Back to a reasonable maximum of mmap'ed areas.  */
2931   mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2932 #endif
2933 
2934   consing_since_gc += nbytes;
2935   vector_cells_consed += len;
2936 
2937   p->next = all_vectors;
2938   all_vectors = p;
2939 
2940   MALLOC_UNBLOCK_INPUT;
2941 
2942   ++n_vectors;
2943   return p;
2944 }
2945 
2946 
2947 /* Allocate a vector with NSLOTS slots.  */
2948 
2949 struct Lisp_Vector *
2950 allocate_vector (nslots)
2951      EMACS_INT nslots;
2952 {
2953   struct Lisp_Vector *v = allocate_vectorlike (nslots);
2954   v->size = nslots;
2955   return v;
2956 }
2957 
2958 
2959 /* Allocate other vector-like structures.  */
2960 
2961 struct Lisp_Vector *
2962 allocate_pseudovector (memlen, lisplen, tag)
2963      int memlen, lisplen;
2964      EMACS_INT tag;
2965 {
2966   struct Lisp_Vector *v = allocate_vectorlike (memlen);
2967   EMACS_INT i;
2968 
2969   /* Only the first lisplen slots will be traced normally by the GC.  */
2970   v->size = lisplen;
2971   for (i = 0; i < lisplen; ++i)
2972     v->contents[i] = Qnil;
2973 
2974   XSETPVECTYPE (v, tag);        /* Add the appropriate tag.  */
2975   return v;
2976 }
2977 
2978 struct Lisp_Hash_Table *
2979 allocate_hash_table (void)
2980 {
2981   return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
2982 }
2983 
2984 
2985 struct window *
2986 allocate_window ()
2987 {
2988   return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
2989 }
2990 
2991 
2992 struct terminal *
2993 allocate_terminal ()
2994 {
2995   struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
2996                                               next_terminal, PVEC_TERMINAL);
2997   /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
2998   bzero (&(t->next_terminal),
2999          ((char*)(t+1)) - ((char*)&(t->next_terminal)));
3000 
3001   return t;
3002 }
3003 
3004 struct frame *
3005 allocate_frame ()
3006 {
3007   struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
3008                                            face_cache, PVEC_FRAME);
3009   /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
3010   bzero (&(f->face_cache),
3011          ((char*)(f+1)) - ((char*)&(f->face_cache)));
3012   return f;
3013 }
3014 
3015 
3016 struct Lisp_Process *
3017 allocate_process ()
3018 {
3019   return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3020 }
3021 
3022 
3023 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3024        doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
3025 See also the function `vector'.  */)
3026      (length, init)
3027      register Lisp_Object length, init;
3028 {
3029   Lisp_Object vector;
3030   register EMACS_INT sizei;
3031   register int index;
3032   register struct Lisp_Vector *p;
3033 
3034   CHECK_NATNUM (length);
3035   sizei = XFASTINT (length);
3036 
3037   p = allocate_vector (sizei);
3038   for (index = 0; index < sizei; index++)
3039     p->contents[index] = init;
3040 
3041   XSETVECTOR (vector, p);
3042   return vector;
3043 }
3044 
3045 
3046 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3047        doc: /* Return a newly created vector with specified arguments as elements.
3048 Any number of arguments, even zero arguments, are allowed.
3049 usage: (vector &rest OBJECTS)  */)
3050      (nargs, args)
3051      register int nargs;
3052      Lisp_Object *args;
3053 {
3054   register Lisp_Object len, val;
3055   register int index;
3056   register struct Lisp_Vector *p;
3057 
3058   XSETFASTINT (len, nargs);
3059   val = Fmake_vector (len, Qnil);
3060   p = XVECTOR (val);
3061   for (index = 0; index < nargs; index++)
3062     p->contents[index] = args[index];
3063   return val;
3064 }
3065 
3066 
3067 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3068        doc: /* Create a byte-code object with specified arguments as elements.
3069 The arguments should be the arglist, bytecode-string, constant vector,
3070 stack size, (optional) doc string, and (optional) interactive spec.
3071 The first four arguments are required; at most six have any
3072 significance.
3073 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS)  */)
3074      (nargs, args)
3075      register int nargs;
3076      Lisp_Object *args;
3077 {
3078   register Lisp_Object len, val;
3079   register int index;
3080   register struct Lisp_Vector *p;
3081 
3082   XSETFASTINT (len, nargs);
3083   if (!NILP (Vpurify_flag))
3084     val = make_pure_vector ((EMACS_INT) nargs);
3085   else
3086     val = Fmake_vector (len, Qnil);
3087 
3088   if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
3089     /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3090        earlier because they produced a raw 8-bit string for byte-code
3091        and now such a byte-code string is loaded as multibyte while
3092        raw 8-bit characters converted to multibyte form.  Thus, now we
3093        must convert them back to the original unibyte form.  */
3094     args[1] = Fstring_as_unibyte (args[1]);
3095 
3096   p = XVECTOR (val);
3097   for (index = 0; index < nargs; index++)
3098     {
3099       if (!NILP (Vpurify_flag))
3100         args[index] = Fpurecopy (args[index]);
3101       p->contents[index] = args[index];
3102     }
3103   XSETPVECTYPE (p, PVEC_COMPILED);
3104   XSETCOMPILED (val, p);
3105   return val;
3106 }
3107 
3108 
3109 
3110 /***********************************************************************
3111                            Symbol Allocation
3112  ***********************************************************************/
3113 
3114 /* Each symbol_block is just under 1020 bytes long, since malloc
3115    really allocates in units of powers of two and uses 4 bytes for its
3116    own overhead. */
3117 
3118 #define SYMBOL_BLOCK_SIZE \
3119   ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3120 
3121 struct symbol_block
3122 {
3123   /* Place `symbols' first, to preserve alignment.  */
3124   struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3125   struct symbol_block *next;
3126 };
3127 
3128 /* Current symbol block and index of first unused Lisp_Symbol
3129    structure in it.  */
3130 
3131 static struct symbol_block *symbol_block;
3132 static int symbol_block_index;
3133 
3134 /* List of free symbols.  */
3135 
3136 static struct Lisp_Symbol *symbol_free_list;
3137 
3138 /* Total number of symbol blocks now in use.  */
3139 
3140 static int n_symbol_blocks;
3141 
3142 
3143 /* Initialize symbol allocation.  */
3144 
3145 static void
3146 init_symbol ()
3147 {
3148   symbol_block = NULL;
3149   symbol_block_index = SYMBOL_BLOCK_SIZE;
3150   symbol_free_list = 0;
3151   n_symbol_blocks = 0;
3152 }
3153 
3154 
3155 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3156        doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3157 Its value and function definition are void, and its property list is nil.  */)
3158      (name)
3159      Lisp_Object name;
3160 {
3161   register Lisp_Object val;
3162   register struct Lisp_Symbol *p;
3163 
3164   CHECK_STRING (name);
3165 
3166   /* eassert (!handling_signal); */
3167 
3168   MALLOC_BLOCK_INPUT;
3169 
3170   if (symbol_free_list)
3171     {
3172       XSETSYMBOL (val, symbol_free_list);
3173       symbol_free_list = symbol_free_list->next;
3174     }
3175   else
3176     {
3177       if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3178         {
3179           struct symbol_block *new;
3180           new = (struct symbol_block *) lisp_malloc (sizeof *new,
3181                                                      MEM_TYPE_SYMBOL);
3182           new->next = symbol_block;
3183           symbol_block = new;
3184           symbol_block_index = 0;
3185           n_symbol_blocks++;
3186         }
3187       XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
3188       symbol_block_index++;
3189     }
3190 
3191   MALLOC_UNBLOCK_INPUT;
3192 
3193   p = XSYMBOL (val);
3194   p->xname = name;
3195   p->plist = Qnil;
3196   p->redirect = SYMBOL_PLAINVAL;
3197   SET_SYMBOL_VAL (p, Qunbound);
3198   p->function = Qunbound;
3199   p->next = NULL;
3200   p->gcmarkbit = 0;
3201   p->interned = SYMBOL_UNINTERNED;
3202   p->constant = 0;
3203   consing_since_gc += sizeof (struct Lisp_Symbol);
3204   symbols_consed++;
3205   return val;
3206 }
3207 
3208 
3209 
3210 /***********************************************************************
3211                        Marker (Misc) Allocation
3212  ***********************************************************************/
3213 
3214 /* Allocation of markers and other objects that share that structure.
3215    Works like allocation of conses. */
3216 
3217 #define MARKER_BLOCK_SIZE \
3218   ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3219 
3220 struct marker_block
3221 {
3222   /* Place `markers' first, to preserve alignment.  */
3223   union Lisp_Misc markers[MARKER_BLOCK_SIZE];
3224   struct marker_block *next;
3225 };
3226 
3227 static struct marker_block *marker_block;
3228 static int marker_block_index;
3229 
3230 static union Lisp_Misc *marker_free_list;
3231 
3232 /* Total number of marker blocks now in use.  */
3233 
3234 static int n_marker_blocks;
3235 
3236 static void
3237 init_marker ()
3238 {
3239   marker_block = NULL;
3240   marker_block_index = MARKER_BLOCK_SIZE;
3241   marker_free_list = 0;
3242   n_marker_blocks = 0;
3243 }
3244 
3245 /* Return a newly allocated Lisp_Misc object, with no substructure.  */
3246 
3247 Lisp_Object
3248 allocate_misc ()
3249 {
3250   Lisp_Object val;
3251 
3252   /* eassert (!handling_signal); */
3253 
3254   MALLOC_BLOCK_INPUT;
3255 
3256   if (marker_free_list)
3257     {
3258       XSETMISC (val, marker_free_list);
3259       marker_free_list = marker_free_list->u_free.chain;
3260     }
3261   else
3262     {
3263       if (marker_block_index == MARKER_BLOCK_SIZE)
3264         {
3265           struct marker_block *new;
3266           new = (struct marker_block *) lisp_malloc (sizeof *new,
3267                                                      MEM_TYPE_MISC);
3268           new->next = marker_block;
3269           marker_block = new;
3270           marker_block_index = 0;
3271           n_marker_blocks++;
3272           total_free_markers += MARKER_BLOCK_SIZE;
3273         }
3274       XSETMISC (val, &marker_block->markers[marker_block_index]);
3275       marker_block_index++;
3276     }
3277 
3278   MALLOC_UNBLOCK_INPUT;
3279 
3280   --total_free_markers;
3281   consing_since_gc += sizeof (union Lisp_Misc);
3282   misc_objects_consed++;
3283   XMISCANY (val)->gcmarkbit = 0;
3284   return val;
3285 }
3286 
3287 /* Free a Lisp_Misc object */
3288 
3289 void
3290 free_misc (misc)
3291      Lisp_Object misc;
3292 {
3293   XMISCTYPE (misc) = Lisp_Misc_Free;
3294   XMISC (misc)->u_free.chain = marker_free_list;
3295   marker_free_list = XMISC (misc);
3296 
3297   total_free_markers++;
3298 }
3299 
3300 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3301    INTEGER.  This is used to package C values to call record_unwind_protect.
3302    The unwind function can get the C values back using XSAVE_VALUE.  */
3303 
3304 Lisp_Object
3305 make_save_value (pointer, integer)
3306      void *pointer;
3307      int integer;
3308 {
3309   register Lisp_Object val;
3310   register struct Lisp_Save_Value *p;
3311 
3312   val = allocate_misc ();
3313   XMISCTYPE (val) = Lisp_Misc_Save_Value;
3314   p = XSAVE_VALUE (val);
3315   p->pointer = pointer;
3316   p->integer = integer;
3317   p->dogc = 0;
3318   return val;
3319 }
3320 
3321 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3322        doc: /* Return a newly allocated marker which does not point at any place.  */)
3323      ()
3324 {
3325   register Lisp_Object val;
3326   register struct Lisp_Marker *p;
3327 
3328   val = allocate_misc ();
3329   XMISCTYPE (val) = Lisp_Misc_Marker;
3330   p = XMARKER (val);
3331   p->buffer = 0;
3332   p->bytepos = 0;
3333   p->charpos = 0;
3334   p->next = NULL;
3335   p->insertion_type = 0;
3336   return val;
3337 }
3338 
3339 /* Put MARKER back on the free list after using it temporarily.  */
3340 
3341 void
3342 free_marker (marker)
3343      Lisp_Object marker;
3344 {
3345   unchain_marker (XMARKER (marker));
3346   free_misc (marker);
3347 }
3348 
3349 
3350 /* Return a newly created vector or string with specified arguments as
3351    elements.  If all the arguments are characters that can fit
3352    in a string of events, make a string; otherwise, make a vector.
3353 
3354    Any number of arguments, even zero arguments, are allowed.  */
3355 
3356 Lisp_Object
3357 make_event_array (nargs, args)
3358      register int nargs;
3359      Lisp_Object *args;
3360 {
3361   int i;
3362 
3363   for (i = 0; i < nargs; i++)
3364     /* The things that fit in a string
3365        are characters that are in 0...127,
3366        after discarding the meta bit and all the bits above it.  */
3367     if (!INTEGERP (args[i])
3368         || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
3369       return Fvector (nargs, args);
3370 
3371   /* Since the loop exited, we know that all the things in it are
3372      characters, so we can make a string.  */
3373   {
3374     Lisp_Object result;
3375 
3376     result = Fmake_string (make_number (nargs), make_number (0));
3377     for (i = 0; i < nargs; i++)
3378       {
3379         SSET (result, i, XINT (args[i]));
3380         /* Move the meta bit to the right place for a string char.  */
3381         if (XINT (args[i]) & CHAR_META)
3382           SSET (result, i, SREF (result, i) | 0x80);
3383       }
3384 
3385     return result;
3386   }
3387 }
3388 
3389 
3390 
3391 /************************************************************************
3392                            Memory Full Handling
3393  ************************************************************************/
3394 
3395 
3396 /* Called if malloc returns zero.  */
3397 
3398 void
3399 memory_full ()
3400 {
3401   int i;
3402 
3403   Vmemory_full = Qt;
3404 
3405   memory_full_cons_threshold = sizeof (struct cons_block);
3406 
3407   /* The first time we get here, free the spare memory.  */
3408   for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
3409     if (spare_memory[i])
3410       {
3411         if (i == 0)
3412           free (spare_memory[i]);
3413         else if (i >= 1 && i <= 4)
3414           lisp_align_free (spare_memory[i]);
3415         else
3416           lisp_free (spare_memory[i]);
3417         spare_memory[i] = 0;
3418       }
3419 
3420   /* Record the space now used.  When it decreases substantially,
3421      we can refill the memory reserve.  */
3422 #ifndef SYSTEM_MALLOC
3423   bytes_used_when_full = BYTES_USED;
3424 #endif
3425 
3426   /* This used to call error, but if we've run out of memory, we could
3427      get infinite recursion trying to build the string.  */
3428   xsignal (Qnil, Vmemory_signal_data);
3429 }
3430 
3431 /* If we released our reserve (due to running out of memory),
3432    and we have a fair amount free once again,
3433    try to set aside another reserve in case we run out once more.
3434 
3435    This is called when a relocatable block is freed in ralloc.c,
3436    and also directly from this file, in case we're not using ralloc.c.  */
3437 
3438 void
3439 refill_memory_reserve ()
3440 {
3441 #ifndef SYSTEM_MALLOC
3442   if (spare_memory[0] == 0)
3443     spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
3444   if (spare_memory[1] == 0)
3445     spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3446                                                   MEM_TYPE_CONS);
3447   if (spare_memory[2] == 0)
3448     spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3449                                                   MEM_TYPE_CONS);
3450   if (spare_memory[3] == 0)
3451     spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3452                                                   MEM_TYPE_CONS);
3453   if (spare_memory[4] == 0)
3454     spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3455                                                   MEM_TYPE_CONS);
3456   if (spare_memory[5] == 0)
3457     spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
3458                                             MEM_TYPE_STRING);
3459   if (spare_memory[6] == 0)
3460     spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
3461                                             MEM_TYPE_STRING);
3462   if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3463     Vmemory_full = Qnil;
3464 #endif
3465 }
3466 
3467 /************************************************************************
3468                            C Stack Marking
3469  ************************************************************************/
3470 
3471 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3472 
3473 /* Conservative C stack marking requires a method to identify possibly
3474    live Lisp objects given a pointer value.  We do this by keeping
3475    track of blocks of Lisp data that are allocated in a red-black tree
3476    (see also the comment of mem_node which is the type of nodes in
3477    that tree).  Function lisp_malloc adds information for an allocated
3478    block to the red-black tree with calls to mem_insert, and function
3479    lisp_free removes it with mem_delete.  Functions live_string_p etc
3480    call mem_find to lookup information about a given pointer in the
3481    tree, and use that to determine if the pointer points to a Lisp
3482    object or not.  */
3483 
3484 /* Initialize this part of alloc.c.  */
3485 
3486 static void
3487 mem_init ()
3488 {
3489   mem_z.left = mem_z.right = MEM_NIL;
3490   mem_z.parent = NULL;
3491   mem_z.color = MEM_BLACK;
3492   mem_z.start = mem_z.end = NULL;
3493   mem_root = MEM_NIL;
3494 }
3495 
3496 
3497 /* Value is a pointer to the mem_node containing START.  Value is
3498    MEM_NIL if there is no node in the tree containing START.  */
3499 
3500 static INLINE struct mem_node *
3501 mem_find (start)
3502      void *start;
3503 {
3504   struct mem_node *p;
3505 
3506   if (start < min_heap_address || start > max_heap_address)
3507     return MEM_NIL;
3508 
3509   /* Make the search always successful to speed up the loop below.  */
3510   mem_z.start = start;
3511   mem_z.end = (char *) start + 1;
3512 
3513   p = mem_root;
3514   while (start < p->start || start >= p->end)
3515     p = start < p->start ? p->left : p->right;
3516   return p;
3517 }
3518 
3519 
3520 /* Insert a new node into the tree for a block of memory with start
3521    address START, end address END, and type TYPE.  Value is a
3522    pointer to the node that was inserted.  */
3523 
3524 static struct mem_node *
3525 mem_insert (start, end, type)
3526      void *start, *end;
3527      enum mem_type type;
3528 {
3529   struct mem_node *c, *parent, *x;
3530 
3531   if (min_heap_address == NULL || start < min_heap_address)
3532     min_heap_address = start;
3533   if (max_heap_address == NULL || end > max_heap_address)
3534     max_heap_address = end;
3535 
3536   /* See where in the tree a node for START belongs.  In this
3537      particular application, it shouldn't happen that a node is already
3538      present.  For debugging purposes, let's check that.  */
3539   c = mem_root;
3540   parent = NULL;
3541 
3542 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3543 
3544   while (c != MEM_NIL)
3545     {
3546       if (start >= c->start && start < c->end)
3547         abort ();
3548       parent = c;
3549       c = start < c->start ? c->left : c->right;
3550     }
3551 
3552 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3553 
3554   while (c != MEM_NIL)
3555     {
3556       parent = c;
3557       c = start < c->start ? c->left : c->right;
3558     }
3559 
3560 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3561 
3562   /* Create a new node.  */
3563 #ifdef GC_MALLOC_CHECK
3564   x = (struct mem_node *) _malloc_internal (sizeof *x);
3565   if (x == NULL)
3566     abort ();
3567 #else
3568   x = (struct mem_node *) xmalloc (sizeof *x);
3569 #endif
3570   x->start = start;
3571   x->end = end;
3572   x->type = type;
3573   x->parent = parent;
3574   x->left = x->right = MEM_NIL;
3575   x->color = MEM_RED;
3576 
3577   /* Insert it as child of PARENT or install it as root.  */
3578   if (parent)
3579     {
3580       if (start < parent->start)
3581         parent->left = x;
3582       else
3583         parent->right = x;
3584     }
3585   else
3586     mem_root = x;
3587 
3588   /* Re-establish red-black tree properties.  */
3589   mem_insert_fixup (x);
3590 
3591   return x;
3592 }
3593 
3594 
3595 /* Re-establish the red-black properties of the tree, and thereby
3596    balance the tree, after node X has been inserted; X is always red.  */
3597 
3598 static void
3599 mem_insert_fixup (x)
3600      struct mem_node *x;
3601 {
3602   while (x != mem_root && x->parent->color == MEM_RED)
3603     {
3604       /* X is red and its parent is red.  This is a violation of
3605          red-black tree property #3.  */
3606 
3607       if (x->parent == x->parent->parent->left)
3608         {
3609           /* We're on the left side of our grandparent, and Y is our
3610              "uncle".  */
3611           struct mem_node *y = x->parent->parent->right;
3612 
3613           if (y->color == MEM_RED)
3614             {
3615               /* Uncle and parent are red but should be black because
3616                  X is red.  Change the colors accordingly and proceed
3617                  with the grandparent.  */
3618               x->parent->color = MEM_BLACK;
3619               y->color = MEM_BLACK;
3620               x->parent->parent->color = MEM_RED;
3621               x = x->parent->parent;
3622             }
3623           else
3624             {
3625               /* Parent and uncle have different colors; parent is
3626                  red, uncle is black.  */
3627               if (x == x->parent->right)
3628                 {
3629                   x = x->parent;
3630                   mem_rotate_left (x);
3631                 }
3632 
3633               x->parent->color = MEM_BLACK;
3634               x->parent->parent->color = MEM_RED;
3635               mem_rotate_right (x->parent->parent);
3636             }
3637         }
3638       else
3639         {
3640           /* This is the symmetrical case of above.  */
3641           struct mem_node *y = x->parent->parent->left;
3642 
3643           if (y->color == MEM_RED)
3644             {
3645               x->parent->color = MEM_BLACK;
3646               y->color = MEM_BLACK;
3647               x->parent->parent->color = MEM_RED;
3648               x = x->parent->parent;
3649             }
3650           else
3651             {
3652               if (x == x->parent->left)
3653                 {
3654                   x = x->parent;
3655                   mem_rotate_right (x);
3656                 }
3657 
3658               x->parent->color = MEM_BLACK;
3659               x->parent->parent->color = MEM_RED;
3660               mem_rotate_left (x->parent->parent);
3661             }
3662         }
3663     }
3664 
3665   /* The root may have been changed to red due to the algorithm.  Set
3666      it to black so that property #5 is satisfied.  */
3667   mem_root->color = MEM_BLACK;
3668 }
3669 
3670 
3671 /*   (x)                   (y)
3672      / \                   / \
3673     a   (y)      ===>    (x)  c
3674         / \              / \
3675        b   c            a   b  */
3676 
3677 static void
3678 mem_rotate_left (x)
3679      struct mem_node *x;
3680 {
3681   struct mem_node *y;
3682 
3683   /* Turn y's left sub-tree into x's right sub-tree.  */
3684   y = x->right;
3685   x->right = y->left;
3686   if (y->left != MEM_NIL)
3687     y->left->parent = x;
3688 
3689   /* Y's parent was x's parent.  */
3690   if (y != MEM_NIL)
3691     y->parent = x->parent;
3692 
3693   /* Get the parent to point to y instead of x.  */
3694   if (x->parent)
3695     {
3696       if (x == x->parent->left)
3697         x->parent->left = y;
3698       else
3699         x->parent->right = y;
3700     }
3701   else
3702     mem_root = y;
3703 
3704   /* Put x on y's left.  */
3705   y->left = x;
3706   if (x != MEM_NIL)
3707     x->parent = y;
3708 }
3709 
3710 
3711 /*     (x)                (Y)
3712        / \                / \
3713      (y)  c      ===>    a  (x)
3714      / \                    / \
3715     a   b                  b   c  */
3716 
3717 static void
3718 mem_rotate_right (x)
3719      struct mem_node *x;
3720 {
3721   struct mem_node *y = x->left;
3722 
3723   x->left = y->right;
3724   if (y->right != MEM_NIL)
3725     y->right->parent = x;
3726 
3727   if (y != MEM_NIL)
3728     y->parent = x->parent;
3729   if (x->parent)
3730     {
3731       if (x == x->parent->right)
3732         x->parent->right = y;
3733       else
3734         x->parent->left = y;
3735     }
3736   else
3737     mem_root = y;
3738 
3739   y->right = x;
3740   if (x != MEM_NIL)
3741     x->parent = y;
3742 }
3743 
3744 
3745 /* Delete node Z from the tree.  If Z is null or MEM_NIL, do nothing.  */
3746 
3747 static void
3748 mem_delete (z)
3749      struct mem_node *z;
3750 {
3751   struct mem_node *x, *y;
3752 
3753   if (!z || z == MEM_NIL)
3754     return;
3755 
3756   if (z->left == MEM_NIL || z->right == MEM_NIL)
3757     y = z;
3758   else
3759     {
3760       y = z->right;
3761       while (y->left != MEM_NIL)
3762         y = y->left;
3763     }
3764 
3765   if (y->left != MEM_NIL)
3766     x = y->left;
3767   else
3768     x = y->right;
3769 
3770   x->parent = y->parent;
3771   if (y->parent)
3772     {
3773       if (y == y->parent->left)
3774         y->parent->left = x;
3775       else
3776         y->parent->right = x;
3777     }
3778   else
3779     mem_root = x;
3780 
3781   if (y != z)
3782     {
3783       z->start = y->start;
3784       z->end = y->end;
3785       z->type = y->type;
3786     }
3787 
3788   if (y->color == MEM_BLACK)
3789     mem_delete_fixup (x);
3790 
3791 #ifdef GC_MALLOC_CHECK
3792   _free_internal (y);
3793 #else
3794   xfree (y);
3795 #endif
3796 }
3797 
3798 
3799 /* Re-establish the red-black properties of the tree, after a
3800    deletion.  */
3801 
3802 static void
3803 mem_delete_fixup (x)
3804      struct mem_node *x;
3805 {
3806   while (x != mem_root && x->color == MEM_BLACK)
3807     {
3808       if (x == x->parent->left)
3809         {
3810           struct mem_node *w = x->parent->right;
3811 
3812           if (w->color == MEM_RED)
3813             {
3814               w->color = MEM_BLACK;
3815               x->parent->color = MEM_RED;
3816               mem_rotate_left (x->parent);
3817               w = x->parent->right;
3818             }
3819 
3820           if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
3821             {
3822               w->color = MEM_RED;
3823               x = x->parent;
3824             }
3825           else
3826             {
3827               if (w->right->color == MEM_BLACK)
3828                 {
3829                   w->left->color = MEM_BLACK;
3830                   w->color = MEM_RED;
3831                   mem_rotate_right (w);
3832                   w = x->parent->right;
3833                 }
3834               w->color = x->parent->color;
3835               x->parent->color = MEM_BLACK;
3836               w->right->color = MEM_BLACK;
3837               mem_rotate_left (x->parent);
3838               x = mem_root;
3839             }
3840         }
3841       else
3842         {
3843           struct mem_node *w = x->parent->left;
3844 
3845           if (w->color == MEM_RED)
3846             {
3847               w->color = MEM_BLACK;
3848               x->parent->color = MEM_RED;
3849               mem_rotate_right (x->parent);
3850               w = x->parent->left;
3851             }
3852 
3853           if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
3854             {
3855               w->color = MEM_RED;
3856               x = x->parent;
3857             }
3858           else
3859             {
3860               if (w->left->color == MEM_BLACK)
3861                 {
3862                   w->right->color = MEM_BLACK;
3863                   w->color = MEM_RED;
3864                   mem_rotate_left (w);
3865                   w = x->parent->left;
3866                 }
3867 
3868               w->color = x->parent->color;
3869               x->parent->color = MEM_BLACK;
3870               w->left->color = MEM_BLACK;
3871               mem_rotate_right (x->parent);
3872               x = mem_root;
3873             }
3874         }
3875     }
3876 
3877   x->color = MEM_BLACK;
3878 }
3879 
3880 
3881 /* Value is non-zero if P is a pointer to a live Lisp string on
3882    the heap.  M is a pointer to the mem_block for P.  */
3883 
3884 static INLINE int
3885 live_string_p (m, p)
3886      struct mem_node *m;
3887      void *p;
3888 {
3889   if (m->type == MEM_TYPE_STRING)
3890     {
3891       struct string_block *b = (struct string_block *) m->start;
3892       int offset = (char *) p - (char *) &b->strings[0];
3893 
3894       /* P must point to the start of a Lisp_String structure, and it
3895          must not be on the free-list.  */
3896       return (offset >= 0
3897               && offset % sizeof b->strings[0] == 0
3898               && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
3899               && ((struct Lisp_String *) p)->data != NULL);
3900     }
3901   else
3902     return 0;
3903 }
3904 
3905 
3906 /* Value is non-zero if P is a pointer to a live Lisp cons on
3907    the heap.  M is a pointer to the mem_block for P.  */
3908 
3909 static INLINE int
3910 live_cons_p (m, p)
3911      struct mem_node *m;
3912      void *p;
3913 {
3914   if (m->type == MEM_TYPE_CONS)
3915     {
3916       struct cons_block *b = (struct cons_block *) m->start;
3917       int offset = (char *) p - (char *) &b->conses[0];
3918 
3919       /* P must point to the start of a Lisp_Cons, not be
3920          one of the unused cells in the current cons block,
3921          and not be on the free-list.  */
3922       return (offset >= 0
3923               && offset % sizeof b->conses[0] == 0
3924               && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
3925               && (b != cons_block
3926                   || offset / sizeof b->conses[0] < cons_block_index)
3927               && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
3928     }
3929   else
3930     return 0;
3931 }
3932 
3933 
3934 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3935    the heap.  M is a pointer to the mem_block for P.  */
3936 
3937 static INLINE int
3938 live_symbol_p (m, p)
3939      struct mem_node *m;
3940      void *p;
3941 {
3942   if (m->type == MEM_TYPE_SYMBOL)
3943     {
3944       struct symbol_block *b = (struct symbol_block *) m->start;
3945       int offset = (char *) p - (char *) &b->symbols[0];
3946 
3947       /* P must point to the start of a Lisp_Symbol, not be
3948          one of the unused cells in the current symbol block,
3949          and not be on the free-list.  */
3950       return (offset >= 0
3951               && offset % sizeof b->symbols[0] == 0
3952               && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3953               && (b != symbol_block
3954                   || offset / sizeof b->symbols[0] < symbol_block_index)
3955               && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
3956     }
3957   else
3958     return 0;
3959 }
3960 
3961 
3962 /* Value is non-zero if P is a pointer to a live Lisp float on
3963    the heap.  M is a pointer to the mem_block for P.  */
3964 
3965 static INLINE int
3966 live_float_p (m, p)
3967      struct mem_node *m;
3968      void *p;
3969 {
3970   if (m->type == MEM_TYPE_FLOAT)
3971     {
3972       struct float_block *b = (struct float_block *) m->start;
3973       int offset = (char *) p - (char *) &b->floats[0];
3974 
3975       /* P must point to the start of a Lisp_Float and not be
3976          one of the unused cells in the current float block.  */
3977       return (offset >= 0
3978               && offset % sizeof b->floats[0] == 0
3979               && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
3980               && (b != float_block
3981                   || offset / sizeof b->floats[0] < float_block_index));
3982     }
3983   else
3984     return 0;
3985 }
3986 
3987 
3988 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3989    the heap.  M is a pointer to the mem_block for P.  */
3990 
3991 static INLINE int
3992 live_misc_p (m, p)
3993      struct mem_node *m;
3994      void *p;
3995 {
3996   if (m->type == MEM_TYPE_MISC)
3997     {
3998       struct marker_block *b = (struct marker_block *) m->start;
3999       int offset = (char *) p - (char *) &b->markers[0];
4000 
4001       /* P must point to the start of a Lisp_Misc, not be
4002          one of the unused cells in the current misc block,
4003          and not be on the free-list.  */
4004       return (offset >= 0
4005               && offset % sizeof b->markers[0] == 0
4006               && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4007               && (b != marker_block
4008                   || offset / sizeof b->markers[0] < marker_block_index)
4009               && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4010     }
4011   else
4012     return 0;
4013 }
4014 
4015 
4016 /* Value is non-zero if P is a pointer to a live vector-like object.
4017    M is a pointer to the mem_block for P.  */
4018 
4019 static INLINE int
4020 live_vector_p (m, p)
4021      struct mem_node *m;
4022      void *p;
4023 {
4024   return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
4025 }
4026 
4027 
4028 /* Value is non-zero if P is a pointer to a live buffer.  M is a
4029    pointer to the mem_block for P.  */
4030 
4031 static INLINE int
4032 live_buffer_p (m, p)
4033      struct mem_node *m;
4034      void *p;
4035 {
4036   /* P must point to the start of the block, and the buffer
4037      must not have been killed.  */
4038   return (m->type == MEM_TYPE_BUFFER
4039           && p == m->start
4040           && !NILP (((struct buffer *) p)->name));
4041 }
4042 
4043 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4044 
4045 #if GC_MARK_STACK
4046 
4047 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4048 
4049 /* Array of objects that are kept alive because the C stack contains
4050    a pattern that looks like a reference to them .  */
4051 
4052 #define MAX_ZOMBIES 10
4053 static Lisp_Object zombies[MAX_ZOMBIES];
4054 
4055 /* Number of zombie objects.  */
4056 
4057 static int nzombies;
4058 
4059 /* Number of garbage collections.  */
4060 
4061 static int ngcs;
4062 
4063 /* Average percentage of zombies per collection.  */
4064 
4065 static double avg_zombies;
4066 
4067 /* Max. number of live and zombie objects.  */
4068 
4069 static int max_live, max_zombies;
4070 
4071 /* Average number of live objects per GC.  */
4072 
4073 static double avg_live;
4074 
4075 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4076        doc: /* Show information about live and zombie objects.  */)
4077      ()
4078 {
4079   Lisp_Object args[8], zombie_list = Qnil;
4080   int i;
4081   for (i = 0; i < nzombies; i++)
4082     zombie_list = Fcons (zombies[i], zombie_list);
4083   args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4084   args[1] = make_number (ngcs);
4085   args[2] = make_float (avg_live);
4086   args[3] = make_float (avg_zombies);
4087   args[4] = make_float (avg_zombies / avg_live / 100);
4088   args[5] = make_number (max_live);
4089   args[6] = make_number (max_zombies);
4090   args[7] = zombie_list;
4091   return Fmessage (8, args);
4092 }
4093 
4094 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4095 
4096 
4097 /* Mark OBJ if we can prove it's a Lisp_Object.  */
4098 
4099 static INLINE void
4100 mark_maybe_object (obj)
4101      Lisp_Object obj;
4102 {
4103   void *po = (void *) XPNTR (obj);
4104   struct mem_node *m = mem_find (po);
4105 
4106   if (m != MEM_NIL)
4107     {
4108       int mark_p = 0;
4109 
4110       switch (XTYPE (obj))
4111         {
4112         case Lisp_String:
4113           mark_p = (live_string_p (m, po)
4114                     && !STRING_MARKED_P ((struct Lisp_String *) po));
4115           break;
4116 
4117         case Lisp_Cons:
4118           mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4119           break;
4120 
4121         case Lisp_Symbol:
4122           mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4123           break;
4124 
4125         case Lisp_Float:
4126           mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4127           break;
4128 
4129         case Lisp_Vectorlike:
4130           /* Note: can't check BUFFERP before we know it's a
4131              buffer because checking that dereferences the pointer
4132              PO which might point anywhere.  */
4133           if (live_vector_p (m, po))
4134             mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4135           else if (live_buffer_p (m, po))
4136             mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4137           break;
4138 
4139         case Lisp_Misc:
4140           mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4141           break;
4142 
4143         default:
4144           break;
4145         }
4146 
4147       if (mark_p)
4148         {
4149 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4150           if (nzombies < MAX_ZOMBIES)
4151             zombies[nzombies] = obj;
4152           ++nzombies;
4153 #endif
4154           mark_object (obj);
4155         }
4156     }
4157 }
4158 
4159 
4160 /* If P points to Lisp data, mark that as live if it isn't already
4161    marked.  */
4162 
4163 static INLINE void
4164 mark_maybe_pointer (p)
4165      void *p;
4166 {
4167   struct mem_node *m;
4168 
4169   /* Quickly rule out some values which can't point to Lisp data.  */
4170   if ((EMACS_INT) p %
4171 #ifdef USE_LSB_TAG
4172       8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8.  */
4173 #else
4174       2 /* We assume that Lisp data is aligned on even addresses.  */
4175 #endif
4176       )
4177     return;
4178 
4179   m = mem_find (p);
4180   if (m != MEM_NIL)
4181     {
4182       Lisp_Object obj = Qnil;
4183 
4184       switch (m->type)
4185         {
4186         case MEM_TYPE_NON_LISP:
4187           /* Nothing to do; not a pointer to Lisp memory.  */
4188           break;
4189 
4190         case MEM_TYPE_BUFFER:
4191           if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
4192             XSETVECTOR (obj, p);
4193           break;
4194 
4195         case MEM_TYPE_CONS:
4196           if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4197             XSETCONS (obj, p);
4198           break;
4199 
4200         case MEM_TYPE_STRING:
4201           if (live_string_p (m, p)
4202               && !STRING_MARKED_P ((struct Lisp_String *) p))
4203             XSETSTRING (obj, p);
4204           break;
4205 
4206         case MEM_TYPE_MISC:
4207           if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4208             XSETMISC (obj, p);
4209           break;
4210 
4211         case MEM_TYPE_SYMBOL:
4212           if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4213             XSETSYMBOL (obj, p);
4214           break;
4215 
4216         case MEM_TYPE_FLOAT:
4217           if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4218             XSETFLOAT (obj, p);
4219           break;
4220 
4221         case MEM_TYPE_VECTORLIKE:
4222           if (live_vector_p (m, p))
4223             {
4224               Lisp_Object tem;
4225               XSETVECTOR (tem, p);
4226               if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4227                 obj = tem;
4228             }
4229           break;
4230 
4231         default:
4232           abort ();
4233         }
4234 
4235       if (!NILP (obj))
4236         mark_object (obj);
4237     }
4238 }
4239 
4240 
4241 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4242    or END+OFFSET..START. */
4243 
4244 static void
4245 mark_memory (start, end, offset)
4246      void *start, *end;
4247      int offset;
4248 {
4249   Lisp_Object *p;
4250   void **pp;
4251 
4252 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4253   nzombies = 0;
4254 #endif
4255 
4256   /* Make START the pointer to the start of the memory region,
4257      if it isn't already.  */
4258   if (end < start)
4259     {
4260       void *tem = start;
4261       start = end;
4262       end = tem;
4263     }
4264 
4265   /* Mark Lisp_Objects.  */
4266   for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
4267     mark_maybe_object (*p);
4268 
4269   /* Mark Lisp data pointed to.  This is necessary because, in some
4270      situations, the C compiler optimizes Lisp objects away, so that
4271      only a pointer to them remains.  Example:
4272 
4273      DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4274      ()
4275      {
4276        Lisp_Object obj = build_string ("test");
4277        struct Lisp_String *s = XSTRING (obj);
4278        Fgarbage_collect ();
4279        fprintf (stderr, "test `%s'\n", s->data);
4280        return Qnil;
4281      }
4282 
4283      Here, `obj' isn't really used, and the compiler optimizes it
4284      away.  The only reference to the life string is through the
4285      pointer `s'.  */
4286 
4287   for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
4288     mark_maybe_pointer (*pp);
4289 }
4290 
4291 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4292    the GCC system configuration.  In gcc 3.2, the only systems for
4293    which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4294    by others?) and ns32k-pc532-min.  */
4295 
4296 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4297 
4298 static int setjmp_tested_p, longjmps_done;
4299 
4300 #define SETJMP_WILL_LIKELY_WORK "\
4301 \n\
4302 Emacs garbage collector has been changed to use conservative stack\n\
4303 marking.  Emacs has determined that the method it uses to do the\n\
4304 marking will likely work on your system, but this isn't sure.\n\
4305 \n\
4306 If you are a system-programmer, or can get the help of a local wizard\n\
4307 who is, please take a look at the function mark_stack in alloc.c, and\n\
4308 verify that the methods used are appropriate for your system.\n\
4309 \n\
4310 Please mail the result to <emacs-devel@gnu.org>.\n\
4311 "
4312 
4313 #define SETJMP_WILL_NOT_WORK "\
4314 \n\
4315 Emacs garbage collector has been changed to use conservative stack\n\
4316 marking.  Emacs has determined that the default method it uses to do the\n\
4317 marking will not work on your system.  We will need a system-dependent\n\
4318 solution for your system.\n\
4319 \n\
4320 Please take a look at the function mark_stack in alloc.c, and\n\
4321 try to find a way to make it work on your system.\n\
4322 \n\
4323 Note that you may get false negatives, depending on the compiler.\n\
4324 In particular, you need to use -O with GCC for this test.\n\
4325 \n\
4326 Please mail the result to <emacs-devel@gnu.org>.\n\
4327 "
4328 
4329 
4330 /* Perform a quick check if it looks like setjmp saves registers in a
4331    jmp_buf.  Print a message to stderr saying so.  When this test
4332    succeeds, this is _not_ a proof that setjmp is sufficient for
4333    conservative stack marking.  Only the sources or a disassembly
4334    can prove that.  */
4335 
4336 static void
4337 test_setjmp ()
4338 {
4339   char buf[10];
4340   register int x;
4341   jmp_buf jbuf;
4342   int result = 0;
4343 
4344   /* Arrange for X to be put in a register.  */
4345   sprintf (buf, "1");
4346   x = strlen (buf);
4347   x = 2 * x - 1;
4348 
4349   setjmp (jbuf);
4350   if (longjmps_done == 1)
4351     {
4352       /* Came here after the longjmp at the end of the function.
4353 
4354          If x == 1, the longjmp has restored the register to its
4355          value before the setjmp, and we can hope that setjmp
4356          saves all such registers in the jmp_buf, although that
4357          isn't sure.
4358 
4359          For other values of X, either something really strange is
4360          taking place, or the setjmp just didn't save the register.  */
4361 
4362       if (x == 1)
4363         fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
4364       else
4365         {
4366           fprintf (stderr, SETJMP_WILL_NOT_WORK);
4367           exit (1);
4368         }
4369     }
4370 
4371   ++longjmps_done;
4372   x = 2;
4373   if (longjmps_done == 1)
4374     longjmp (jbuf, 1);
4375 }
4376 
4377 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4378 
4379 
4380 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4381 
4382 /* Abort if anything GCPRO'd doesn't survive the GC.  */
4383 
4384 static void
4385 check_gcpros ()
4386 {
4387   struct gcpro *p;
4388   int i;
4389 
4390   for (p = gcprolist; p; p = p->next)
4391     for (i = 0; i < p->nvars; ++i)
4392       if (!survives_gc_p (p->var[i]))
4393         /* FIXME: It's not necessarily a bug.  It might just be that the
4394            GCPRO is unnecessary or should release the object sooner.  */
4395         abort ();
4396 }
4397 
4398 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4399 
4400 static void
4401 dump_zombies ()
4402 {
4403   int i;
4404 
4405   fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
4406   for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
4407     {
4408       fprintf (stderr, "  %d = ", i);
4409       debug_print (zombies[i]);
4410     }
4411 }
4412 
4413 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4414 
4415 
4416 /* Mark live Lisp objects on the C stack.
4417 
4418    There are several system-dependent problems to consider when
4419    porting this to new architectures:
4420 
4421    Processor Registers
4422 
4423    We have to mark Lisp objects in CPU registers that can hold local
4424    variables or are used to pass parameters.
4425 
4426    If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4427    something that either saves relevant registers on the stack, or
4428    calls mark_maybe_object passing it each register's contents.
4429 
4430    If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4431    implementation assumes that calling setjmp saves registers we need
4432    to see in a jmp_buf which itself lies on the stack.  This doesn't
4433    have to be true!  It must be verified for each system, possibly
4434    by taking a look at the source code of setjmp.
4435 
4436    Stack Layout
4437 
4438    Architectures differ in the way their processor stack is organized.
4439    For example, the stack might look like this
4440 
4441      +----------------+
4442      |  Lisp_Object   |  size = 4
4443      +----------------+
4444      | something else |  size = 2
4445      +----------------+
4446      |  Lisp_Object   |  size = 4
4447      +----------------+
4448      |  ...           |
4449 
4450    In such a case, not every Lisp_Object will be aligned equally.  To
4451    find all Lisp_Object on the stack it won't be sufficient to walk
4452    the stack in steps of 4 bytes.  Instead, two passes will be
4453    necessary, one starting at the start of the stack, and a second
4454    pass starting at the start of the stack + 2.  Likewise, if the
4455    minimal alignment of Lisp_Objects on the stack is 1, four passes
4456    would be necessary, each one starting with one byte more offset
4457    from the stack start.
4458 
4459    The current code assumes by default that Lisp_Objects are aligned
4460    equally on the stack.  */
4461 
4462 static void
4463 mark_stack ()
4464 {
4465   int i;
4466   /* jmp_buf may not be aligned enough on darwin-ppc64 */
4467   union aligned_jmpbuf {
4468     Lisp_Object o;
4469     jmp_buf j;
4470   } j;
4471   volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
4472   void *end;
4473 
4474   /* This trick flushes the register windows so that all the state of
4475      the process is contained in the stack.  */
4476   /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4477      needed on ia64 too.  See mach_dep.c, where it also says inline
4478      assembler doesn't work with relevant proprietary compilers.  */
4479 #ifdef __sparc__
4480 #if defined (__sparc64__) && defined (__FreeBSD__)
4481   /* FreeBSD does not have a ta 3 handler.  */
4482   asm ("flushw");
4483 #else
4484   asm ("ta 3");
4485 #endif
4486 #endif
4487 
4488   /* Save registers that we need to see on the stack.  We need to see
4489      registers used to hold register variables and registers used to
4490      pass parameters.  */
4491 #ifdef GC_SAVE_REGISTERS_ON_STACK
4492   GC_SAVE_REGISTERS_ON_STACK (end);
4493 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4494 
4495 #ifndef GC_SETJMP_WORKS  /* If it hasn't been checked yet that
4496                             setjmp will definitely work, test it
4497                             and print a message with the result
4498                             of the test.  */
4499   if (!setjmp_tested_p)
4500     {
4501       setjmp_tested_p = 1;
4502       test_setjmp ();
4503     }
4504 #endif /* GC_SETJMP_WORKS */
4505 
4506   setjmp (j.j);
4507   end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4508 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4509 
4510   /* This assumes that the stack is a contiguous region in memory.  If
4511      that's not the case, something has to be done here to iterate
4512      over the stack segments.  */
4513 #ifndef GC_LISP_OBJECT_ALIGNMENT
4514 #ifdef __GNUC__
4515 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4516 #else
4517 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4518 #endif
4519 #endif
4520   for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
4521     mark_memory (stack_base, end, i);
4522   /* Allow for marking a secondary stack, like the register stack on the
4523      ia64.  */
4524 #ifdef GC_MARK_SECONDARY_STACK
4525   GC_MARK_SECONDARY_STACK ();
4526 #endif
4527 
4528 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4529   check_gcpros ();
4530 #endif
4531 }
4532 
4533 #endif /* GC_MARK_STACK != 0 */
4534 
4535 
4536 /* Determine whether it is safe to access memory at address P.  */
4537 static int
4538 valid_pointer_p (p)
4539      void *p;
4540 {
4541 #ifdef WINDOWSNT
4542   return w32_valid_pointer_p (p, 16);
4543 #else
4544   int fd;
4545 
4546   /* Obviously, we cannot just access it (we would SEGV trying), so we
4547      trick the o/s to tell us whether p is a valid pointer.
4548      Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4549      not validate p in that case.  */
4550 
4551   if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
4552     {
4553       int valid = (emacs_write (fd, (char *)p, 16) == 16);
4554       emacs_close (fd);
4555       unlink ("__Valid__Lisp__Object__");
4556       return valid;
4557     }
4558 
4559     return -1;
4560 #endif
4561 }
4562 
4563 /* Return 1 if OBJ is a valid lisp object.
4564    Return 0 if OBJ is NOT a valid lisp object.
4565    Return -1 if we cannot validate OBJ.
4566    This function can be quite slow,
4567    so it should only be used in code for manual debugging.  */
4568 
4569 int
4570 valid_lisp_object_p (obj)
4571      Lisp_Object obj;
4572 {
4573   void *p;
4574 #if GC_MARK_STACK
4575   struct mem_node *m;
4576 #endif
4577 
4578   if (INTEGERP (obj))
4579     return 1;
4580 
4581   p = (void *) XPNTR (obj);
4582   if (PURE_POINTER_P (p))
4583     return 1;
4584 
4585 #if !GC_MARK_STACK
4586   return valid_pointer_p (p);
4587 #else
4588 
4589   m = mem_find (p);
4590 
4591   if (m == MEM_NIL)
4592     {
4593       int valid = valid_pointer_p (p);
4594       if (valid <= 0)
4595         return valid;
4596 
4597       if (SUBRP (obj))
4598         return 1;
4599 
4600       return 0;
4601     }
4602 
4603   switch (m->type)
4604     {
4605     case MEM_TYPE_NON_LISP:
4606       return 0;
4607 
4608     case MEM_TYPE_BUFFER:
4609       return live_buffer_p (m, p);
4610 
4611     case MEM_TYPE_CONS:
4612       return live_cons_p (m, p);
4613 
4614     case MEM_TYPE_STRING:
4615       return live_string_p (m, p);
4616 
4617     case MEM_TYPE_MISC:
4618       return live_misc_p (m, p);
4619 
4620     case MEM_TYPE_SYMBOL:
4621       return live_symbol_p (m, p);
4622 
4623     case MEM_TYPE_FLOAT:
4624       return live_float_p (m, p);
4625 
4626     case MEM_TYPE_VECTORLIKE:
4627       return live_vector_p (m, p);
4628 
4629     default:
4630       break;
4631     }
4632 
4633   return 0;
4634 #endif
4635 }
4636 
4637 
4638 
4639 
4640 /***********************************************************************
4641                        Pure Storage Management
4642  ***********************************************************************/
4643 
4644 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4645    pointer to it.  TYPE is the Lisp type for which the memory is
4646    allocated.  TYPE < 0 means it's not used for a Lisp object.  */
4647 
4648 static POINTER_TYPE *
4649 pure_alloc (size, type)
4650      size_t size;
4651      int type;
4652 {
4653   POINTER_TYPE *result;
4654 #ifdef USE_LSB_TAG
4655   size_t alignment = (1 << GCTYPEBITS);
4656 #else
4657   size_t alignment = sizeof (EMACS_INT);
4658 
4659   /* Give Lisp_Floats an extra alignment.  */
4660   if (type == Lisp_Float)
4661     {
4662 #if defined __GNUC__ && __GNUC__ >= 2
4663       alignment = __alignof (struct Lisp_Float);
4664 #else
4665       alignment = sizeof (struct Lisp_Float);
4666 #endif
4667     }
4668 #endif
4669 
4670  again:
4671   if (type >= 0)
4672     {
4673       /* Allocate space for a Lisp object from the beginning of the free
4674          space with taking account of alignment.  */
4675       result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
4676       pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
4677     }
4678   else
4679     {
4680       /* Allocate space for a non-Lisp object from the end of the free
4681          space.  */
4682       pure_bytes_used_non_lisp += size;
4683       result = purebeg + pure_size - pure_bytes_used_non_lisp;
4684     }
4685   pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
4686 
4687   if (pure_bytes_used <= pure_size)
4688     return result;
4689 
4690   /* Don't allocate a large amount here,
4691      because it might get mmap'd and then its address
4692      might not be usable.  */
4693   purebeg = (char *) xmalloc (10000);
4694   pure_size = 10000;
4695   pure_bytes_used_before_overflow += pure_bytes_used - size;
4696   pure_bytes_used = 0;
4697   pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
4698   goto again;
4699 }
4700 
4701 
4702 /* Print a warning if PURESIZE is too small.  */
4703 
4704 void
4705 check_pure_size ()
4706 {
4707   if (pure_bytes_used_before_overflow)
4708     message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4709              (int) (pure_bytes_used + pure_bytes_used_before_overflow));
4710 }
4711 
4712 
4713 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4714    the non-Lisp data pool of the pure storage, and return its start
4715    address.  Return NULL if not found.  */
4716 
4717 static char *
4718 find_string_data_in_pure (data, nbytes)
4719      const char *data;
4720      int nbytes;
4721 {
4722   int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4723   const unsigned char *p;
4724   char *non_lisp_beg;
4725 
4726   if (pure_bytes_used_non_lisp < nbytes + 1)
4727     return NULL;
4728 
4729   /* Set up the Boyer-Moore table.  */
4730   skip = nbytes + 1;
4731   for (i = 0; i < 256; i++)
4732     bm_skip[i] = skip;
4733 
4734   p = (const unsigned char *) data;
4735   while (--skip > 0)
4736     bm_skip[*p++] = skip;
4737 
4738   last_char_skip = bm_skip['\0'];
4739 
4740   non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
4741   start_max = pure_bytes_used_non_lisp - (nbytes + 1);
4742 
4743   /* See the comments in the function `boyer_moore' (search.c) for the
4744      use of `infinity'.  */
4745   infinity = pure_bytes_used_non_lisp + 1;
4746   bm_skip['\0'] = infinity;
4747 
4748   p = (const unsigned char *) non_lisp_beg + nbytes;
4749   start = 0;
4750   do
4751     {
4752       /* Check the last character (== '\0').  */
4753       do
4754         {
4755           start += bm_skip[*(p + start)];
4756         }
4757       while (start <= start_max);
4758 
4759       if (start < infinity)
4760         /* Couldn't find the last character.  */
4761         return NULL;
4762 
4763       /* No less than `infinity' means we could find the last
4764          character at `p[start - infinity]'.  */
4765       start -= infinity;
4766 
4767       /* Check the remaining characters.  */
4768       if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
4769         /* Found.  */
4770         return non_lisp_beg + start;
4771 
4772       start += last_char_skip;
4773     }
4774   while (start <= start_max);
4775 
4776   return NULL;
4777 }
4778 
4779 
4780 /* Return a string allocated in pure space.  DATA is a buffer holding
4781    NCHARS characters, and NBYTES bytes of string data.  MULTIBYTE
4782    non-zero means make the result string multibyte.
4783 
4784    Must get an error if pure storage is full, since if it cannot hold
4785    a large string it may be able to hold conses that point to that
4786    string; then the string is not protected from gc.  */
4787 
4788 Lisp_Object
4789 make_pure_string (data, nchars, nbytes, multibyte)
4790      const char *data;
4791      int nchars, nbytes;
4792      int multibyte;
4793 {
4794   Lisp_Object string;
4795   struct Lisp_String *s;
4796 
4797   s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4798   s->data = find_string_data_in_pure (data, nbytes);
4799   if (s->data == NULL)
4800     {
4801       s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
4802       bcopy (data, s->data, nbytes);
4803       s->data[nbytes] = '\0';
4804     }
4805   s->size = nchars;
4806   s->size_byte = multibyte ? nbytes : -1;
4807   s->intervals = NULL_INTERVAL;
4808   XSETSTRING (string, s);
4809   return string;
4810 }
4811 
4812 /* Return a string a string allocated in pure space.  Do not allocate
4813    the string data, just point to DATA.  */
4814 
4815 Lisp_Object
4816 make_pure_c_string (const char *data)
4817 {
4818   Lisp_Object string;
4819   struct Lisp_String *s;
4820   int nchars = strlen (data);
4821 
4822   s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4823   s->size = nchars;
4824   s->size_byte = -1;
4825   s->data = (unsigned char *) data;
4826   s->intervals = NULL_INTERVAL;
4827   XSETSTRING (string, s);
4828   return string;
4829 }
4830 
4831 /* Return a cons allocated from pure space.  Give it pure copies
4832    of CAR as car and CDR as cdr.  */
4833 
4834 Lisp_Object
4835 pure_cons (car, cdr)
4836      Lisp_Object car, cdr;
4837 {
4838   register Lisp_Object new;
4839   struct Lisp_Cons *p;
4840 
4841   p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4842   XSETCONS (new, p);
4843   XSETCAR (new, Fpurecopy (car));
4844   XSETCDR (new, Fpurecopy (cdr));
4845   return new;
4846 }
4847 
4848 
4849 /* Value is a float object with value NUM allocated from pure space.  */
4850 
4851 static Lisp_Object
4852 make_pure_float (num)
4853      double num;
4854 {
4855   register Lisp_Object new;
4856   struct Lisp_Float *p;
4857 
4858   p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4859   XSETFLOAT (new, p);
4860   XFLOAT_INIT (new, num);
4861   return new;
4862 }
4863 
4864 
4865 /* Return a vector with room for LEN Lisp_Objects allocated from
4866    pure space.  */
4867 
4868 Lisp_Object
4869 make_pure_vector (len)
4870      EMACS_INT len;
4871 {
4872   Lisp_Object new;
4873   struct Lisp_Vector *p;
4874   size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
4875 
4876   p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4877   XSETVECTOR (new, p);
4878   XVECTOR (new)->size = len;
4879   return new;
4880 }
4881 
4882 
4883 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
4884        doc: /* Make a copy of object OBJ in pure storage.
4885 Recursively copies contents of vectors and cons cells.
4886 Does not copy symbols.  Copies strings without text properties.  */)
4887      (obj)
4888      register Lisp_Object obj;
4889 {
4890   if (NILP (Vpurify_flag))
4891     return obj;
4892 
4893   if (PURE_POINTER_P (XPNTR (obj)))
4894     return obj;
4895 
4896   if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing.  */
4897     {
4898       Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
4899       if (!NILP (tmp))
4900         return tmp;
4901     }
4902 
4903   if (CONSP (obj))
4904     obj = pure_cons (XCAR (obj), XCDR (obj));
4905   else if (FLOATP (obj))
4906     obj = make_pure_float (XFLOAT_DATA (obj));
4907   else if (STRINGP (obj))
4908     obj = make_pure_string (SDATA (obj), SCHARS (obj),
4909                             SBYTES (obj),
4910                             STRING_MULTIBYTE (obj));
4911   else if (COMPILEDP (obj) || VECTORP (obj))
4912     {
4913       register struct Lisp_Vector *vec;
4914       register int i;
4915       EMACS_INT size;
4916 
4917       size = XVECTOR (obj)->size;
4918       if (size & PSEUDOVECTOR_FLAG)
4919         size &= PSEUDOVECTOR_SIZE_MASK;
4920       vec = XVECTOR (make_pure_vector (size));
4921       for (i = 0; i < size; i++)
4922         vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
4923       if (COMPILEDP (obj))
4924         {
4925           XSETPVECTYPE (vec, PVEC_COMPILED);
4926           XSETCOMPILED (obj, vec);
4927         }
4928       else
4929         XSETVECTOR (obj, vec);
4930     }
4931   else if (MARKERP (obj))
4932     error ("Attempt to copy a marker to pure storage");
4933   else
4934     /* Not purified, don't hash-cons.  */
4935     return obj;
4936 
4937   if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing.  */
4938     Fputhash (obj, obj, Vpurify_flag);
4939 
4940   return obj;
4941 }
4942 
4943 
4944 
4945 /***********************************************************************
4946                           Protection from GC
4947  ***********************************************************************/
4948 
4949 /* Put an entry in staticvec, pointing at the variable with address
4950    VARADDRESS.  */
4951 
4952 void
4953 staticpro (varaddress)
4954      Lisp_Object *varaddress;
4955 {
4956   staticvec[staticidx++] = varaddress;
4957   if (staticidx >= NSTATICS)
4958     abort ();
4959 }
4960 
4961 
4962 /***********************************************************************
4963                           Protection from GC
4964  ***********************************************************************/
4965 
4966 /* Temporarily prevent garbage collection.  */
4967 
4968 int
4969 inhibit_garbage_collection ()
4970 {
4971   int count = SPECPDL_INDEX ();
4972   int nbits = min (VALBITS, BITS_PER_INT);
4973 
4974   specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
4975   return count;
4976 }
4977 
4978 
4979 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
4980        doc: /* Reclaim storage for Lisp objects no longer needed.
4981 Garbage collection happens automatically if you cons more than
4982 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4983 `garbage-collect' normally returns a list with info on amount of space in use:
4984  ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4985   (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4986   (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4987   (USED-STRINGS . FREE-STRINGS))
4988 However, if there was overflow in pure space, `garbage-collect'
4989 returns nil, because real GC can't be done.  */)
4990      ()
4991 {
4992   register struct specbinding *bind;
4993   struct catchtag *catch;
4994   struct handler *handler;
4995   char stack_top_variable;
4996   register int i;
4997   int message_p;
4998   Lisp_Object total[8];
4999   int count = SPECPDL_INDEX ();
5000   EMACS_TIME t1, t2, t3;
5001 
5002   if (abort_on_gc)
5003     abort ();
5004 
5005   /* Can't GC if pure storage overflowed because we can't determine
5006      if something is a pure object or not.  */
5007   if (pure_bytes_used_before_overflow)
5008     return Qnil;
5009 
5010   CHECK_CONS_LIST ();
5011 
5012   /* Don't keep undo information around forever.
5013      Do this early on, so it is no problem if the user quits.  */
5014   {
5015     register struct buffer *nextb = all_buffers;
5016 
5017     while (nextb)
5018       {
5019         /* If a buffer's undo list is Qt, that means that undo is
5020            turned off in that buffer.  Calling truncate_undo_list on
5021            Qt tends to return NULL, which effectively turns undo back on.
5022            So don't call truncate_undo_list if undo_list is Qt.  */
5023         if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
5024           truncate_undo_list (nextb);
5025 
5026         /* Shrink buffer gaps, but skip indirect and dead buffers.  */
5027         if (nextb->base_buffer == 0 && !NILP (nextb->name)
5028             && ! nextb->text->inhibit_shrinking)
5029           {
5030             /* If a buffer's gap size is more than 10% of the buffer
5031                size, or larger than 2000 bytes, then shrink it
5032                accordingly.  Keep a minimum size of 20 bytes.  */
5033             int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5034 
5035             if (nextb->text->gap_size > size)
5036               {
5037                 struct buffer *save_current = current_buffer;
5038                 current_buffer = nextb;
5039                 make_gap (-(nextb->text->gap_size - size));
5040                 current_buffer = save_current;
5041               }
5042           }
5043 
5044         nextb = nextb->next;
5045       }
5046   }
5047 
5048   EMACS_GET_TIME (t1);
5049 
5050   /* In case user calls debug_print during GC,
5051      don't let that cause a recursive GC.  */
5052   consing_since_gc = 0;
5053 
5054   /* Save what's currently displayed in the echo area.  */
5055   message_p = push_message ();
5056   record_unwind_protect (pop_message_unwind, Qnil);
5057 
5058   /* Save a copy of the contents of the stack, for debugging.  */
5059 #if MAX_SAVE_STACK > 0
5060   if (NILP (Vpurify_flag))
5061     {
5062       i = &stack_top_variable - stack_bottom;
5063       if (i < 0) i = -i;
5064       if (i < MAX_SAVE_STACK)
5065         {
5066           if (stack_copy == 0)
5067             stack_copy = (char *) xmalloc (stack_copy_size = i);
5068           else if (stack_copy_size < i)
5069             stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
5070           if (stack_copy)
5071             {
5072               if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
5073                 bcopy (stack_bottom, stack_copy, i);
5074               else
5075                 bcopy (&stack_top_variable, stack_copy, i);
5076             }
5077         }
5078     }
5079 #endif /* MAX_SAVE_STACK > 0 */
5080 
5081   if (garbage_collection_messages)
5082     message1_nolog ("Garbage collecting...");
5083 
5084   BLOCK_INPUT;
5085 
5086   shrink_regexp_cache ();
5087 
5088   gc_in_progress = 1;
5089 
5090   /* clear_marks (); */
5091 
5092   /* Mark all the special slots that serve as the roots of accessibility.  */
5093 
5094   for (i = 0; i < staticidx; i++)
5095     mark_object (*staticvec[i]);
5096 
5097   for (bind = specpdl; bind != specpdl_ptr; bind++)
5098     {
5099       mark_object (bind->symbol);
5100       mark_object (bind->old_value);
5101     }
5102   mark_terminals ();
5103   mark_kboards ();
5104   mark_ttys ();
5105 
5106 #ifdef USE_GTK
5107   {
5108     extern void xg_mark_data ();
5109     xg_mark_data ();
5110   }
5111 #endif
5112 
5113 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5114      || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5115   mark_stack ();
5116 #else
5117   {
5118     register struct gcpro *tail;
5119     for (tail = gcprolist; tail; tail = tail->next)
5120       for (i = 0; i < tail->nvars; i++)
5121         mark_object (tail->var[i]);
5122   }
5123 #endif
5124 
5125   mark_byte_stack ();
5126   for (catch = catchlist; catch; catch = catch->next)
5127     {
5128       mark_object (catch->tag);
5129       mark_object (catch->val);
5130     }
5131   for (handler = handlerlist; handler; handler = handler->next)
5132     {
5133       mark_object (handler->handler);
5134       mark_object (handler->var);
5135     }
5136   mark_backtrace ();
5137 
5138 #ifdef HAVE_WINDOW_SYSTEM
5139   mark_fringe_data ();
5140 #endif
5141 
5142 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5143   mark_stack ();
5144 #endif
5145 
5146   /* Everything is now marked, except for the things that require special
5147      finalization, i.e. the undo_list.
5148      Look thru every buffer's undo list
5149      for elements that update markers that were not marked,
5150      and delete them.  */
5151   {
5152     register struct buffer *nextb = all_buffers;
5153 
5154     while (nextb)
5155       {
5156         /* If a buffer's undo list is Qt, that means that undo is
5157            turned off in that buffer.  Calling truncate_undo_list on
5158            Qt tends to return NULL, which effectively turns undo back on.
5159            So don't call truncate_undo_list if undo_list is Qt.  */
5160         if (! EQ (nextb->undo_list, Qt))
5161           {
5162             Lisp_Object tail, prev;
5163             tail = nextb->undo_list;
5164             prev = Qnil;
5165             while (CONSP (tail))
5166               {
5167                 if (CONSP (XCAR (tail))
5168                     && MARKERP (XCAR (XCAR (tail)))
5169                     && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5170                   {
5171                     if (NILP (prev))
5172                       nextb->undo_list = tail = XCDR (tail);
5173                     else
5174                       {
5175                         tail = XCDR (tail);
5176                         XSETCDR (prev, tail);
5177                       }
5178                   }
5179                 else
5180                   {
5181                     prev = tail;
5182                     tail = XCDR (tail);
5183                   }
5184               }
5185           }
5186         /* Now that we have stripped the elements that need not be in the
5187            undo_list any more, we can finally mark the list.  */
5188         mark_object (nextb->undo_list);
5189 
5190         nextb = nextb->next;
5191       }
5192   }
5193 
5194   gc_sweep ();
5195 
5196   /* Clear the mark bits that we set in certain root slots.  */
5197 
5198   unmark_byte_stack ();
5199   VECTOR_UNMARK (&buffer_defaults);
5200   VECTOR_UNMARK (&buffer_local_symbols);
5201 
5202 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5203   dump_zombies ();
5204 #endif
5205 
5206   UNBLOCK_INPUT;
5207 
5208   CHECK_CONS_LIST ();
5209 
5210   /* clear_marks (); */
5211   gc_in_progress = 0;
5212 
5213   consing_since_gc = 0;
5214   if (gc_cons_threshold < 10000)
5215     gc_cons_threshold = 10000;
5216 
5217   if (FLOATP (Vgc_cons_percentage))
5218     { /* Set gc_cons_combined_threshold.  */
5219       EMACS_INT total = 0;
5220 
5221       total += total_conses  * sizeof (struct Lisp_Cons);
5222       total += total_symbols * sizeof (struct Lisp_Symbol);
5223       total += total_markers * sizeof (union Lisp_Misc);
5224       total += total_string_size;
5225       total += total_vector_size * sizeof (Lisp_Object);
5226       total += total_floats  * sizeof (struct Lisp_Float);
5227       total += total_intervals * sizeof (struct interval);
5228       total += total_strings * sizeof (struct Lisp_String);
5229 
5230       gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
5231     }
5232   else
5233     gc_relative_threshold = 0;
5234 
5235   if (garbage_collection_messages)
5236     {
5237       if (message_p || minibuf_level > 0)
5238         restore_message ();
5239       else
5240         message1_nolog ("Garbage collecting...done");
5241     }
5242 
5243   unbind_to (count, Qnil);
5244 
5245   total[0] = Fcons (make_number (total_conses),
5246                     make_number (total_free_conses));
5247   total[1] = Fcons (make_number (total_symbols),
5248                     make_number (total_free_symbols));
5249   total[2] = Fcons (make_number (total_markers),
5250                     make_number (total_free_markers));
5251   total[3] = make_number (total_string_size);
5252   total[4] = make_number (total_vector_size);
5253   total[5] = Fcons (make_number (total_floats),
5254                     make_number (total_free_floats));
5255   total[6] = Fcons (make_number (total_intervals),
5256                     make_number (total_free_intervals));
5257   total[7] = Fcons (make_number (total_strings),
5258                     make_number (total_free_strings));
5259 
5260 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5261   {
5262     /* Compute average percentage of zombies.  */
5263     double nlive = 0;
5264 
5265     for (i = 0; i < 7; ++i)
5266       if (CONSP (total[i]))
5267         nlive += XFASTINT (XCAR (total[i]));
5268 
5269     avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5270     max_live = max (nlive, max_live);
5271     avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5272     max_zombies = max (nzombies, max_zombies);
5273     ++ngcs;
5274     }
5275 #endif
5276 
5277   if (!NILP (Vpost_gc_hook))
5278     {
5279       int count = inhibit_garbage_collection ();
5280       safe_run_hooks (Qpost_gc_hook);
5281       unbind_to (count, Qnil);
5282     }
5283 
5284   /* Accumulate statistics.  */
5285   EMACS_GET_TIME (t2);
5286   EMACS_SUB_TIME (t3, t2, t1);
5287   if (FLOATP (Vgc_elapsed))
5288     Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
5289                               EMACS_SECS (t3) +
5290                               EMACS_USECS (t3) * 1.0e-6);
5291   gcs_done++;
5292 
5293   return Flist (sizeof total / sizeof *total, total);
5294 }
5295 
5296 
5297 /* Mark Lisp objects in glyph matrix MATRIX.  Currently the
5298    only interesting objects referenced from glyphs are strings.  */
5299 
5300 static void
5301 mark_glyph_matrix (matrix)
5302      struct glyph_matrix *matrix;
5303 {
5304   struct glyph_row *row = matrix->rows;
5305   struct glyph_row *end = row + matrix->nrows;
5306 
5307   for (; row < end; ++row)
5308     if (row->enabled_p)
5309       {
5310         int area;
5311         for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
5312           {
5313             struct glyph *glyph = row->glyphs[area];
5314             struct glyph *end_glyph = glyph + row->used[area];
5315 
5316             for (; glyph < end_glyph; ++glyph)
5317               if (STRINGP (glyph->object)
5318                   && !STRING_MARKED_P (XSTRING (glyph->object)))
5319                 mark_object (glyph->object);
5320           }
5321       }
5322 }
5323 
5324 
5325 /* Mark Lisp faces in the face cache C.  */
5326 
5327 static void
5328 mark_face_cache (c)
5329      struct face_cache *c;
5330 {
5331   if (c)
5332     {
5333       int i, j;
5334       for (i = 0; i < c->used; ++i)
5335         {
5336           struct face *face = FACE_FROM_ID (c->f, i);
5337 
5338           if (face)
5339             {
5340               for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
5341                 mark_object (face->lface[j]);
5342             }
5343         }
5344     }
5345 }
5346 
5347 
5348 
5349 /* Mark reference to a Lisp_Object.
5350    If the object referred to has not been seen yet, recursively mark
5351    all the references contained in it.  */
5352 
5353 #define LAST_MARKED_SIZE 500
5354 static Lisp_Object last_marked[LAST_MARKED_SIZE];
5355 int last_marked_index;
5356 
5357 /* For debugging--call abort when we cdr down this many
5358    links of a list, in mark_object.  In debugging,
5359    the call to abort will hit a breakpoint.
5360    Normally this is zero and the check never goes off.  */
5361 static int mark_object_loop_halt;
5362 
5363 static void
5364 mark_vectorlike (ptr)
5365      struct Lisp_Vector *ptr;
5366 {
5367   register EMACS_INT size = ptr->size;
5368   register int i;
5369 
5370   eassert (!VECTOR_MARKED_P (ptr));
5371   VECTOR_MARK (ptr);            /* Else mark it */
5372   if (size & PSEUDOVECTOR_FLAG)
5373     size &= PSEUDOVECTOR_SIZE_MASK;
5374 
5375   /* Note that this size is not the memory-footprint size, but only
5376      the number of Lisp_Object fields that we should trace.
5377      The distinction is used e.g. by Lisp_Process which places extra
5378      non-Lisp_Object fields at the end of the structure.  */
5379   for (i = 0; i < size; i++) /* and then mark its elements */
5380     mark_object (ptr->contents[i]);
5381 }
5382 
5383 /* Like mark_vectorlike but optimized for char-tables (and
5384    sub-char-tables) assuming that the contents are mostly integers or
5385    symbols.  */
5386 
5387 static void
5388 mark_char_table (ptr)
5389      struct Lisp_Vector *ptr;
5390 {
5391   register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
5392   register int i;
5393 
5394   eassert (!VECTOR_MARKED_P (ptr));
5395   VECTOR_MARK (ptr);
5396   for (i = 0; i < size; i++)
5397     {
5398       Lisp_Object val = ptr->contents[i];
5399 
5400       if (INTEGERP (val) || SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)
5401         continue;
5402       if (SUB_CHAR_TABLE_P (val))
5403         {
5404           if (! VECTOR_MARKED_P (XVECTOR (val)))
5405             mark_char_table (XVECTOR (val));
5406         }
5407       else
5408         mark_object (val);
5409     }
5410 }
5411 
5412 void
5413 mark_object (arg)
5414      Lisp_Object arg;
5415 {
5416   register Lisp_Object obj = arg;
5417 #ifdef GC_CHECK_MARKED_OBJECTS
5418   void *po;
5419   struct mem_node *m;
5420 #endif
5421   int cdr_count = 0;
5422 
5423  loop:
5424 
5425   if (PURE_POINTER_P (XPNTR (obj)))
5426     return;
5427 
5428   last_marked[last_marked_index++] = obj;
5429   if (last_marked_index == LAST_MARKED_SIZE)
5430     last_marked_index = 0;
5431 
5432   /* Perform some sanity checks on the objects marked here.  Abort if
5433      we encounter an object we know is bogus.  This increases GC time
5434      by ~80%, and requires compilation with GC_MARK_STACK != 0.  */
5435 #ifdef GC_CHECK_MARKED_OBJECTS
5436 
5437   po = (void *) XPNTR (obj);
5438 
5439   /* Check that the object pointed to by PO is known to be a Lisp
5440      structure allocated from the heap.  */
5441 #define CHECK_ALLOCATED()                       \
5442   do {                                          \
5443     m = mem_find (po);                          \
5444     if (m == MEM_NIL)                           \
5445       abort ();                                 \
5446   } while (0)
5447 
5448   /* Check that the object pointed to by PO is live, using predicate
5449      function LIVEP.  */
5450 #define CHECK_LIVE(LIVEP)                       \
5451   do {                                          \
5452     if (!LIVEP (m, po))                         \
5453       abort ();                                 \
5454   } while (0)
5455 
5456   /* Check both of the above conditions.  */
5457 #define CHECK_ALLOCATED_AND_LIVE(LIVEP)         \
5458   do {                                          \
5459     CHECK_ALLOCATED ();                         \
5460     CHECK_LIVE (LIVEP);                         \
5461   } while (0)                                   \
5462 
5463 #else /* not GC_CHECK_MARKED_OBJECTS */
5464 
5465 #define CHECK_ALLOCATED()               (void) 0
5466 #define CHECK_LIVE(LIVEP)               (void) 0
5467 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5468 
5469 #endif /* not GC_CHECK_MARKED_OBJECTS */
5470 
5471   switch (SWITCH_ENUM_CAST (XTYPE (obj)))
5472     {
5473     case Lisp_String:
5474       {
5475         register struct Lisp_String *ptr = XSTRING (obj);
5476         if (STRING_MARKED_P (ptr))
5477           break;
5478         CHECK_ALLOCATED_AND_LIVE (live_string_p);
5479         MARK_INTERVAL_TREE (ptr->intervals);
5480         MARK_STRING (ptr);
5481 #ifdef GC_CHECK_STRING_BYTES
5482         /* Check that the string size recorded in the string is the
5483            same as the one recorded in the sdata structure. */
5484         CHECK_STRING_BYTES (ptr);
5485 #endif /* GC_CHECK_STRING_BYTES */
5486       }
5487       break;
5488 
5489     case Lisp_Vectorlike:
5490       if (VECTOR_MARKED_P (XVECTOR (obj)))
5491         break;
5492 #ifdef GC_CHECK_MARKED_OBJECTS
5493       m = mem_find (po);
5494       if (m == MEM_NIL && !SUBRP (obj)
5495           && po != &buffer_defaults
5496           && po != &buffer_local_symbols)
5497         abort ();
5498 #endif /* GC_CHECK_MARKED_OBJECTS */
5499 
5500       if (BUFFERP (obj))
5501         {
5502 #ifdef GC_CHECK_MARKED_OBJECTS
5503           if (po != &buffer_defaults && po != &buffer_local_symbols)
5504             {
5505               struct buffer *b;
5506               for (b = all_buffers; b && b != po; b = b->next)
5507                 ;
5508               if (b == NULL)
5509                 abort ();
5510             }
5511 #endif /* GC_CHECK_MARKED_OBJECTS */
5512           mark_buffer (obj);
5513         }
5514       else if (SUBRP (obj))
5515         break;
5516       else if (COMPILEDP (obj))
5517         /* We could treat this just like a vector, but it is better to
5518            save the COMPILED_CONSTANTS element for last and avoid
5519            recursion there.  */
5520         {
5521           register struct Lisp_Vector *ptr = XVECTOR (obj);
5522           register EMACS_INT size = ptr->size;
5523           register int i;
5524 
5525           CHECK_LIVE (live_vector_p);
5526           VECTOR_MARK (ptr);    /* Else mark it */
5527           size &= PSEUDOVECTOR_SIZE_MASK;
5528           for (i = 0; i < size; i++) /* and then mark its elements */
5529             {
5530               if (i != COMPILED_CONSTANTS)
5531                 mark_object (ptr->contents[i]);
5532             }
5533           obj = ptr->contents[COMPILED_CONSTANTS];
5534           goto loop;
5535         }
5536       else if (FRAMEP (obj))
5537         {
5538           register struct frame *ptr = XFRAME (obj);
5539           mark_vectorlike (XVECTOR (obj));
5540           mark_face_cache (ptr->face_cache);
5541         }
5542       else if (WINDOWP (obj))
5543         {
5544           register struct Lisp_Vector *ptr = XVECTOR (obj);
5545           struct window *w = XWINDOW (obj);
5546           mark_vectorlike (ptr);
5547           /* Mark glyphs for leaf windows.  Marking window matrices is
5548              sufficient because frame matrices use the same glyph
5549              memory.  */
5550           if (NILP (w->hchild)
5551               && NILP (w->vchild)
5552               && w->current_matrix)
5553             {
5554               mark_glyph_matrix (w->current_matrix);
5555               mark_glyph_matrix (w->desired_matrix);
5556             }
5557         }
5558       else if (HASH_TABLE_P (obj))
5559         {
5560           struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
5561           mark_vectorlike ((struct Lisp_Vector *)h);
5562           /* If hash table is not weak, mark all keys and values.
5563              For weak tables, mark only the vector.  */
5564           if (NILP (h->weak))
5565             mark_object (h->key_and_value);
5566           else
5567             VECTOR_MARK (XVECTOR (h->key_and_value));
5568         }
5569       else if (CHAR_TABLE_P (obj))
5570         mark_char_table (XVECTOR (obj));
5571       else
5572         mark_vectorlike (XVECTOR (obj));
5573       break;
5574 
5575     case Lisp_Symbol:
5576       {
5577         register struct Lisp_Symbol *ptr = XSYMBOL (obj);
5578         struct Lisp_Symbol *ptrx;
5579 
5580         if (ptr->gcmarkbit)
5581           break;
5582         CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
5583         ptr->gcmarkbit = 1;
5584         mark_object (ptr->function);
5585         mark_object (ptr->plist);
5586         switch (ptr->redirect)
5587           {
5588           case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
5589           case SYMBOL_VARALIAS:
5590             {
5591               Lisp_Object tem;
5592               XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
5593               mark_object (tem);
5594               break;
5595             }
5596           case SYMBOL_LOCALIZED:
5597             {
5598               struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5599               /* If the value is forwarded to a buffer or keyboard field,
5600                  these are marked when we see the corresponding object.
5601                  And if it's forwarded to a C variable, either it's not
5602                  a Lisp_Object var, or it's staticpro'd already.  */
5603               mark_object (blv->where);
5604               mark_object (blv->valcell);
5605               mark_object (blv->defcell);
5606               break;
5607             }
5608           case SYMBOL_FORWARDED:
5609             /* If the value is forwarded to a buffer or keyboard field,
5610                these are marked when we see the corresponding object.
5611                And if it's forwarded to a C variable, either it's not
5612                a Lisp_Object var, or it's staticpro'd already.  */
5613             break;
5614           default: abort ();
5615           }
5616         if (!PURE_POINTER_P (XSTRING (ptr->xname)))
5617           MARK_STRING (XSTRING (ptr->xname));
5618         MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
5619 
5620         ptr = ptr->next;
5621         if (ptr)
5622           {
5623             ptrx = ptr;         /* Use of ptrx avoids compiler bug on Sun */
5624             XSETSYMBOL (obj, ptrx);
5625             goto loop;
5626           }
5627       }
5628       break;
5629 
5630     case Lisp_Misc:
5631       CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5632       if (XMISCANY (obj)->gcmarkbit)
5633         break;
5634       XMISCANY (obj)->gcmarkbit = 1;
5635 
5636       switch (XMISCTYPE (obj))
5637         {
5638 
5639         case Lisp_Misc_Marker:
5640           /* DO NOT mark thru the marker's chain.
5641              The buffer's markers chain does not preserve markers from gc;
5642              instead, markers are removed from the chain when freed by gc.  */
5643           break;
5644 
5645         case Lisp_Misc_Save_Value:
5646 #if GC_MARK_STACK
5647           {
5648             register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5649             /* If DOGC is set, POINTER is the address of a memory
5650                area containing INTEGER potential Lisp_Objects.  */
5651             if (ptr->dogc)
5652               {
5653                 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
5654                 int nelt;
5655                 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
5656                   mark_maybe_object (*p);
5657               }
5658           }
5659 #endif
5660           break;
5661 
5662         case Lisp_Misc_Overlay:
5663           {
5664             struct Lisp_Overlay *ptr = XOVERLAY (obj);
5665             mark_object (ptr->start);
5666             mark_object (ptr->end);
5667             mark_object (ptr->plist);
5668             if (ptr->next)
5669               {
5670                 XSETMISC (obj, ptr->next);
5671                 goto loop;
5672               }
5673           }
5674           break;
5675 
5676         default:
5677           abort ();
5678         }
5679       break;
5680 
5681     case Lisp_Cons:
5682       {
5683         register struct Lisp_Cons *ptr = XCONS (obj);
5684         if (CONS_MARKED_P (ptr))
5685           break;
5686         CHECK_ALLOCATED_AND_LIVE (live_cons_p);
5687         CONS_MARK (ptr);
5688         /* If the cdr is nil, avoid recursion for the car.  */
5689         if (EQ (ptr->u.cdr, Qnil))
5690           {
5691             obj = ptr->car;
5692             cdr_count = 0;
5693             goto loop;
5694           }
5695         mark_object (ptr->car);
5696         obj = ptr->u.cdr;
5697         cdr_count++;
5698         if (cdr_count == mark_object_loop_halt)
5699           abort ();
5700         goto loop;
5701       }
5702 
5703     case Lisp_Float:
5704       CHECK_ALLOCATED_AND_LIVE (live_float_p);
5705       FLOAT_MARK (XFLOAT (obj));
5706       break;
5707 
5708     case_Lisp_Int:
5709       break;
5710 
5711     default:
5712       abort ();
5713     }
5714 
5715 #undef CHECK_LIVE
5716 #undef CHECK_ALLOCATED
5717 #undef CHECK_ALLOCATED_AND_LIVE
5718 }
5719 
5720 /* Mark the pointers in a buffer structure.  */
5721 
5722 static void
5723 mark_buffer (buf)
5724      Lisp_Object buf;
5725 {
5726   register struct buffer *buffer = XBUFFER (buf);
5727   register Lisp_Object *ptr, tmp;
5728   Lisp_Object base_buffer;
5729 
5730   eassert (!VECTOR_MARKED_P (buffer));
5731   VECTOR_MARK (buffer);
5732 
5733   MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5734 
5735   /* For now, we just don't mark the undo_list.  It's done later in
5736      a special way just before the sweep phase, and after stripping
5737      some of its elements that are not needed any more.  */
5738 
5739   if (buffer->overlays_before)
5740     {
5741       XSETMISC (tmp, buffer->overlays_before);
5742       mark_object (tmp);
5743     }
5744   if (buffer->overlays_after)
5745     {
5746       XSETMISC (tmp, buffer->overlays_after);
5747       mark_object (tmp);
5748     }
5749 
5750   /* buffer-local Lisp variables start at `undo_list',
5751      tho only the ones from `name' on are GC'd normally.  */
5752   for (ptr = &buffer->name;
5753        (char *)ptr < (char *)buffer + sizeof (struct buffer);
5754        ptr++)
5755     mark_object (*ptr);
5756 
5757   /* If this is an indirect buffer, mark its base buffer.  */
5758   if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5759     {
5760       XSETBUFFER (base_buffer, buffer->base_buffer);
5761       mark_buffer (base_buffer);
5762     }
5763 }
5764 
5765 /* Mark the Lisp pointers in the terminal objects.
5766    Called by the Fgarbage_collector.  */
5767 
5768 static void
5769 mark_terminals (void)
5770 {
5771   struct terminal *t;
5772   for (t = terminal_list; t; t = t->next_terminal)
5773     {
5774       eassert (t->name != NULL);
5775       if (!VECTOR_MARKED_P (t))
5776         {
5777 #ifdef HAVE_WINDOW_SYSTEM
5778           mark_image_cache (t->image_cache);
5779 #endif /* HAVE_WINDOW_SYSTEM */
5780           mark_vectorlike ((struct Lisp_Vector *)t);
5781         }
5782     }
5783 }
5784 
5785 
5786 
5787 /* Value is non-zero if OBJ will survive the current GC because it's
5788    either marked or does not need to be marked to survive.  */
5789 
5790 int
5791 survives_gc_p (obj)
5792      Lisp_Object obj;
5793 {
5794   int survives_p;
5795 
5796   switch (XTYPE (obj))
5797     {
5798     case_Lisp_Int:
5799       survives_p = 1;
5800       break;
5801 
5802     case Lisp_Symbol:
5803       survives_p = XSYMBOL (obj)->gcmarkbit;
5804       break;
5805 
5806     case Lisp_Misc:
5807       survives_p = XMISCANY (obj)->gcmarkbit;
5808       break;
5809 
5810     case Lisp_String:
5811       survives_p = STRING_MARKED_P (XSTRING (obj));
5812       break;
5813 
5814     case Lisp_Vectorlike:
5815       survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
5816       break;
5817 
5818     case Lisp_Cons:
5819       survives_p = CONS_MARKED_P (XCONS (obj));
5820       break;
5821 
5822     case Lisp_Float:
5823       survives_p = FLOAT_MARKED_P (XFLOAT (obj));
5824       break;
5825 
5826     default:
5827       abort ();
5828     }
5829 
5830   return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
5831 }
5832 
5833 
5834 
5835 /* Sweep: find all structures not marked, and free them. */
5836 
5837 static void
5838 gc_sweep ()
5839 {
5840   /* Remove or mark entries in weak hash tables.
5841      This must be done before any object is unmarked.  */
5842   sweep_weak_hash_tables ();
5843 
5844   sweep_strings ();
5845 #ifdef GC_CHECK_STRING_BYTES
5846   if (!noninteractive)
5847     check_string_bytes (1);
5848 #endif
5849 
5850   /* Put all unmarked conses on free list */
5851   {
5852     register struct cons_block *cblk;
5853     struct cons_block **cprev = &cons_block;
5854     register int lim = cons_block_index;
5855     register int num_free = 0, num_used = 0;
5856 
5857     cons_free_list = 0;
5858 
5859     for (cblk = cons_block; cblk; cblk = *cprev)
5860       {
5861         register int i = 0;
5862         int this_free = 0;
5863         int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
5864 
5865         /* Scan the mark bits an int at a time.  */
5866         for (i = 0; i <= ilim; i++)
5867           {
5868             if (cblk->gcmarkbits[i] == -1)
5869               {
5870                 /* Fast path - all cons cells for this int are marked.  */
5871                 cblk->gcmarkbits[i] = 0;
5872                 num_used += BITS_PER_INT;
5873               }
5874             else
5875               {
5876                 /* Some cons cells for this int are not marked.
5877                    Find which ones, and free them.  */
5878                 int start, pos, stop;
5879 
5880                 start = i * BITS_PER_INT;
5881                 stop = lim - start;
5882                 if (stop > BITS_PER_INT)
5883                   stop = BITS_PER_INT;
5884                 stop += start;
5885 
5886                 for (pos = start; pos < stop; pos++)
5887                   {
5888                     if (!CONS_MARKED_P (&cblk->conses[pos]))
5889                       {
5890                         this_free++;
5891                         cblk->conses[pos].u.chain = cons_free_list;
5892                         cons_free_list = &cblk->conses[pos];
5893 #if GC_MARK_STACK
5894                         cons_free_list->car = Vdead;
5895 #endif
5896                       }
5897                     else
5898                       {
5899                         num_used++;
5900                         CONS_UNMARK (&cblk->conses[pos]);
5901                       }
5902                   }
5903               }
5904           }
5905 
5906         lim = CONS_BLOCK_SIZE;
5907         /* If this block contains only free conses and we have already
5908            seen more than two blocks worth of free conses then deallocate
5909            this block.  */
5910         if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
5911           {
5912             *cprev = cblk->next;
5913             /* Unhook from the free list.  */
5914             cons_free_list = cblk->conses[0].u.chain;
5915             lisp_align_free (cblk);
5916             n_cons_blocks--;
5917           }
5918         else
5919           {
5920             num_free += this_free;
5921             cprev = &cblk->next;
5922           }
5923       }
5924     total_conses = num_used;
5925     total_free_conses = num_free;
5926   }
5927 
5928   /* Put all unmarked floats on free list */
5929   {
5930     register struct float_block *fblk;
5931     struct float_block **fprev = &float_block;
5932     register int lim = float_block_index;
5933     register int num_free = 0, num_used = 0;
5934 
5935     float_free_list = 0;
5936 
5937     for (fblk = float_block; fblk; fblk = *fprev)
5938       {
5939         register int i;
5940         int this_free = 0;
5941         for (i = 0; i < lim; i++)
5942           if (!FLOAT_MARKED_P (&fblk->floats[i]))
5943             {
5944               this_free++;
5945               fblk->floats[i].u.chain = float_free_list;
5946               float_free_list = &fblk->floats[i];
5947             }
5948           else
5949             {
5950               num_used++;
5951               FLOAT_UNMARK (&fblk->floats[i]);
5952             }
5953         lim = FLOAT_BLOCK_SIZE;
5954         /* If this block contains only free floats and we have already
5955            seen more than two blocks worth of free floats then deallocate
5956            this block.  */
5957         if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
5958           {
5959             *fprev = fblk->next;
5960             /* Unhook from the free list.  */
5961             float_free_list = fblk->floats[0].u.chain;
5962             lisp_align_free (fblk);
5963             n_float_blocks--;
5964           }
5965         else
5966           {
5967             num_free += this_free;
5968             fprev = &fblk->next;
5969           }
5970       }
5971     total_floats = num_used;
5972     total_free_floats = num_free;
5973   }
5974 
5975   /* Put all unmarked intervals on free list */
5976   {
5977     register struct interval_block *iblk;
5978     struct interval_block **iprev = &interval_block;
5979     register int lim = interval_block_index;
5980     register int num_free = 0, num_used = 0;
5981 
5982     interval_free_list = 0;
5983 
5984     for (iblk = interval_block; iblk; iblk = *iprev)
5985       {
5986         register int i;
5987         int this_free = 0;
5988 
5989         for (i = 0; i < lim; i++)
5990           {
5991             if (!iblk->intervals[i].gcmarkbit)
5992               {
5993                 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
5994                 interval_free_list = &iblk->intervals[i];
5995                 this_free++;
5996               }
5997             else
5998               {
5999                 num_used++;
6000                 iblk->intervals[i].gcmarkbit = 0;
6001               }
6002           }
6003         lim = INTERVAL_BLOCK_SIZE;
6004         /* If this block contains only free intervals and we have already
6005            seen more than two blocks worth of free intervals then
6006            deallocate this block.  */
6007         if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6008           {
6009             *iprev = iblk->next;
6010             /* Unhook from the free list.  */
6011             interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
6012             lisp_free (iblk);
6013             n_interval_blocks--;
6014           }
6015         else
6016           {
6017             num_free += this_free;
6018             iprev = &iblk->next;
6019           }
6020       }
6021     total_intervals = num_used;
6022     total_free_intervals = num_free;
6023   }
6024 
6025   /* Put all unmarked symbols on free list */
6026   {
6027     register struct symbol_block *sblk;
6028     struct symbol_block **sprev = &symbol_block;
6029     register int lim = symbol_block_index;
6030     register int num_free = 0, num_used = 0;
6031 
6032     symbol_free_list = NULL;
6033 
6034     for (sblk = symbol_block; sblk; sblk = *sprev)
6035       {
6036         int this_free = 0;
6037         struct Lisp_Symbol *sym = sblk->symbols;
6038         struct Lisp_Symbol *end = sym + lim;
6039 
6040         for (; sym < end; ++sym)
6041           {
6042             /* Check if the symbol was created during loadup.  In such a case
6043                it might be pointed to by pure bytecode which we don't trace,
6044                so we conservatively assume that it is live.  */
6045             int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
6046 
6047             if (!sym->gcmarkbit && !pure_p)
6048               {
6049                 if (sym->redirect == SYMBOL_LOCALIZED)
6050                   xfree (SYMBOL_BLV (sym));
6051                 sym->next = symbol_free_list;
6052                 symbol_free_list = sym;
6053 #if GC_MARK_STACK
6054                 symbol_free_list->function = Vdead;
6055 #endif
6056                 ++this_free;
6057               }
6058             else
6059               {
6060                 ++num_used;
6061                 if (!pure_p)
6062                   UNMARK_STRING (XSTRING (sym->xname));
6063                 sym->gcmarkbit = 0;
6064               }
6065           }
6066 
6067         lim = SYMBOL_BLOCK_SIZE;
6068         /* If this block contains only free symbols and we have already
6069            seen more than two blocks worth of free symbols then deallocate
6070            this block.  */
6071         if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6072           {
6073             *sprev = sblk->next;
6074             /* Unhook from the free list.  */
6075             symbol_free_list = sblk->symbols[0].next;
6076             lisp_free (sblk);
6077             n_symbol_blocks--;
6078           }
6079         else
6080           {
6081             num_free += this_free;
6082             sprev = &sblk->next;
6083           }
6084       }
6085     total_symbols = num_used;
6086     total_free_symbols = num_free;
6087   }
6088 
6089   /* Put all unmarked misc's on free list.
6090      For a marker, first unchain it from the buffer it points into.  */
6091   {
6092     register struct marker_block *mblk;
6093     struct marker_block **mprev = &marker_block;
6094     register int lim = marker_block_index;
6095     register int num_free = 0, num_used = 0;
6096 
6097     marker_free_list = 0;
6098 
6099     for (mblk = marker_block; mblk; mblk = *mprev)
6100       {
6101         register int i;
6102         int this_free = 0;
6103 
6104         for (i = 0; i < lim; i++)
6105           {
6106             if (!mblk->markers[i].u_any.gcmarkbit)
6107               {
6108                 if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
6109                   unchain_marker (&mblk->markers[i].u_marker);
6110                 /* Set the type of the freed object to Lisp_Misc_Free.
6111                    We could leave the type alone, since nobody checks it,
6112                    but this might catch bugs faster.  */
6113                 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
6114                 mblk->markers[i].u_free.chain = marker_free_list;
6115                 marker_free_list = &mblk->markers[i];
6116                 this_free++;
6117               }
6118             else
6119               {
6120                 num_used++;
6121                 mblk->markers[i].u_any.gcmarkbit = 0;
6122               }
6123           }
6124         lim = MARKER_BLOCK_SIZE;
6125         /* If this block contains only free markers and we have already
6126            seen more than two blocks worth of free markers then deallocate
6127            this block.  */
6128         if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6129           {
6130             *mprev = mblk->next;
6131             /* Unhook from the free list.  */
6132             marker_free_list = mblk->markers[0].u_free.chain;
6133             lisp_free (mblk);
6134             n_marker_blocks--;
6135           }
6136         else
6137           {
6138             num_free += this_free;
6139             mprev = &mblk->next;
6140           }
6141       }
6142 
6143     total_markers = num_used;
6144     total_free_markers = num_free;
6145   }
6146 
6147   /* Free all unmarked buffers */
6148   {
6149     register struct buffer *buffer = all_buffers, *prev = 0, *next;
6150 
6151     while (buffer)
6152       if (!VECTOR_MARKED_P (buffer))
6153         {
6154           if (prev)
6155             prev->next = buffer->next;
6156           else
6157             all_buffers = buffer->next;
6158           next = buffer->next;
6159           lisp_free (buffer);
6160           buffer = next;
6161         }
6162       else
6163         {
6164           VECTOR_UNMARK (buffer);
6165           UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
6166           prev = buffer, buffer = buffer->next;
6167         }
6168   }
6169 
6170   /* Free all unmarked vectors */
6171   {
6172     register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6173     total_vector_size = 0;
6174 
6175     while (vector)
6176       if (!VECTOR_MARKED_P (vector))
6177         {
6178           if (prev)
6179             prev->next = vector->next;
6180           else
6181             all_vectors = vector->next;
6182           next = vector->next;
6183           lisp_free (vector);
6184           n_vectors--;
6185           vector = next;
6186 
6187         }
6188       else
6189         {
6190           VECTOR_UNMARK (vector);
6191           if (vector->size & PSEUDOVECTOR_FLAG)
6192             total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
6193           else
6194             total_vector_size += vector->size;
6195           prev = vector, vector = vector->next;
6196         }
6197   }
6198 
6199 #ifdef GC_CHECK_STRING_BYTES
6200   if (!noninteractive)
6201     check_string_bytes (1);
6202 #endif
6203 }
6204 
6205 
6206 
6207 
6208 /* Debugging aids.  */
6209 
6210 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
6211        doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6212 This may be helpful in debugging Emacs's memory usage.
6213 We divide the value by 1024 to make sure it fits in a Lisp integer.  */)
6214      ()
6215 {
6216   Lisp_Object end;
6217 
6218   XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
6219 
6220   return end;
6221 }
6222 
6223 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
6224        doc: /* Return a list of counters that measure how much consing there has been.
6225 Each of these counters increments for a certain kind of object.
6226 The counters wrap around from the largest positive integer to zero.
6227 Garbage collection does not decrease them.
6228 The elements of the value are as follows:
6229   (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6230 All are in units of 1 = one object consed
6231 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6232 objects consed.
6233 MISCS include overlays, markers, and some internal types.
6234 Frames, windows, buffers, and subprocesses count as vectors
6235   (but the contents of a buffer's text do not count here).  */)
6236      ()
6237 {
6238   Lisp_Object consed[8];
6239 
6240   consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
6241   consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
6242   consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
6243   consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
6244   consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
6245   consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
6246   consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
6247   consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6248 
6249   return Flist (8, consed);
6250 }
6251 
6252 int suppress_checking;
6253 
6254 void
6255 die (msg, file, line)
6256      const char *msg;
6257      const char *file;
6258      int line;
6259 {
6260   fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6261            file, line, msg);
6262   abort ();
6263 }
6264 
6265 /* Initialization */
6266 
6267 void
6268 init_alloc_once ()
6269 {
6270   /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
6271   purebeg = PUREBEG;
6272   pure_size = PURESIZE;
6273   pure_bytes_used = 0;
6274   pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6275   pure_bytes_used_before_overflow = 0;
6276 
6277   /* Initialize the list of free aligned blocks.  */
6278   free_ablock = NULL;
6279 
6280 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6281   mem_init ();
6282   Vdead = make_pure_string ("DEAD", 4, 4, 0);
6283 #endif
6284 
6285   all_vectors = 0;
6286   ignore_warnings = 1;
6287 #ifdef DOUG_LEA_MALLOC
6288   mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
6289   mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
6290   mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
6291 #endif
6292   init_strings ();
6293   init_cons ();
6294   init_symbol ();
6295   init_marker ();
6296   init_float ();
6297   init_intervals ();
6298   init_weak_hash_tables ();
6299 
6300 #ifdef REL_ALLOC
6301   malloc_hysteresis = 32;
6302 #else
6303   malloc_hysteresis = 0;
6304 #endif
6305 
6306   refill_memory_reserve ();
6307 
6308   ignore_warnings = 0;
6309   gcprolist = 0;
6310   byte_stack_list = 0;
6311   staticidx = 0;
6312   consing_since_gc = 0;
6313   gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6314   gc_relative_threshold = 0;
6315 
6316 #ifdef VIRT_ADDR_VARIES
6317   malloc_sbrk_unused = 1<<22;   /* A large number */
6318   malloc_sbrk_used = 100000;    /* as reasonable as any number */
6319 #endif /* VIRT_ADDR_VARIES */
6320 }
6321 
6322 void
6323 init_alloc ()
6324 {
6325   gcprolist = 0;
6326   byte_stack_list = 0;
6327 #if GC_MARK_STACK
6328 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6329   setjmp_tested_p = longjmps_done = 0;
6330 #endif
6331 #endif
6332   Vgc_elapsed = make_float (0.0);
6333   gcs_done = 0;
6334 }
6335 
6336 void
6337 syms_of_alloc ()
6338 {
6339   DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
6340               doc: /* *Number of bytes of consing between garbage collections.
6341 Garbage collection can happen automatically once this many bytes have been
6342 allocated since the last garbage collection.  All data types count.
6343 
6344 Garbage collection happens automatically only when `eval' is called.
6345 
6346 By binding this temporarily to a large number, you can effectively
6347 prevent garbage collection during a part of the program.
6348 See also `gc-cons-percentage'.  */);
6349 
6350   DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
6351                doc: /* *Portion of the heap used for allocation.
6352 Garbage collection can happen automatically once this portion of the heap
6353 has been allocated since the last garbage collection.
6354 If this portion is smaller than `gc-cons-threshold', this is ignored.  */);
6355   Vgc_cons_percentage = make_float (0.1);
6356 
6357   DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
6358               doc: /* Number of bytes of sharable Lisp data allocated so far.  */);
6359 
6360   DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
6361               doc: /* Number of cons cells that have been consed so far.  */);
6362 
6363   DEFVAR_INT ("floats-consed", &floats_consed,
6364               doc: /* Number of floats that have been consed so far.  */);
6365 
6366   DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
6367               doc: /* Number of vector cells that have been consed so far.  */);
6368 
6369   DEFVAR_INT ("symbols-consed", &symbols_consed,
6370               doc: /* Number of symbols that have been consed so far.  */);
6371 
6372   DEFVAR_INT ("string-chars-consed", &string_chars_consed,
6373               doc: /* Number of string characters that have been consed so far.  */);
6374 
6375   DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
6376               doc: /* Number of miscellaneous objects that have been consed so far.  */);
6377 
6378   DEFVAR_INT ("intervals-consed", &intervals_consed,
6379               doc: /* Number of intervals that have been consed so far.  */);
6380 
6381   DEFVAR_INT ("strings-consed", &strings_consed,
6382               doc: /* Number of strings that have been consed so far.  */);
6383 
6384   DEFVAR_LISP ("purify-flag", &Vpurify_flag,
6385                doc: /* Non-nil means loading Lisp code in order to dump an executable.
6386 This means that certain objects should be allocated in shared (pure) space.
6387 It can also be set to a hash-table, in which case this table is used to
6388 do hash-consing of the objects allocated to pure space.  */);
6389 
6390   DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
6391                doc: /* Non-nil means display messages at start and end of garbage collection.  */);
6392   garbage_collection_messages = 0;
6393 
6394   DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
6395                doc: /* Hook run after garbage collection has finished.  */);
6396   Vpost_gc_hook = Qnil;
6397   Qpost_gc_hook = intern_c_string ("post-gc-hook");
6398   staticpro (&Qpost_gc_hook);
6399 
6400   DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
6401                doc: /* Precomputed `signal' argument for memory-full error.  */);
6402   /* We build this in advance because if we wait until we need it, we might
6403      not be able to allocate the memory to hold it.  */
6404   Vmemory_signal_data
6405     = pure_cons (Qerror,
6406                  pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
6407 
6408   DEFVAR_LISP ("memory-full", &Vmemory_full,
6409                doc: /* Non-nil means Emacs cannot get much more Lisp memory.  */);
6410   Vmemory_full = Qnil;
6411 
6412   staticpro (&Qgc_cons_threshold);
6413   Qgc_cons_threshold = intern_c_string ("gc-cons-threshold");
6414 
6415   staticpro (&Qchar_table_extra_slots);
6416   Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
6417 
6418   DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
6419                doc: /* Accumulated time elapsed in garbage collections.
6420 The time is in seconds as a floating point value.  */);
6421   DEFVAR_INT ("gcs-done", &gcs_done,
6422               doc: /* Accumulated number of garbage collections done.  */);
6423 
6424   defsubr (&Scons);
6425   defsubr (&Slist);
6426   defsubr (&Svector);
6427   defsubr (&Smake_byte_code);
6428   defsubr (&Smake_list);
6429   defsubr (&Smake_vector);
6430   defsubr (&Smake_string);
6431   defsubr (&Smake_bool_vector);
6432   defsubr (&Smake_symbol);
6433   defsubr (&Smake_marker);
6434   defsubr (&Spurecopy);
6435   defsubr (&Sgarbage_collect);
6436   defsubr (&Smemory_limit);
6437   defsubr (&Smemory_use_counts);
6438 
6439 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6440   defsubr (&Sgc_status);
6441 #endif
6442 }
6443 
6444 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6445    (do not change this comment) */