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