Don't call the same hook twice due to obsolete aliases
[emacs.git] / src / alloc.c
blob2cee64625641c3ba6f67b464f36bcc7af935e568
1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2017 Free Software
4 Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 #include <config.h>
23 #include <errno.h>
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include <limits.h> /* For CHAR_BIT. */
27 #include <signal.h> /* For SIGABRT, SIGDANGER. */
29 #ifdef HAVE_PTHREAD
30 #include <pthread.h>
31 #endif
33 #include "lisp.h"
34 #include "dispextern.h"
35 #include "intervals.h"
36 #include "puresize.h"
37 #include "sheap.h"
38 #include "systime.h"
39 #include "character.h"
40 #include "buffer.h"
41 #include "window.h"
42 #include "keyboard.h"
43 #include "frame.h"
44 #include "blockinput.h"
45 #include "termhooks.h" /* For struct terminal. */
46 #ifdef HAVE_WINDOW_SYSTEM
47 #include TERM_HEADER
48 #endif /* HAVE_WINDOW_SYSTEM */
50 #include <flexmember.h>
51 #include <verify.h>
52 #include <execinfo.h> /* For backtrace. */
54 #ifdef HAVE_LINUX_SYSINFO
55 #include <sys/sysinfo.h>
56 #endif
58 #ifdef MSDOS
59 #include "dosfns.h" /* For dos_memory_info. */
60 #endif
62 #ifdef HAVE_MALLOC_H
63 # include <malloc.h>
64 #endif
66 #if (defined ENABLE_CHECKING \
67 && defined HAVE_VALGRIND_VALGRIND_H \
68 && !defined USE_VALGRIND)
69 # define USE_VALGRIND 1
70 #endif
72 #if USE_VALGRIND
73 #include <valgrind/valgrind.h>
74 #include <valgrind/memcheck.h>
75 static bool valgrind_p;
76 #endif
78 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
79 We turn that on by default when ENABLE_CHECKING is defined;
80 define GC_CHECK_MARKED_OBJECTS to zero to disable. */
82 #if defined ENABLE_CHECKING && !defined GC_CHECK_MARKED_OBJECTS
83 # define GC_CHECK_MARKED_OBJECTS 1
84 #endif
86 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
87 memory. Can do this only if using gmalloc.c and if not checking
88 marked objects. */
90 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
91 || defined HYBRID_MALLOC || GC_CHECK_MARKED_OBJECTS)
92 #undef GC_MALLOC_CHECK
93 #endif
95 #include <unistd.h>
96 #include <fcntl.h>
98 #ifdef USE_GTK
99 # include "gtkutil.h"
100 #endif
101 #ifdef WINDOWSNT
102 #include "w32.h"
103 #include "w32heap.h" /* for sbrk */
104 #endif
106 #ifdef GNU_LINUX
107 /* The address where the heap starts. */
108 void *
109 my_heap_start (void)
111 static void *start;
112 if (! start)
113 start = sbrk (0);
114 return start;
116 #endif
118 #ifdef DOUG_LEA_MALLOC
120 /* Specify maximum number of areas to mmap. It would be nice to use a
121 value that explicitly means "no limit". */
123 #define MMAP_MAX_AREAS 100000000
125 /* A pointer to the memory allocated that copies that static data
126 inside glibc's malloc. */
127 static void *malloc_state_ptr;
129 /* Restore the dumped malloc state. Because malloc can be invoked
130 even before main (e.g. by the dynamic linker), the dumped malloc
131 state must be restored as early as possible using this special hook. */
132 static void
133 malloc_initialize_hook (void)
135 static bool malloc_using_checking;
137 if (! initialized)
139 #ifdef GNU_LINUX
140 my_heap_start ();
141 #endif
142 malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL;
144 else
146 if (!malloc_using_checking)
148 /* Work around a bug in glibc's malloc. MALLOC_CHECK_ must be
149 ignored if the heap to be restored was constructed without
150 malloc checking. Can't use unsetenv, since that calls malloc. */
151 char **p = environ;
152 if (p)
153 for (; *p; p++)
154 if (strncmp (*p, "MALLOC_CHECK_=", 14) == 0)
157 *p = p[1];
158 while (*++p);
160 break;
164 if (malloc_set_state (malloc_state_ptr) != 0)
165 emacs_abort ();
166 # ifndef XMALLOC_OVERRUN_CHECK
167 alloc_unexec_post ();
168 # endif
172 /* Declare the malloc initialization hook, which runs before 'main' starts.
173 EXTERNALLY_VISIBLE works around Bug#22522. */
174 # ifndef __MALLOC_HOOK_VOLATILE
175 # define __MALLOC_HOOK_VOLATILE
176 # endif
177 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
178 = malloc_initialize_hook;
180 #endif
182 #if defined DOUG_LEA_MALLOC || !defined CANNOT_DUMP
184 /* Allocator-related actions to do just before and after unexec. */
186 void
187 alloc_unexec_pre (void)
189 # ifdef DOUG_LEA_MALLOC
190 malloc_state_ptr = malloc_get_state ();
191 if (!malloc_state_ptr)
192 fatal ("malloc_get_state: %s", strerror (errno));
193 # endif
194 # ifdef HYBRID_MALLOC
195 bss_sbrk_did_unexec = true;
196 # endif
199 void
200 alloc_unexec_post (void)
202 # ifdef DOUG_LEA_MALLOC
203 free (malloc_state_ptr);
204 # endif
205 # ifdef HYBRID_MALLOC
206 bss_sbrk_did_unexec = false;
207 # endif
209 #endif
211 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
212 to a struct Lisp_String. */
214 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
215 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
216 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
218 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
219 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
220 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
222 /* Default value of gc_cons_threshold (see below). */
224 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
226 /* Global variables. */
227 struct emacs_globals globals;
229 /* Number of bytes of consing done since the last gc. */
231 EMACS_INT consing_since_gc;
233 /* Similar minimum, computed from Vgc_cons_percentage. */
235 EMACS_INT gc_relative_threshold;
237 /* Minimum number of bytes of consing since GC before next GC,
238 when memory is full. */
240 EMACS_INT memory_full_cons_threshold;
242 /* True during GC. */
244 bool gc_in_progress;
246 /* Number of live and free conses etc. */
248 static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
249 static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
250 static EMACS_INT total_free_floats, total_floats;
252 /* Points to memory space allocated as "spare", to be freed if we run
253 out of memory. We keep one large block, four cons-blocks, and
254 two string blocks. */
256 static char *spare_memory[7];
258 /* Amount of spare memory to keep in large reserve block, or to see
259 whether this much is available when malloc fails on a larger request. */
261 #define SPARE_MEMORY (1 << 14)
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. */
269 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
270 #define PUREBEG (char *) pure
272 /* Pointer to the pure area, and its size. */
274 static char *purebeg;
275 static ptrdiff_t pure_size;
277 /* Number of bytes of pure storage used before pure storage overflowed.
278 If this is non-zero, this implies that an overflow occurred. */
280 static ptrdiff_t pure_bytes_used_before_overflow;
282 /* Index in pure at which next pure Lisp object will be allocated.. */
284 static ptrdiff_t pure_bytes_used_lisp;
286 /* Number of bytes allocated for non-Lisp objects in pure storage. */
288 static ptrdiff_t pure_bytes_used_non_lisp;
290 /* If nonzero, this is a warning delivered by malloc and not yet
291 displayed. */
293 const char *pending_malloc_warning;
295 #if 0 /* Normally, pointer sanity only on request... */
296 #ifdef ENABLE_CHECKING
297 #define SUSPICIOUS_OBJECT_CHECKING 1
298 #endif
299 #endif
301 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
302 bug is unresolved. */
303 #define SUSPICIOUS_OBJECT_CHECKING 1
305 #ifdef SUSPICIOUS_OBJECT_CHECKING
306 struct suspicious_free_record
308 void *suspicious_object;
309 void *backtrace[128];
311 static void *suspicious_objects[32];
312 static int suspicious_object_index;
313 struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
314 static int suspicious_free_history_index;
315 /* Find the first currently-monitored suspicious pointer in range
316 [begin,end) or NULL if no such pointer exists. */
317 static void *find_suspicious_object_in_range (void *begin, void *end);
318 static void detect_suspicious_free (void *ptr);
319 #else
320 # define find_suspicious_object_in_range(begin, end) NULL
321 # define detect_suspicious_free(ptr) (void)
322 #endif
324 /* Maximum amount of C stack to save when a GC happens. */
326 #ifndef MAX_SAVE_STACK
327 #define MAX_SAVE_STACK 16000
328 #endif
330 /* Buffer in which we save a copy of the C stack at each GC. */
332 #if MAX_SAVE_STACK > 0
333 static char *stack_copy;
334 static ptrdiff_t stack_copy_size;
336 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
337 avoiding any address sanitization. */
339 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
340 no_sanitize_memcpy (void *dest, void const *src, size_t size)
342 if (! ADDRESS_SANITIZER)
343 return memcpy (dest, src, size);
344 else
346 size_t i;
347 char *d = dest;
348 char const *s = src;
349 for (i = 0; i < size; i++)
350 d[i] = s[i];
351 return dest;
355 #endif /* MAX_SAVE_STACK > 0 */
357 static void mark_terminals (void);
358 static void gc_sweep (void);
359 static Lisp_Object make_pure_vector (ptrdiff_t);
360 static void mark_buffer (struct buffer *);
362 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
363 static void refill_memory_reserve (void);
364 #endif
365 static void compact_small_strings (void);
366 static void free_large_strings (void);
367 extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
369 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
370 what memory allocated via lisp_malloc and lisp_align_malloc is intended
371 for what purpose. This enumeration specifies the type of memory. */
373 enum mem_type
375 MEM_TYPE_NON_LISP,
376 MEM_TYPE_BUFFER,
377 MEM_TYPE_CONS,
378 MEM_TYPE_STRING,
379 MEM_TYPE_MISC,
380 MEM_TYPE_SYMBOL,
381 MEM_TYPE_FLOAT,
382 /* Since all non-bool pseudovectors are small enough to be
383 allocated from vector blocks, this memory type denotes
384 large regular vectors and large bool pseudovectors. */
385 MEM_TYPE_VECTORLIKE,
386 /* Special type to denote vector blocks. */
387 MEM_TYPE_VECTOR_BLOCK,
388 /* Special type to denote reserved memory. */
389 MEM_TYPE_SPARE
392 /* A unique object in pure space used to make some Lisp objects
393 on free lists recognizable in O(1). */
395 static Lisp_Object Vdead;
396 #define DEADP(x) EQ (x, Vdead)
398 #ifdef GC_MALLOC_CHECK
400 enum mem_type allocated_mem_type;
402 #endif /* GC_MALLOC_CHECK */
404 /* A node in the red-black tree describing allocated memory containing
405 Lisp data. Each such block is recorded with its start and end
406 address when it is allocated, and removed from the tree when it
407 is freed.
409 A red-black tree is a balanced binary tree with the following
410 properties:
412 1. Every node is either red or black.
413 2. Every leaf is black.
414 3. If a node is red, then both of its children are black.
415 4. Every simple path from a node to a descendant leaf contains
416 the same number of black nodes.
417 5. The root is always black.
419 When nodes are inserted into the tree, or deleted from the tree,
420 the tree is "fixed" so that these properties are always true.
422 A red-black tree with N internal nodes has height at most 2
423 log(N+1). Searches, insertions and deletions are done in O(log N).
424 Please see a text book about data structures for a detailed
425 description of red-black trees. Any book worth its salt should
426 describe them. */
428 struct mem_node
430 /* Children of this node. These pointers are never NULL. When there
431 is no child, the value is MEM_NIL, which points to a dummy node. */
432 struct mem_node *left, *right;
434 /* The parent of this node. In the root node, this is NULL. */
435 struct mem_node *parent;
437 /* Start and end of allocated region. */
438 void *start, *end;
440 /* Node color. */
441 enum {MEM_BLACK, MEM_RED} color;
443 /* Memory type. */
444 enum mem_type type;
447 /* Root of the tree describing allocated Lisp memory. */
449 static struct mem_node *mem_root;
451 /* Lowest and highest known address in the heap. */
453 static void *min_heap_address, *max_heap_address;
455 /* Sentinel node of the tree. */
457 static struct mem_node mem_z;
458 #define MEM_NIL &mem_z
460 static struct mem_node *mem_insert (void *, void *, enum mem_type);
461 static void mem_insert_fixup (struct mem_node *);
462 static void mem_rotate_left (struct mem_node *);
463 static void mem_rotate_right (struct mem_node *);
464 static void mem_delete (struct mem_node *);
465 static void mem_delete_fixup (struct mem_node *);
466 static struct mem_node *mem_find (void *);
468 #ifndef DEADP
469 # define DEADP(x) 0
470 #endif
472 /* Addresses of staticpro'd variables. Initialize it to a nonzero
473 value; otherwise some compilers put it into BSS. */
475 enum { NSTATICS = 2048 };
476 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
478 /* Index of next unused slot in staticvec. */
480 static int staticidx;
482 static void *pure_alloc (size_t, int);
484 /* True if N is a power of 2. N should be positive. */
486 #define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
488 /* Return X rounded to the next multiple of Y. Y should be positive,
489 and Y - 1 + X should not overflow. Arguments should not have side
490 effects, as they are evaluated more than once. Tune for Y being a
491 power of 2. */
493 #define ROUNDUP(x, y) (POWER_OF_2 (y) \
494 ? ((y) - 1 + (x)) & ~ ((y) - 1) \
495 : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
497 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
499 static void *
500 pointer_align (void *ptr, int alignment)
502 return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
505 /* Extract the pointer hidden within A, if A is not a symbol.
506 If A is a symbol, extract the hidden pointer's offset from lispsym,
507 converted to void *. */
509 #define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
510 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
512 /* Extract the pointer hidden within A. */
514 #define macro_XPNTR(a) \
515 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
516 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
518 /* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
519 functions, as functions are cleaner and can be used in debuggers.
520 Also, define them as macros if being compiled with GCC without
521 optimization, for performance in that case. The macro_* names are
522 private to this section of code. */
524 static ATTRIBUTE_UNUSED void *
525 XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
527 return macro_XPNTR_OR_SYMBOL_OFFSET (a);
529 static ATTRIBUTE_UNUSED void *
530 XPNTR (Lisp_Object a)
532 return macro_XPNTR (a);
535 #if DEFINE_KEY_OPS_AS_MACROS
536 # define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
537 # define XPNTR(a) macro_XPNTR (a)
538 #endif
540 static void
541 XFLOAT_INIT (Lisp_Object f, double n)
543 XFLOAT (f)->u.data = n;
546 #ifdef DOUG_LEA_MALLOC
547 static bool
548 pointers_fit_in_lispobj_p (void)
550 return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG;
553 static bool
554 mmap_lisp_allowed_p (void)
556 /* If we can't store all memory addresses in our lisp objects, it's
557 risky to let the heap use mmap and give us addresses from all
558 over our address space. We also can't use mmap for lisp objects
559 if we might dump: unexec doesn't preserve the contents of mmapped
560 regions. */
561 return pointers_fit_in_lispobj_p () && !might_dump;
563 #endif
565 /* Head of a circularly-linked list of extant finalizers. */
566 static struct Lisp_Finalizer finalizers;
568 /* Head of a circularly-linked list of finalizers that must be invoked
569 because we deemed them unreachable. This list must be global, and
570 not a local inside garbage_collect_1, in case we GC again while
571 running finalizers. */
572 static struct Lisp_Finalizer doomed_finalizers;
575 /************************************************************************
576 Malloc
577 ************************************************************************/
579 #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
581 /* Function malloc calls this if it finds we are near exhausting storage. */
583 void
584 malloc_warning (const char *str)
586 pending_malloc_warning = str;
589 #endif
591 /* Display an already-pending malloc warning. */
593 void
594 display_malloc_warning (void)
596 call3 (intern ("display-warning"),
597 intern ("alloc"),
598 build_string (pending_malloc_warning),
599 intern ("emergency"));
600 pending_malloc_warning = 0;
603 /* Called if we can't allocate relocatable space for a buffer. */
605 void
606 buffer_memory_full (ptrdiff_t nbytes)
608 /* If buffers use the relocating allocator, no need to free
609 spare_memory, because we may have plenty of malloc space left
610 that we could get, and if we don't, the malloc that fails will
611 itself cause spare_memory to be freed. If buffers don't use the
612 relocating allocator, treat this like any other failing
613 malloc. */
615 #ifndef REL_ALLOC
616 memory_full (nbytes);
617 #else
618 /* This used to call error, but if we've run out of memory, we could
619 get infinite recursion trying to build the string. */
620 xsignal (Qnil, Vmemory_signal_data);
621 #endif
624 /* A common multiple of the positive integers A and B. Ideally this
625 would be the least common multiple, but there's no way to do that
626 as a constant expression in C, so do the best that we can easily do. */
627 #define COMMON_MULTIPLE(a, b) \
628 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
630 #ifndef XMALLOC_OVERRUN_CHECK
631 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
632 #else
634 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
635 around each block.
637 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
638 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
639 block size in little-endian order. The trailer consists of
640 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
642 The header is used to detect whether this block has been allocated
643 through these functions, as some low-level libc functions may
644 bypass the malloc hooks. */
646 #define XMALLOC_OVERRUN_CHECK_SIZE 16
647 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
648 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
650 #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
652 #define XMALLOC_HEADER_ALIGNMENT \
653 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
655 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
656 hold a size_t value and (2) the header size is a multiple of the
657 alignment that Emacs needs for C types and for USE_LSB_TAG. */
658 #define XMALLOC_OVERRUN_SIZE_SIZE \
659 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
660 + XMALLOC_HEADER_ALIGNMENT - 1) \
661 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
662 - XMALLOC_OVERRUN_CHECK_SIZE)
664 static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
665 { '\x9a', '\x9b', '\xae', '\xaf',
666 '\xbf', '\xbe', '\xce', '\xcf',
667 '\xea', '\xeb', '\xec', '\xed',
668 '\xdf', '\xde', '\x9c', '\x9d' };
670 static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
671 { '\xaa', '\xab', '\xac', '\xad',
672 '\xba', '\xbb', '\xbc', '\xbd',
673 '\xca', '\xcb', '\xcc', '\xcd',
674 '\xda', '\xdb', '\xdc', '\xdd' };
676 /* Insert and extract the block size in the header. */
678 static void
679 xmalloc_put_size (unsigned char *ptr, size_t size)
681 int i;
682 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
684 *--ptr = size & ((1 << CHAR_BIT) - 1);
685 size >>= CHAR_BIT;
689 static size_t
690 xmalloc_get_size (unsigned char *ptr)
692 size_t size = 0;
693 int i;
694 ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
695 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
697 size <<= CHAR_BIT;
698 size += *ptr++;
700 return size;
704 /* Like malloc, but wraps allocated block with header and trailer. */
706 static void *
707 overrun_check_malloc (size_t size)
709 register unsigned char *val;
710 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
711 emacs_abort ();
713 val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
714 if (val)
716 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
717 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
718 xmalloc_put_size (val, size);
719 memcpy (val + size, xmalloc_overrun_check_trailer,
720 XMALLOC_OVERRUN_CHECK_SIZE);
722 return val;
726 /* Like realloc, but checks old block for overrun, and wraps new block
727 with header and trailer. */
729 static void *
730 overrun_check_realloc (void *block, size_t size)
732 register unsigned char *val = (unsigned char *) block;
733 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
734 emacs_abort ();
736 if (val
737 && memcmp (xmalloc_overrun_check_header,
738 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
739 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
741 size_t osize = xmalloc_get_size (val);
742 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
743 XMALLOC_OVERRUN_CHECK_SIZE))
744 emacs_abort ();
745 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
746 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
747 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
750 val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
752 if (val)
754 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
755 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
756 xmalloc_put_size (val, size);
757 memcpy (val + size, xmalloc_overrun_check_trailer,
758 XMALLOC_OVERRUN_CHECK_SIZE);
760 return val;
763 /* Like free, but checks block for overrun. */
765 static void
766 overrun_check_free (void *block)
768 unsigned char *val = (unsigned char *) block;
770 if (val
771 && memcmp (xmalloc_overrun_check_header,
772 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
773 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
775 size_t osize = xmalloc_get_size (val);
776 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
777 XMALLOC_OVERRUN_CHECK_SIZE))
778 emacs_abort ();
779 #ifdef XMALLOC_CLEAR_FREE_MEMORY
780 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
781 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
782 #else
783 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
784 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
785 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
786 #endif
789 free (val);
792 #undef malloc
793 #undef realloc
794 #undef free
795 #define malloc overrun_check_malloc
796 #define realloc overrun_check_realloc
797 #define free overrun_check_free
798 #endif
800 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
801 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
802 If that variable is set, block input while in one of Emacs's memory
803 allocation functions. There should be no need for this debugging
804 option, since signal handlers do not allocate memory, but Emacs
805 formerly allocated memory in signal handlers and this compile-time
806 option remains as a way to help debug the issue should it rear its
807 ugly head again. */
808 #ifdef XMALLOC_BLOCK_INPUT_CHECK
809 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
810 static void
811 malloc_block_input (void)
813 if (block_input_in_memory_allocators)
814 block_input ();
816 static void
817 malloc_unblock_input (void)
819 if (block_input_in_memory_allocators)
820 unblock_input ();
822 # define MALLOC_BLOCK_INPUT malloc_block_input ()
823 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
824 #else
825 # define MALLOC_BLOCK_INPUT ((void) 0)
826 # define MALLOC_UNBLOCK_INPUT ((void) 0)
827 #endif
829 #define MALLOC_PROBE(size) \
830 do { \
831 if (profiler_memory_running) \
832 malloc_probe (size); \
833 } while (0)
835 static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
836 static void *lrealloc (void *, size_t);
838 /* Like malloc but check for no memory and block interrupt input. */
840 void *
841 xmalloc (size_t size)
843 void *val;
845 MALLOC_BLOCK_INPUT;
846 val = lmalloc (size);
847 MALLOC_UNBLOCK_INPUT;
849 if (!val && size)
850 memory_full (size);
851 MALLOC_PROBE (size);
852 return val;
855 /* Like the above, but zeroes out the memory just allocated. */
857 void *
858 xzalloc (size_t size)
860 void *val;
862 MALLOC_BLOCK_INPUT;
863 val = lmalloc (size);
864 MALLOC_UNBLOCK_INPUT;
866 if (!val && size)
867 memory_full (size);
868 memset (val, 0, size);
869 MALLOC_PROBE (size);
870 return val;
873 /* Like realloc but check for no memory and block interrupt input.. */
875 void *
876 xrealloc (void *block, size_t size)
878 void *val;
880 MALLOC_BLOCK_INPUT;
881 /* We must call malloc explicitly when BLOCK is 0, since some
882 reallocs don't do this. */
883 if (! block)
884 val = lmalloc (size);
885 else
886 val = lrealloc (block, size);
887 MALLOC_UNBLOCK_INPUT;
889 if (!val && size)
890 memory_full (size);
891 MALLOC_PROBE (size);
892 return val;
896 /* Like free but block interrupt input. */
898 void
899 xfree (void *block)
901 if (!block)
902 return;
903 MALLOC_BLOCK_INPUT;
904 free (block);
905 MALLOC_UNBLOCK_INPUT;
906 /* We don't call refill_memory_reserve here
907 because in practice the call in r_alloc_free seems to suffice. */
911 /* Other parts of Emacs pass large int values to allocator functions
912 expecting ptrdiff_t. This is portable in practice, but check it to
913 be safe. */
914 verify (INT_MAX <= PTRDIFF_MAX);
917 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
918 Signal an error on memory exhaustion, and block interrupt input. */
920 void *
921 xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
923 eassert (0 <= nitems && 0 < item_size);
924 ptrdiff_t nbytes;
925 if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
926 memory_full (SIZE_MAX);
927 return xmalloc (nbytes);
931 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
932 Signal an error on memory exhaustion, and block interrupt input. */
934 void *
935 xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
937 eassert (0 <= nitems && 0 < item_size);
938 ptrdiff_t nbytes;
939 if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
940 memory_full (SIZE_MAX);
941 return xrealloc (pa, nbytes);
945 /* Grow PA, which points to an array of *NITEMS items, and return the
946 location of the reallocated array, updating *NITEMS to reflect its
947 new size. The new array will contain at least NITEMS_INCR_MIN more
948 items, but will not contain more than NITEMS_MAX items total.
949 ITEM_SIZE is the size of each item, in bytes.
951 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
952 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
953 infinity.
955 If PA is null, then allocate a new array instead of reallocating
956 the old one.
958 Block interrupt input as needed. If memory exhaustion occurs, set
959 *NITEMS to zero if PA is null, and signal an error (i.e., do not
960 return).
962 Thus, to grow an array A without saving its old contents, do
963 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
964 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
965 and signals an error, and later this code is reexecuted and
966 attempts to free A. */
968 void *
969 xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
970 ptrdiff_t nitems_max, ptrdiff_t item_size)
972 ptrdiff_t n0 = *nitems;
973 eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);
975 /* The approximate size to use for initial small allocation
976 requests. This is the largest "small" request for the GNU C
977 library malloc. */
978 enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
980 /* If the array is tiny, grow it to about (but no greater than)
981 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
982 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
983 NITEMS_MAX, and what the C language can represent safely. */
985 ptrdiff_t n, nbytes;
986 if (INT_ADD_WRAPV (n0, n0 >> 1, &n))
987 n = PTRDIFF_MAX;
988 if (0 <= nitems_max && nitems_max < n)
989 n = nitems_max;
991 ptrdiff_t adjusted_nbytes
992 = ((INT_MULTIPLY_WRAPV (n, item_size, &nbytes) || SIZE_MAX < nbytes)
993 ? min (PTRDIFF_MAX, SIZE_MAX)
994 : nbytes < DEFAULT_MXFAST ? DEFAULT_MXFAST : 0);
995 if (adjusted_nbytes)
997 n = adjusted_nbytes / item_size;
998 nbytes = adjusted_nbytes - adjusted_nbytes % item_size;
1001 if (! pa)
1002 *nitems = 0;
1003 if (n - n0 < nitems_incr_min
1004 && (INT_ADD_WRAPV (n0, nitems_incr_min, &n)
1005 || (0 <= nitems_max && nitems_max < n)
1006 || INT_MULTIPLY_WRAPV (n, item_size, &nbytes)))
1007 memory_full (SIZE_MAX);
1008 pa = xrealloc (pa, nbytes);
1009 *nitems = n;
1010 return pa;
1014 /* Like strdup, but uses xmalloc. */
1016 char *
1017 xstrdup (const char *s)
1019 ptrdiff_t size;
1020 eassert (s);
1021 size = strlen (s) + 1;
1022 return memcpy (xmalloc (size), s, size);
1025 /* Like above, but duplicates Lisp string to C string. */
1027 char *
1028 xlispstrdup (Lisp_Object string)
1030 ptrdiff_t size = SBYTES (string) + 1;
1031 return memcpy (xmalloc (size), SSDATA (string), size);
1034 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1035 pointed to. If STRING is null, assign it without copying anything.
1036 Allocate before freeing, to avoid a dangling pointer if allocation
1037 fails. */
1039 void
1040 dupstring (char **ptr, char const *string)
1042 char *old = *ptr;
1043 *ptr = string ? xstrdup (string) : 0;
1044 xfree (old);
1048 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1049 argument is a const pointer. */
1051 void
1052 xputenv (char const *string)
1054 if (putenv ((char *) string) != 0)
1055 memory_full (0);
1058 /* Return a newly allocated memory block of SIZE bytes, remembering
1059 to free it when unwinding. */
1060 void *
1061 record_xmalloc (size_t size)
1063 void *p = xmalloc (size);
1064 record_unwind_protect_ptr (xfree, p);
1065 return p;
1069 /* Like malloc but used for allocating Lisp data. NBYTES is the
1070 number of bytes to allocate, TYPE describes the intended use of the
1071 allocated memory block (for strings, for conses, ...). */
1073 #if ! USE_LSB_TAG
1074 void *lisp_malloc_loser EXTERNALLY_VISIBLE;
1075 #endif
1077 static void *
1078 lisp_malloc (size_t nbytes, enum mem_type type)
1080 register void *val;
1082 MALLOC_BLOCK_INPUT;
1084 #ifdef GC_MALLOC_CHECK
1085 allocated_mem_type = type;
1086 #endif
1088 val = lmalloc (nbytes);
1090 #if ! USE_LSB_TAG
1091 /* If the memory just allocated cannot be addressed thru a Lisp
1092 object's pointer, and it needs to be,
1093 that's equivalent to running out of memory. */
1094 if (val && type != MEM_TYPE_NON_LISP)
1096 Lisp_Object tem;
1097 XSETCONS (tem, (char *) val + nbytes - 1);
1098 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
1100 lisp_malloc_loser = val;
1101 free (val);
1102 val = 0;
1105 #endif
1107 #ifndef GC_MALLOC_CHECK
1108 if (val && type != MEM_TYPE_NON_LISP)
1109 mem_insert (val, (char *) val + nbytes, type);
1110 #endif
1112 MALLOC_UNBLOCK_INPUT;
1113 if (!val && nbytes)
1114 memory_full (nbytes);
1115 MALLOC_PROBE (nbytes);
1116 return val;
1119 /* Free BLOCK. This must be called to free memory allocated with a
1120 call to lisp_malloc. */
1122 static void
1123 lisp_free (void *block)
1125 MALLOC_BLOCK_INPUT;
1126 free (block);
1127 #ifndef GC_MALLOC_CHECK
1128 mem_delete (mem_find (block));
1129 #endif
1130 MALLOC_UNBLOCK_INPUT;
1133 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1135 /* The entry point is lisp_align_malloc which returns blocks of at most
1136 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1138 /* Byte alignment of storage blocks. */
1139 #define BLOCK_ALIGN (1 << 10)
1140 verify (POWER_OF_2 (BLOCK_ALIGN));
1142 /* Use aligned_alloc if it or a simple substitute is available.
1143 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1144 clang 3.3 anyway. Aligned allocation is incompatible with
1145 unexmacosx.c, so don't use it on Darwin. */
1147 #if ! ADDRESS_SANITIZER && !defined DARWIN_OS
1148 # if (defined HAVE_ALIGNED_ALLOC \
1149 || (defined HYBRID_MALLOC \
1150 ? defined HAVE_POSIX_MEMALIGN \
1151 : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
1152 # define USE_ALIGNED_ALLOC 1
1153 # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
1154 # define USE_ALIGNED_ALLOC 1
1155 # define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */
1156 static void *
1157 aligned_alloc (size_t alignment, size_t size)
1159 /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *).
1160 Verify this for all arguments this function is given. */
1161 verify (BLOCK_ALIGN % sizeof (void *) == 0
1162 && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *)));
1163 verify (GCALIGNMENT % sizeof (void *) == 0
1164 && POWER_OF_2 (GCALIGNMENT / sizeof (void *)));
1165 eassert (alignment == BLOCK_ALIGN || alignment == GCALIGNMENT);
1167 void *p;
1168 return posix_memalign (&p, alignment, size) == 0 ? p : 0;
1170 # endif
1171 #endif
1173 /* Padding to leave at the end of a malloc'd block. This is to give
1174 malloc a chance to minimize the amount of memory wasted to alignment.
1175 It should be tuned to the particular malloc library used.
1176 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1177 aligned_alloc on the other hand would ideally prefer a value of 4
1178 because otherwise, there's 1020 bytes wasted between each ablocks.
1179 In Emacs, testing shows that those 1020 can most of the time be
1180 efficiently used by malloc to place other objects, so a value of 0 can
1181 still preferable unless you have a lot of aligned blocks and virtually
1182 nothing else. */
1183 #define BLOCK_PADDING 0
1184 #define BLOCK_BYTES \
1185 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1187 /* Internal data structures and constants. */
1189 #define ABLOCKS_SIZE 16
1191 /* An aligned block of memory. */
1192 struct ablock
1194 union
1196 char payload[BLOCK_BYTES];
1197 struct ablock *next_free;
1198 } x;
1200 /* ABASE is the aligned base of the ablocks. It is overloaded to
1201 hold a virtual "busy" field that counts twice the number of used
1202 ablock values in the parent ablocks, plus one if the real base of
1203 the parent ablocks is ABASE (if the "busy" field is even, the
1204 word before the first ablock holds a pointer to the real base).
1205 The first ablock has a "busy" ABASE, and the others have an
1206 ordinary pointer ABASE. To tell the difference, the code assumes
1207 that pointers, when cast to uintptr_t, are at least 2 *
1208 ABLOCKS_SIZE + 1. */
1209 struct ablocks *abase;
1211 /* The padding of all but the last ablock is unused. The padding of
1212 the last ablock in an ablocks is not allocated. */
1213 #if BLOCK_PADDING
1214 char padding[BLOCK_PADDING];
1215 #endif
1218 /* A bunch of consecutive aligned blocks. */
1219 struct ablocks
1221 struct ablock blocks[ABLOCKS_SIZE];
1224 /* Size of the block requested from malloc or aligned_alloc. */
1225 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1227 #define ABLOCK_ABASE(block) \
1228 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1229 ? (struct ablocks *) (block) \
1230 : (block)->abase)
1232 /* Virtual `busy' field. */
1233 #define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
1235 /* Pointer to the (not necessarily aligned) malloc block. */
1236 #ifdef USE_ALIGNED_ALLOC
1237 #define ABLOCKS_BASE(abase) (abase)
1238 #else
1239 #define ABLOCKS_BASE(abase) \
1240 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
1241 #endif
1243 /* The list of free ablock. */
1244 static struct ablock *free_ablock;
1246 /* Allocate an aligned block of nbytes.
1247 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1248 smaller or equal to BLOCK_BYTES. */
1249 static void *
1250 lisp_align_malloc (size_t nbytes, enum mem_type type)
1252 void *base, *val;
1253 struct ablocks *abase;
1255 eassert (nbytes <= BLOCK_BYTES);
1257 MALLOC_BLOCK_INPUT;
1259 #ifdef GC_MALLOC_CHECK
1260 allocated_mem_type = type;
1261 #endif
1263 if (!free_ablock)
1265 int i;
1266 bool aligned;
1268 #ifdef DOUG_LEA_MALLOC
1269 if (!mmap_lisp_allowed_p ())
1270 mallopt (M_MMAP_MAX, 0);
1271 #endif
1273 #ifdef USE_ALIGNED_ALLOC
1274 verify (ABLOCKS_BYTES % BLOCK_ALIGN == 0);
1275 abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES);
1276 #else
1277 base = malloc (ABLOCKS_BYTES);
1278 abase = pointer_align (base, BLOCK_ALIGN);
1279 #endif
1281 if (base == 0)
1283 MALLOC_UNBLOCK_INPUT;
1284 memory_full (ABLOCKS_BYTES);
1287 aligned = (base == abase);
1288 if (!aligned)
1289 ((void **) abase)[-1] = base;
1291 #ifdef DOUG_LEA_MALLOC
1292 if (!mmap_lisp_allowed_p ())
1293 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1294 #endif
1296 #if ! USE_LSB_TAG
1297 /* If the memory just allocated cannot be addressed thru a Lisp
1298 object's pointer, and it needs to be, that's equivalent to
1299 running out of memory. */
1300 if (type != MEM_TYPE_NON_LISP)
1302 Lisp_Object tem;
1303 char *end = (char *) base + ABLOCKS_BYTES - 1;
1304 XSETCONS (tem, end);
1305 if ((char *) XCONS (tem) != end)
1307 lisp_malloc_loser = base;
1308 free (base);
1309 MALLOC_UNBLOCK_INPUT;
1310 memory_full (SIZE_MAX);
1313 #endif
1315 /* Initialize the blocks and put them on the free list.
1316 If `base' was not properly aligned, we can't use the last block. */
1317 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1319 abase->blocks[i].abase = abase;
1320 abase->blocks[i].x.next_free = free_ablock;
1321 free_ablock = &abase->blocks[i];
1323 intptr_t ialigned = aligned;
1324 ABLOCKS_BUSY (abase) = (struct ablocks *) ialigned;
1326 eassert ((uintptr_t) abase % BLOCK_ALIGN == 0);
1327 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
1328 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1329 eassert (ABLOCKS_BASE (abase) == base);
1330 eassert ((intptr_t) ABLOCKS_BUSY (abase) == aligned);
1333 abase = ABLOCK_ABASE (free_ablock);
1334 ABLOCKS_BUSY (abase)
1335 = (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
1336 val = free_ablock;
1337 free_ablock = free_ablock->x.next_free;
1339 #ifndef GC_MALLOC_CHECK
1340 if (type != MEM_TYPE_NON_LISP)
1341 mem_insert (val, (char *) val + nbytes, type);
1342 #endif
1344 MALLOC_UNBLOCK_INPUT;
1346 MALLOC_PROBE (nbytes);
1348 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
1349 return val;
1352 static void
1353 lisp_align_free (void *block)
1355 struct ablock *ablock = block;
1356 struct ablocks *abase = ABLOCK_ABASE (ablock);
1358 MALLOC_BLOCK_INPUT;
1359 #ifndef GC_MALLOC_CHECK
1360 mem_delete (mem_find (block));
1361 #endif
1362 /* Put on free list. */
1363 ablock->x.next_free = free_ablock;
1364 free_ablock = ablock;
1365 /* Update busy count. */
1366 intptr_t busy = (intptr_t) ABLOCKS_BUSY (abase) - 2;
1367 eassume (0 <= busy && busy <= 2 * ABLOCKS_SIZE - 1);
1368 ABLOCKS_BUSY (abase) = (struct ablocks *) busy;
1370 if (busy < 2)
1371 { /* All the blocks are free. */
1372 int i = 0;
1373 bool aligned = busy;
1374 struct ablock **tem = &free_ablock;
1375 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1377 while (*tem)
1379 if (*tem >= (struct ablock *) abase && *tem < atop)
1381 i++;
1382 *tem = (*tem)->x.next_free;
1384 else
1385 tem = &(*tem)->x.next_free;
1387 eassert ((aligned & 1) == aligned);
1388 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1389 #ifdef USE_POSIX_MEMALIGN
1390 eassert ((uintptr_t) ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1391 #endif
1392 free (ABLOCKS_BASE (abase));
1394 MALLOC_UNBLOCK_INPUT;
1397 #if !defined __GNUC__ && !defined __alignof__
1398 # define __alignof__(type) alignof (type)
1399 #endif
1401 /* True if malloc (N) is known to return a multiple of GCALIGNMENT
1402 whenever N is also a multiple. In practice this is true if
1403 __alignof__ (max_align_t) is a multiple as well, assuming
1404 GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked
1405 into. Use __alignof__ if available, as otherwise
1406 MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the
1407 alignment is OK there.
1409 This is a macro, not an enum constant, for portability to HP-UX
1410 10.20 cc and AIX 3.2.5 xlc. */
1411 #define MALLOC_IS_GC_ALIGNED \
1412 (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0)
1414 /* True if a malloc-returned pointer P is suitably aligned for SIZE,
1415 where Lisp alignment may be needed if SIZE is Lisp-aligned. */
1417 static bool
1418 laligned (void *p, size_t size)
1420 return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0
1421 || size % GCALIGNMENT != 0);
1424 /* Like malloc and realloc except that if SIZE is Lisp-aligned, make
1425 sure the result is too, if necessary by reallocating (typically
1426 with larger and larger sizes) until the allocator returns a
1427 Lisp-aligned pointer. Code that needs to allocate C heap memory
1428 for a Lisp object should use one of these functions to obtain a
1429 pointer P; that way, if T is an enum Lisp_Type value and L ==
1430 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
1432 On typical modern platforms these functions' loops do not iterate.
1433 On now-rare (and perhaps nonexistent) platforms, the loops in
1434 theory could repeat forever. If an infinite loop is possible on a
1435 platform, a build would surely loop and the builder can then send
1436 us a bug report. Adding a counter to try to detect any such loop
1437 would complicate the code (and possibly introduce bugs, in code
1438 that's never really exercised) for little benefit. */
1440 static void *
1441 lmalloc (size_t size)
1443 #if USE_ALIGNED_ALLOC
1444 if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0)
1445 return aligned_alloc (GCALIGNMENT, size);
1446 #endif
1448 while (true)
1450 void *p = malloc (size);
1451 if (laligned (p, size))
1452 return p;
1453 free (p);
1454 size_t bigger = size + GCALIGNMENT;
1455 if (size < bigger)
1456 size = bigger;
1460 static void *
1461 lrealloc (void *p, size_t size)
1463 while (true)
1465 p = realloc (p, size);
1466 if (laligned (p, size))
1467 return p;
1468 size_t bigger = size + GCALIGNMENT;
1469 if (size < bigger)
1470 size = bigger;
1475 /***********************************************************************
1476 Interval Allocation
1477 ***********************************************************************/
1479 /* Number of intervals allocated in an interval_block structure.
1480 The 1020 is 1024 minus malloc overhead. */
1482 #define INTERVAL_BLOCK_SIZE \
1483 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1485 /* Intervals are allocated in chunks in the form of an interval_block
1486 structure. */
1488 struct interval_block
1490 /* Place `intervals' first, to preserve alignment. */
1491 struct interval intervals[INTERVAL_BLOCK_SIZE];
1492 struct interval_block *next;
1495 /* Current interval block. Its `next' pointer points to older
1496 blocks. */
1498 static struct interval_block *interval_block;
1500 /* Index in interval_block above of the next unused interval
1501 structure. */
1503 static int interval_block_index = INTERVAL_BLOCK_SIZE;
1505 /* Number of free and live intervals. */
1507 static EMACS_INT total_free_intervals, total_intervals;
1509 /* List of free intervals. */
1511 static INTERVAL interval_free_list;
1513 /* Return a new interval. */
1515 INTERVAL
1516 make_interval (void)
1518 INTERVAL val;
1520 MALLOC_BLOCK_INPUT;
1522 if (interval_free_list)
1524 val = interval_free_list;
1525 interval_free_list = INTERVAL_PARENT (interval_free_list);
1527 else
1529 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1531 struct interval_block *newi
1532 = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP);
1534 newi->next = interval_block;
1535 interval_block = newi;
1536 interval_block_index = 0;
1537 total_free_intervals += INTERVAL_BLOCK_SIZE;
1539 val = &interval_block->intervals[interval_block_index++];
1542 MALLOC_UNBLOCK_INPUT;
1544 consing_since_gc += sizeof (struct interval);
1545 intervals_consed++;
1546 total_free_intervals--;
1547 RESET_INTERVAL (val);
1548 val->gcmarkbit = 0;
1549 return val;
1553 /* Mark Lisp objects in interval I. */
1555 static void
1556 mark_interval (INTERVAL i, void *dummy)
1558 /* Intervals should never be shared. So, if extra internal checking is
1559 enabled, GC aborts if it seems to have visited an interval twice. */
1560 eassert (!i->gcmarkbit);
1561 i->gcmarkbit = 1;
1562 mark_object (i->plist);
1565 /* Mark the interval tree rooted in I. */
1567 #define MARK_INTERVAL_TREE(i) \
1568 do { \
1569 if (i && !i->gcmarkbit) \
1570 traverse_intervals_noorder (i, mark_interval, NULL); \
1571 } while (0)
1573 /***********************************************************************
1574 String Allocation
1575 ***********************************************************************/
1577 /* Lisp_Strings are allocated in string_block structures. When a new
1578 string_block is allocated, all the Lisp_Strings it contains are
1579 added to a free-list string_free_list. When a new Lisp_String is
1580 needed, it is taken from that list. During the sweep phase of GC,
1581 string_blocks that are entirely free are freed, except two which
1582 we keep.
1584 String data is allocated from sblock structures. Strings larger
1585 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1586 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1588 Sblocks consist internally of sdata structures, one for each
1589 Lisp_String. The sdata structure points to the Lisp_String it
1590 belongs to. The Lisp_String points back to the `u.data' member of
1591 its sdata structure.
1593 When a Lisp_String is freed during GC, it is put back on
1594 string_free_list, and its `data' member and its sdata's `string'
1595 pointer is set to null. The size of the string is recorded in the
1596 `n.nbytes' member of the sdata. So, sdata structures that are no
1597 longer used, can be easily recognized, and it's easy to compact the
1598 sblocks of small strings which we do in compact_small_strings. */
1600 /* Size in bytes of an sblock structure used for small strings. This
1601 is 8192 minus malloc overhead. */
1603 #define SBLOCK_SIZE 8188
1605 /* Strings larger than this are considered large strings. String data
1606 for large strings is allocated from individual sblocks. */
1608 #define LARGE_STRING_BYTES 1024
1610 /* The SDATA typedef is a struct or union describing string memory
1611 sub-allocated from an sblock. This is where the contents of Lisp
1612 strings are stored. */
1614 struct sdata
1616 /* Back-pointer to the string this sdata belongs to. If null, this
1617 structure is free, and NBYTES (in this structure or in the union below)
1618 contains the string's byte size (the same value that STRING_BYTES
1619 would return if STRING were non-null). If non-null, STRING_BYTES
1620 (STRING) is the size of the data, and DATA contains the string's
1621 contents. */
1622 struct Lisp_String *string;
1624 #ifdef GC_CHECK_STRING_BYTES
1625 ptrdiff_t nbytes;
1626 #endif
1628 unsigned char data[FLEXIBLE_ARRAY_MEMBER];
1631 #ifdef GC_CHECK_STRING_BYTES
1633 typedef struct sdata sdata;
1634 #define SDATA_NBYTES(S) (S)->nbytes
1635 #define SDATA_DATA(S) (S)->data
1637 #else
1639 typedef union
1641 struct Lisp_String *string;
1643 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1644 which has a flexible array member. However, if implemented by
1645 giving this union a member of type 'struct sdata', the union
1646 could not be the last (flexible) member of 'struct sblock',
1647 because C99 prohibits a flexible array member from having a type
1648 that is itself a flexible array. So, comment this member out here,
1649 but remember that the option's there when using this union. */
1650 #if 0
1651 struct sdata u;
1652 #endif
1654 /* When STRING is null. */
1655 struct
1657 struct Lisp_String *string;
1658 ptrdiff_t nbytes;
1659 } n;
1660 } sdata;
1662 #define SDATA_NBYTES(S) (S)->n.nbytes
1663 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1665 #endif /* not GC_CHECK_STRING_BYTES */
1667 enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) };
1669 /* Structure describing a block of memory which is sub-allocated to
1670 obtain string data memory for strings. Blocks for small strings
1671 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1672 as large as needed. */
1674 struct sblock
1676 /* Next in list. */
1677 struct sblock *next;
1679 /* Pointer to the next free sdata block. This points past the end
1680 of the sblock if there isn't any space left in this block. */
1681 sdata *next_free;
1683 /* String data. */
1684 sdata data[FLEXIBLE_ARRAY_MEMBER];
1687 /* Number of Lisp strings in a string_block structure. The 1020 is
1688 1024 minus malloc overhead. */
1690 #define STRING_BLOCK_SIZE \
1691 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1693 /* Structure describing a block from which Lisp_String structures
1694 are allocated. */
1696 struct string_block
1698 /* Place `strings' first, to preserve alignment. */
1699 struct Lisp_String strings[STRING_BLOCK_SIZE];
1700 struct string_block *next;
1703 /* Head and tail of the list of sblock structures holding Lisp string
1704 data. We always allocate from current_sblock. The NEXT pointers
1705 in the sblock structures go from oldest_sblock to current_sblock. */
1707 static struct sblock *oldest_sblock, *current_sblock;
1709 /* List of sblocks for large strings. */
1711 static struct sblock *large_sblocks;
1713 /* List of string_block structures. */
1715 static struct string_block *string_blocks;
1717 /* Free-list of Lisp_Strings. */
1719 static struct Lisp_String *string_free_list;
1721 /* Number of live and free Lisp_Strings. */
1723 static EMACS_INT total_strings, total_free_strings;
1725 /* Number of bytes used by live strings. */
1727 static EMACS_INT total_string_bytes;
1729 /* Given a pointer to a Lisp_String S which is on the free-list
1730 string_free_list, return a pointer to its successor in the
1731 free-list. */
1733 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1735 /* Return a pointer to the sdata structure belonging to Lisp string S.
1736 S must be live, i.e. S->data must not be null. S->data is actually
1737 a pointer to the `u.data' member of its sdata structure; the
1738 structure starts at a constant offset in front of that. */
1740 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1743 #ifdef GC_CHECK_STRING_OVERRUN
1745 /* We check for overrun in string data blocks by appending a small
1746 "cookie" after each allocated string data block, and check for the
1747 presence of this cookie during GC. */
1749 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1750 static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1751 { '\xde', '\xad', '\xbe', '\xef' };
1753 #else
1754 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1755 #endif
1757 /* Value is the size of an sdata structure large enough to hold NBYTES
1758 bytes of string data. The value returned includes a terminating
1759 NUL byte, the size of the sdata structure, and padding. */
1761 #ifdef GC_CHECK_STRING_BYTES
1763 #define SDATA_SIZE(NBYTES) FLEXSIZEOF (struct sdata, data, NBYTES)
1765 #else /* not GC_CHECK_STRING_BYTES */
1767 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1768 less than the size of that member. The 'max' is not needed when
1769 SDATA_DATA_OFFSET is a multiple of FLEXALIGNOF (struct sdata),
1770 because then the alignment code reserves enough space. */
1772 #define SDATA_SIZE(NBYTES) \
1773 ((SDATA_DATA_OFFSET \
1774 + (SDATA_DATA_OFFSET % FLEXALIGNOF (struct sdata) == 0 \
1775 ? NBYTES \
1776 : max (NBYTES, FLEXALIGNOF (struct sdata) - 1)) \
1777 + 1 \
1778 + FLEXALIGNOF (struct sdata) - 1) \
1779 & ~(FLEXALIGNOF (struct sdata) - 1))
1781 #endif /* not GC_CHECK_STRING_BYTES */
1783 /* Extra bytes to allocate for each string. */
1785 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1787 /* Exact bound on the number of bytes in a string, not counting the
1788 terminating null. A string cannot contain more bytes than
1789 STRING_BYTES_BOUND, nor can it be so long that the size_t
1790 arithmetic in allocate_string_data would overflow while it is
1791 calculating a value to be passed to malloc. */
1792 static ptrdiff_t const STRING_BYTES_MAX =
1793 min (STRING_BYTES_BOUND,
1794 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
1795 - GC_STRING_EXTRA
1796 - offsetof (struct sblock, data)
1797 - SDATA_DATA_OFFSET)
1798 & ~(sizeof (EMACS_INT) - 1)));
1800 /* Initialize string allocation. Called from init_alloc_once. */
1802 static void
1803 init_strings (void)
1805 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1806 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1810 #ifdef GC_CHECK_STRING_BYTES
1812 static int check_string_bytes_count;
1814 /* Like STRING_BYTES, but with debugging check. Can be
1815 called during GC, so pay attention to the mark bit. */
1817 ptrdiff_t
1818 string_bytes (struct Lisp_String *s)
1820 ptrdiff_t nbytes =
1821 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1823 if (!PURE_P (s) && s->data && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1824 emacs_abort ();
1825 return nbytes;
1828 /* Check validity of Lisp strings' string_bytes member in B. */
1830 static void
1831 check_sblock (struct sblock *b)
1833 sdata *from, *end, *from_end;
1835 end = b->next_free;
1837 for (from = b->data; from < end; from = from_end)
1839 /* Compute the next FROM here because copying below may
1840 overwrite data we need to compute it. */
1841 ptrdiff_t nbytes;
1843 /* Check that the string size recorded in the string is the
1844 same as the one recorded in the sdata structure. */
1845 nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
1846 : SDATA_NBYTES (from));
1847 from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1852 /* Check validity of Lisp strings' string_bytes member. ALL_P
1853 means check all strings, otherwise check only most
1854 recently allocated strings. Used for hunting a bug. */
1856 static void
1857 check_string_bytes (bool all_p)
1859 if (all_p)
1861 struct sblock *b;
1863 for (b = large_sblocks; b; b = b->next)
1865 struct Lisp_String *s = b->data[0].string;
1866 if (s)
1867 string_bytes (s);
1870 for (b = oldest_sblock; b; b = b->next)
1871 check_sblock (b);
1873 else if (current_sblock)
1874 check_sblock (current_sblock);
1877 #else /* not GC_CHECK_STRING_BYTES */
1879 #define check_string_bytes(all) ((void) 0)
1881 #endif /* GC_CHECK_STRING_BYTES */
1883 #ifdef GC_CHECK_STRING_FREE_LIST
1885 /* Walk through the string free list looking for bogus next pointers.
1886 This may catch buffer overrun from a previous string. */
1888 static void
1889 check_string_free_list (void)
1891 struct Lisp_String *s;
1893 /* Pop a Lisp_String off the free-list. */
1894 s = string_free_list;
1895 while (s != NULL)
1897 if ((uintptr_t) s < 1024)
1898 emacs_abort ();
1899 s = NEXT_FREE_LISP_STRING (s);
1902 #else
1903 #define check_string_free_list()
1904 #endif
1906 /* Return a new Lisp_String. */
1908 static struct Lisp_String *
1909 allocate_string (void)
1911 struct Lisp_String *s;
1913 MALLOC_BLOCK_INPUT;
1915 /* If the free-list is empty, allocate a new string_block, and
1916 add all the Lisp_Strings in it to the free-list. */
1917 if (string_free_list == NULL)
1919 struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1920 int i;
1922 b->next = string_blocks;
1923 string_blocks = b;
1925 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1927 s = b->strings + i;
1928 /* Every string on a free list should have NULL data pointer. */
1929 s->data = NULL;
1930 NEXT_FREE_LISP_STRING (s) = string_free_list;
1931 string_free_list = s;
1934 total_free_strings += STRING_BLOCK_SIZE;
1937 check_string_free_list ();
1939 /* Pop a Lisp_String off the free-list. */
1940 s = string_free_list;
1941 string_free_list = NEXT_FREE_LISP_STRING (s);
1943 MALLOC_UNBLOCK_INPUT;
1945 --total_free_strings;
1946 ++total_strings;
1947 ++strings_consed;
1948 consing_since_gc += sizeof *s;
1950 #ifdef GC_CHECK_STRING_BYTES
1951 if (!noninteractive)
1953 if (++check_string_bytes_count == 200)
1955 check_string_bytes_count = 0;
1956 check_string_bytes (1);
1958 else
1959 check_string_bytes (0);
1961 #endif /* GC_CHECK_STRING_BYTES */
1963 return s;
1967 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1968 plus a NUL byte at the end. Allocate an sdata structure for S, and
1969 set S->data to its `u.data' member. Store a NUL byte at the end of
1970 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1971 S->data if it was initially non-null. */
1973 void
1974 allocate_string_data (struct Lisp_String *s,
1975 EMACS_INT nchars, EMACS_INT nbytes)
1977 sdata *data, *old_data;
1978 struct sblock *b;
1979 ptrdiff_t needed, old_nbytes;
1981 if (STRING_BYTES_MAX < nbytes)
1982 string_overflow ();
1984 /* Determine the number of bytes needed to store NBYTES bytes
1985 of string data. */
1986 needed = SDATA_SIZE (nbytes);
1987 if (s->data)
1989 old_data = SDATA_OF_STRING (s);
1990 old_nbytes = STRING_BYTES (s);
1992 else
1993 old_data = NULL;
1995 MALLOC_BLOCK_INPUT;
1997 if (nbytes > LARGE_STRING_BYTES)
1999 size_t size = FLEXSIZEOF (struct sblock, data, needed);
2001 #ifdef DOUG_LEA_MALLOC
2002 if (!mmap_lisp_allowed_p ())
2003 mallopt (M_MMAP_MAX, 0);
2004 #endif
2006 b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
2008 #ifdef DOUG_LEA_MALLOC
2009 if (!mmap_lisp_allowed_p ())
2010 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2011 #endif
2013 data = b->data;
2014 b->next = large_sblocks;
2015 b->next_free = data;
2016 large_sblocks = b;
2018 else if (current_sblock == NULL
2019 || (((char *) current_sblock + SBLOCK_SIZE
2020 - (char *) current_sblock->next_free)
2021 < (needed + GC_STRING_EXTRA)))
2023 /* Not enough room in the current sblock. */
2024 b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2025 data = b->data;
2026 b->next = NULL;
2027 b->next_free = data;
2029 if (current_sblock)
2030 current_sblock->next = b;
2031 else
2032 oldest_sblock = b;
2033 current_sblock = b;
2035 else
2037 b = current_sblock;
2038 data = b->next_free;
2041 data->string = s;
2042 b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2044 MALLOC_UNBLOCK_INPUT;
2046 s->data = SDATA_DATA (data);
2047 #ifdef GC_CHECK_STRING_BYTES
2048 SDATA_NBYTES (data) = nbytes;
2049 #endif
2050 s->size = nchars;
2051 s->size_byte = nbytes;
2052 s->data[nbytes] = '\0';
2053 #ifdef GC_CHECK_STRING_OVERRUN
2054 memcpy ((char *) data + needed, string_overrun_cookie,
2055 GC_STRING_OVERRUN_COOKIE_SIZE);
2056 #endif
2058 /* Note that Faset may call to this function when S has already data
2059 assigned. In this case, mark data as free by setting it's string
2060 back-pointer to null, and record the size of the data in it. */
2061 if (old_data)
2063 SDATA_NBYTES (old_data) = old_nbytes;
2064 old_data->string = NULL;
2067 consing_since_gc += needed;
2071 /* Sweep and compact strings. */
2073 NO_INLINE /* For better stack traces */
2074 static void
2075 sweep_strings (void)
2077 struct string_block *b, *next;
2078 struct string_block *live_blocks = NULL;
2080 string_free_list = NULL;
2081 total_strings = total_free_strings = 0;
2082 total_string_bytes = 0;
2084 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2085 for (b = string_blocks; b; b = next)
2087 int i, nfree = 0;
2088 struct Lisp_String *free_list_before = string_free_list;
2090 next = b->next;
2092 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
2094 struct Lisp_String *s = b->strings + i;
2096 if (s->data)
2098 /* String was not on free-list before. */
2099 if (STRING_MARKED_P (s))
2101 /* String is live; unmark it and its intervals. */
2102 UNMARK_STRING (s);
2104 /* Do not use string_(set|get)_intervals here. */
2105 s->intervals = balance_intervals (s->intervals);
2107 ++total_strings;
2108 total_string_bytes += STRING_BYTES (s);
2110 else
2112 /* String is dead. Put it on the free-list. */
2113 sdata *data = SDATA_OF_STRING (s);
2115 /* Save the size of S in its sdata so that we know
2116 how large that is. Reset the sdata's string
2117 back-pointer so that we know it's free. */
2118 #ifdef GC_CHECK_STRING_BYTES
2119 if (string_bytes (s) != SDATA_NBYTES (data))
2120 emacs_abort ();
2121 #else
2122 data->n.nbytes = STRING_BYTES (s);
2123 #endif
2124 data->string = NULL;
2126 /* Reset the strings's `data' member so that we
2127 know it's free. */
2128 s->data = NULL;
2130 /* Put the string on the free-list. */
2131 NEXT_FREE_LISP_STRING (s) = string_free_list;
2132 string_free_list = s;
2133 ++nfree;
2136 else
2138 /* S was on the free-list before. Put it there again. */
2139 NEXT_FREE_LISP_STRING (s) = string_free_list;
2140 string_free_list = s;
2141 ++nfree;
2145 /* Free blocks that contain free Lisp_Strings only, except
2146 the first two of them. */
2147 if (nfree == STRING_BLOCK_SIZE
2148 && total_free_strings > STRING_BLOCK_SIZE)
2150 lisp_free (b);
2151 string_free_list = free_list_before;
2153 else
2155 total_free_strings += nfree;
2156 b->next = live_blocks;
2157 live_blocks = b;
2161 check_string_free_list ();
2163 string_blocks = live_blocks;
2164 free_large_strings ();
2165 compact_small_strings ();
2167 check_string_free_list ();
2171 /* Free dead large strings. */
2173 static void
2174 free_large_strings (void)
2176 struct sblock *b, *next;
2177 struct sblock *live_blocks = NULL;
2179 for (b = large_sblocks; b; b = next)
2181 next = b->next;
2183 if (b->data[0].string == NULL)
2184 lisp_free (b);
2185 else
2187 b->next = live_blocks;
2188 live_blocks = b;
2192 large_sblocks = live_blocks;
2196 /* Compact data of small strings. Free sblocks that don't contain
2197 data of live strings after compaction. */
2199 static void
2200 compact_small_strings (void)
2202 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2203 to, and TB_END is the end of TB. */
2204 struct sblock *tb = oldest_sblock;
2205 if (tb)
2207 sdata *tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
2208 sdata *to = tb->data;
2210 /* Step through the blocks from the oldest to the youngest. We
2211 expect that old blocks will stabilize over time, so that less
2212 copying will happen this way. */
2213 struct sblock *b = tb;
2216 sdata *end = b->next_free;
2217 eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2219 for (sdata *from = b->data; from < end; )
2221 /* Compute the next FROM here because copying below may
2222 overwrite data we need to compute it. */
2223 ptrdiff_t nbytes;
2224 struct Lisp_String *s = from->string;
2226 #ifdef GC_CHECK_STRING_BYTES
2227 /* Check that the string size recorded in the string is the
2228 same as the one recorded in the sdata structure. */
2229 if (s && string_bytes (s) != SDATA_NBYTES (from))
2230 emacs_abort ();
2231 #endif /* GC_CHECK_STRING_BYTES */
2233 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
2234 eassert (nbytes <= LARGE_STRING_BYTES);
2236 nbytes = SDATA_SIZE (nbytes);
2237 sdata *from_end = (sdata *) ((char *) from
2238 + nbytes + GC_STRING_EXTRA);
2240 #ifdef GC_CHECK_STRING_OVERRUN
2241 if (memcmp (string_overrun_cookie,
2242 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
2243 GC_STRING_OVERRUN_COOKIE_SIZE))
2244 emacs_abort ();
2245 #endif
2247 /* Non-NULL S means it's alive. Copy its data. */
2248 if (s)
2250 /* If TB is full, proceed with the next sblock. */
2251 sdata *to_end = (sdata *) ((char *) to
2252 + nbytes + GC_STRING_EXTRA);
2253 if (to_end > tb_end)
2255 tb->next_free = to;
2256 tb = tb->next;
2257 tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
2258 to = tb->data;
2259 to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2262 /* Copy, and update the string's `data' pointer. */
2263 if (from != to)
2265 eassert (tb != b || to < from);
2266 memmove (to, from, nbytes + GC_STRING_EXTRA);
2267 to->string->data = SDATA_DATA (to);
2270 /* Advance past the sdata we copied to. */
2271 to = to_end;
2273 from = from_end;
2275 b = b->next;
2277 while (b);
2279 /* The rest of the sblocks following TB don't contain live data, so
2280 we can free them. */
2281 for (b = tb->next; b; )
2283 struct sblock *next = b->next;
2284 lisp_free (b);
2285 b = next;
2288 tb->next_free = to;
2289 tb->next = NULL;
2292 current_sblock = tb;
2295 void
2296 string_overflow (void)
2298 error ("Maximum string size exceeded");
2301 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
2302 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
2303 LENGTH must be an integer.
2304 INIT must be an integer that represents a character. */)
2305 (Lisp_Object length, Lisp_Object init)
2307 register Lisp_Object val;
2308 int c;
2309 EMACS_INT nbytes;
2311 CHECK_NATNUM (length);
2312 CHECK_CHARACTER (init);
2314 c = XFASTINT (init);
2315 if (ASCII_CHAR_P (c))
2317 nbytes = XINT (length);
2318 val = make_uninit_string (nbytes);
2319 if (nbytes)
2321 memset (SDATA (val), c, nbytes);
2322 SDATA (val)[nbytes] = 0;
2325 else
2327 unsigned char str[MAX_MULTIBYTE_LENGTH];
2328 ptrdiff_t len = CHAR_STRING (c, str);
2329 EMACS_INT string_len = XINT (length);
2330 unsigned char *p, *beg, *end;
2332 if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes))
2333 string_overflow ();
2334 val = make_uninit_multibyte_string (string_len, nbytes);
2335 for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len)
2337 /* First time we just copy `str' to the data of `val'. */
2338 if (p == beg)
2339 memcpy (p, str, len);
2340 else
2342 /* Next time we copy largest possible chunk from
2343 initialized to uninitialized part of `val'. */
2344 len = min (p - beg, end - p);
2345 memcpy (p, beg, len);
2348 if (nbytes)
2349 *p = 0;
2352 return val;
2355 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2356 Return A. */
2358 Lisp_Object
2359 bool_vector_fill (Lisp_Object a, Lisp_Object init)
2361 EMACS_INT nbits = bool_vector_size (a);
2362 if (0 < nbits)
2364 unsigned char *data = bool_vector_uchar_data (a);
2365 int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1;
2366 ptrdiff_t nbytes = bool_vector_bytes (nbits);
2367 int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1));
2368 memset (data, pattern, nbytes - 1);
2369 data[nbytes - 1] = pattern & last_mask;
2371 return a;
2374 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2376 Lisp_Object
2377 make_uninit_bool_vector (EMACS_INT nbits)
2379 Lisp_Object val;
2380 EMACS_INT words = bool_vector_words (nbits);
2381 EMACS_INT word_bytes = words * sizeof (bits_word);
2382 EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
2383 + word_size - 1)
2384 / word_size);
2385 struct Lisp_Bool_Vector *p
2386 = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
2387 XSETVECTOR (val, p);
2388 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
2389 p->size = nbits;
2391 /* Clear padding at the end. */
2392 if (words)
2393 p->data[words - 1] = 0;
2395 return val;
2398 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2399 doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2400 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2401 (Lisp_Object length, Lisp_Object init)
2403 Lisp_Object val;
2405 CHECK_NATNUM (length);
2406 val = make_uninit_bool_vector (XFASTINT (length));
2407 return bool_vector_fill (val, init);
2410 DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
2411 doc: /* Return a new bool-vector with specified arguments as elements.
2412 Any number of arguments, even zero arguments, are allowed.
2413 usage: (bool-vector &rest OBJECTS) */)
2414 (ptrdiff_t nargs, Lisp_Object *args)
2416 ptrdiff_t i;
2417 Lisp_Object vector;
2419 vector = make_uninit_bool_vector (nargs);
2420 for (i = 0; i < nargs; i++)
2421 bool_vector_set (vector, i, !NILP (args[i]));
2423 return vector;
2426 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2427 of characters from the contents. This string may be unibyte or
2428 multibyte, depending on the contents. */
2430 Lisp_Object
2431 make_string (const char *contents, ptrdiff_t nbytes)
2433 register Lisp_Object val;
2434 ptrdiff_t nchars, multibyte_nbytes;
2436 parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
2437 &nchars, &multibyte_nbytes);
2438 if (nbytes == nchars || nbytes != multibyte_nbytes)
2439 /* CONTENTS contains no multibyte sequences or contains an invalid
2440 multibyte sequence. We must make unibyte string. */
2441 val = make_unibyte_string (contents, nbytes);
2442 else
2443 val = make_multibyte_string (contents, nchars, nbytes);
2444 return val;
2447 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2449 Lisp_Object
2450 make_unibyte_string (const char *contents, ptrdiff_t length)
2452 register Lisp_Object val;
2453 val = make_uninit_string (length);
2454 memcpy (SDATA (val), contents, length);
2455 return val;
2459 /* Make a multibyte string from NCHARS characters occupying NBYTES
2460 bytes at CONTENTS. */
2462 Lisp_Object
2463 make_multibyte_string (const char *contents,
2464 ptrdiff_t nchars, ptrdiff_t nbytes)
2466 register Lisp_Object val;
2467 val = make_uninit_multibyte_string (nchars, nbytes);
2468 memcpy (SDATA (val), contents, nbytes);
2469 return val;
2473 /* Make a string from NCHARS characters occupying NBYTES bytes at
2474 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2476 Lisp_Object
2477 make_string_from_bytes (const char *contents,
2478 ptrdiff_t nchars, ptrdiff_t nbytes)
2480 register Lisp_Object val;
2481 val = make_uninit_multibyte_string (nchars, nbytes);
2482 memcpy (SDATA (val), contents, nbytes);
2483 if (SBYTES (val) == SCHARS (val))
2484 STRING_SET_UNIBYTE (val);
2485 return val;
2489 /* Make a string from NCHARS characters occupying NBYTES bytes at
2490 CONTENTS. The argument MULTIBYTE controls whether to label the
2491 string as multibyte. If NCHARS is negative, it counts the number of
2492 characters by itself. */
2494 Lisp_Object
2495 make_specified_string (const char *contents,
2496 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
2498 Lisp_Object val;
2500 if (nchars < 0)
2502 if (multibyte)
2503 nchars = multibyte_chars_in_text ((const unsigned char *) contents,
2504 nbytes);
2505 else
2506 nchars = nbytes;
2508 val = make_uninit_multibyte_string (nchars, nbytes);
2509 memcpy (SDATA (val), contents, nbytes);
2510 if (!multibyte)
2511 STRING_SET_UNIBYTE (val);
2512 return val;
2516 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2517 occupying LENGTH bytes. */
2519 Lisp_Object
2520 make_uninit_string (EMACS_INT length)
2522 Lisp_Object val;
2524 if (!length)
2525 return empty_unibyte_string;
2526 val = make_uninit_multibyte_string (length, length);
2527 STRING_SET_UNIBYTE (val);
2528 return val;
2532 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2533 which occupy NBYTES bytes. */
2535 Lisp_Object
2536 make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2538 Lisp_Object string;
2539 struct Lisp_String *s;
2541 if (nchars < 0)
2542 emacs_abort ();
2543 if (!nbytes)
2544 return empty_multibyte_string;
2546 s = allocate_string ();
2547 s->intervals = NULL;
2548 allocate_string_data (s, nchars, nbytes);
2549 XSETSTRING (string, s);
2550 string_chars_consed += nbytes;
2551 return string;
2554 /* Print arguments to BUF according to a FORMAT, then return
2555 a Lisp_String initialized with the data from BUF. */
2557 Lisp_Object
2558 make_formatted_string (char *buf, const char *format, ...)
2560 va_list ap;
2561 int length;
2563 va_start (ap, format);
2564 length = vsprintf (buf, format, ap);
2565 va_end (ap);
2566 return make_string (buf, length);
2570 /***********************************************************************
2571 Float Allocation
2572 ***********************************************************************/
2574 /* We store float cells inside of float_blocks, allocating a new
2575 float_block with malloc whenever necessary. Float cells reclaimed
2576 by GC are put on a free list to be reallocated before allocating
2577 any new float cells from the latest float_block. */
2579 #define FLOAT_BLOCK_SIZE \
2580 (((BLOCK_BYTES - sizeof (struct float_block *) \
2581 /* The compiler might add padding at the end. */ \
2582 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2583 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2585 #define GETMARKBIT(block,n) \
2586 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2587 >> ((n) % BITS_PER_BITS_WORD)) \
2588 & 1)
2590 #define SETMARKBIT(block,n) \
2591 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2592 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2594 #define UNSETMARKBIT(block,n) \
2595 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2596 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2598 #define FLOAT_BLOCK(fptr) \
2599 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2601 #define FLOAT_INDEX(fptr) \
2602 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2604 struct float_block
2606 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2607 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2608 bits_word gcmarkbits[1 + FLOAT_BLOCK_SIZE / BITS_PER_BITS_WORD];
2609 struct float_block *next;
2612 #define FLOAT_MARKED_P(fptr) \
2613 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2615 #define FLOAT_MARK(fptr) \
2616 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2618 #define FLOAT_UNMARK(fptr) \
2619 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2621 /* Current float_block. */
2623 static struct float_block *float_block;
2625 /* Index of first unused Lisp_Float in the current float_block. */
2627 static int float_block_index = FLOAT_BLOCK_SIZE;
2629 /* Free-list of Lisp_Floats. */
2631 static struct Lisp_Float *float_free_list;
2633 /* Return a new float object with value FLOAT_VALUE. */
2635 Lisp_Object
2636 make_float (double float_value)
2638 register Lisp_Object val;
2640 MALLOC_BLOCK_INPUT;
2642 if (float_free_list)
2644 /* We use the data field for chaining the free list
2645 so that we won't use the same field that has the mark bit. */
2646 XSETFLOAT (val, float_free_list);
2647 float_free_list = float_free_list->u.chain;
2649 else
2651 if (float_block_index == FLOAT_BLOCK_SIZE)
2653 struct float_block *new
2654 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
2655 new->next = float_block;
2656 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2657 float_block = new;
2658 float_block_index = 0;
2659 total_free_floats += FLOAT_BLOCK_SIZE;
2661 XSETFLOAT (val, &float_block->floats[float_block_index]);
2662 float_block_index++;
2665 MALLOC_UNBLOCK_INPUT;
2667 XFLOAT_INIT (val, float_value);
2668 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2669 consing_since_gc += sizeof (struct Lisp_Float);
2670 floats_consed++;
2671 total_free_floats--;
2672 return val;
2677 /***********************************************************************
2678 Cons Allocation
2679 ***********************************************************************/
2681 /* We store cons cells inside of cons_blocks, allocating a new
2682 cons_block with malloc whenever necessary. Cons cells reclaimed by
2683 GC are put on a free list to be reallocated before allocating
2684 any new cons cells from the latest cons_block. */
2686 #define CONS_BLOCK_SIZE \
2687 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2688 /* The compiler might add padding at the end. */ \
2689 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2690 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2692 #define CONS_BLOCK(fptr) \
2693 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2695 #define CONS_INDEX(fptr) \
2696 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2698 struct cons_block
2700 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2701 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2702 bits_word gcmarkbits[1 + CONS_BLOCK_SIZE / BITS_PER_BITS_WORD];
2703 struct cons_block *next;
2706 #define CONS_MARKED_P(fptr) \
2707 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2709 #define CONS_MARK(fptr) \
2710 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2712 #define CONS_UNMARK(fptr) \
2713 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2715 /* Current cons_block. */
2717 static struct cons_block *cons_block;
2719 /* Index of first unused Lisp_Cons in the current block. */
2721 static int cons_block_index = CONS_BLOCK_SIZE;
2723 /* Free-list of Lisp_Cons structures. */
2725 static struct Lisp_Cons *cons_free_list;
2727 /* Explicitly free a cons cell by putting it on the free-list. */
2729 void
2730 free_cons (struct Lisp_Cons *ptr)
2732 ptr->u.chain = cons_free_list;
2733 ptr->car = Vdead;
2734 cons_free_list = ptr;
2735 consing_since_gc -= sizeof *ptr;
2736 total_free_conses++;
2739 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2740 doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2741 (Lisp_Object car, Lisp_Object cdr)
2743 register Lisp_Object val;
2745 MALLOC_BLOCK_INPUT;
2747 if (cons_free_list)
2749 /* We use the cdr for chaining the free list
2750 so that we won't use the same field that has the mark bit. */
2751 XSETCONS (val, cons_free_list);
2752 cons_free_list = cons_free_list->u.chain;
2754 else
2756 if (cons_block_index == CONS_BLOCK_SIZE)
2758 struct cons_block *new
2759 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
2760 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2761 new->next = cons_block;
2762 cons_block = new;
2763 cons_block_index = 0;
2764 total_free_conses += CONS_BLOCK_SIZE;
2766 XSETCONS (val, &cons_block->conses[cons_block_index]);
2767 cons_block_index++;
2770 MALLOC_UNBLOCK_INPUT;
2772 XSETCAR (val, car);
2773 XSETCDR (val, cdr);
2774 eassert (!CONS_MARKED_P (XCONS (val)));
2775 consing_since_gc += sizeof (struct Lisp_Cons);
2776 total_free_conses--;
2777 cons_cells_consed++;
2778 return val;
2781 #ifdef GC_CHECK_CONS_LIST
2782 /* Get an error now if there's any junk in the cons free list. */
2783 void
2784 check_cons_list (void)
2786 struct Lisp_Cons *tail = cons_free_list;
2788 while (tail)
2789 tail = tail->u.chain;
2791 #endif
2793 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2795 Lisp_Object
2796 list1 (Lisp_Object arg1)
2798 return Fcons (arg1, Qnil);
2801 Lisp_Object
2802 list2 (Lisp_Object arg1, Lisp_Object arg2)
2804 return Fcons (arg1, Fcons (arg2, Qnil));
2808 Lisp_Object
2809 list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2811 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2815 Lisp_Object
2816 list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
2818 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2822 Lisp_Object
2823 list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
2825 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2826 Fcons (arg5, Qnil)))));
2829 /* Make a list of COUNT Lisp_Objects, where ARG is the
2830 first one. Allocate conses from pure space if TYPE
2831 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2833 Lisp_Object
2834 listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
2836 Lisp_Object (*cons) (Lisp_Object, Lisp_Object);
2837 switch (type)
2839 case CONSTYPE_PURE: cons = pure_cons; break;
2840 case CONSTYPE_HEAP: cons = Fcons; break;
2841 default: emacs_abort ();
2844 eassume (0 < count);
2845 Lisp_Object val = cons (arg, Qnil);
2846 Lisp_Object tail = val;
2848 va_list ap;
2849 va_start (ap, arg);
2850 for (ptrdiff_t i = 1; i < count; i++)
2852 Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil);
2853 XSETCDR (tail, elem);
2854 tail = elem;
2856 va_end (ap);
2858 return val;
2861 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2862 doc: /* Return a newly created list with specified arguments as elements.
2863 Any number of arguments, even zero arguments, are allowed.
2864 usage: (list &rest OBJECTS) */)
2865 (ptrdiff_t nargs, Lisp_Object *args)
2867 register Lisp_Object val;
2868 val = Qnil;
2870 while (nargs > 0)
2872 nargs--;
2873 val = Fcons (args[nargs], val);
2875 return val;
2879 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2880 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2881 (Lisp_Object length, Lisp_Object init)
2883 Lisp_Object val = Qnil;
2884 CHECK_NATNUM (length);
2886 for (EMACS_INT size = XFASTINT (length); 0 < size; size--)
2888 val = Fcons (init, val);
2889 rarely_quit (size);
2892 return val;
2897 /***********************************************************************
2898 Vector Allocation
2899 ***********************************************************************/
2901 /* Sometimes a vector's contents are merely a pointer internally used
2902 in vector allocation code. On the rare platforms where a null
2903 pointer cannot be tagged, represent it with a Lisp 0.
2904 Usually you don't want to touch this. */
2906 static struct Lisp_Vector *
2907 next_vector (struct Lisp_Vector *v)
2909 return XUNTAG (v->contents[0], Lisp_Int0);
2912 static void
2913 set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
2915 v->contents[0] = make_lisp_ptr (p, Lisp_Int0);
2918 /* This value is balanced well enough to avoid too much internal overhead
2919 for the most common cases; it's not required to be a power of two, but
2920 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2922 #define VECTOR_BLOCK_SIZE 4096
2924 enum
2926 /* Alignment of struct Lisp_Vector objects. */
2927 vector_alignment = COMMON_MULTIPLE (FLEXALIGNOF (struct Lisp_Vector),
2928 GCALIGNMENT),
2930 /* Vector size requests are a multiple of this. */
2931 roundup_size = COMMON_MULTIPLE (vector_alignment, word_size)
2934 /* Verify assumptions described above. */
2935 verify (VECTOR_BLOCK_SIZE % roundup_size == 0);
2936 verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
2938 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2939 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2940 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2941 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2943 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2945 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2947 /* Size of the minimal vector allocated from block. */
2949 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2951 /* Size of the largest vector allocated from block. */
2953 #define VBLOCK_BYTES_MAX \
2954 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2956 /* We maintain one free list for each possible block-allocated
2957 vector size, and this is the number of free lists we have. */
2959 #define VECTOR_MAX_FREE_LIST_INDEX \
2960 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2962 /* Common shortcut to advance vector pointer over a block data. */
2964 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2966 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2968 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2970 /* Common shortcut to setup vector on a free list. */
2972 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2973 do { \
2974 (tmp) = ((nbytes - header_size) / word_size); \
2975 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2976 eassert ((nbytes) % roundup_size == 0); \
2977 (tmp) = VINDEX (nbytes); \
2978 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2979 set_next_vector (v, vector_free_lists[tmp]); \
2980 vector_free_lists[tmp] = (v); \
2981 total_free_vector_slots += (nbytes) / word_size; \
2982 } while (0)
2984 /* This internal type is used to maintain the list of large vectors
2985 which are allocated at their own, e.g. outside of vector blocks.
2987 struct large_vector itself cannot contain a struct Lisp_Vector, as
2988 the latter contains a flexible array member and C99 does not allow
2989 such structs to be nested. Instead, each struct large_vector
2990 object LV is followed by a struct Lisp_Vector, which is at offset
2991 large_vector_offset from LV, and whose address is therefore
2992 large_vector_vec (&LV). */
2994 struct large_vector
2996 struct large_vector *next;
2999 enum
3001 large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment)
3004 static struct Lisp_Vector *
3005 large_vector_vec (struct large_vector *p)
3007 return (struct Lisp_Vector *) ((char *) p + large_vector_offset);
3010 /* This internal type is used to maintain an underlying storage
3011 for small vectors. */
3013 struct vector_block
3015 char data[VECTOR_BLOCK_BYTES];
3016 struct vector_block *next;
3019 /* Chain of vector blocks. */
3021 static struct vector_block *vector_blocks;
3023 /* Vector free lists, where NTH item points to a chain of free
3024 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
3026 static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
3028 /* Singly-linked list of large vectors. */
3030 static struct large_vector *large_vectors;
3032 /* The only vector with 0 slots, allocated from pure space. */
3034 Lisp_Object zero_vector;
3036 /* Number of live vectors. */
3038 static EMACS_INT total_vectors;
3040 /* Total size of live and free vectors, in Lisp_Object units. */
3042 static EMACS_INT total_vector_slots, total_free_vector_slots;
3044 /* Get a new vector block. */
3046 static struct vector_block *
3047 allocate_vector_block (void)
3049 struct vector_block *block = xmalloc (sizeof *block);
3051 #ifndef GC_MALLOC_CHECK
3052 mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
3053 MEM_TYPE_VECTOR_BLOCK);
3054 #endif
3056 block->next = vector_blocks;
3057 vector_blocks = block;
3058 return block;
3061 /* Called once to initialize vector allocation. */
3063 static void
3064 init_vectors (void)
3066 zero_vector = make_pure_vector (0);
3069 /* Allocate vector from a vector block. */
3071 static struct Lisp_Vector *
3072 allocate_vector_from_block (size_t nbytes)
3074 struct Lisp_Vector *vector;
3075 struct vector_block *block;
3076 size_t index, restbytes;
3078 eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
3079 eassert (nbytes % roundup_size == 0);
3081 /* First, try to allocate from a free list
3082 containing vectors of the requested size. */
3083 index = VINDEX (nbytes);
3084 if (vector_free_lists[index])
3086 vector = vector_free_lists[index];
3087 vector_free_lists[index] = next_vector (vector);
3088 total_free_vector_slots -= nbytes / word_size;
3089 return vector;
3092 /* Next, check free lists containing larger vectors. Since
3093 we will split the result, we should have remaining space
3094 large enough to use for one-slot vector at least. */
3095 for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
3096 index < VECTOR_MAX_FREE_LIST_INDEX; index++)
3097 if (vector_free_lists[index])
3099 /* This vector is larger than requested. */
3100 vector = vector_free_lists[index];
3101 vector_free_lists[index] = next_vector (vector);
3102 total_free_vector_slots -= nbytes / word_size;
3104 /* Excess bytes are used for the smaller vector,
3105 which should be set on an appropriate free list. */
3106 restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
3107 eassert (restbytes % roundup_size == 0);
3108 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
3109 return vector;
3112 /* Finally, need a new vector block. */
3113 block = allocate_vector_block ();
3115 /* New vector will be at the beginning of this block. */
3116 vector = (struct Lisp_Vector *) block->data;
3118 /* If the rest of space from this block is large enough
3119 for one-slot vector at least, set up it on a free list. */
3120 restbytes = VECTOR_BLOCK_BYTES - nbytes;
3121 if (restbytes >= VBLOCK_BYTES_MIN)
3123 eassert (restbytes % roundup_size == 0);
3124 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
3126 return vector;
3129 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3131 #define VECTOR_IN_BLOCK(vector, block) \
3132 ((char *) (vector) <= (block)->data \
3133 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3135 /* Return the memory footprint of V in bytes. */
3137 static ptrdiff_t
3138 vector_nbytes (struct Lisp_Vector *v)
3140 ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
3141 ptrdiff_t nwords;
3143 if (size & PSEUDOVECTOR_FLAG)
3145 if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
3147 struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
3148 ptrdiff_t word_bytes = (bool_vector_words (bv->size)
3149 * sizeof (bits_word));
3150 ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
3151 verify (header_size <= bool_header_size);
3152 nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
3154 else
3155 nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
3156 + ((size & PSEUDOVECTOR_REST_MASK)
3157 >> PSEUDOVECTOR_SIZE_BITS));
3159 else
3160 nwords = size;
3161 return vroundup (header_size + word_size * nwords);
3164 /* Release extra resources still in use by VECTOR, which may be any
3165 vector-like object. */
3167 static void
3168 cleanup_vector (struct Lisp_Vector *vector)
3170 detect_suspicious_free (vector);
3171 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)
3172 && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
3173 == FONT_OBJECT_MAX))
3175 struct font_driver const *drv = ((struct font *) vector)->driver;
3177 /* The font driver might sometimes be NULL, e.g. if Emacs was
3178 interrupted before it had time to set it up. */
3179 if (drv)
3181 /* Attempt to catch subtle bugs like Bug#16140. */
3182 eassert (valid_font_driver (drv));
3183 drv->close ((struct font *) vector);
3187 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
3188 finalize_one_thread ((struct thread_state *) vector);
3189 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
3190 finalize_one_mutex ((struct Lisp_Mutex *) vector);
3191 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
3192 finalize_one_condvar ((struct Lisp_CondVar *) vector);
3195 /* Reclaim space used by unmarked vectors. */
3197 NO_INLINE /* For better stack traces */
3198 static void
3199 sweep_vectors (void)
3201 struct vector_block *block, **bprev = &vector_blocks;
3202 struct large_vector *lv, **lvprev = &large_vectors;
3203 struct Lisp_Vector *vector, *next;
3205 total_vectors = total_vector_slots = total_free_vector_slots = 0;
3206 memset (vector_free_lists, 0, sizeof (vector_free_lists));
3208 /* Looking through vector blocks. */
3210 for (block = vector_blocks; block; block = *bprev)
3212 bool free_this_block = 0;
3213 ptrdiff_t nbytes;
3215 for (vector = (struct Lisp_Vector *) block->data;
3216 VECTOR_IN_BLOCK (vector, block); vector = next)
3218 if (VECTOR_MARKED_P (vector))
3220 VECTOR_UNMARK (vector);
3221 total_vectors++;
3222 nbytes = vector_nbytes (vector);
3223 total_vector_slots += nbytes / word_size;
3224 next = ADVANCE (vector, nbytes);
3226 else
3228 ptrdiff_t total_bytes;
3230 cleanup_vector (vector);
3231 nbytes = vector_nbytes (vector);
3232 total_bytes = nbytes;
3233 next = ADVANCE (vector, nbytes);
3235 /* While NEXT is not marked, try to coalesce with VECTOR,
3236 thus making VECTOR of the largest possible size. */
3238 while (VECTOR_IN_BLOCK (next, block))
3240 if (VECTOR_MARKED_P (next))
3241 break;
3242 cleanup_vector (next);
3243 nbytes = vector_nbytes (next);
3244 total_bytes += nbytes;
3245 next = ADVANCE (next, nbytes);
3248 eassert (total_bytes % roundup_size == 0);
3250 if (vector == (struct Lisp_Vector *) block->data
3251 && !VECTOR_IN_BLOCK (next, block))
3252 /* This block should be freed because all of its
3253 space was coalesced into the only free vector. */
3254 free_this_block = 1;
3255 else
3257 size_t tmp;
3258 SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
3263 if (free_this_block)
3265 *bprev = block->next;
3266 #ifndef GC_MALLOC_CHECK
3267 mem_delete (mem_find (block->data));
3268 #endif
3269 xfree (block);
3271 else
3272 bprev = &block->next;
3275 /* Sweep large vectors. */
3277 for (lv = large_vectors; lv; lv = *lvprev)
3279 vector = large_vector_vec (lv);
3280 if (VECTOR_MARKED_P (vector))
3282 VECTOR_UNMARK (vector);
3283 total_vectors++;
3284 if (vector->header.size & PSEUDOVECTOR_FLAG)
3285 total_vector_slots += vector_nbytes (vector) / word_size;
3286 else
3287 total_vector_slots
3288 += header_size / word_size + vector->header.size;
3289 lvprev = &lv->next;
3291 else
3293 *lvprev = lv->next;
3294 lisp_free (lv);
3299 /* Value is a pointer to a newly allocated Lisp_Vector structure
3300 with room for LEN Lisp_Objects. */
3302 static struct Lisp_Vector *
3303 allocate_vectorlike (ptrdiff_t len)
3305 struct Lisp_Vector *p;
3307 MALLOC_BLOCK_INPUT;
3309 if (len == 0)
3310 p = XVECTOR (zero_vector);
3311 else
3313 size_t nbytes = header_size + len * word_size;
3315 #ifdef DOUG_LEA_MALLOC
3316 if (!mmap_lisp_allowed_p ())
3317 mallopt (M_MMAP_MAX, 0);
3318 #endif
3320 if (nbytes <= VBLOCK_BYTES_MAX)
3321 p = allocate_vector_from_block (vroundup (nbytes));
3322 else
3324 struct large_vector *lv
3325 = lisp_malloc ((large_vector_offset + header_size
3326 + len * word_size),
3327 MEM_TYPE_VECTORLIKE);
3328 lv->next = large_vectors;
3329 large_vectors = lv;
3330 p = large_vector_vec (lv);
3333 #ifdef DOUG_LEA_MALLOC
3334 if (!mmap_lisp_allowed_p ())
3335 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
3336 #endif
3338 if (find_suspicious_object_in_range (p, (char *) p + nbytes))
3339 emacs_abort ();
3341 consing_since_gc += nbytes;
3342 vector_cells_consed += len;
3345 MALLOC_UNBLOCK_INPUT;
3347 return p;
3351 /* Allocate a vector with LEN slots. */
3353 struct Lisp_Vector *
3354 allocate_vector (EMACS_INT len)
3356 struct Lisp_Vector *v;
3357 ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX);
3359 if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
3360 memory_full (SIZE_MAX);
3361 v = allocate_vectorlike (len);
3362 if (len)
3363 v->header.size = len;
3364 return v;
3368 /* Allocate other vector-like structures. */
3370 struct Lisp_Vector *
3371 allocate_pseudovector (int memlen, int lisplen,
3372 int zerolen, enum pvec_type tag)
3374 struct Lisp_Vector *v = allocate_vectorlike (memlen);
3376 /* Catch bogus values. */
3377 eassert (0 <= tag && tag <= PVEC_FONT);
3378 eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
3379 eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1);
3380 eassert (lisplen <= PSEUDOVECTOR_SIZE_MASK);
3382 /* Only the first LISPLEN slots will be traced normally by the GC. */
3383 memclear (v->contents, zerolen * word_size);
3384 XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
3385 return v;
3388 struct buffer *
3389 allocate_buffer (void)
3391 struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER);
3393 BUFFER_PVEC_INIT (b);
3394 /* Put B on the chain of all buffers including killed ones. */
3395 b->next = all_buffers;
3396 all_buffers = b;
3397 /* Note that the rest fields of B are not initialized. */
3398 return b;
3402 /* Allocate a record with COUNT slots. COUNT must be positive, and
3403 includes the type slot. */
3405 static struct Lisp_Vector *
3406 allocate_record (EMACS_INT count)
3408 if (count > PSEUDOVECTOR_SIZE_MASK)
3409 error ("Attempt to allocate a record of %"pI"d slots; max is %d",
3410 count, PSEUDOVECTOR_SIZE_MASK);
3411 struct Lisp_Vector *p = allocate_vectorlike (count);
3412 p->header.size = count;
3413 XSETPVECTYPE (p, PVEC_RECORD);
3414 return p;
3418 DEFUN ("make-record", Fmake_record, Smake_record, 3, 3, 0,
3419 doc: /* Create a new record.
3420 TYPE is its type as returned by `type-of'; it should be either a
3421 symbol or a type descriptor. SLOTS is the number of non-type slots,
3422 each initialized to INIT. */)
3423 (Lisp_Object type, Lisp_Object slots, Lisp_Object init)
3425 CHECK_NATNUM (slots);
3426 EMACS_INT size = XFASTINT (slots) + 1;
3427 struct Lisp_Vector *p = allocate_record (size);
3428 p->contents[0] = type;
3429 for (ptrdiff_t i = 1; i < size; i++)
3430 p->contents[i] = init;
3431 return make_lisp_ptr (p, Lisp_Vectorlike);
3435 DEFUN ("record", Frecord, Srecord, 1, MANY, 0,
3436 doc: /* Create a new record.
3437 TYPE is its type as returned by `type-of'; it should be either a
3438 symbol or a type descriptor. SLOTS is used to initialize the record
3439 slots with shallow copies of the arguments.
3440 usage: (record TYPE &rest SLOTS) */)
3441 (ptrdiff_t nargs, Lisp_Object *args)
3443 struct Lisp_Vector *p = allocate_record (nargs);
3444 memcpy (p->contents, args, nargs * sizeof *args);
3445 return make_lisp_ptr (p, Lisp_Vectorlike);
3449 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3450 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
3451 See also the function `vector'. */)
3452 (Lisp_Object length, Lisp_Object init)
3454 CHECK_NATNUM (length);
3455 struct Lisp_Vector *p = allocate_vector (XFASTINT (length));
3456 for (ptrdiff_t i = 0; i < XFASTINT (length); i++)
3457 p->contents[i] = init;
3458 return make_lisp_ptr (p, Lisp_Vectorlike);
3461 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3462 doc: /* Return a newly created vector with specified arguments as elements.
3463 Any number of arguments, even zero arguments, are allowed.
3464 usage: (vector &rest OBJECTS) */)
3465 (ptrdiff_t nargs, Lisp_Object *args)
3467 Lisp_Object val = make_uninit_vector (nargs);
3468 struct Lisp_Vector *p = XVECTOR (val);
3469 memcpy (p->contents, args, nargs * sizeof *args);
3470 return val;
3473 void
3474 make_byte_code (struct Lisp_Vector *v)
3476 /* Don't allow the global zero_vector to become a byte code object. */
3477 eassert (0 < v->header.size);
3479 if (v->header.size > 1 && STRINGP (v->contents[1])
3480 && STRING_MULTIBYTE (v->contents[1]))
3481 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3482 earlier because they produced a raw 8-bit string for byte-code
3483 and now such a byte-code string is loaded as multibyte while
3484 raw 8-bit characters converted to multibyte form. Thus, now we
3485 must convert them back to the original unibyte form. */
3486 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3487 XSETPVECTYPE (v, PVEC_COMPILED);
3490 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3491 doc: /* Create a byte-code object with specified arguments as elements.
3492 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3493 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3494 and (optional) INTERACTIVE-SPEC.
3495 The first four arguments are required; at most six have any
3496 significance.
3497 The ARGLIST can be either like the one of `lambda', in which case the arguments
3498 will be dynamically bound before executing the byte code, or it can be an
3499 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3500 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3501 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3502 argument to catch the left-over arguments. If such an integer is used, the
3503 arguments will not be dynamically bound but will be instead pushed on the
3504 stack before executing the byte-code.
3505 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3506 (ptrdiff_t nargs, Lisp_Object *args)
3508 Lisp_Object val = make_uninit_vector (nargs);
3509 struct Lisp_Vector *p = XVECTOR (val);
3511 /* We used to purecopy everything here, if purify-flag was set. This worked
3512 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3513 dangerous, since make-byte-code is used during execution to build
3514 closures, so any closure built during the preload phase would end up
3515 copied into pure space, including its free variables, which is sometimes
3516 just wasteful and other times plainly wrong (e.g. those free vars may want
3517 to be setcar'd). */
3519 memcpy (p->contents, args, nargs * sizeof *args);
3520 make_byte_code (p);
3521 XSETCOMPILED (val, p);
3522 return val;
3527 /***********************************************************************
3528 Symbol Allocation
3529 ***********************************************************************/
3531 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3532 of the required alignment. */
3534 union aligned_Lisp_Symbol
3536 struct Lisp_Symbol s;
3537 unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
3538 & -GCALIGNMENT];
3541 /* Each symbol_block is just under 1020 bytes long, since malloc
3542 really allocates in units of powers of two and uses 4 bytes for its
3543 own overhead. */
3545 #define SYMBOL_BLOCK_SIZE \
3546 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3548 struct symbol_block
3550 /* Place `symbols' first, to preserve alignment. */
3551 union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3552 struct symbol_block *next;
3555 /* Current symbol block and index of first unused Lisp_Symbol
3556 structure in it. */
3558 static struct symbol_block *symbol_block;
3559 static int symbol_block_index = SYMBOL_BLOCK_SIZE;
3560 /* Pointer to the first symbol_block that contains pinned symbols.
3561 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3562 10K of which are pinned (and all but 250 of them are interned in obarray),
3563 whereas a "typical session" has in the order of 30K symbols.
3564 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3565 than 30K to find the 10K symbols we need to mark. */
3566 static struct symbol_block *symbol_block_pinned;
3568 /* List of free symbols. */
3570 static struct Lisp_Symbol *symbol_free_list;
3572 static void
3573 set_symbol_name (Lisp_Object sym, Lisp_Object name)
3575 XSYMBOL (sym)->name = name;
3578 void
3579 init_symbol (Lisp_Object val, Lisp_Object name)
3581 struct Lisp_Symbol *p = XSYMBOL (val);
3582 set_symbol_name (val, name);
3583 set_symbol_plist (val, Qnil);
3584 p->redirect = SYMBOL_PLAINVAL;
3585 SET_SYMBOL_VAL (p, Qunbound);
3586 set_symbol_function (val, Qnil);
3587 set_symbol_next (val, NULL);
3588 p->gcmarkbit = false;
3589 p->interned = SYMBOL_UNINTERNED;
3590 p->trapped_write = SYMBOL_UNTRAPPED_WRITE;
3591 p->declared_special = false;
3592 p->pinned = false;
3595 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3596 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3597 Its value is void, and its function definition and property list are nil. */)
3598 (Lisp_Object name)
3600 Lisp_Object val;
3602 CHECK_STRING (name);
3604 MALLOC_BLOCK_INPUT;
3606 if (symbol_free_list)
3608 XSETSYMBOL (val, symbol_free_list);
3609 symbol_free_list = symbol_free_list->next;
3611 else
3613 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3615 struct symbol_block *new
3616 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL);
3617 new->next = symbol_block;
3618 symbol_block = new;
3619 symbol_block_index = 0;
3620 total_free_symbols += SYMBOL_BLOCK_SIZE;
3622 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
3623 symbol_block_index++;
3626 MALLOC_UNBLOCK_INPUT;
3628 init_symbol (val, name);
3629 consing_since_gc += sizeof (struct Lisp_Symbol);
3630 symbols_consed++;
3631 total_free_symbols--;
3632 return val;
3637 /***********************************************************************
3638 Marker (Misc) Allocation
3639 ***********************************************************************/
3641 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3642 the required alignment. */
3644 union aligned_Lisp_Misc
3646 union Lisp_Misc m;
3647 unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
3648 & -GCALIGNMENT];
3651 /* Allocation of markers and other objects that share that structure.
3652 Works like allocation of conses. */
3654 #define MARKER_BLOCK_SIZE \
3655 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3657 struct marker_block
3659 /* Place `markers' first, to preserve alignment. */
3660 union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
3661 struct marker_block *next;
3664 static struct marker_block *marker_block;
3665 static int marker_block_index = MARKER_BLOCK_SIZE;
3667 static union Lisp_Misc *marker_free_list;
3669 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3671 static Lisp_Object
3672 allocate_misc (enum Lisp_Misc_Type type)
3674 Lisp_Object val;
3676 MALLOC_BLOCK_INPUT;
3678 if (marker_free_list)
3680 XSETMISC (val, marker_free_list);
3681 marker_free_list = marker_free_list->u_free.chain;
3683 else
3685 if (marker_block_index == MARKER_BLOCK_SIZE)
3687 struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
3688 new->next = marker_block;
3689 marker_block = new;
3690 marker_block_index = 0;
3691 total_free_markers += MARKER_BLOCK_SIZE;
3693 XSETMISC (val, &marker_block->markers[marker_block_index].m);
3694 marker_block_index++;
3697 MALLOC_UNBLOCK_INPUT;
3699 --total_free_markers;
3700 consing_since_gc += sizeof (union Lisp_Misc);
3701 misc_objects_consed++;
3702 XMISCANY (val)->type = type;
3703 XMISCANY (val)->gcmarkbit = 0;
3704 return val;
3707 /* Free a Lisp_Misc object. */
3709 void
3710 free_misc (Lisp_Object misc)
3712 XMISCANY (misc)->type = Lisp_Misc_Free;
3713 XMISC (misc)->u_free.chain = marker_free_list;
3714 marker_free_list = XMISC (misc);
3715 consing_since_gc -= sizeof (union Lisp_Misc);
3716 total_free_markers++;
3719 /* Verify properties of Lisp_Save_Value's representation
3720 that are assumed here and elsewhere. */
3722 verify (SAVE_UNUSED == 0);
3723 verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT)
3724 >> SAVE_SLOT_BITS)
3725 == 0);
3727 /* Return Lisp_Save_Value objects for the various combinations
3728 that callers need. */
3730 Lisp_Object
3731 make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c)
3733 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3734 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3735 p->save_type = SAVE_TYPE_INT_INT_INT;
3736 p->data[0].integer = a;
3737 p->data[1].integer = b;
3738 p->data[2].integer = c;
3739 return val;
3742 Lisp_Object
3743 make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c,
3744 Lisp_Object d)
3746 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3747 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3748 p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ;
3749 p->data[0].object = a;
3750 p->data[1].object = b;
3751 p->data[2].object = c;
3752 p->data[3].object = d;
3753 return val;
3756 Lisp_Object
3757 make_save_ptr (void *a)
3759 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3760 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3761 p->save_type = SAVE_POINTER;
3762 p->data[0].pointer = a;
3763 return val;
3766 Lisp_Object
3767 make_save_ptr_int (void *a, ptrdiff_t b)
3769 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3770 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3771 p->save_type = SAVE_TYPE_PTR_INT;
3772 p->data[0].pointer = a;
3773 p->data[1].integer = b;
3774 return val;
3777 Lisp_Object
3778 make_save_ptr_ptr (void *a, void *b)
3780 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3781 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3782 p->save_type = SAVE_TYPE_PTR_PTR;
3783 p->data[0].pointer = a;
3784 p->data[1].pointer = b;
3785 return val;
3788 Lisp_Object
3789 make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c)
3791 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3792 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3793 p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ;
3794 p->data[0].funcpointer = a;
3795 p->data[1].pointer = b;
3796 p->data[2].object = c;
3797 return val;
3800 /* Return a Lisp_Save_Value object that represents an array A
3801 of N Lisp objects. */
3803 Lisp_Object
3804 make_save_memory (Lisp_Object *a, ptrdiff_t n)
3806 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3807 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3808 p->save_type = SAVE_TYPE_MEMORY;
3809 p->data[0].pointer = a;
3810 p->data[1].integer = n;
3811 return val;
3814 /* Free a Lisp_Save_Value object. Do not use this function
3815 if SAVE contains pointer other than returned by xmalloc. */
3817 void
3818 free_save_value (Lisp_Object save)
3820 xfree (XSAVE_POINTER (save, 0));
3821 free_misc (save);
3824 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3826 Lisp_Object
3827 build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
3829 register Lisp_Object overlay;
3831 overlay = allocate_misc (Lisp_Misc_Overlay);
3832 OVERLAY_START (overlay) = start;
3833 OVERLAY_END (overlay) = end;
3834 set_overlay_plist (overlay, plist);
3835 XOVERLAY (overlay)->next = NULL;
3836 return overlay;
3839 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3840 doc: /* Return a newly allocated marker which does not point at any place. */)
3841 (void)
3843 register Lisp_Object val;
3844 register struct Lisp_Marker *p;
3846 val = allocate_misc (Lisp_Misc_Marker);
3847 p = XMARKER (val);
3848 p->buffer = 0;
3849 p->bytepos = 0;
3850 p->charpos = 0;
3851 p->next = NULL;
3852 p->insertion_type = 0;
3853 p->need_adjustment = 0;
3854 return val;
3857 /* Return a newly allocated marker which points into BUF
3858 at character position CHARPOS and byte position BYTEPOS. */
3860 Lisp_Object
3861 build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3863 Lisp_Object obj;
3864 struct Lisp_Marker *m;
3866 /* No dead buffers here. */
3867 eassert (BUFFER_LIVE_P (buf));
3869 /* Every character is at least one byte. */
3870 eassert (charpos <= bytepos);
3872 obj = allocate_misc (Lisp_Misc_Marker);
3873 m = XMARKER (obj);
3874 m->buffer = buf;
3875 m->charpos = charpos;
3876 m->bytepos = bytepos;
3877 m->insertion_type = 0;
3878 m->need_adjustment = 0;
3879 m->next = BUF_MARKERS (buf);
3880 BUF_MARKERS (buf) = m;
3881 return obj;
3884 /* Put MARKER back on the free list after using it temporarily. */
3886 void
3887 free_marker (Lisp_Object marker)
3889 unchain_marker (XMARKER (marker));
3890 free_misc (marker);
3894 /* Return a newly created vector or string with specified arguments as
3895 elements. If all the arguments are characters that can fit
3896 in a string of events, make a string; otherwise, make a vector.
3898 Any number of arguments, even zero arguments, are allowed. */
3900 Lisp_Object
3901 make_event_array (ptrdiff_t nargs, Lisp_Object *args)
3903 ptrdiff_t i;
3905 for (i = 0; i < nargs; i++)
3906 /* The things that fit in a string
3907 are characters that are in 0...127,
3908 after discarding the meta bit and all the bits above it. */
3909 if (!INTEGERP (args[i])
3910 || (XINT (args[i]) & ~(-CHAR_META)) >= 0200)
3911 return Fvector (nargs, args);
3913 /* Since the loop exited, we know that all the things in it are
3914 characters, so we can make a string. */
3916 Lisp_Object result;
3918 result = Fmake_string (make_number (nargs), make_number (0));
3919 for (i = 0; i < nargs; i++)
3921 SSET (result, i, XINT (args[i]));
3922 /* Move the meta bit to the right place for a string char. */
3923 if (XINT (args[i]) & CHAR_META)
3924 SSET (result, i, SREF (result, i) | 0x80);
3927 return result;
3931 #ifdef HAVE_MODULES
3932 /* Create a new module user ptr object. */
3933 Lisp_Object
3934 make_user_ptr (void (*finalizer) (void *), void *p)
3936 Lisp_Object obj;
3937 struct Lisp_User_Ptr *uptr;
3939 obj = allocate_misc (Lisp_Misc_User_Ptr);
3940 uptr = XUSER_PTR (obj);
3941 uptr->finalizer = finalizer;
3942 uptr->p = p;
3943 return obj;
3945 #endif
3947 static void
3948 init_finalizer_list (struct Lisp_Finalizer *head)
3950 head->prev = head->next = head;
3953 /* Insert FINALIZER before ELEMENT. */
3955 static void
3956 finalizer_insert (struct Lisp_Finalizer *element,
3957 struct Lisp_Finalizer *finalizer)
3959 eassert (finalizer->prev == NULL);
3960 eassert (finalizer->next == NULL);
3961 finalizer->next = element;
3962 finalizer->prev = element->prev;
3963 finalizer->prev->next = finalizer;
3964 element->prev = finalizer;
3967 static void
3968 unchain_finalizer (struct Lisp_Finalizer *finalizer)
3970 if (finalizer->prev != NULL)
3972 eassert (finalizer->next != NULL);
3973 finalizer->prev->next = finalizer->next;
3974 finalizer->next->prev = finalizer->prev;
3975 finalizer->prev = finalizer->next = NULL;
3979 static void
3980 mark_finalizer_list (struct Lisp_Finalizer *head)
3982 for (struct Lisp_Finalizer *finalizer = head->next;
3983 finalizer != head;
3984 finalizer = finalizer->next)
3986 finalizer->base.gcmarkbit = true;
3987 mark_object (finalizer->function);
3991 /* Move doomed finalizers to list DEST from list SRC. A doomed
3992 finalizer is one that is not GC-reachable and whose
3993 finalizer->function is non-nil. */
3995 static void
3996 queue_doomed_finalizers (struct Lisp_Finalizer *dest,
3997 struct Lisp_Finalizer *src)
3999 struct Lisp_Finalizer *finalizer = src->next;
4000 while (finalizer != src)
4002 struct Lisp_Finalizer *next = finalizer->next;
4003 if (!finalizer->base.gcmarkbit && !NILP (finalizer->function))
4005 unchain_finalizer (finalizer);
4006 finalizer_insert (dest, finalizer);
4009 finalizer = next;
4013 static Lisp_Object
4014 run_finalizer_handler (Lisp_Object args)
4016 add_to_log ("finalizer failed: %S", args);
4017 return Qnil;
4020 static void
4021 run_finalizer_function (Lisp_Object function)
4023 ptrdiff_t count = SPECPDL_INDEX ();
4025 specbind (Qinhibit_quit, Qt);
4026 internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
4027 unbind_to (count, Qnil);
4030 static void
4031 run_finalizers (struct Lisp_Finalizer *finalizers)
4033 struct Lisp_Finalizer *finalizer;
4034 Lisp_Object function;
4036 while (finalizers->next != finalizers)
4038 finalizer = finalizers->next;
4039 eassert (finalizer->base.type == Lisp_Misc_Finalizer);
4040 unchain_finalizer (finalizer);
4041 function = finalizer->function;
4042 if (!NILP (function))
4044 finalizer->function = Qnil;
4045 run_finalizer_function (function);
4050 DEFUN ("make-finalizer", Fmake_finalizer, Smake_finalizer, 1, 1, 0,
4051 doc: /* Make a finalizer that will run FUNCTION.
4052 FUNCTION will be called after garbage collection when the returned
4053 finalizer object becomes unreachable. If the finalizer object is
4054 reachable only through references from finalizer objects, it does not
4055 count as reachable for the purpose of deciding whether to run
4056 FUNCTION. FUNCTION will be run once per finalizer object. */)
4057 (Lisp_Object function)
4059 Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer);
4060 struct Lisp_Finalizer *finalizer = XFINALIZER (val);
4061 finalizer->function = function;
4062 finalizer->prev = finalizer->next = NULL;
4063 finalizer_insert (&finalizers, finalizer);
4064 return val;
4068 /************************************************************************
4069 Memory Full Handling
4070 ************************************************************************/
4073 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
4074 there may have been size_t overflow so that malloc was never
4075 called, or perhaps malloc was invoked successfully but the
4076 resulting pointer had problems fitting into a tagged EMACS_INT. In
4077 either case this counts as memory being full even though malloc did
4078 not fail. */
4080 void
4081 memory_full (size_t nbytes)
4083 /* Do not go into hysterics merely because a large request failed. */
4084 bool enough_free_memory = 0;
4085 if (SPARE_MEMORY < nbytes)
4087 void *p;
4089 MALLOC_BLOCK_INPUT;
4090 p = malloc (SPARE_MEMORY);
4091 if (p)
4093 free (p);
4094 enough_free_memory = 1;
4096 MALLOC_UNBLOCK_INPUT;
4099 if (! enough_free_memory)
4101 int i;
4103 Vmemory_full = Qt;
4105 memory_full_cons_threshold = sizeof (struct cons_block);
4107 /* The first time we get here, free the spare memory. */
4108 for (i = 0; i < ARRAYELTS (spare_memory); i++)
4109 if (spare_memory[i])
4111 if (i == 0)
4112 free (spare_memory[i]);
4113 else if (i >= 1 && i <= 4)
4114 lisp_align_free (spare_memory[i]);
4115 else
4116 lisp_free (spare_memory[i]);
4117 spare_memory[i] = 0;
4121 /* This used to call error, but if we've run out of memory, we could
4122 get infinite recursion trying to build the string. */
4123 xsignal (Qnil, Vmemory_signal_data);
4126 /* If we released our reserve (due to running out of memory),
4127 and we have a fair amount free once again,
4128 try to set aside another reserve in case we run out once more.
4130 This is called when a relocatable block is freed in ralloc.c,
4131 and also directly from this file, in case we're not using ralloc.c. */
4133 void
4134 refill_memory_reserve (void)
4136 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4137 if (spare_memory[0] == 0)
4138 spare_memory[0] = malloc (SPARE_MEMORY);
4139 if (spare_memory[1] == 0)
4140 spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
4141 MEM_TYPE_SPARE);
4142 if (spare_memory[2] == 0)
4143 spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
4144 MEM_TYPE_SPARE);
4145 if (spare_memory[3] == 0)
4146 spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
4147 MEM_TYPE_SPARE);
4148 if (spare_memory[4] == 0)
4149 spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
4150 MEM_TYPE_SPARE);
4151 if (spare_memory[5] == 0)
4152 spare_memory[5] = lisp_malloc (sizeof (struct string_block),
4153 MEM_TYPE_SPARE);
4154 if (spare_memory[6] == 0)
4155 spare_memory[6] = lisp_malloc (sizeof (struct string_block),
4156 MEM_TYPE_SPARE);
4157 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
4158 Vmemory_full = Qnil;
4159 #endif
4162 /************************************************************************
4163 C Stack Marking
4164 ************************************************************************/
4166 /* Conservative C stack marking requires a method to identify possibly
4167 live Lisp objects given a pointer value. We do this by keeping
4168 track of blocks of Lisp data that are allocated in a red-black tree
4169 (see also the comment of mem_node which is the type of nodes in
4170 that tree). Function lisp_malloc adds information for an allocated
4171 block to the red-black tree with calls to mem_insert, and function
4172 lisp_free removes it with mem_delete. Functions live_string_p etc
4173 call mem_find to lookup information about a given pointer in the
4174 tree, and use that to determine if the pointer points to a Lisp
4175 object or not. */
4177 /* Initialize this part of alloc.c. */
4179 static void
4180 mem_init (void)
4182 mem_z.left = mem_z.right = MEM_NIL;
4183 mem_z.parent = NULL;
4184 mem_z.color = MEM_BLACK;
4185 mem_z.start = mem_z.end = NULL;
4186 mem_root = MEM_NIL;
4190 /* Value is a pointer to the mem_node containing START. Value is
4191 MEM_NIL if there is no node in the tree containing START. */
4193 static struct mem_node *
4194 mem_find (void *start)
4196 struct mem_node *p;
4198 if (start < min_heap_address || start > max_heap_address)
4199 return MEM_NIL;
4201 /* Make the search always successful to speed up the loop below. */
4202 mem_z.start = start;
4203 mem_z.end = (char *) start + 1;
4205 p = mem_root;
4206 while (start < p->start || start >= p->end)
4207 p = start < p->start ? p->left : p->right;
4208 return p;
4212 /* Insert a new node into the tree for a block of memory with start
4213 address START, end address END, and type TYPE. Value is a
4214 pointer to the node that was inserted. */
4216 static struct mem_node *
4217 mem_insert (void *start, void *end, enum mem_type type)
4219 struct mem_node *c, *parent, *x;
4221 if (min_heap_address == NULL || start < min_heap_address)
4222 min_heap_address = start;
4223 if (max_heap_address == NULL || end > max_heap_address)
4224 max_heap_address = end;
4226 /* See where in the tree a node for START belongs. In this
4227 particular application, it shouldn't happen that a node is already
4228 present. For debugging purposes, let's check that. */
4229 c = mem_root;
4230 parent = NULL;
4232 while (c != MEM_NIL)
4234 parent = c;
4235 c = start < c->start ? c->left : c->right;
4238 /* Create a new node. */
4239 #ifdef GC_MALLOC_CHECK
4240 x = malloc (sizeof *x);
4241 if (x == NULL)
4242 emacs_abort ();
4243 #else
4244 x = xmalloc (sizeof *x);
4245 #endif
4246 x->start = start;
4247 x->end = end;
4248 x->type = type;
4249 x->parent = parent;
4250 x->left = x->right = MEM_NIL;
4251 x->color = MEM_RED;
4253 /* Insert it as child of PARENT or install it as root. */
4254 if (parent)
4256 if (start < parent->start)
4257 parent->left = x;
4258 else
4259 parent->right = x;
4261 else
4262 mem_root = x;
4264 /* Re-establish red-black tree properties. */
4265 mem_insert_fixup (x);
4267 return x;
4271 /* Re-establish the red-black properties of the tree, and thereby
4272 balance the tree, after node X has been inserted; X is always red. */
4274 static void
4275 mem_insert_fixup (struct mem_node *x)
4277 while (x != mem_root && x->parent->color == MEM_RED)
4279 /* X is red and its parent is red. This is a violation of
4280 red-black tree property #3. */
4282 if (x->parent == x->parent->parent->left)
4284 /* We're on the left side of our grandparent, and Y is our
4285 "uncle". */
4286 struct mem_node *y = x->parent->parent->right;
4288 if (y->color == MEM_RED)
4290 /* Uncle and parent are red but should be black because
4291 X is red. Change the colors accordingly and proceed
4292 with the grandparent. */
4293 x->parent->color = MEM_BLACK;
4294 y->color = MEM_BLACK;
4295 x->parent->parent->color = MEM_RED;
4296 x = x->parent->parent;
4298 else
4300 /* Parent and uncle have different colors; parent is
4301 red, uncle is black. */
4302 if (x == x->parent->right)
4304 x = x->parent;
4305 mem_rotate_left (x);
4308 x->parent->color = MEM_BLACK;
4309 x->parent->parent->color = MEM_RED;
4310 mem_rotate_right (x->parent->parent);
4313 else
4315 /* This is the symmetrical case of above. */
4316 struct mem_node *y = x->parent->parent->left;
4318 if (y->color == MEM_RED)
4320 x->parent->color = MEM_BLACK;
4321 y->color = MEM_BLACK;
4322 x->parent->parent->color = MEM_RED;
4323 x = x->parent->parent;
4325 else
4327 if (x == x->parent->left)
4329 x = x->parent;
4330 mem_rotate_right (x);
4333 x->parent->color = MEM_BLACK;
4334 x->parent->parent->color = MEM_RED;
4335 mem_rotate_left (x->parent->parent);
4340 /* The root may have been changed to red due to the algorithm. Set
4341 it to black so that property #5 is satisfied. */
4342 mem_root->color = MEM_BLACK;
4346 /* (x) (y)
4347 / \ / \
4348 a (y) ===> (x) c
4349 / \ / \
4350 b c a b */
4352 static void
4353 mem_rotate_left (struct mem_node *x)
4355 struct mem_node *y;
4357 /* Turn y's left sub-tree into x's right sub-tree. */
4358 y = x->right;
4359 x->right = y->left;
4360 if (y->left != MEM_NIL)
4361 y->left->parent = x;
4363 /* Y's parent was x's parent. */
4364 if (y != MEM_NIL)
4365 y->parent = x->parent;
4367 /* Get the parent to point to y instead of x. */
4368 if (x->parent)
4370 if (x == x->parent->left)
4371 x->parent->left = y;
4372 else
4373 x->parent->right = y;
4375 else
4376 mem_root = y;
4378 /* Put x on y's left. */
4379 y->left = x;
4380 if (x != MEM_NIL)
4381 x->parent = y;
4385 /* (x) (Y)
4386 / \ / \
4387 (y) c ===> a (x)
4388 / \ / \
4389 a b b c */
4391 static void
4392 mem_rotate_right (struct mem_node *x)
4394 struct mem_node *y = x->left;
4396 x->left = y->right;
4397 if (y->right != MEM_NIL)
4398 y->right->parent = x;
4400 if (y != MEM_NIL)
4401 y->parent = x->parent;
4402 if (x->parent)
4404 if (x == x->parent->right)
4405 x->parent->right = y;
4406 else
4407 x->parent->left = y;
4409 else
4410 mem_root = y;
4412 y->right = x;
4413 if (x != MEM_NIL)
4414 x->parent = y;
4418 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4420 static void
4421 mem_delete (struct mem_node *z)
4423 struct mem_node *x, *y;
4425 if (!z || z == MEM_NIL)
4426 return;
4428 if (z->left == MEM_NIL || z->right == MEM_NIL)
4429 y = z;
4430 else
4432 y = z->right;
4433 while (y->left != MEM_NIL)
4434 y = y->left;
4437 if (y->left != MEM_NIL)
4438 x = y->left;
4439 else
4440 x = y->right;
4442 x->parent = y->parent;
4443 if (y->parent)
4445 if (y == y->parent->left)
4446 y->parent->left = x;
4447 else
4448 y->parent->right = x;
4450 else
4451 mem_root = x;
4453 if (y != z)
4455 z->start = y->start;
4456 z->end = y->end;
4457 z->type = y->type;
4460 if (y->color == MEM_BLACK)
4461 mem_delete_fixup (x);
4463 #ifdef GC_MALLOC_CHECK
4464 free (y);
4465 #else
4466 xfree (y);
4467 #endif
4471 /* Re-establish the red-black properties of the tree, after a
4472 deletion. */
4474 static void
4475 mem_delete_fixup (struct mem_node *x)
4477 while (x != mem_root && x->color == MEM_BLACK)
4479 if (x == x->parent->left)
4481 struct mem_node *w = x->parent->right;
4483 if (w->color == MEM_RED)
4485 w->color = MEM_BLACK;
4486 x->parent->color = MEM_RED;
4487 mem_rotate_left (x->parent);
4488 w = x->parent->right;
4491 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
4493 w->color = MEM_RED;
4494 x = x->parent;
4496 else
4498 if (w->right->color == MEM_BLACK)
4500 w->left->color = MEM_BLACK;
4501 w->color = MEM_RED;
4502 mem_rotate_right (w);
4503 w = x->parent->right;
4505 w->color = x->parent->color;
4506 x->parent->color = MEM_BLACK;
4507 w->right->color = MEM_BLACK;
4508 mem_rotate_left (x->parent);
4509 x = mem_root;
4512 else
4514 struct mem_node *w = x->parent->left;
4516 if (w->color == MEM_RED)
4518 w->color = MEM_BLACK;
4519 x->parent->color = MEM_RED;
4520 mem_rotate_right (x->parent);
4521 w = x->parent->left;
4524 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
4526 w->color = MEM_RED;
4527 x = x->parent;
4529 else
4531 if (w->left->color == MEM_BLACK)
4533 w->right->color = MEM_BLACK;
4534 w->color = MEM_RED;
4535 mem_rotate_left (w);
4536 w = x->parent->left;
4539 w->color = x->parent->color;
4540 x->parent->color = MEM_BLACK;
4541 w->left->color = MEM_BLACK;
4542 mem_rotate_right (x->parent);
4543 x = mem_root;
4548 x->color = MEM_BLACK;
4552 /* Value is non-zero if P is a pointer to a live Lisp string on
4553 the heap. M is a pointer to the mem_block for P. */
4555 static bool
4556 live_string_p (struct mem_node *m, void *p)
4558 if (m->type == MEM_TYPE_STRING)
4560 struct string_block *b = m->start;
4561 ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
4563 /* P must point to the start of a Lisp_String structure, and it
4564 must not be on the free-list. */
4565 return (offset >= 0
4566 && offset % sizeof b->strings[0] == 0
4567 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
4568 && ((struct Lisp_String *) p)->data != NULL);
4570 else
4571 return 0;
4575 /* Value is non-zero if P is a pointer to a live Lisp cons on
4576 the heap. M is a pointer to the mem_block for P. */
4578 static bool
4579 live_cons_p (struct mem_node *m, void *p)
4581 if (m->type == MEM_TYPE_CONS)
4583 struct cons_block *b = m->start;
4584 ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
4586 /* P must point to the start of a Lisp_Cons, not be
4587 one of the unused cells in the current cons block,
4588 and not be on the free-list. */
4589 return (offset >= 0
4590 && offset % sizeof b->conses[0] == 0
4591 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
4592 && (b != cons_block
4593 || offset / sizeof b->conses[0] < cons_block_index)
4594 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
4596 else
4597 return 0;
4601 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4602 the heap. M is a pointer to the mem_block for P. */
4604 static bool
4605 live_symbol_p (struct mem_node *m, void *p)
4607 if (m->type == MEM_TYPE_SYMBOL)
4609 struct symbol_block *b = m->start;
4610 ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
4612 /* P must point to the start of a Lisp_Symbol, not be
4613 one of the unused cells in the current symbol block,
4614 and not be on the free-list. */
4615 return (offset >= 0
4616 && offset % sizeof b->symbols[0] == 0
4617 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
4618 && (b != symbol_block
4619 || offset / sizeof b->symbols[0] < symbol_block_index)
4620 && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
4622 else
4623 return 0;
4627 /* Value is non-zero if P is a pointer to a live Lisp float on
4628 the heap. M is a pointer to the mem_block for P. */
4630 static bool
4631 live_float_p (struct mem_node *m, void *p)
4633 if (m->type == MEM_TYPE_FLOAT)
4635 struct float_block *b = m->start;
4636 ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
4638 /* P must point to the start of a Lisp_Float and not be
4639 one of the unused cells in the current float block. */
4640 return (offset >= 0
4641 && offset % sizeof b->floats[0] == 0
4642 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
4643 && (b != float_block
4644 || offset / sizeof b->floats[0] < float_block_index));
4646 else
4647 return 0;
4651 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4652 the heap. M is a pointer to the mem_block for P. */
4654 static bool
4655 live_misc_p (struct mem_node *m, void *p)
4657 if (m->type == MEM_TYPE_MISC)
4659 struct marker_block *b = m->start;
4660 ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
4662 /* P must point to the start of a Lisp_Misc, not be
4663 one of the unused cells in the current misc block,
4664 and not be on the free-list. */
4665 return (offset >= 0
4666 && offset % sizeof b->markers[0] == 0
4667 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4668 && (b != marker_block
4669 || offset / sizeof b->markers[0] < marker_block_index)
4670 && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4672 else
4673 return 0;
4677 /* Value is non-zero if P is a pointer to a live vector-like object.
4678 M is a pointer to the mem_block for P. */
4680 static bool
4681 live_vector_p (struct mem_node *m, void *p)
4683 if (m->type == MEM_TYPE_VECTOR_BLOCK)
4685 /* This memory node corresponds to a vector block. */
4686 struct vector_block *block = m->start;
4687 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4689 /* P is in the block's allocation range. Scan the block
4690 up to P and see whether P points to the start of some
4691 vector which is not on a free list. FIXME: check whether
4692 some allocation patterns (probably a lot of short vectors)
4693 may cause a substantial overhead of this loop. */
4694 while (VECTOR_IN_BLOCK (vector, block)
4695 && vector <= (struct Lisp_Vector *) p)
4697 if (!PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) && vector == p)
4698 return true;
4699 else
4700 vector = ADVANCE (vector, vector_nbytes (vector));
4703 else if (m->type == MEM_TYPE_VECTORLIKE && p == large_vector_vec (m->start))
4704 /* This memory node corresponds to a large vector. */
4705 return 1;
4706 return 0;
4710 /* Value is non-zero if P is a pointer to a live buffer. M is a
4711 pointer to the mem_block for P. */
4713 static bool
4714 live_buffer_p (struct mem_node *m, void *p)
4716 /* P must point to the start of the block, and the buffer
4717 must not have been killed. */
4718 return (m->type == MEM_TYPE_BUFFER
4719 && p == m->start
4720 && !NILP (((struct buffer *) p)->name_));
4723 /* Mark OBJ if we can prove it's a Lisp_Object. */
4725 static void
4726 mark_maybe_object (Lisp_Object obj)
4728 #if USE_VALGRIND
4729 if (valgrind_p)
4730 VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
4731 #endif
4733 if (INTEGERP (obj))
4734 return;
4736 void *po = XPNTR (obj);
4737 struct mem_node *m = mem_find (po);
4739 if (m != MEM_NIL)
4741 bool mark_p = false;
4743 switch (XTYPE (obj))
4745 case Lisp_String:
4746 mark_p = (live_string_p (m, po)
4747 && !STRING_MARKED_P ((struct Lisp_String *) po));
4748 break;
4750 case Lisp_Cons:
4751 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4752 break;
4754 case Lisp_Symbol:
4755 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4756 break;
4758 case Lisp_Float:
4759 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4760 break;
4762 case Lisp_Vectorlike:
4763 /* Note: can't check BUFFERP before we know it's a
4764 buffer because checking that dereferences the pointer
4765 PO which might point anywhere. */
4766 if (live_vector_p (m, po))
4767 mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4768 else if (live_buffer_p (m, po))
4769 mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4770 break;
4772 case Lisp_Misc:
4773 mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4774 break;
4776 default:
4777 break;
4780 if (mark_p)
4781 mark_object (obj);
4785 /* Return true if P can point to Lisp data, and false otherwise.
4786 Symbols are implemented via offsets not pointers, but the offsets
4787 are also multiples of GCALIGNMENT. */
4789 static bool
4790 maybe_lisp_pointer (void *p)
4792 return (uintptr_t) p % GCALIGNMENT == 0;
4795 #ifndef HAVE_MODULES
4796 enum { HAVE_MODULES = false };
4797 #endif
4799 /* If P points to Lisp data, mark that as live if it isn't already
4800 marked. */
4802 static void
4803 mark_maybe_pointer (void *p)
4805 struct mem_node *m;
4807 #if USE_VALGRIND
4808 if (valgrind_p)
4809 VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
4810 #endif
4812 if (sizeof (Lisp_Object) == sizeof (void *) || !HAVE_MODULES)
4814 if (!maybe_lisp_pointer (p))
4815 return;
4817 else
4819 /* For the wide-int case, also mark emacs_value tagged pointers,
4820 which can be generated by emacs-module.c's value_to_lisp. */
4821 p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1));
4824 m = mem_find (p);
4825 if (m != MEM_NIL)
4827 Lisp_Object obj = Qnil;
4829 switch (m->type)
4831 case MEM_TYPE_NON_LISP:
4832 case MEM_TYPE_SPARE:
4833 /* Nothing to do; not a pointer to Lisp memory. */
4834 break;
4836 case MEM_TYPE_BUFFER:
4837 if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p))
4838 XSETVECTOR (obj, p);
4839 break;
4841 case MEM_TYPE_CONS:
4842 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4843 XSETCONS (obj, p);
4844 break;
4846 case MEM_TYPE_STRING:
4847 if (live_string_p (m, p)
4848 && !STRING_MARKED_P ((struct Lisp_String *) p))
4849 XSETSTRING (obj, p);
4850 break;
4852 case MEM_TYPE_MISC:
4853 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4854 XSETMISC (obj, p);
4855 break;
4857 case MEM_TYPE_SYMBOL:
4858 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4859 XSETSYMBOL (obj, p);
4860 break;
4862 case MEM_TYPE_FLOAT:
4863 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4864 XSETFLOAT (obj, p);
4865 break;
4867 case MEM_TYPE_VECTORLIKE:
4868 case MEM_TYPE_VECTOR_BLOCK:
4869 if (live_vector_p (m, p))
4871 Lisp_Object tem;
4872 XSETVECTOR (tem, p);
4873 if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4874 obj = tem;
4876 break;
4878 default:
4879 emacs_abort ();
4882 if (!NILP (obj))
4883 mark_object (obj);
4888 /* Alignment of pointer values. Use alignof, as it sometimes returns
4889 a smaller alignment than GCC's __alignof__ and mark_memory might
4890 miss objects if __alignof__ were used. */
4891 #define GC_POINTER_ALIGNMENT alignof (void *)
4893 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4894 or END+OFFSET..START. */
4896 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4897 mark_memory (void *start, void *end)
4899 char *pp;
4901 /* Make START the pointer to the start of the memory region,
4902 if it isn't already. */
4903 if (end < start)
4905 void *tem = start;
4906 start = end;
4907 end = tem;
4910 eassert (((uintptr_t) start) % GC_POINTER_ALIGNMENT == 0);
4912 /* Mark Lisp data pointed to. This is necessary because, in some
4913 situations, the C compiler optimizes Lisp objects away, so that
4914 only a pointer to them remains. Example:
4916 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4919 Lisp_Object obj = build_string ("test");
4920 struct Lisp_String *s = XSTRING (obj);
4921 Fgarbage_collect ();
4922 fprintf (stderr, "test '%s'\n", s->data);
4923 return Qnil;
4926 Here, `obj' isn't really used, and the compiler optimizes it
4927 away. The only reference to the life string is through the
4928 pointer `s'. */
4930 for (pp = start; (void *) pp < end; pp += GC_POINTER_ALIGNMENT)
4932 mark_maybe_pointer (*(void **) pp);
4933 mark_maybe_object (*(Lisp_Object *) pp);
4937 #ifndef HAVE___BUILTIN_UNWIND_INIT
4939 # ifdef GC_SETJMP_WORKS
4940 static void
4941 test_setjmp (void)
4944 # else
4946 static bool setjmp_tested_p;
4947 static int longjmps_done;
4949 # define SETJMP_WILL_LIKELY_WORK "\
4951 Emacs garbage collector has been changed to use conservative stack\n\
4952 marking. Emacs has determined that the method it uses to do the\n\
4953 marking will likely work on your system, but this isn't sure.\n\
4955 If you are a system-programmer, or can get the help of a local wizard\n\
4956 who is, please take a look at the function mark_stack in alloc.c, and\n\
4957 verify that the methods used are appropriate for your system.\n\
4959 Please mail the result to <emacs-devel@gnu.org>.\n\
4962 # define SETJMP_WILL_NOT_WORK "\
4964 Emacs garbage collector has been changed to use conservative stack\n\
4965 marking. Emacs has determined that the default method it uses to do the\n\
4966 marking will not work on your system. We will need a system-dependent\n\
4967 solution for your system.\n\
4969 Please take a look at the function mark_stack in alloc.c, and\n\
4970 try to find a way to make it work on your system.\n\
4972 Note that you may get false negatives, depending on the compiler.\n\
4973 In particular, you need to use -O with GCC for this test.\n\
4975 Please mail the result to <emacs-devel@gnu.org>.\n\
4979 /* Perform a quick check if it looks like setjmp saves registers in a
4980 jmp_buf. Print a message to stderr saying so. When this test
4981 succeeds, this is _not_ a proof that setjmp is sufficient for
4982 conservative stack marking. Only the sources or a disassembly
4983 can prove that. */
4985 static void
4986 test_setjmp (void)
4988 if (setjmp_tested_p)
4989 return;
4990 setjmp_tested_p = true;
4991 char buf[10];
4992 register int x;
4993 sys_jmp_buf jbuf;
4995 /* Arrange for X to be put in a register. */
4996 sprintf (buf, "1");
4997 x = strlen (buf);
4998 x = 2 * x - 1;
5000 sys_setjmp (jbuf);
5001 if (longjmps_done == 1)
5003 /* Came here after the longjmp at the end of the function.
5005 If x == 1, the longjmp has restored the register to its
5006 value before the setjmp, and we can hope that setjmp
5007 saves all such registers in the jmp_buf, although that
5008 isn't sure.
5010 For other values of X, either something really strange is
5011 taking place, or the setjmp just didn't save the register. */
5013 if (x == 1)
5014 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
5015 else
5017 fprintf (stderr, SETJMP_WILL_NOT_WORK);
5018 exit (1);
5022 ++longjmps_done;
5023 x = 2;
5024 if (longjmps_done == 1)
5025 sys_longjmp (jbuf, 1);
5027 # endif /* ! GC_SETJMP_WORKS */
5028 #endif /* ! HAVE___BUILTIN_UNWIND_INIT */
5030 /* The type of an object near the stack top, whose address can be used
5031 as a stack scan limit. */
5032 typedef union
5034 /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT,
5035 jmp_buf may not be aligned enough on darwin-ppc64. */
5036 max_align_t o;
5037 #ifndef HAVE___BUILTIN_UNWIND_INIT
5038 sys_jmp_buf j;
5039 char c;
5040 #endif
5041 } stacktop_sentry;
5043 /* Force callee-saved registers and register windows onto the stack.
5044 Use the platform-defined __builtin_unwind_init if available,
5045 obviating the need for machine dependent methods. */
5046 #ifndef HAVE___BUILTIN_UNWIND_INIT
5047 # ifdef __sparc__
5048 /* This trick flushes the register windows so that all the state of
5049 the process is contained in the stack.
5050 FreeBSD does not have a ta 3 handler, so handle it specially.
5051 FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
5052 needed on ia64 too. See mach_dep.c, where it also says inline
5053 assembler doesn't work with relevant proprietary compilers. */
5054 # if defined __sparc64__ && defined __FreeBSD__
5055 # define __builtin_unwind_init() asm ("flushw")
5056 # else
5057 # define __builtin_unwind_init() asm ("ta 3")
5058 # endif
5059 # else
5060 # define __builtin_unwind_init() ((void) 0)
5061 # endif
5062 #endif
5064 /* Set *P to the address of the top of the stack. This must be a
5065 macro, not a function, so that it is executed in the caller’s
5066 environment. It is not inside a do-while so that its storage
5067 survives the macro. */
5068 #ifdef HAVE___BUILTIN_UNWIND_INIT
5069 # define SET_STACK_TOP_ADDRESS(p) \
5070 stacktop_sentry sentry; \
5071 __builtin_unwind_init (); \
5072 *(p) = &sentry
5073 #else
5074 # define SET_STACK_TOP_ADDRESS(p) \
5075 stacktop_sentry sentry; \
5076 __builtin_unwind_init (); \
5077 test_setjmp (); \
5078 sys_setjmp (sentry.j); \
5079 *(p) = &sentry + (stack_bottom < &sentry.c)
5080 #endif
5082 /* Mark live Lisp objects on the C stack.
5084 There are several system-dependent problems to consider when
5085 porting this to new architectures:
5087 Processor Registers
5089 We have to mark Lisp objects in CPU registers that can hold local
5090 variables or are used to pass parameters.
5092 This code assumes that calling setjmp saves registers we need
5093 to see in a jmp_buf which itself lies on the stack. This doesn't
5094 have to be true! It must be verified for each system, possibly
5095 by taking a look at the source code of setjmp.
5097 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
5098 can use it as a machine independent method to store all registers
5099 to the stack. In this case the macros described in the previous
5100 two paragraphs are not used.
5102 Stack Layout
5104 Architectures differ in the way their processor stack is organized.
5105 For example, the stack might look like this
5107 +----------------+
5108 | Lisp_Object | size = 4
5109 +----------------+
5110 | something else | size = 2
5111 +----------------+
5112 | Lisp_Object | size = 4
5113 +----------------+
5114 | ... |
5116 In such a case, not every Lisp_Object will be aligned equally. To
5117 find all Lisp_Object on the stack it won't be sufficient to walk
5118 the stack in steps of 4 bytes. Instead, two passes will be
5119 necessary, one starting at the start of the stack, and a second
5120 pass starting at the start of the stack + 2. Likewise, if the
5121 minimal alignment of Lisp_Objects on the stack is 1, four passes
5122 would be necessary, each one starting with one byte more offset
5123 from the stack start. */
5125 void
5126 mark_stack (char *bottom, char *end)
5128 /* This assumes that the stack is a contiguous region in memory. If
5129 that's not the case, something has to be done here to iterate
5130 over the stack segments. */
5131 mark_memory (bottom, end);
5133 /* Allow for marking a secondary stack, like the register stack on the
5134 ia64. */
5135 #ifdef GC_MARK_SECONDARY_STACK
5136 GC_MARK_SECONDARY_STACK ();
5137 #endif
5140 /* This is a trampoline function that flushes registers to the stack,
5141 and then calls FUNC. ARG is passed through to FUNC verbatim.
5143 This function must be called whenever Emacs is about to release the
5144 global interpreter lock. This lets the garbage collector easily
5145 find roots in registers on threads that are not actively running
5146 Lisp.
5148 It is invalid to run any Lisp code or to allocate any GC memory
5149 from FUNC. */
5151 void
5152 flush_stack_call_func (void (*func) (void *arg), void *arg)
5154 void *end;
5155 struct thread_state *self = current_thread;
5156 SET_STACK_TOP_ADDRESS (&end);
5157 self->stack_top = end;
5158 func (arg);
5159 eassert (current_thread == self);
5162 static bool
5163 c_symbol_p (struct Lisp_Symbol *sym)
5165 char *lispsym_ptr = (char *) lispsym;
5166 char *sym_ptr = (char *) sym;
5167 ptrdiff_t lispsym_offset = sym_ptr - lispsym_ptr;
5168 return 0 <= lispsym_offset && lispsym_offset < sizeof lispsym;
5171 /* Determine whether it is safe to access memory at address P. */
5172 static int
5173 valid_pointer_p (void *p)
5175 #ifdef WINDOWSNT
5176 return w32_valid_pointer_p (p, 16);
5177 #else
5179 if (ADDRESS_SANITIZER)
5180 return p ? -1 : 0;
5182 int fd[2];
5184 /* Obviously, we cannot just access it (we would SEGV trying), so we
5185 trick the o/s to tell us whether p is a valid pointer.
5186 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
5187 not validate p in that case. */
5189 if (emacs_pipe (fd) == 0)
5191 bool valid = emacs_write (fd[1], p, 16) == 16;
5192 emacs_close (fd[1]);
5193 emacs_close (fd[0]);
5194 return valid;
5197 return -1;
5198 #endif
5201 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5202 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5203 cannot validate OBJ. This function can be quite slow, so its primary
5204 use is the manual debugging. The only exception is print_object, where
5205 we use it to check whether the memory referenced by the pointer of
5206 Lisp_Save_Value object contains valid objects. */
5209 valid_lisp_object_p (Lisp_Object obj)
5211 if (INTEGERP (obj))
5212 return 1;
5214 void *p = XPNTR (obj);
5215 if (PURE_P (p))
5216 return 1;
5218 if (SYMBOLP (obj) && c_symbol_p (p))
5219 return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
5221 if (p == &buffer_defaults || p == &buffer_local_symbols)
5222 return 2;
5224 struct mem_node *m = mem_find (p);
5226 if (m == MEM_NIL)
5228 int valid = valid_pointer_p (p);
5229 if (valid <= 0)
5230 return valid;
5232 if (SUBRP (obj))
5233 return 1;
5235 return 0;
5238 switch (m->type)
5240 case MEM_TYPE_NON_LISP:
5241 case MEM_TYPE_SPARE:
5242 return 0;
5244 case MEM_TYPE_BUFFER:
5245 return live_buffer_p (m, p) ? 1 : 2;
5247 case MEM_TYPE_CONS:
5248 return live_cons_p (m, p);
5250 case MEM_TYPE_STRING:
5251 return live_string_p (m, p);
5253 case MEM_TYPE_MISC:
5254 return live_misc_p (m, p);
5256 case MEM_TYPE_SYMBOL:
5257 return live_symbol_p (m, p);
5259 case MEM_TYPE_FLOAT:
5260 return live_float_p (m, p);
5262 case MEM_TYPE_VECTORLIKE:
5263 case MEM_TYPE_VECTOR_BLOCK:
5264 return live_vector_p (m, p);
5266 default:
5267 break;
5270 return 0;
5273 /***********************************************************************
5274 Pure Storage Management
5275 ***********************************************************************/
5277 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5278 pointer to it. TYPE is the Lisp type for which the memory is
5279 allocated. TYPE < 0 means it's not used for a Lisp object. */
5281 static void *
5282 pure_alloc (size_t size, int type)
5284 void *result;
5286 again:
5287 if (type >= 0)
5289 /* Allocate space for a Lisp object from the beginning of the free
5290 space with taking account of alignment. */
5291 result = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT);
5292 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
5294 else
5296 /* Allocate space for a non-Lisp object from the end of the free
5297 space. */
5298 pure_bytes_used_non_lisp += size;
5299 result = purebeg + pure_size - pure_bytes_used_non_lisp;
5301 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
5303 if (pure_bytes_used <= pure_size)
5304 return result;
5306 /* Don't allocate a large amount here,
5307 because it might get mmap'd and then its address
5308 might not be usable. */
5309 purebeg = xmalloc (10000);
5310 pure_size = 10000;
5311 pure_bytes_used_before_overflow += pure_bytes_used - size;
5312 pure_bytes_used = 0;
5313 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
5314 goto again;
5318 #ifndef CANNOT_DUMP
5320 /* Print a warning if PURESIZE is too small. */
5322 void
5323 check_pure_size (void)
5325 if (pure_bytes_used_before_overflow)
5326 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d"
5327 " bytes needed)"),
5328 pure_bytes_used + pure_bytes_used_before_overflow);
5330 #endif
5333 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5334 the non-Lisp data pool of the pure storage, and return its start
5335 address. Return NULL if not found. */
5337 static char *
5338 find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
5340 int i;
5341 ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max;
5342 const unsigned char *p;
5343 char *non_lisp_beg;
5345 if (pure_bytes_used_non_lisp <= nbytes)
5346 return NULL;
5348 /* Set up the Boyer-Moore table. */
5349 skip = nbytes + 1;
5350 for (i = 0; i < 256; i++)
5351 bm_skip[i] = skip;
5353 p = (const unsigned char *) data;
5354 while (--skip > 0)
5355 bm_skip[*p++] = skip;
5357 last_char_skip = bm_skip['\0'];
5359 non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
5360 start_max = pure_bytes_used_non_lisp - (nbytes + 1);
5362 /* See the comments in the function `boyer_moore' (search.c) for the
5363 use of `infinity'. */
5364 infinity = pure_bytes_used_non_lisp + 1;
5365 bm_skip['\0'] = infinity;
5367 p = (const unsigned char *) non_lisp_beg + nbytes;
5368 start = 0;
5371 /* Check the last character (== '\0'). */
5374 start += bm_skip[*(p + start)];
5376 while (start <= start_max);
5378 if (start < infinity)
5379 /* Couldn't find the last character. */
5380 return NULL;
5382 /* No less than `infinity' means we could find the last
5383 character at `p[start - infinity]'. */
5384 start -= infinity;
5386 /* Check the remaining characters. */
5387 if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
5388 /* Found. */
5389 return non_lisp_beg + start;
5391 start += last_char_skip;
5393 while (start <= start_max);
5395 return NULL;
5399 /* Return a string allocated in pure space. DATA is a buffer holding
5400 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5401 means make the result string multibyte.
5403 Must get an error if pure storage is full, since if it cannot hold
5404 a large string it may be able to hold conses that point to that
5405 string; then the string is not protected from gc. */
5407 Lisp_Object
5408 make_pure_string (const char *data,
5409 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
5411 Lisp_Object string;
5412 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
5413 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
5414 if (s->data == NULL)
5416 s->data = pure_alloc (nbytes + 1, -1);
5417 memcpy (s->data, data, nbytes);
5418 s->data[nbytes] = '\0';
5420 s->size = nchars;
5421 s->size_byte = multibyte ? nbytes : -1;
5422 s->intervals = NULL;
5423 XSETSTRING (string, s);
5424 return string;
5427 /* Return a string allocated in pure space. Do not
5428 allocate the string data, just point to DATA. */
5430 Lisp_Object
5431 make_pure_c_string (const char *data, ptrdiff_t nchars)
5433 Lisp_Object string;
5434 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
5435 s->size = nchars;
5436 s->size_byte = -1;
5437 s->data = (unsigned char *) data;
5438 s->intervals = NULL;
5439 XSETSTRING (string, s);
5440 return string;
5443 static Lisp_Object purecopy (Lisp_Object obj);
5445 /* Return a cons allocated from pure space. Give it pure copies
5446 of CAR as car and CDR as cdr. */
5448 Lisp_Object
5449 pure_cons (Lisp_Object car, Lisp_Object cdr)
5451 Lisp_Object new;
5452 struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
5453 XSETCONS (new, p);
5454 XSETCAR (new, purecopy (car));
5455 XSETCDR (new, purecopy (cdr));
5456 return new;
5460 /* Value is a float object with value NUM allocated from pure space. */
5462 static Lisp_Object
5463 make_pure_float (double num)
5465 Lisp_Object new;
5466 struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
5467 XSETFLOAT (new, p);
5468 XFLOAT_INIT (new, num);
5469 return new;
5473 /* Return a vector with room for LEN Lisp_Objects allocated from
5474 pure space. */
5476 static Lisp_Object
5477 make_pure_vector (ptrdiff_t len)
5479 Lisp_Object new;
5480 size_t size = header_size + len * word_size;
5481 struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
5482 XSETVECTOR (new, p);
5483 XVECTOR (new)->header.size = len;
5484 return new;
5487 /* Copy all contents and parameters of TABLE to a new table allocated
5488 from pure space, return the purified table. */
5489 static struct Lisp_Hash_Table *
5490 purecopy_hash_table (struct Lisp_Hash_Table *table)
5492 eassert (NILP (table->weak));
5493 eassert (table->pure);
5495 struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
5496 struct hash_table_test pure_test = table->test;
5498 /* Purecopy the hash table test. */
5499 pure_test.name = purecopy (table->test.name);
5500 pure_test.user_hash_function = purecopy (table->test.user_hash_function);
5501 pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
5503 pure->header = table->header;
5504 pure->weak = purecopy (Qnil);
5505 pure->hash = purecopy (table->hash);
5506 pure->next = purecopy (table->next);
5507 pure->index = purecopy (table->index);
5508 pure->count = table->count;
5509 pure->next_free = table->next_free;
5510 pure->pure = table->pure;
5511 pure->rehash_threshold = table->rehash_threshold;
5512 pure->rehash_size = table->rehash_size;
5513 pure->key_and_value = purecopy (table->key_and_value);
5514 pure->test = pure_test;
5516 return pure;
5519 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
5520 doc: /* Make a copy of object OBJ in pure storage.
5521 Recursively copies contents of vectors and cons cells.
5522 Does not copy symbols. Copies strings without text properties. */)
5523 (register Lisp_Object obj)
5525 if (NILP (Vpurify_flag))
5526 return obj;
5527 else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
5528 /* Can't purify those. */
5529 return obj;
5530 else
5531 return purecopy (obj);
5534 /* Pinned objects are marked before every GC cycle. */
5535 static struct pinned_object
5537 Lisp_Object object;
5538 struct pinned_object *next;
5539 } *pinned_objects;
5541 static Lisp_Object
5542 purecopy (Lisp_Object obj)
5544 if (INTEGERP (obj)
5545 || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj)))
5546 || SUBRP (obj))
5547 return obj; /* Already pure. */
5549 if (STRINGP (obj) && XSTRING (obj)->intervals)
5550 message_with_string ("Dropping text-properties while making string `%s' pure",
5551 obj, true);
5553 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
5555 Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
5556 if (!NILP (tmp))
5557 return tmp;
5560 if (CONSP (obj))
5561 obj = pure_cons (XCAR (obj), XCDR (obj));
5562 else if (FLOATP (obj))
5563 obj = make_pure_float (XFLOAT_DATA (obj));
5564 else if (STRINGP (obj))
5565 obj = make_pure_string (SSDATA (obj), SCHARS (obj),
5566 SBYTES (obj),
5567 STRING_MULTIBYTE (obj));
5568 else if (HASH_TABLE_P (obj))
5570 struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
5571 /* Do not purify hash tables which haven't been defined with
5572 :purecopy as non-nil or are weak - they aren't guaranteed to
5573 not change. */
5574 if (!NILP (table->weak) || !table->pure)
5576 /* Instead, add the hash table to the list of pinned objects,
5577 so that it will be marked during GC. */
5578 struct pinned_object *o = xmalloc (sizeof *o);
5579 o->object = obj;
5580 o->next = pinned_objects;
5581 pinned_objects = o;
5582 return obj; /* Don't hash cons it. */
5585 struct Lisp_Hash_Table *h = purecopy_hash_table (table);
5586 XSET_HASH_TABLE (obj, h);
5588 else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
5590 struct Lisp_Vector *objp = XVECTOR (obj);
5591 ptrdiff_t nbytes = vector_nbytes (objp);
5592 struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike);
5593 register ptrdiff_t i;
5594 ptrdiff_t size = ASIZE (obj);
5595 if (size & PSEUDOVECTOR_FLAG)
5596 size &= PSEUDOVECTOR_SIZE_MASK;
5597 memcpy (vec, objp, nbytes);
5598 for (i = 0; i < size; i++)
5599 vec->contents[i] = purecopy (vec->contents[i]);
5600 XSETVECTOR (obj, vec);
5602 else if (SYMBOLP (obj))
5604 if (!XSYMBOL (obj)->pinned && !c_symbol_p (XSYMBOL (obj)))
5605 { /* We can't purify them, but they appear in many pure objects.
5606 Mark them as `pinned' so we know to mark them at every GC cycle. */
5607 XSYMBOL (obj)->pinned = true;
5608 symbol_block_pinned = symbol_block;
5610 /* Don't hash-cons it. */
5611 return obj;
5613 else
5615 AUTO_STRING (fmt, "Don't know how to purify: %S");
5616 Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj)));
5619 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
5620 Fputhash (obj, obj, Vpurify_flag);
5622 return obj;
5627 /***********************************************************************
5628 Protection from GC
5629 ***********************************************************************/
5631 /* Put an entry in staticvec, pointing at the variable with address
5632 VARADDRESS. */
5634 void
5635 staticpro (Lisp_Object *varaddress)
5637 if (staticidx >= NSTATICS)
5638 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5639 staticvec[staticidx++] = varaddress;
5643 /***********************************************************************
5644 Protection from GC
5645 ***********************************************************************/
5647 /* Temporarily prevent garbage collection. */
5649 ptrdiff_t
5650 inhibit_garbage_collection (void)
5652 ptrdiff_t count = SPECPDL_INDEX ();
5654 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
5655 return count;
5658 /* Used to avoid possible overflows when
5659 converting from C to Lisp integers. */
5661 static Lisp_Object
5662 bounded_number (EMACS_INT number)
5664 return make_number (min (MOST_POSITIVE_FIXNUM, number));
5667 /* Calculate total bytes of live objects. */
5669 static size_t
5670 total_bytes_of_live_objects (void)
5672 size_t tot = 0;
5673 tot += total_conses * sizeof (struct Lisp_Cons);
5674 tot += total_symbols * sizeof (struct Lisp_Symbol);
5675 tot += total_markers * sizeof (union Lisp_Misc);
5676 tot += total_string_bytes;
5677 tot += total_vector_slots * word_size;
5678 tot += total_floats * sizeof (struct Lisp_Float);
5679 tot += total_intervals * sizeof (struct interval);
5680 tot += total_strings * sizeof (struct Lisp_String);
5681 return tot;
5684 #ifdef HAVE_WINDOW_SYSTEM
5686 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5687 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5689 static Lisp_Object
5690 compact_font_cache_entry (Lisp_Object entry)
5692 Lisp_Object tail, *prev = &entry;
5694 for (tail = entry; CONSP (tail); tail = XCDR (tail))
5696 bool drop = 0;
5697 Lisp_Object obj = XCAR (tail);
5699 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5700 if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
5701 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj)))
5702 /* Don't use VECTORP here, as that calls ASIZE, which could
5703 hit assertion violation during GC. */
5704 && (VECTORLIKEP (XCDR (obj))
5705 && ! (gc_asize (XCDR (obj)) & PSEUDOVECTOR_FLAG)))
5707 ptrdiff_t i, size = gc_asize (XCDR (obj));
5708 Lisp_Object obj_cdr = XCDR (obj);
5710 /* If font-spec is not marked, most likely all font-entities
5711 are not marked too. But we must be sure that nothing is
5712 marked within OBJ before we really drop it. */
5713 for (i = 0; i < size; i++)
5715 Lisp_Object objlist;
5717 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr, i))))
5718 break;
5720 objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
5721 for (; CONSP (objlist); objlist = XCDR (objlist))
5723 Lisp_Object val = XCAR (objlist);
5724 struct font *font = GC_XFONT_OBJECT (val);
5726 if (!NILP (AREF (val, FONT_TYPE_INDEX))
5727 && VECTOR_MARKED_P(font))
5728 break;
5730 if (CONSP (objlist))
5732 /* Found a marked font, bail out. */
5733 break;
5737 if (i == size)
5739 /* No marked fonts were found, so this entire font
5740 entity can be dropped. */
5741 drop = 1;
5744 if (drop)
5745 *prev = XCDR (tail);
5746 else
5747 prev = xcdr_addr (tail);
5749 return entry;
5752 /* Compact font caches on all terminals and mark
5753 everything which is still here after compaction. */
5755 static void
5756 compact_font_caches (void)
5758 struct terminal *t;
5760 for (t = terminal_list; t; t = t->next_terminal)
5762 Lisp_Object cache = TERMINAL_FONT_CACHE (t);
5763 /* Inhibit compacting the caches if the user so wishes. Some of
5764 the users don't mind a larger memory footprint, but do mind
5765 slower redisplay. */
5766 if (!inhibit_compacting_font_caches
5767 && CONSP (cache))
5769 Lisp_Object entry;
5771 for (entry = XCDR (cache); CONSP (entry); entry = XCDR (entry))
5772 XSETCAR (entry, compact_font_cache_entry (XCAR (entry)));
5774 mark_object (cache);
5778 #else /* not HAVE_WINDOW_SYSTEM */
5780 #define compact_font_caches() (void)(0)
5782 #endif /* HAVE_WINDOW_SYSTEM */
5784 /* Remove (MARKER . DATA) entries with unmarked MARKER
5785 from buffer undo LIST and return changed list. */
5787 static Lisp_Object
5788 compact_undo_list (Lisp_Object list)
5790 Lisp_Object tail, *prev = &list;
5792 for (tail = list; CONSP (tail); tail = XCDR (tail))
5794 if (CONSP (XCAR (tail))
5795 && MARKERP (XCAR (XCAR (tail)))
5796 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5797 *prev = XCDR (tail);
5798 else
5799 prev = xcdr_addr (tail);
5801 return list;
5804 static void
5805 mark_pinned_objects (void)
5807 for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
5808 mark_object (pobj->object);
5811 static void
5812 mark_pinned_symbols (void)
5814 struct symbol_block *sblk;
5815 int lim = (symbol_block_pinned == symbol_block
5816 ? symbol_block_index : SYMBOL_BLOCK_SIZE);
5818 for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
5820 union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
5821 for (; sym < end; ++sym)
5822 if (sym->s.pinned)
5823 mark_object (make_lisp_symbol (&sym->s));
5825 lim = SYMBOL_BLOCK_SIZE;
5829 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5830 separate function so that we could limit mark_stack in searching
5831 the stack frames below this function, thus avoiding the rare cases
5832 where mark_stack finds values that look like live Lisp objects on
5833 portions of stack that couldn't possibly contain such live objects.
5834 For more details of this, see the discussion at
5835 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5836 static Lisp_Object
5837 garbage_collect_1 (void *end)
5839 struct buffer *nextb;
5840 char stack_top_variable;
5841 ptrdiff_t i;
5842 bool message_p;
5843 ptrdiff_t count = SPECPDL_INDEX ();
5844 struct timespec start;
5845 Lisp_Object retval = Qnil;
5846 size_t tot_before = 0;
5848 /* Can't GC if pure storage overflowed because we can't determine
5849 if something is a pure object or not. */
5850 if (pure_bytes_used_before_overflow)
5851 return Qnil;
5853 /* Record this function, so it appears on the profiler's backtraces. */
5854 record_in_backtrace (QAutomatic_GC, 0, 0);
5856 check_cons_list ();
5858 /* Don't keep undo information around forever.
5859 Do this early on, so it is no problem if the user quits. */
5860 FOR_EACH_BUFFER (nextb)
5861 compact_buffer (nextb);
5863 if (profiler_memory_running)
5864 tot_before = total_bytes_of_live_objects ();
5866 start = current_timespec ();
5868 /* In case user calls debug_print during GC,
5869 don't let that cause a recursive GC. */
5870 consing_since_gc = 0;
5872 /* Save what's currently displayed in the echo area. Don't do that
5873 if we are GC'ing because we've run out of memory, since
5874 push_message will cons, and we might have no memory for that. */
5875 if (NILP (Vmemory_full))
5877 message_p = push_message ();
5878 record_unwind_protect_void (pop_message_unwind);
5880 else
5881 message_p = false;
5883 /* Save a copy of the contents of the stack, for debugging. */
5884 #if MAX_SAVE_STACK > 0
5885 if (NILP (Vpurify_flag))
5887 char *stack;
5888 ptrdiff_t stack_size;
5889 if (&stack_top_variable < stack_bottom)
5891 stack = &stack_top_variable;
5892 stack_size = stack_bottom - &stack_top_variable;
5894 else
5896 stack = stack_bottom;
5897 stack_size = &stack_top_variable - stack_bottom;
5899 if (stack_size <= MAX_SAVE_STACK)
5901 if (stack_copy_size < stack_size)
5903 stack_copy = xrealloc (stack_copy, stack_size);
5904 stack_copy_size = stack_size;
5906 no_sanitize_memcpy (stack_copy, stack, stack_size);
5909 #endif /* MAX_SAVE_STACK > 0 */
5911 if (garbage_collection_messages)
5912 message1_nolog ("Garbage collecting...");
5914 block_input ();
5916 shrink_regexp_cache ();
5918 gc_in_progress = 1;
5920 /* Mark all the special slots that serve as the roots of accessibility. */
5922 mark_buffer (&buffer_defaults);
5923 mark_buffer (&buffer_local_symbols);
5925 for (i = 0; i < ARRAYELTS (lispsym); i++)
5926 mark_object (builtin_lisp_symbol (i));
5928 for (i = 0; i < staticidx; i++)
5929 mark_object (*staticvec[i]);
5931 mark_pinned_objects ();
5932 mark_pinned_symbols ();
5933 mark_terminals ();
5934 mark_kboards ();
5935 mark_threads ();
5937 #ifdef USE_GTK
5938 xg_mark_data ();
5939 #endif
5941 #ifdef HAVE_WINDOW_SYSTEM
5942 mark_fringe_data ();
5943 #endif
5945 #ifdef HAVE_MODULES
5946 mark_modules ();
5947 #endif
5949 /* Everything is now marked, except for the data in font caches,
5950 undo lists, and finalizers. The first two are compacted by
5951 removing an items which aren't reachable otherwise. */
5953 compact_font_caches ();
5955 FOR_EACH_BUFFER (nextb)
5957 if (!EQ (BVAR (nextb, undo_list), Qt))
5958 bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list)));
5959 /* Now that we have stripped the elements that need not be
5960 in the undo_list any more, we can finally mark the list. */
5961 mark_object (BVAR (nextb, undo_list));
5964 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5965 to doomed_finalizers so we can run their associated functions
5966 after GC. It's important to scan finalizers at this stage so
5967 that we can be sure that unmarked finalizers are really
5968 unreachable except for references from their associated functions
5969 and from other finalizers. */
5971 queue_doomed_finalizers (&doomed_finalizers, &finalizers);
5972 mark_finalizer_list (&doomed_finalizers);
5974 gc_sweep ();
5976 /* Clear the mark bits that we set in certain root slots. */
5977 VECTOR_UNMARK (&buffer_defaults);
5978 VECTOR_UNMARK (&buffer_local_symbols);
5980 check_cons_list ();
5982 gc_in_progress = 0;
5984 unblock_input ();
5986 consing_since_gc = 0;
5987 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
5988 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
5990 gc_relative_threshold = 0;
5991 if (FLOATP (Vgc_cons_percentage))
5992 { /* Set gc_cons_combined_threshold. */
5993 double tot = total_bytes_of_live_objects ();
5995 tot *= XFLOAT_DATA (Vgc_cons_percentage);
5996 if (0 < tot)
5998 if (tot < TYPE_MAXIMUM (EMACS_INT))
5999 gc_relative_threshold = tot;
6000 else
6001 gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
6005 if (garbage_collection_messages && NILP (Vmemory_full))
6007 if (message_p || minibuf_level > 0)
6008 restore_message ();
6009 else
6010 message1_nolog ("Garbage collecting...done");
6013 unbind_to (count, Qnil);
6015 Lisp_Object total[] = {
6016 list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
6017 bounded_number (total_conses),
6018 bounded_number (total_free_conses)),
6019 list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
6020 bounded_number (total_symbols),
6021 bounded_number (total_free_symbols)),
6022 list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
6023 bounded_number (total_markers),
6024 bounded_number (total_free_markers)),
6025 list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
6026 bounded_number (total_strings),
6027 bounded_number (total_free_strings)),
6028 list3 (Qstring_bytes, make_number (1),
6029 bounded_number (total_string_bytes)),
6030 list3 (Qvectors,
6031 make_number (header_size + sizeof (Lisp_Object)),
6032 bounded_number (total_vectors)),
6033 list4 (Qvector_slots, make_number (word_size),
6034 bounded_number (total_vector_slots),
6035 bounded_number (total_free_vector_slots)),
6036 list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
6037 bounded_number (total_floats),
6038 bounded_number (total_free_floats)),
6039 list4 (Qintervals, make_number (sizeof (struct interval)),
6040 bounded_number (total_intervals),
6041 bounded_number (total_free_intervals)),
6042 list3 (Qbuffers, make_number (sizeof (struct buffer)),
6043 bounded_number (total_buffers)),
6045 #ifdef DOUG_LEA_MALLOC
6046 list4 (Qheap, make_number (1024),
6047 bounded_number ((mallinfo ().uordblks + 1023) >> 10),
6048 bounded_number ((mallinfo ().fordblks + 1023) >> 10)),
6049 #endif
6051 retval = CALLMANY (Flist, total);
6053 /* GC is complete: now we can run our finalizer callbacks. */
6054 run_finalizers (&doomed_finalizers);
6056 if (!NILP (Vpost_gc_hook))
6058 ptrdiff_t gc_count = inhibit_garbage_collection ();
6059 safe_run_hooks (Qpost_gc_hook);
6060 unbind_to (gc_count, Qnil);
6063 /* Accumulate statistics. */
6064 if (FLOATP (Vgc_elapsed))
6066 struct timespec since_start = timespec_sub (current_timespec (), start);
6067 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
6068 + timespectod (since_start));
6071 gcs_done++;
6073 /* Collect profiling data. */
6074 if (profiler_memory_running)
6076 size_t swept = 0;
6077 size_t tot_after = total_bytes_of_live_objects ();
6078 if (tot_before > tot_after)
6079 swept = tot_before - tot_after;
6080 malloc_probe (swept);
6083 return retval;
6086 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
6087 doc: /* Reclaim storage for Lisp objects no longer needed.
6088 Garbage collection happens automatically if you cons more than
6089 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
6090 `garbage-collect' normally returns a list with info on amount of space in use,
6091 where each entry has the form (NAME SIZE USED FREE), where:
6092 - NAME is a symbol describing the kind of objects this entry represents,
6093 - SIZE is the number of bytes used by each one,
6094 - USED is the number of those objects that were found live in the heap,
6095 - FREE is the number of those objects that are not live but that Emacs
6096 keeps around for future allocations (maybe because it does not know how
6097 to return them to the OS).
6098 However, if there was overflow in pure space, `garbage-collect'
6099 returns nil, because real GC can't be done.
6100 See Info node `(elisp)Garbage Collection'. */)
6101 (void)
6103 void *end;
6104 SET_STACK_TOP_ADDRESS (&end);
6105 return garbage_collect_1 (end);
6108 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
6109 only interesting objects referenced from glyphs are strings. */
6111 static void
6112 mark_glyph_matrix (struct glyph_matrix *matrix)
6114 struct glyph_row *row = matrix->rows;
6115 struct glyph_row *end = row + matrix->nrows;
6117 for (; row < end; ++row)
6118 if (row->enabled_p)
6120 int area;
6121 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
6123 struct glyph *glyph = row->glyphs[area];
6124 struct glyph *end_glyph = glyph + row->used[area];
6126 for (; glyph < end_glyph; ++glyph)
6127 if (STRINGP (glyph->object)
6128 && !STRING_MARKED_P (XSTRING (glyph->object)))
6129 mark_object (glyph->object);
6134 /* Mark reference to a Lisp_Object.
6135 If the object referred to has not been seen yet, recursively mark
6136 all the references contained in it. */
6138 #define LAST_MARKED_SIZE 500
6139 Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
6140 static int last_marked_index;
6142 /* For debugging--call abort when we cdr down this many
6143 links of a list, in mark_object. In debugging,
6144 the call to abort will hit a breakpoint.
6145 Normally this is zero and the check never goes off. */
6146 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
6148 static void
6149 mark_vectorlike (struct Lisp_Vector *ptr)
6151 ptrdiff_t size = ptr->header.size;
6152 ptrdiff_t i;
6154 eassert (!VECTOR_MARKED_P (ptr));
6155 VECTOR_MARK (ptr); /* Else mark it. */
6156 if (size & PSEUDOVECTOR_FLAG)
6157 size &= PSEUDOVECTOR_SIZE_MASK;
6159 /* Note that this size is not the memory-footprint size, but only
6160 the number of Lisp_Object fields that we should trace.
6161 The distinction is used e.g. by Lisp_Process which places extra
6162 non-Lisp_Object fields at the end of the structure... */
6163 for (i = 0; i < size; i++) /* ...and then mark its elements. */
6164 mark_object (ptr->contents[i]);
6167 /* Like mark_vectorlike but optimized for char-tables (and
6168 sub-char-tables) assuming that the contents are mostly integers or
6169 symbols. */
6171 static void
6172 mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
6174 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6175 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
6176 int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
6178 eassert (!VECTOR_MARKED_P (ptr));
6179 VECTOR_MARK (ptr);
6180 for (i = idx; i < size; i++)
6182 Lisp_Object val = ptr->contents[i];
6184 if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
6185 continue;
6186 if (SUB_CHAR_TABLE_P (val))
6188 if (! VECTOR_MARKED_P (XVECTOR (val)))
6189 mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
6191 else
6192 mark_object (val);
6196 NO_INLINE /* To reduce stack depth in mark_object. */
6197 static Lisp_Object
6198 mark_compiled (struct Lisp_Vector *ptr)
6200 int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6202 VECTOR_MARK (ptr);
6203 for (i = 0; i < size; i++)
6204 if (i != COMPILED_CONSTANTS)
6205 mark_object (ptr->contents[i]);
6206 return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
6209 /* Mark the chain of overlays starting at PTR. */
6211 static void
6212 mark_overlay (struct Lisp_Overlay *ptr)
6214 for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
6216 ptr->gcmarkbit = 1;
6217 /* These two are always markers and can be marked fast. */
6218 XMARKER (ptr->start)->gcmarkbit = 1;
6219 XMARKER (ptr->end)->gcmarkbit = 1;
6220 mark_object (ptr->plist);
6224 /* Mark Lisp_Objects and special pointers in BUFFER. */
6226 static void
6227 mark_buffer (struct buffer *buffer)
6229 /* This is handled much like other pseudovectors... */
6230 mark_vectorlike ((struct Lisp_Vector *) buffer);
6232 /* ...but there are some buffer-specific things. */
6234 MARK_INTERVAL_TREE (buffer_intervals (buffer));
6236 /* For now, we just don't mark the undo_list. It's done later in
6237 a special way just before the sweep phase, and after stripping
6238 some of its elements that are not needed any more. */
6240 mark_overlay (buffer->overlays_before);
6241 mark_overlay (buffer->overlays_after);
6243 /* If this is an indirect buffer, mark its base buffer. */
6244 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
6245 mark_buffer (buffer->base_buffer);
6248 /* Mark Lisp faces in the face cache C. */
6250 NO_INLINE /* To reduce stack depth in mark_object. */
6251 static void
6252 mark_face_cache (struct face_cache *c)
6254 if (c)
6256 int i, j;
6257 for (i = 0; i < c->used; ++i)
6259 struct face *face = FACE_FROM_ID_OR_NULL (c->f, i);
6261 if (face)
6263 if (face->font && !VECTOR_MARKED_P (face->font))
6264 mark_vectorlike ((struct Lisp_Vector *) face->font);
6266 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
6267 mark_object (face->lface[j]);
6273 NO_INLINE /* To reduce stack depth in mark_object. */
6274 static void
6275 mark_localized_symbol (struct Lisp_Symbol *ptr)
6277 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
6278 Lisp_Object where = blv->where;
6279 /* If the value is set up for a killed buffer or deleted
6280 frame, restore its global binding. If the value is
6281 forwarded to a C variable, either it's not a Lisp_Object
6282 var, or it's staticpro'd already. */
6283 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
6284 || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
6285 swap_in_global_binding (ptr);
6286 mark_object (blv->where);
6287 mark_object (blv->valcell);
6288 mark_object (blv->defcell);
6291 NO_INLINE /* To reduce stack depth in mark_object. */
6292 static void
6293 mark_save_value (struct Lisp_Save_Value *ptr)
6295 /* If `save_type' is zero, `data[0].pointer' is the address
6296 of a memory area containing `data[1].integer' potential
6297 Lisp_Objects. */
6298 if (ptr->save_type == SAVE_TYPE_MEMORY)
6300 Lisp_Object *p = ptr->data[0].pointer;
6301 ptrdiff_t nelt;
6302 for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
6303 mark_maybe_object (*p);
6305 else
6307 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6308 int i;
6309 for (i = 0; i < SAVE_VALUE_SLOTS; i++)
6310 if (save_type (ptr, i) == SAVE_OBJECT)
6311 mark_object (ptr->data[i].object);
6315 /* Remove killed buffers or items whose car is a killed buffer from
6316 LIST, and mark other items. Return changed LIST, which is marked. */
6318 static Lisp_Object
6319 mark_discard_killed_buffers (Lisp_Object list)
6321 Lisp_Object tail, *prev = &list;
6323 for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
6324 tail = XCDR (tail))
6326 Lisp_Object tem = XCAR (tail);
6327 if (CONSP (tem))
6328 tem = XCAR (tem);
6329 if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem)))
6330 *prev = XCDR (tail);
6331 else
6333 CONS_MARK (XCONS (tail));
6334 mark_object (XCAR (tail));
6335 prev = xcdr_addr (tail);
6338 mark_object (tail);
6339 return list;
6342 /* Determine type of generic Lisp_Object and mark it accordingly.
6344 This function implements a straightforward depth-first marking
6345 algorithm and so the recursion depth may be very high (a few
6346 tens of thousands is not uncommon). To minimize stack usage,
6347 a few cold paths are moved out to NO_INLINE functions above.
6348 In general, inlining them doesn't help you to gain more speed. */
6350 void
6351 mark_object (Lisp_Object arg)
6353 register Lisp_Object obj;
6354 void *po;
6355 #if GC_CHECK_MARKED_OBJECTS
6356 struct mem_node *m;
6357 #endif
6358 ptrdiff_t cdr_count = 0;
6360 obj = arg;
6361 loop:
6363 po = XPNTR (obj);
6364 if (PURE_P (po))
6365 return;
6367 last_marked[last_marked_index++] = obj;
6368 if (last_marked_index == LAST_MARKED_SIZE)
6369 last_marked_index = 0;
6371 /* Perform some sanity checks on the objects marked here. Abort if
6372 we encounter an object we know is bogus. This increases GC time
6373 by ~80%. */
6374 #if GC_CHECK_MARKED_OBJECTS
6376 /* Check that the object pointed to by PO is known to be a Lisp
6377 structure allocated from the heap. */
6378 #define CHECK_ALLOCATED() \
6379 do { \
6380 m = mem_find (po); \
6381 if (m == MEM_NIL) \
6382 emacs_abort (); \
6383 } while (0)
6385 /* Check that the object pointed to by PO is live, using predicate
6386 function LIVEP. */
6387 #define CHECK_LIVE(LIVEP) \
6388 do { \
6389 if (!LIVEP (m, po)) \
6390 emacs_abort (); \
6391 } while (0)
6393 /* Check both of the above conditions, for non-symbols. */
6394 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6395 do { \
6396 CHECK_ALLOCATED (); \
6397 CHECK_LIVE (LIVEP); \
6398 } while (0) \
6400 /* Check both of the above conditions, for symbols. */
6401 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6402 do { \
6403 if (!c_symbol_p (ptr)) \
6405 CHECK_ALLOCATED (); \
6406 CHECK_LIVE (live_symbol_p); \
6408 } while (0) \
6410 #else /* not GC_CHECK_MARKED_OBJECTS */
6412 #define CHECK_LIVE(LIVEP) ((void) 0)
6413 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6414 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6416 #endif /* not GC_CHECK_MARKED_OBJECTS */
6418 switch (XTYPE (obj))
6420 case Lisp_String:
6422 register struct Lisp_String *ptr = XSTRING (obj);
6423 if (STRING_MARKED_P (ptr))
6424 break;
6425 CHECK_ALLOCATED_AND_LIVE (live_string_p);
6426 MARK_STRING (ptr);
6427 MARK_INTERVAL_TREE (ptr->intervals);
6428 #ifdef GC_CHECK_STRING_BYTES
6429 /* Check that the string size recorded in the string is the
6430 same as the one recorded in the sdata structure. */
6431 string_bytes (ptr);
6432 #endif /* GC_CHECK_STRING_BYTES */
6434 break;
6436 case Lisp_Vectorlike:
6438 register struct Lisp_Vector *ptr = XVECTOR (obj);
6440 if (VECTOR_MARKED_P (ptr))
6441 break;
6443 #if GC_CHECK_MARKED_OBJECTS
6444 m = mem_find (po);
6445 if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
6446 emacs_abort ();
6447 #endif /* GC_CHECK_MARKED_OBJECTS */
6449 enum pvec_type pvectype
6450 = PSEUDOVECTOR_TYPE (ptr);
6452 if (pvectype != PVEC_SUBR
6453 && pvectype != PVEC_BUFFER
6454 && !main_thread_p (po))
6455 CHECK_LIVE (live_vector_p);
6457 switch (pvectype)
6459 case PVEC_BUFFER:
6460 #if GC_CHECK_MARKED_OBJECTS
6462 struct buffer *b;
6463 FOR_EACH_BUFFER (b)
6464 if (b == po)
6465 break;
6466 if (b == NULL)
6467 emacs_abort ();
6469 #endif /* GC_CHECK_MARKED_OBJECTS */
6470 mark_buffer ((struct buffer *) ptr);
6471 break;
6473 case PVEC_COMPILED:
6474 /* Although we could treat this just like a vector, mark_compiled
6475 returns the COMPILED_CONSTANTS element, which is marked at the
6476 next iteration of goto-loop here. This is done to avoid a few
6477 recursive calls to mark_object. */
6478 obj = mark_compiled (ptr);
6479 if (!NILP (obj))
6480 goto loop;
6481 break;
6483 case PVEC_FRAME:
6485 struct frame *f = (struct frame *) ptr;
6487 mark_vectorlike (ptr);
6488 mark_face_cache (f->face_cache);
6489 #ifdef HAVE_WINDOW_SYSTEM
6490 if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
6492 struct font *font = FRAME_FONT (f);
6494 if (font && !VECTOR_MARKED_P (font))
6495 mark_vectorlike ((struct Lisp_Vector *) font);
6497 #endif
6499 break;
6501 case PVEC_WINDOW:
6503 struct window *w = (struct window *) ptr;
6505 mark_vectorlike (ptr);
6507 /* Mark glyph matrices, if any. Marking window
6508 matrices is sufficient because frame matrices
6509 use the same glyph memory. */
6510 if (w->current_matrix)
6512 mark_glyph_matrix (w->current_matrix);
6513 mark_glyph_matrix (w->desired_matrix);
6516 /* Filter out killed buffers from both buffer lists
6517 in attempt to help GC to reclaim killed buffers faster.
6518 We can do it elsewhere for live windows, but this is the
6519 best place to do it for dead windows. */
6520 wset_prev_buffers
6521 (w, mark_discard_killed_buffers (w->prev_buffers));
6522 wset_next_buffers
6523 (w, mark_discard_killed_buffers (w->next_buffers));
6525 break;
6527 case PVEC_HASH_TABLE:
6529 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
6531 mark_vectorlike (ptr);
6532 mark_object (h->test.name);
6533 mark_object (h->test.user_hash_function);
6534 mark_object (h->test.user_cmp_function);
6535 /* If hash table is not weak, mark all keys and values.
6536 For weak tables, mark only the vector. */
6537 if (NILP (h->weak))
6538 mark_object (h->key_and_value);
6539 else
6540 VECTOR_MARK (XVECTOR (h->key_and_value));
6542 break;
6544 case PVEC_CHAR_TABLE:
6545 case PVEC_SUB_CHAR_TABLE:
6546 mark_char_table (ptr, (enum pvec_type) pvectype);
6547 break;
6549 case PVEC_BOOL_VECTOR:
6550 /* No Lisp_Objects to mark in a bool vector. */
6551 VECTOR_MARK (ptr);
6552 break;
6554 case PVEC_SUBR:
6555 break;
6557 case PVEC_FREE:
6558 emacs_abort ();
6560 default:
6561 mark_vectorlike (ptr);
6564 break;
6566 case Lisp_Symbol:
6568 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
6569 nextsym:
6570 if (ptr->gcmarkbit)
6571 break;
6572 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6573 ptr->gcmarkbit = 1;
6574 /* Attempt to catch bogus objects. */
6575 eassert (valid_lisp_object_p (ptr->function));
6576 mark_object (ptr->function);
6577 mark_object (ptr->plist);
6578 switch (ptr->redirect)
6580 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
6581 case SYMBOL_VARALIAS:
6583 Lisp_Object tem;
6584 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
6585 mark_object (tem);
6586 break;
6588 case SYMBOL_LOCALIZED:
6589 mark_localized_symbol (ptr);
6590 break;
6591 case SYMBOL_FORWARDED:
6592 /* If the value is forwarded to a buffer or keyboard field,
6593 these are marked when we see the corresponding object.
6594 And if it's forwarded to a C variable, either it's not
6595 a Lisp_Object var, or it's staticpro'd already. */
6596 break;
6597 default: emacs_abort ();
6599 if (!PURE_P (XSTRING (ptr->name)))
6600 MARK_STRING (XSTRING (ptr->name));
6601 MARK_INTERVAL_TREE (string_intervals (ptr->name));
6602 /* Inner loop to mark next symbol in this bucket, if any. */
6603 po = ptr = ptr->next;
6604 if (ptr)
6605 goto nextsym;
6607 break;
6609 case Lisp_Misc:
6610 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
6612 if (XMISCANY (obj)->gcmarkbit)
6613 break;
6615 switch (XMISCTYPE (obj))
6617 case Lisp_Misc_Marker:
6618 /* DO NOT mark thru the marker's chain.
6619 The buffer's markers chain does not preserve markers from gc;
6620 instead, markers are removed from the chain when freed by gc. */
6621 XMISCANY (obj)->gcmarkbit = 1;
6622 break;
6624 case Lisp_Misc_Save_Value:
6625 XMISCANY (obj)->gcmarkbit = 1;
6626 mark_save_value (XSAVE_VALUE (obj));
6627 break;
6629 case Lisp_Misc_Overlay:
6630 mark_overlay (XOVERLAY (obj));
6631 break;
6633 case Lisp_Misc_Finalizer:
6634 XMISCANY (obj)->gcmarkbit = true;
6635 mark_object (XFINALIZER (obj)->function);
6636 break;
6638 #ifdef HAVE_MODULES
6639 case Lisp_Misc_User_Ptr:
6640 XMISCANY (obj)->gcmarkbit = true;
6641 break;
6642 #endif
6644 default:
6645 emacs_abort ();
6647 break;
6649 case Lisp_Cons:
6651 register struct Lisp_Cons *ptr = XCONS (obj);
6652 if (CONS_MARKED_P (ptr))
6653 break;
6654 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
6655 CONS_MARK (ptr);
6656 /* If the cdr is nil, avoid recursion for the car. */
6657 if (EQ (ptr->u.cdr, Qnil))
6659 obj = ptr->car;
6660 cdr_count = 0;
6661 goto loop;
6663 mark_object (ptr->car);
6664 obj = ptr->u.cdr;
6665 cdr_count++;
6666 if (cdr_count == mark_object_loop_halt)
6667 emacs_abort ();
6668 goto loop;
6671 case Lisp_Float:
6672 CHECK_ALLOCATED_AND_LIVE (live_float_p);
6673 FLOAT_MARK (XFLOAT (obj));
6674 break;
6676 case_Lisp_Int:
6677 break;
6679 default:
6680 emacs_abort ();
6683 #undef CHECK_LIVE
6684 #undef CHECK_ALLOCATED
6685 #undef CHECK_ALLOCATED_AND_LIVE
6687 /* Mark the Lisp pointers in the terminal objects.
6688 Called by Fgarbage_collect. */
6690 static void
6691 mark_terminals (void)
6693 struct terminal *t;
6694 for (t = terminal_list; t; t = t->next_terminal)
6696 eassert (t->name != NULL);
6697 #ifdef HAVE_WINDOW_SYSTEM
6698 /* If a terminal object is reachable from a stacpro'ed object,
6699 it might have been marked already. Make sure the image cache
6700 gets marked. */
6701 mark_image_cache (t->image_cache);
6702 #endif /* HAVE_WINDOW_SYSTEM */
6703 if (!VECTOR_MARKED_P (t))
6704 mark_vectorlike ((struct Lisp_Vector *)t);
6710 /* Value is non-zero if OBJ will survive the current GC because it's
6711 either marked or does not need to be marked to survive. */
6713 bool
6714 survives_gc_p (Lisp_Object obj)
6716 bool survives_p;
6718 switch (XTYPE (obj))
6720 case_Lisp_Int:
6721 survives_p = 1;
6722 break;
6724 case Lisp_Symbol:
6725 survives_p = XSYMBOL (obj)->gcmarkbit;
6726 break;
6728 case Lisp_Misc:
6729 survives_p = XMISCANY (obj)->gcmarkbit;
6730 break;
6732 case Lisp_String:
6733 survives_p = STRING_MARKED_P (XSTRING (obj));
6734 break;
6736 case Lisp_Vectorlike:
6737 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
6738 break;
6740 case Lisp_Cons:
6741 survives_p = CONS_MARKED_P (XCONS (obj));
6742 break;
6744 case Lisp_Float:
6745 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
6746 break;
6748 default:
6749 emacs_abort ();
6752 return survives_p || PURE_P (XPNTR (obj));
6758 NO_INLINE /* For better stack traces */
6759 static void
6760 sweep_conses (void)
6762 struct cons_block *cblk;
6763 struct cons_block **cprev = &cons_block;
6764 int lim = cons_block_index;
6765 EMACS_INT num_free = 0, num_used = 0;
6767 cons_free_list = 0;
6769 for (cblk = cons_block; cblk; cblk = *cprev)
6771 int i = 0;
6772 int this_free = 0;
6773 int ilim = (lim + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
6775 /* Scan the mark bits an int at a time. */
6776 for (i = 0; i < ilim; i++)
6778 if (cblk->gcmarkbits[i] == BITS_WORD_MAX)
6780 /* Fast path - all cons cells for this int are marked. */
6781 cblk->gcmarkbits[i] = 0;
6782 num_used += BITS_PER_BITS_WORD;
6784 else
6786 /* Some cons cells for this int are not marked.
6787 Find which ones, and free them. */
6788 int start, pos, stop;
6790 start = i * BITS_PER_BITS_WORD;
6791 stop = lim - start;
6792 if (stop > BITS_PER_BITS_WORD)
6793 stop = BITS_PER_BITS_WORD;
6794 stop += start;
6796 for (pos = start; pos < stop; pos++)
6798 if (!CONS_MARKED_P (&cblk->conses[pos]))
6800 this_free++;
6801 cblk->conses[pos].u.chain = cons_free_list;
6802 cons_free_list = &cblk->conses[pos];
6803 cons_free_list->car = Vdead;
6805 else
6807 num_used++;
6808 CONS_UNMARK (&cblk->conses[pos]);
6814 lim = CONS_BLOCK_SIZE;
6815 /* If this block contains only free conses and we have already
6816 seen more than two blocks worth of free conses then deallocate
6817 this block. */
6818 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
6820 *cprev = cblk->next;
6821 /* Unhook from the free list. */
6822 cons_free_list = cblk->conses[0].u.chain;
6823 lisp_align_free (cblk);
6825 else
6827 num_free += this_free;
6828 cprev = &cblk->next;
6831 total_conses = num_used;
6832 total_free_conses = num_free;
6835 NO_INLINE /* For better stack traces */
6836 static void
6837 sweep_floats (void)
6839 register struct float_block *fblk;
6840 struct float_block **fprev = &float_block;
6841 register int lim = float_block_index;
6842 EMACS_INT num_free = 0, num_used = 0;
6844 float_free_list = 0;
6846 for (fblk = float_block; fblk; fblk = *fprev)
6848 register int i;
6849 int this_free = 0;
6850 for (i = 0; i < lim; i++)
6851 if (!FLOAT_MARKED_P (&fblk->floats[i]))
6853 this_free++;
6854 fblk->floats[i].u.chain = float_free_list;
6855 float_free_list = &fblk->floats[i];
6857 else
6859 num_used++;
6860 FLOAT_UNMARK (&fblk->floats[i]);
6862 lim = FLOAT_BLOCK_SIZE;
6863 /* If this block contains only free floats and we have already
6864 seen more than two blocks worth of free floats then deallocate
6865 this block. */
6866 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
6868 *fprev = fblk->next;
6869 /* Unhook from the free list. */
6870 float_free_list = fblk->floats[0].u.chain;
6871 lisp_align_free (fblk);
6873 else
6875 num_free += this_free;
6876 fprev = &fblk->next;
6879 total_floats = num_used;
6880 total_free_floats = num_free;
6883 NO_INLINE /* For better stack traces */
6884 static void
6885 sweep_intervals (void)
6887 register struct interval_block *iblk;
6888 struct interval_block **iprev = &interval_block;
6889 register int lim = interval_block_index;
6890 EMACS_INT num_free = 0, num_used = 0;
6892 interval_free_list = 0;
6894 for (iblk = interval_block; iblk; iblk = *iprev)
6896 register int i;
6897 int this_free = 0;
6899 for (i = 0; i < lim; i++)
6901 if (!iblk->intervals[i].gcmarkbit)
6903 set_interval_parent (&iblk->intervals[i], interval_free_list);
6904 interval_free_list = &iblk->intervals[i];
6905 this_free++;
6907 else
6909 num_used++;
6910 iblk->intervals[i].gcmarkbit = 0;
6913 lim = INTERVAL_BLOCK_SIZE;
6914 /* If this block contains only free intervals and we have already
6915 seen more than two blocks worth of free intervals then
6916 deallocate this block. */
6917 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6919 *iprev = iblk->next;
6920 /* Unhook from the free list. */
6921 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
6922 lisp_free (iblk);
6924 else
6926 num_free += this_free;
6927 iprev = &iblk->next;
6930 total_intervals = num_used;
6931 total_free_intervals = num_free;
6934 NO_INLINE /* For better stack traces */
6935 static void
6936 sweep_symbols (void)
6938 struct symbol_block *sblk;
6939 struct symbol_block **sprev = &symbol_block;
6940 int lim = symbol_block_index;
6941 EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym);
6943 symbol_free_list = NULL;
6945 for (int i = 0; i < ARRAYELTS (lispsym); i++)
6946 lispsym[i].s.gcmarkbit = 0;
6948 for (sblk = symbol_block; sblk; sblk = *sprev)
6950 int this_free = 0;
6951 union aligned_Lisp_Symbol *sym = sblk->symbols;
6952 union aligned_Lisp_Symbol *end = sym + lim;
6954 for (; sym < end; ++sym)
6956 if (!sym->s.gcmarkbit)
6958 if (sym->s.redirect == SYMBOL_LOCALIZED)
6959 xfree (SYMBOL_BLV (&sym->s));
6960 sym->s.next = symbol_free_list;
6961 symbol_free_list = &sym->s;
6962 symbol_free_list->function = Vdead;
6963 ++this_free;
6965 else
6967 ++num_used;
6968 sym->s.gcmarkbit = 0;
6969 /* Attempt to catch bogus objects. */
6970 eassert (valid_lisp_object_p (sym->s.function));
6974 lim = SYMBOL_BLOCK_SIZE;
6975 /* If this block contains only free symbols and we have already
6976 seen more than two blocks worth of free symbols then deallocate
6977 this block. */
6978 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6980 *sprev = sblk->next;
6981 /* Unhook from the free list. */
6982 symbol_free_list = sblk->symbols[0].s.next;
6983 lisp_free (sblk);
6985 else
6987 num_free += this_free;
6988 sprev = &sblk->next;
6991 total_symbols = num_used;
6992 total_free_symbols = num_free;
6995 NO_INLINE /* For better stack traces. */
6996 static void
6997 sweep_misc (void)
6999 register struct marker_block *mblk;
7000 struct marker_block **mprev = &marker_block;
7001 register int lim = marker_block_index;
7002 EMACS_INT num_free = 0, num_used = 0;
7004 /* Put all unmarked misc's on free list. For a marker, first
7005 unchain it from the buffer it points into. */
7007 marker_free_list = 0;
7009 for (mblk = marker_block; mblk; mblk = *mprev)
7011 register int i;
7012 int this_free = 0;
7014 for (i = 0; i < lim; i++)
7016 if (!mblk->markers[i].m.u_any.gcmarkbit)
7018 if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
7019 unchain_marker (&mblk->markers[i].m.u_marker);
7020 else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
7021 unchain_finalizer (&mblk->markers[i].m.u_finalizer);
7022 #ifdef HAVE_MODULES
7023 else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
7025 struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr;
7026 if (uptr->finalizer)
7027 uptr->finalizer (uptr->p);
7029 #endif
7030 /* Set the type of the freed object to Lisp_Misc_Free.
7031 We could leave the type alone, since nobody checks it,
7032 but this might catch bugs faster. */
7033 mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
7034 mblk->markers[i].m.u_free.chain = marker_free_list;
7035 marker_free_list = &mblk->markers[i].m;
7036 this_free++;
7038 else
7040 num_used++;
7041 mblk->markers[i].m.u_any.gcmarkbit = 0;
7044 lim = MARKER_BLOCK_SIZE;
7045 /* If this block contains only free markers and we have already
7046 seen more than two blocks worth of free markers then deallocate
7047 this block. */
7048 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
7050 *mprev = mblk->next;
7051 /* Unhook from the free list. */
7052 marker_free_list = mblk->markers[0].m.u_free.chain;
7053 lisp_free (mblk);
7055 else
7057 num_free += this_free;
7058 mprev = &mblk->next;
7062 total_markers = num_used;
7063 total_free_markers = num_free;
7066 NO_INLINE /* For better stack traces */
7067 static void
7068 sweep_buffers (void)
7070 register struct buffer *buffer, **bprev = &all_buffers;
7072 total_buffers = 0;
7073 for (buffer = all_buffers; buffer; buffer = *bprev)
7074 if (!VECTOR_MARKED_P (buffer))
7076 *bprev = buffer->next;
7077 lisp_free (buffer);
7079 else
7081 VECTOR_UNMARK (buffer);
7082 /* Do not use buffer_(set|get)_intervals here. */
7083 buffer->text->intervals = balance_intervals (buffer->text->intervals);
7084 total_buffers++;
7085 bprev = &buffer->next;
7089 /* Sweep: find all structures not marked, and free them. */
7090 static void
7091 gc_sweep (void)
7093 /* Remove or mark entries in weak hash tables.
7094 This must be done before any object is unmarked. */
7095 sweep_weak_hash_tables ();
7097 sweep_strings ();
7098 check_string_bytes (!noninteractive);
7099 sweep_conses ();
7100 sweep_floats ();
7101 sweep_intervals ();
7102 sweep_symbols ();
7103 sweep_misc ();
7104 sweep_buffers ();
7105 sweep_vectors ();
7106 check_string_bytes (!noninteractive);
7109 DEFUN ("memory-info", Fmemory_info, Smemory_info, 0, 0, 0,
7110 doc: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
7111 All values are in Kbytes. If there is no swap space,
7112 last two values are zero. If the system is not supported
7113 or memory information can't be obtained, return nil. */)
7114 (void)
7116 #if defined HAVE_LINUX_SYSINFO
7117 struct sysinfo si;
7118 uintmax_t units;
7120 if (sysinfo (&si))
7121 return Qnil;
7122 #ifdef LINUX_SYSINFO_UNIT
7123 units = si.mem_unit;
7124 #else
7125 units = 1;
7126 #endif
7127 return list4i ((uintmax_t) si.totalram * units / 1024,
7128 (uintmax_t) si.freeram * units / 1024,
7129 (uintmax_t) si.totalswap * units / 1024,
7130 (uintmax_t) si.freeswap * units / 1024);
7131 #elif defined WINDOWSNT
7132 unsigned long long totalram, freeram, totalswap, freeswap;
7134 if (w32_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
7135 return list4i ((uintmax_t) totalram / 1024,
7136 (uintmax_t) freeram / 1024,
7137 (uintmax_t) totalswap / 1024,
7138 (uintmax_t) freeswap / 1024);
7139 else
7140 return Qnil;
7141 #elif defined MSDOS
7142 unsigned long totalram, freeram, totalswap, freeswap;
7144 if (dos_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
7145 return list4i ((uintmax_t) totalram / 1024,
7146 (uintmax_t) freeram / 1024,
7147 (uintmax_t) totalswap / 1024,
7148 (uintmax_t) freeswap / 1024);
7149 else
7150 return Qnil;
7151 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7152 /* FIXME: add more systems. */
7153 return Qnil;
7154 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7157 /* Debugging aids. */
7159 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
7160 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
7161 This may be helpful in debugging Emacs's memory usage.
7162 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
7163 (void)
7165 Lisp_Object end;
7167 #if defined HAVE_NS || defined __APPLE__ || !HAVE_SBRK
7168 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
7169 XSETINT (end, 0);
7170 #else
7171 XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
7172 #endif
7174 return end;
7177 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
7178 doc: /* Return a list of counters that measure how much consing there has been.
7179 Each of these counters increments for a certain kind of object.
7180 The counters wrap around from the largest positive integer to zero.
7181 Garbage collection does not decrease them.
7182 The elements of the value are as follows:
7183 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
7184 All are in units of 1 = one object consed
7185 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
7186 objects consed.
7187 MISCS include overlays, markers, and some internal types.
7188 Frames, windows, buffers, and subprocesses count as vectors
7189 (but the contents of a buffer's text do not count here). */)
7190 (void)
7192 return listn (CONSTYPE_HEAP, 8,
7193 bounded_number (cons_cells_consed),
7194 bounded_number (floats_consed),
7195 bounded_number (vector_cells_consed),
7196 bounded_number (symbols_consed),
7197 bounded_number (string_chars_consed),
7198 bounded_number (misc_objects_consed),
7199 bounded_number (intervals_consed),
7200 bounded_number (strings_consed));
7203 static bool
7204 symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
7206 struct Lisp_Symbol *sym = XSYMBOL (symbol);
7207 Lisp_Object val = find_symbol_value (symbol);
7208 return (EQ (val, obj)
7209 || EQ (sym->function, obj)
7210 || (!NILP (sym->function)
7211 && COMPILEDP (sym->function)
7212 && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
7213 || (!NILP (val)
7214 && COMPILEDP (val)
7215 && EQ (AREF (val, COMPILED_BYTECODE), obj)));
7218 /* Find at most FIND_MAX symbols which have OBJ as their value or
7219 function. This is used in gdbinit's `xwhichsymbols' command. */
7221 Lisp_Object
7222 which_symbols (Lisp_Object obj, EMACS_INT find_max)
7224 struct symbol_block *sblk;
7225 ptrdiff_t gc_count = inhibit_garbage_collection ();
7226 Lisp_Object found = Qnil;
7228 if (! DEADP (obj))
7230 for (int i = 0; i < ARRAYELTS (lispsym); i++)
7232 Lisp_Object sym = builtin_lisp_symbol (i);
7233 if (symbol_uses_obj (sym, obj))
7235 found = Fcons (sym, found);
7236 if (--find_max == 0)
7237 goto out;
7241 for (sblk = symbol_block; sblk; sblk = sblk->next)
7243 union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
7244 int bn;
7246 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++)
7248 if (sblk == symbol_block && bn >= symbol_block_index)
7249 break;
7251 Lisp_Object sym = make_lisp_symbol (&aligned_sym->s);
7252 if (symbol_uses_obj (sym, obj))
7254 found = Fcons (sym, found);
7255 if (--find_max == 0)
7256 goto out;
7262 out:
7263 unbind_to (gc_count, Qnil);
7264 return found;
7267 #ifdef SUSPICIOUS_OBJECT_CHECKING
7269 static void *
7270 find_suspicious_object_in_range (void *begin, void *end)
7272 char *begin_a = begin;
7273 char *end_a = end;
7274 int i;
7276 for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
7278 char *suspicious_object = suspicious_objects[i];
7279 if (begin_a <= suspicious_object && suspicious_object < end_a)
7280 return suspicious_object;
7283 return NULL;
7286 static void
7287 note_suspicious_free (void *ptr)
7289 struct suspicious_free_record *rec;
7291 rec = &suspicious_free_history[suspicious_free_history_index++];
7292 if (suspicious_free_history_index ==
7293 ARRAYELTS (suspicious_free_history))
7295 suspicious_free_history_index = 0;
7298 memset (rec, 0, sizeof (*rec));
7299 rec->suspicious_object = ptr;
7300 backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace));
7303 static void
7304 detect_suspicious_free (void *ptr)
7306 int i;
7308 eassert (ptr != NULL);
7310 for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
7311 if (suspicious_objects[i] == ptr)
7313 note_suspicious_free (ptr);
7314 suspicious_objects[i] = NULL;
7318 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7320 DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
7321 doc: /* Return OBJ, maybe marking it for extra scrutiny.
7322 If Emacs is compiled with suspicious object checking, capture
7323 a stack trace when OBJ is freed in order to help track down
7324 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7325 (Lisp_Object obj)
7327 #ifdef SUSPICIOUS_OBJECT_CHECKING
7328 /* Right now, we care only about vectors. */
7329 if (VECTORLIKEP (obj))
7331 suspicious_objects[suspicious_object_index++] = XVECTOR (obj);
7332 if (suspicious_object_index == ARRAYELTS (suspicious_objects))
7333 suspicious_object_index = 0;
7335 #endif
7336 return obj;
7339 #ifdef ENABLE_CHECKING
7341 bool suppress_checking;
7343 void
7344 die (const char *msg, const char *file, int line)
7346 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7347 file, line, msg);
7348 terminate_due_to_signal (SIGABRT, INT_MAX);
7351 #endif /* ENABLE_CHECKING */
7353 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7355 /* Stress alloca with inconveniently sized requests and check
7356 whether all allocated areas may be used for Lisp_Object. */
7358 NO_INLINE static void
7359 verify_alloca (void)
7361 int i;
7362 enum { ALLOCA_CHECK_MAX = 256 };
7363 /* Start from size of the smallest Lisp object. */
7364 for (i = sizeof (struct Lisp_Cons); i <= ALLOCA_CHECK_MAX; i++)
7366 void *ptr = alloca (i);
7367 make_lisp_ptr (ptr, Lisp_Cons);
7371 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7373 #define verify_alloca() ((void) 0)
7375 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7377 /* Initialization. */
7379 void
7380 init_alloc_once (void)
7382 /* Even though Qt's contents are not set up, its address is known. */
7383 Vpurify_flag = Qt;
7385 purebeg = PUREBEG;
7386 pure_size = PURESIZE;
7388 verify_alloca ();
7389 init_finalizer_list (&finalizers);
7390 init_finalizer_list (&doomed_finalizers);
7392 mem_init ();
7393 Vdead = make_pure_string ("DEAD", 4, 4, 0);
7395 #ifdef DOUG_LEA_MALLOC
7396 mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
7397 mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
7398 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
7399 #endif
7400 init_strings ();
7401 init_vectors ();
7403 refill_memory_reserve ();
7404 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
7407 void
7408 init_alloc (void)
7410 Vgc_elapsed = make_float (0.0);
7411 gcs_done = 0;
7413 #if USE_VALGRIND
7414 valgrind_p = RUNNING_ON_VALGRIND != 0;
7415 #endif
7418 void
7419 syms_of_alloc (void)
7421 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
7422 doc: /* Number of bytes of consing between garbage collections.
7423 Garbage collection can happen automatically once this many bytes have been
7424 allocated since the last garbage collection. All data types count.
7426 Garbage collection happens automatically only when `eval' is called.
7428 By binding this temporarily to a large number, you can effectively
7429 prevent garbage collection during a part of the program.
7430 See also `gc-cons-percentage'. */);
7432 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
7433 doc: /* Portion of the heap used for allocation.
7434 Garbage collection can happen automatically once this portion of the heap
7435 has been allocated since the last garbage collection.
7436 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7437 Vgc_cons_percentage = make_float (0.1);
7439 DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
7440 doc: /* Number of bytes of shareable Lisp data allocated so far. */);
7442 DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
7443 doc: /* Number of cons cells that have been consed so far. */);
7445 DEFVAR_INT ("floats-consed", floats_consed,
7446 doc: /* Number of floats that have been consed so far. */);
7448 DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
7449 doc: /* Number of vector cells that have been consed so far. */);
7451 DEFVAR_INT ("symbols-consed", symbols_consed,
7452 doc: /* Number of symbols that have been consed so far. */);
7453 symbols_consed += ARRAYELTS (lispsym);
7455 DEFVAR_INT ("string-chars-consed", string_chars_consed,
7456 doc: /* Number of string characters that have been consed so far. */);
7458 DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
7459 doc: /* Number of miscellaneous objects that have been consed so far.
7460 These include markers and overlays, plus certain objects not visible
7461 to users. */);
7463 DEFVAR_INT ("intervals-consed", intervals_consed,
7464 doc: /* Number of intervals that have been consed so far. */);
7466 DEFVAR_INT ("strings-consed", strings_consed,
7467 doc: /* Number of strings that have been consed so far. */);
7469 DEFVAR_LISP ("purify-flag", Vpurify_flag,
7470 doc: /* Non-nil means loading Lisp code in order to dump an executable.
7471 This means that certain objects should be allocated in shared (pure) space.
7472 It can also be set to a hash-table, in which case this table is used to
7473 do hash-consing of the objects allocated to pure space. */);
7475 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
7476 doc: /* Non-nil means display messages at start and end of garbage collection. */);
7477 garbage_collection_messages = 0;
7479 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
7480 doc: /* Hook run after garbage collection has finished. */);
7481 Vpost_gc_hook = Qnil;
7482 DEFSYM (Qpost_gc_hook, "post-gc-hook");
7484 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
7485 doc: /* Precomputed `signal' argument for memory-full error. */);
7486 /* We build this in advance because if we wait until we need it, we might
7487 not be able to allocate the memory to hold it. */
7488 Vmemory_signal_data
7489 = listn (CONSTYPE_PURE, 2, Qerror,
7490 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7492 DEFVAR_LISP ("memory-full", Vmemory_full,
7493 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7494 Vmemory_full = Qnil;
7496 DEFSYM (Qconses, "conses");
7497 DEFSYM (Qsymbols, "symbols");
7498 DEFSYM (Qmiscs, "miscs");
7499 DEFSYM (Qstrings, "strings");
7500 DEFSYM (Qvectors, "vectors");
7501 DEFSYM (Qfloats, "floats");
7502 DEFSYM (Qintervals, "intervals");
7503 DEFSYM (Qbuffers, "buffers");
7504 DEFSYM (Qstring_bytes, "string-bytes");
7505 DEFSYM (Qvector_slots, "vector-slots");
7506 DEFSYM (Qheap, "heap");
7507 DEFSYM (QAutomatic_GC, "Automatic GC");
7509 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
7510 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
7512 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
7513 doc: /* Accumulated time elapsed in garbage collections.
7514 The time is in seconds as a floating point value. */);
7515 DEFVAR_INT ("gcs-done", gcs_done,
7516 doc: /* Accumulated number of garbage collections done. */);
7518 defsubr (&Scons);
7519 defsubr (&Slist);
7520 defsubr (&Svector);
7521 defsubr (&Srecord);
7522 defsubr (&Sbool_vector);
7523 defsubr (&Smake_byte_code);
7524 defsubr (&Smake_list);
7525 defsubr (&Smake_vector);
7526 defsubr (&Smake_record);
7527 defsubr (&Smake_string);
7528 defsubr (&Smake_bool_vector);
7529 defsubr (&Smake_symbol);
7530 defsubr (&Smake_marker);
7531 defsubr (&Smake_finalizer);
7532 defsubr (&Spurecopy);
7533 defsubr (&Sgarbage_collect);
7534 defsubr (&Smemory_limit);
7535 defsubr (&Smemory_info);
7536 defsubr (&Smemory_use_counts);
7537 defsubr (&Ssuspicious_object);
7540 /* When compiled with GCC, GDB might say "No enum type named
7541 pvec_type" if we don't have at least one symbol with that type, and
7542 then xbacktrace could fail. Similarly for the other enums and
7543 their values. Some non-GCC compilers don't like these constructs. */
7544 #ifdef __GNUC__
7545 union
7547 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
7548 enum char_table_specials char_table_specials;
7549 enum char_bits char_bits;
7550 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
7551 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
7552 enum Lisp_Bits Lisp_Bits;
7553 enum Lisp_Compiled Lisp_Compiled;
7554 enum maxargs maxargs;
7555 enum MAX_ALLOCA MAX_ALLOCA;
7556 enum More_Lisp_Bits More_Lisp_Bits;
7557 enum pvec_type pvec_type;
7558 } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
7559 #endif /* __GNUC__ */