* lisp/textmodes/table.el (table-insert): Don't use `symbol-name' on
[emacs.git] / src / alloc.c
blob5bb528c64ab4ff271515b3c67abbcffafb751b1b
1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4 Free Software 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
11 (at 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 #define LISP_INLINE EXTERN_INLINE
25 #include <stdio.h>
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
30 #endif
32 #ifdef HAVE_PTHREAD
33 #include <pthread.h>
34 #endif
36 #include "lisp.h"
37 #include "process.h"
38 #include "intervals.h"
39 #include "puresize.h"
40 #include "character.h"
41 #include "buffer.h"
42 #include "window.h"
43 #include "keyboard.h"
44 #include "frame.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
48 #include <verify.h>
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
52 #if ! GC_MARK_STACK
53 # undef GC_CHECK_MARKED_OBJECTS
54 #endif
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
58 marked objects. */
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
63 #endif
65 #include <unistd.h>
66 #ifndef HAVE_UNISTD_H
67 extern void *sbrk ();
68 #endif
70 #include <fcntl.h>
72 #ifdef USE_GTK
73 # include "gtkutil.h"
74 #endif
75 #ifdef WINDOWSNT
76 #include "w32.h"
77 #include "w32heap.h" /* for sbrk */
78 #endif
80 #ifdef DOUG_LEA_MALLOC
82 #include <malloc.h>
84 /* Specify maximum number of areas to mmap. It would be nice to use a
85 value that explicitly means "no limit". */
87 #define MMAP_MAX_AREAS 100000000
89 #endif /* not DOUG_LEA_MALLOC */
91 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
92 to a struct Lisp_String. */
94 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
95 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
96 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
98 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
99 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
100 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
102 /* Default value of gc_cons_threshold (see below). */
104 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
106 /* Global variables. */
107 struct emacs_globals globals;
109 /* Number of bytes of consing done since the last gc. */
111 EMACS_INT consing_since_gc;
113 /* Similar minimum, computed from Vgc_cons_percentage. */
115 EMACS_INT gc_relative_threshold;
117 /* Minimum number of bytes of consing since GC before next GC,
118 when memory is full. */
120 EMACS_INT memory_full_cons_threshold;
122 /* True during GC. */
124 bool gc_in_progress;
126 /* True means abort if try to GC.
127 This is for code which is written on the assumption that
128 no GC will happen, so as to verify that assumption. */
130 bool abort_on_gc;
132 /* Number of live and free conses etc. */
134 static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
135 static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
136 static EMACS_INT total_free_floats, total_floats;
138 /* Points to memory space allocated as "spare", to be freed if we run
139 out of memory. We keep one large block, four cons-blocks, and
140 two string blocks. */
142 static char *spare_memory[7];
144 /* Amount of spare memory to keep in large reserve block, or to see
145 whether this much is available when malloc fails on a larger request. */
147 #define SPARE_MEMORY (1 << 14)
149 /* Initialize it to a nonzero value to force it into data space
150 (rather than bss space). That way unexec will remap it into text
151 space (pure), on some systems. We have not implemented the
152 remapping on more recent systems because this is less important
153 nowadays than in the days of small memories and timesharing. */
155 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
156 #define PUREBEG (char *) pure
158 /* Pointer to the pure area, and its size. */
160 static char *purebeg;
161 static ptrdiff_t pure_size;
163 /* Number of bytes of pure storage used before pure storage overflowed.
164 If this is non-zero, this implies that an overflow occurred. */
166 static ptrdiff_t pure_bytes_used_before_overflow;
168 /* True if P points into pure space. */
170 #define PURE_POINTER_P(P) \
171 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
173 /* Index in pure at which next pure Lisp object will be allocated.. */
175 static ptrdiff_t pure_bytes_used_lisp;
177 /* Number of bytes allocated for non-Lisp objects in pure storage. */
179 static ptrdiff_t pure_bytes_used_non_lisp;
181 /* If nonzero, this is a warning delivered by malloc and not yet
182 displayed. */
184 const char *pending_malloc_warning;
186 /* Maximum amount of C stack to save when a GC happens. */
188 #ifndef MAX_SAVE_STACK
189 #define MAX_SAVE_STACK 16000
190 #endif
192 /* Buffer in which we save a copy of the C stack at each GC. */
194 #if MAX_SAVE_STACK > 0
195 static char *stack_copy;
196 static ptrdiff_t stack_copy_size;
197 #endif
199 static Lisp_Object Qconses;
200 static Lisp_Object Qsymbols;
201 static Lisp_Object Qmiscs;
202 static Lisp_Object Qstrings;
203 static Lisp_Object Qvectors;
204 static Lisp_Object Qfloats;
205 static Lisp_Object Qintervals;
206 static Lisp_Object Qbuffers;
207 static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
208 static Lisp_Object Qgc_cons_threshold;
209 Lisp_Object Qautomatic_gc;
210 Lisp_Object Qchar_table_extra_slots;
212 /* Hook run after GC has finished. */
214 static Lisp_Object Qpost_gc_hook;
216 static void mark_terminals (void);
217 static void gc_sweep (void);
218 static Lisp_Object make_pure_vector (ptrdiff_t);
219 static void mark_glyph_matrix (struct glyph_matrix *);
220 static void mark_face_cache (struct face_cache *);
221 static void mark_buffer (struct buffer *);
223 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
224 static void refill_memory_reserve (void);
225 #endif
226 static struct Lisp_String *allocate_string (void);
227 static void compact_small_strings (void);
228 static void free_large_strings (void);
229 static void sweep_strings (void);
230 static void free_misc (Lisp_Object);
231 extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
233 /* When scanning the C stack for live Lisp objects, Emacs keeps track
234 of what memory allocated via lisp_malloc is intended for what
235 purpose. This enumeration specifies the type of memory. */
237 enum mem_type
239 MEM_TYPE_NON_LISP,
240 MEM_TYPE_BUFFER,
241 MEM_TYPE_CONS,
242 MEM_TYPE_STRING,
243 MEM_TYPE_MISC,
244 MEM_TYPE_SYMBOL,
245 MEM_TYPE_FLOAT,
246 /* We used to keep separate mem_types for subtypes of vectors such as
247 process, hash_table, frame, terminal, and window, but we never made
248 use of the distinction, so it only caused source-code complexity
249 and runtime slowdown. Minor but pointless. */
250 MEM_TYPE_VECTORLIKE,
251 /* Special type to denote vector blocks. */
252 MEM_TYPE_VECTOR_BLOCK,
253 /* Special type to denote reserved memory. */
254 MEM_TYPE_SPARE
257 static void *lisp_malloc (size_t, enum mem_type);
260 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
262 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
263 #include <stdio.h> /* For fprintf. */
264 #endif
266 /* A unique object in pure space used to make some Lisp objects
267 on free lists recognizable in O(1). */
269 static Lisp_Object Vdead;
270 #define DEADP(x) EQ (x, Vdead)
272 #ifdef GC_MALLOC_CHECK
274 enum mem_type allocated_mem_type;
276 #endif /* GC_MALLOC_CHECK */
278 /* A node in the red-black tree describing allocated memory containing
279 Lisp data. Each such block is recorded with its start and end
280 address when it is allocated, and removed from the tree when it
281 is freed.
283 A red-black tree is a balanced binary tree with the following
284 properties:
286 1. Every node is either red or black.
287 2. Every leaf is black.
288 3. If a node is red, then both of its children are black.
289 4. Every simple path from a node to a descendant leaf contains
290 the same number of black nodes.
291 5. The root is always black.
293 When nodes are inserted into the tree, or deleted from the tree,
294 the tree is "fixed" so that these properties are always true.
296 A red-black tree with N internal nodes has height at most 2
297 log(N+1). Searches, insertions and deletions are done in O(log N).
298 Please see a text book about data structures for a detailed
299 description of red-black trees. Any book worth its salt should
300 describe them. */
302 struct mem_node
304 /* Children of this node. These pointers are never NULL. When there
305 is no child, the value is MEM_NIL, which points to a dummy node. */
306 struct mem_node *left, *right;
308 /* The parent of this node. In the root node, this is NULL. */
309 struct mem_node *parent;
311 /* Start and end of allocated region. */
312 void *start, *end;
314 /* Node color. */
315 enum {MEM_BLACK, MEM_RED} color;
317 /* Memory type. */
318 enum mem_type type;
321 /* Base address of stack. Set in main. */
323 Lisp_Object *stack_base;
325 /* Root of the tree describing allocated Lisp memory. */
327 static struct mem_node *mem_root;
329 /* Lowest and highest known address in the heap. */
331 static void *min_heap_address, *max_heap_address;
333 /* Sentinel node of the tree. */
335 static struct mem_node mem_z;
336 #define MEM_NIL &mem_z
338 static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
339 static void lisp_free (void *);
340 static void mark_stack (void);
341 static bool live_vector_p (struct mem_node *, void *);
342 static bool live_buffer_p (struct mem_node *, void *);
343 static bool live_string_p (struct mem_node *, void *);
344 static bool live_cons_p (struct mem_node *, void *);
345 static bool live_symbol_p (struct mem_node *, void *);
346 static bool live_float_p (struct mem_node *, void *);
347 static bool live_misc_p (struct mem_node *, void *);
348 static void mark_maybe_object (Lisp_Object);
349 static void mark_memory (void *, void *);
350 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
351 static void mem_init (void);
352 static struct mem_node *mem_insert (void *, void *, enum mem_type);
353 static void mem_insert_fixup (struct mem_node *);
354 static void mem_rotate_left (struct mem_node *);
355 static void mem_rotate_right (struct mem_node *);
356 static void mem_delete (struct mem_node *);
357 static void mem_delete_fixup (struct mem_node *);
358 static struct mem_node *mem_find (void *);
359 #endif
362 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
363 static void check_gcpros (void);
364 #endif
366 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
368 #ifndef DEADP
369 # define DEADP(x) 0
370 #endif
372 /* Recording what needs to be marked for gc. */
374 struct gcpro *gcprolist;
376 /* Addresses of staticpro'd variables. Initialize it to a nonzero
377 value; otherwise some compilers put it into BSS. */
379 #define NSTATICS 0x800
380 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
382 /* Index of next unused slot in staticvec. */
384 static int staticidx;
386 static void *pure_alloc (size_t, int);
389 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
390 ALIGNMENT must be a power of 2. */
392 #define ALIGN(ptr, ALIGNMENT) \
393 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
394 & ~ ((ALIGNMENT) - 1)))
398 /************************************************************************
399 Malloc
400 ************************************************************************/
402 /* Function malloc calls this if it finds we are near exhausting storage. */
404 void
405 malloc_warning (const char *str)
407 pending_malloc_warning = str;
411 /* Display an already-pending malloc warning. */
413 void
414 display_malloc_warning (void)
416 call3 (intern ("display-warning"),
417 intern ("alloc"),
418 build_string (pending_malloc_warning),
419 intern ("emergency"));
420 pending_malloc_warning = 0;
423 /* Called if we can't allocate relocatable space for a buffer. */
425 void
426 buffer_memory_full (ptrdiff_t nbytes)
428 /* If buffers use the relocating allocator, no need to free
429 spare_memory, because we may have plenty of malloc space left
430 that we could get, and if we don't, the malloc that fails will
431 itself cause spare_memory to be freed. If buffers don't use the
432 relocating allocator, treat this like any other failing
433 malloc. */
435 #ifndef REL_ALLOC
436 memory_full (nbytes);
437 #endif
439 /* This used to call error, but if we've run out of memory, we could
440 get infinite recursion trying to build the string. */
441 xsignal (Qnil, Vmemory_signal_data);
444 /* A common multiple of the positive integers A and B. Ideally this
445 would be the least common multiple, but there's no way to do that
446 as a constant expression in C, so do the best that we can easily do. */
447 #define COMMON_MULTIPLE(a, b) \
448 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
450 #ifndef XMALLOC_OVERRUN_CHECK
451 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
452 #else
454 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
455 around each block.
457 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
458 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
459 block size in little-endian order. The trailer consists of
460 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
462 The header is used to detect whether this block has been allocated
463 through these functions, as some low-level libc functions may
464 bypass the malloc hooks. */
466 #define XMALLOC_OVERRUN_CHECK_SIZE 16
467 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
468 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
470 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
471 hold a size_t value and (2) the header size is a multiple of the
472 alignment that Emacs needs for C types and for USE_LSB_TAG. */
473 #define XMALLOC_BASE_ALIGNMENT \
474 alignof (union { long double d; intmax_t i; void *p; })
476 #if USE_LSB_TAG
477 # define XMALLOC_HEADER_ALIGNMENT \
478 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
479 #else
480 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
481 #endif
482 #define XMALLOC_OVERRUN_SIZE_SIZE \
483 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
484 + XMALLOC_HEADER_ALIGNMENT - 1) \
485 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
486 - XMALLOC_OVERRUN_CHECK_SIZE)
488 static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
489 { '\x9a', '\x9b', '\xae', '\xaf',
490 '\xbf', '\xbe', '\xce', '\xcf',
491 '\xea', '\xeb', '\xec', '\xed',
492 '\xdf', '\xde', '\x9c', '\x9d' };
494 static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
495 { '\xaa', '\xab', '\xac', '\xad',
496 '\xba', '\xbb', '\xbc', '\xbd',
497 '\xca', '\xcb', '\xcc', '\xcd',
498 '\xda', '\xdb', '\xdc', '\xdd' };
500 /* Insert and extract the block size in the header. */
502 static void
503 xmalloc_put_size (unsigned char *ptr, size_t size)
505 int i;
506 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
508 *--ptr = size & ((1 << CHAR_BIT) - 1);
509 size >>= CHAR_BIT;
513 static size_t
514 xmalloc_get_size (unsigned char *ptr)
516 size_t size = 0;
517 int i;
518 ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
519 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
521 size <<= CHAR_BIT;
522 size += *ptr++;
524 return size;
528 /* Like malloc, but wraps allocated block with header and trailer. */
530 static void *
531 overrun_check_malloc (size_t size)
533 register unsigned char *val;
534 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
535 emacs_abort ();
537 val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
538 if (val)
540 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
541 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
542 xmalloc_put_size (val, size);
543 memcpy (val + size, xmalloc_overrun_check_trailer,
544 XMALLOC_OVERRUN_CHECK_SIZE);
546 return val;
550 /* Like realloc, but checks old block for overrun, and wraps new block
551 with header and trailer. */
553 static void *
554 overrun_check_realloc (void *block, size_t size)
556 register unsigned char *val = (unsigned char *) block;
557 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
558 emacs_abort ();
560 if (val
561 && memcmp (xmalloc_overrun_check_header,
562 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
563 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
565 size_t osize = xmalloc_get_size (val);
566 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
567 XMALLOC_OVERRUN_CHECK_SIZE))
568 emacs_abort ();
569 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
570 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
571 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
574 val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
576 if (val)
578 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
579 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
580 xmalloc_put_size (val, size);
581 memcpy (val + size, xmalloc_overrun_check_trailer,
582 XMALLOC_OVERRUN_CHECK_SIZE);
584 return val;
587 /* Like free, but checks block for overrun. */
589 static void
590 overrun_check_free (void *block)
592 unsigned char *val = (unsigned char *) block;
594 if (val
595 && memcmp (xmalloc_overrun_check_header,
596 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
597 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
599 size_t osize = xmalloc_get_size (val);
600 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
601 XMALLOC_OVERRUN_CHECK_SIZE))
602 emacs_abort ();
603 #ifdef XMALLOC_CLEAR_FREE_MEMORY
604 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
605 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
606 #else
607 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
608 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
609 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
610 #endif
613 free (val);
616 #undef malloc
617 #undef realloc
618 #undef free
619 #define malloc overrun_check_malloc
620 #define realloc overrun_check_realloc
621 #define free overrun_check_free
622 #endif
624 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
625 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
626 If that variable is set, block input while in one of Emacs's memory
627 allocation functions. There should be no need for this debugging
628 option, since signal handlers do not allocate memory, but Emacs
629 formerly allocated memory in signal handlers and this compile-time
630 option remains as a way to help debug the issue should it rear its
631 ugly head again. */
632 #ifdef XMALLOC_BLOCK_INPUT_CHECK
633 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
634 static void
635 malloc_block_input (void)
637 if (block_input_in_memory_allocators)
638 block_input ();
640 static void
641 malloc_unblock_input (void)
643 if (block_input_in_memory_allocators)
644 unblock_input ();
646 # define MALLOC_BLOCK_INPUT malloc_block_input ()
647 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
648 #else
649 # define MALLOC_BLOCK_INPUT ((void) 0)
650 # define MALLOC_UNBLOCK_INPUT ((void) 0)
651 #endif
653 #define MALLOC_PROBE(size) \
654 do { \
655 if (profiler_memory_running) \
656 malloc_probe (size); \
657 } while (0)
660 /* Like malloc but check for no memory and block interrupt input.. */
662 void *
663 xmalloc (size_t size)
665 void *val;
667 MALLOC_BLOCK_INPUT;
668 val = malloc (size);
669 MALLOC_UNBLOCK_INPUT;
671 if (!val && size)
672 memory_full (size);
673 MALLOC_PROBE (size);
674 return val;
677 /* Like the above, but zeroes out the memory just allocated. */
679 void *
680 xzalloc (size_t size)
682 void *val;
684 MALLOC_BLOCK_INPUT;
685 val = malloc (size);
686 MALLOC_UNBLOCK_INPUT;
688 if (!val && size)
689 memory_full (size);
690 memset (val, 0, size);
691 MALLOC_PROBE (size);
692 return val;
695 /* Like realloc but check for no memory and block interrupt input.. */
697 void *
698 xrealloc (void *block, size_t size)
700 void *val;
702 MALLOC_BLOCK_INPUT;
703 /* We must call malloc explicitly when BLOCK is 0, since some
704 reallocs don't do this. */
705 if (! block)
706 val = malloc (size);
707 else
708 val = realloc (block, size);
709 MALLOC_UNBLOCK_INPUT;
711 if (!val && size)
712 memory_full (size);
713 MALLOC_PROBE (size);
714 return val;
718 /* Like free but block interrupt input. */
720 void
721 xfree (void *block)
723 if (!block)
724 return;
725 MALLOC_BLOCK_INPUT;
726 free (block);
727 MALLOC_UNBLOCK_INPUT;
728 /* We don't call refill_memory_reserve here
729 because in practice the call in r_alloc_free seems to suffice. */
733 /* Other parts of Emacs pass large int values to allocator functions
734 expecting ptrdiff_t. This is portable in practice, but check it to
735 be safe. */
736 verify (INT_MAX <= PTRDIFF_MAX);
739 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
740 Signal an error on memory exhaustion, and block interrupt input. */
742 void *
743 xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
745 eassert (0 <= nitems && 0 < item_size);
746 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
747 memory_full (SIZE_MAX);
748 return xmalloc (nitems * item_size);
752 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
753 Signal an error on memory exhaustion, and block interrupt input. */
755 void *
756 xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
758 eassert (0 <= nitems && 0 < item_size);
759 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
760 memory_full (SIZE_MAX);
761 return xrealloc (pa, nitems * item_size);
765 /* Grow PA, which points to an array of *NITEMS items, and return the
766 location of the reallocated array, updating *NITEMS to reflect its
767 new size. The new array will contain at least NITEMS_INCR_MIN more
768 items, but will not contain more than NITEMS_MAX items total.
769 ITEM_SIZE is the size of each item, in bytes.
771 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
772 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
773 infinity.
775 If PA is null, then allocate a new array instead of reallocating
776 the old one. Thus, to grow an array A without saving its old
777 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
778 &NITEMS, ...).
780 Block interrupt input as needed. If memory exhaustion occurs, set
781 *NITEMS to zero if PA is null, and signal an error (i.e., do not
782 return). */
784 void *
785 xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
786 ptrdiff_t nitems_max, ptrdiff_t item_size)
788 /* The approximate size to use for initial small allocation
789 requests. This is the largest "small" request for the GNU C
790 library malloc. */
791 enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
793 /* If the array is tiny, grow it to about (but no greater than)
794 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
795 ptrdiff_t n = *nitems;
796 ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n;
797 ptrdiff_t half_again = n >> 1;
798 ptrdiff_t incr_estimate = max (tiny_max, half_again);
800 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
801 NITEMS_MAX, and what the C language can represent safely. */
802 ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size;
803 ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
804 ? nitems_max : C_language_max);
805 ptrdiff_t nitems_incr_max = n_max - n;
806 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
808 eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
809 if (! pa)
810 *nitems = 0;
811 if (nitems_incr_max < incr)
812 memory_full (SIZE_MAX);
813 n += incr;
814 pa = xrealloc (pa, n * item_size);
815 *nitems = n;
816 return pa;
820 /* Like strdup, but uses xmalloc. */
822 char *
823 xstrdup (const char *s)
825 size_t len = strlen (s) + 1;
826 char *p = xmalloc (len);
827 memcpy (p, s, len);
828 return p;
832 /* Unwind for SAFE_ALLOCA */
834 Lisp_Object
835 safe_alloca_unwind (Lisp_Object arg)
837 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
839 p->dogc = 0;
840 xfree (p->pointer);
841 p->pointer = 0;
842 free_misc (arg);
843 return Qnil;
846 /* Return a newly allocated memory block of SIZE bytes, remembering
847 to free it when unwinding. */
848 void *
849 record_xmalloc (size_t size)
851 void *p = xmalloc (size);
852 record_unwind_protect (safe_alloca_unwind, make_save_value (p, 0));
853 return p;
857 /* Like malloc but used for allocating Lisp data. NBYTES is the
858 number of bytes to allocate, TYPE describes the intended use of the
859 allocated memory block (for strings, for conses, ...). */
861 #if ! USE_LSB_TAG
862 void *lisp_malloc_loser EXTERNALLY_VISIBLE;
863 #endif
865 static void *
866 lisp_malloc (size_t nbytes, enum mem_type type)
868 register void *val;
870 MALLOC_BLOCK_INPUT;
872 #ifdef GC_MALLOC_CHECK
873 allocated_mem_type = type;
874 #endif
876 val = malloc (nbytes);
878 #if ! USE_LSB_TAG
879 /* If the memory just allocated cannot be addressed thru a Lisp
880 object's pointer, and it needs to be,
881 that's equivalent to running out of memory. */
882 if (val && type != MEM_TYPE_NON_LISP)
884 Lisp_Object tem;
885 XSETCONS (tem, (char *) val + nbytes - 1);
886 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
888 lisp_malloc_loser = val;
889 free (val);
890 val = 0;
893 #endif
895 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
896 if (val && type != MEM_TYPE_NON_LISP)
897 mem_insert (val, (char *) val + nbytes, type);
898 #endif
900 MALLOC_UNBLOCK_INPUT;
901 if (!val && nbytes)
902 memory_full (nbytes);
903 MALLOC_PROBE (nbytes);
904 return val;
907 /* Free BLOCK. This must be called to free memory allocated with a
908 call to lisp_malloc. */
910 static void
911 lisp_free (void *block)
913 MALLOC_BLOCK_INPUT;
914 free (block);
915 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
916 mem_delete (mem_find (block));
917 #endif
918 MALLOC_UNBLOCK_INPUT;
921 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
923 /* The entry point is lisp_align_malloc which returns blocks of at most
924 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
926 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
927 #define USE_POSIX_MEMALIGN 1
928 #endif
930 /* BLOCK_ALIGN has to be a power of 2. */
931 #define BLOCK_ALIGN (1 << 10)
933 /* Padding to leave at the end of a malloc'd block. This is to give
934 malloc a chance to minimize the amount of memory wasted to alignment.
935 It should be tuned to the particular malloc library used.
936 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
937 posix_memalign on the other hand would ideally prefer a value of 4
938 because otherwise, there's 1020 bytes wasted between each ablocks.
939 In Emacs, testing shows that those 1020 can most of the time be
940 efficiently used by malloc to place other objects, so a value of 0 can
941 still preferable unless you have a lot of aligned blocks and virtually
942 nothing else. */
943 #define BLOCK_PADDING 0
944 #define BLOCK_BYTES \
945 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
947 /* Internal data structures and constants. */
949 #define ABLOCKS_SIZE 16
951 /* An aligned block of memory. */
952 struct ablock
954 union
956 char payload[BLOCK_BYTES];
957 struct ablock *next_free;
958 } x;
959 /* `abase' is the aligned base of the ablocks. */
960 /* It is overloaded to hold the virtual `busy' field that counts
961 the number of used ablock in the parent ablocks.
962 The first ablock has the `busy' field, the others have the `abase'
963 field. To tell the difference, we assume that pointers will have
964 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
965 is used to tell whether the real base of the parent ablocks is `abase'
966 (if not, the word before the first ablock holds a pointer to the
967 real base). */
968 struct ablocks *abase;
969 /* The padding of all but the last ablock is unused. The padding of
970 the last ablock in an ablocks is not allocated. */
971 #if BLOCK_PADDING
972 char padding[BLOCK_PADDING];
973 #endif
976 /* A bunch of consecutive aligned blocks. */
977 struct ablocks
979 struct ablock blocks[ABLOCKS_SIZE];
982 /* Size of the block requested from malloc or posix_memalign. */
983 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
985 #define ABLOCK_ABASE(block) \
986 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
987 ? (struct ablocks *)(block) \
988 : (block)->abase)
990 /* Virtual `busy' field. */
991 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
993 /* Pointer to the (not necessarily aligned) malloc block. */
994 #ifdef USE_POSIX_MEMALIGN
995 #define ABLOCKS_BASE(abase) (abase)
996 #else
997 #define ABLOCKS_BASE(abase) \
998 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
999 #endif
1001 /* The list of free ablock. */
1002 static struct ablock *free_ablock;
1004 /* Allocate an aligned block of nbytes.
1005 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1006 smaller or equal to BLOCK_BYTES. */
1007 static void *
1008 lisp_align_malloc (size_t nbytes, enum mem_type type)
1010 void *base, *val;
1011 struct ablocks *abase;
1013 eassert (nbytes <= BLOCK_BYTES);
1015 MALLOC_BLOCK_INPUT;
1017 #ifdef GC_MALLOC_CHECK
1018 allocated_mem_type = type;
1019 #endif
1021 if (!free_ablock)
1023 int i;
1024 intptr_t aligned; /* int gets warning casting to 64-bit pointer. */
1026 #ifdef DOUG_LEA_MALLOC
1027 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1028 because mapped region contents are not preserved in
1029 a dumped Emacs. */
1030 mallopt (M_MMAP_MAX, 0);
1031 #endif
1033 #ifdef USE_POSIX_MEMALIGN
1035 int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
1036 if (err)
1037 base = NULL;
1038 abase = base;
1040 #else
1041 base = malloc (ABLOCKS_BYTES);
1042 abase = ALIGN (base, BLOCK_ALIGN);
1043 #endif
1045 if (base == 0)
1047 MALLOC_UNBLOCK_INPUT;
1048 memory_full (ABLOCKS_BYTES);
1051 aligned = (base == abase);
1052 if (!aligned)
1053 ((void**)abase)[-1] = base;
1055 #ifdef DOUG_LEA_MALLOC
1056 /* Back to a reasonable maximum of mmap'ed areas. */
1057 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1058 #endif
1060 #if ! USE_LSB_TAG
1061 /* If the memory just allocated cannot be addressed thru a Lisp
1062 object's pointer, and it needs to be, that's equivalent to
1063 running out of memory. */
1064 if (type != MEM_TYPE_NON_LISP)
1066 Lisp_Object tem;
1067 char *end = (char *) base + ABLOCKS_BYTES - 1;
1068 XSETCONS (tem, end);
1069 if ((char *) XCONS (tem) != end)
1071 lisp_malloc_loser = base;
1072 free (base);
1073 MALLOC_UNBLOCK_INPUT;
1074 memory_full (SIZE_MAX);
1077 #endif
1079 /* Initialize the blocks and put them on the free list.
1080 If `base' was not properly aligned, we can't use the last block. */
1081 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1083 abase->blocks[i].abase = abase;
1084 abase->blocks[i].x.next_free = free_ablock;
1085 free_ablock = &abase->blocks[i];
1087 ABLOCKS_BUSY (abase) = (struct ablocks *) aligned;
1089 eassert (0 == ((uintptr_t) abase) % BLOCK_ALIGN);
1090 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
1091 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1092 eassert (ABLOCKS_BASE (abase) == base);
1093 eassert (aligned == (intptr_t) ABLOCKS_BUSY (abase));
1096 abase = ABLOCK_ABASE (free_ablock);
1097 ABLOCKS_BUSY (abase) =
1098 (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
1099 val = free_ablock;
1100 free_ablock = free_ablock->x.next_free;
1102 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1103 if (type != MEM_TYPE_NON_LISP)
1104 mem_insert (val, (char *) val + nbytes, type);
1105 #endif
1107 MALLOC_UNBLOCK_INPUT;
1109 MALLOC_PROBE (nbytes);
1111 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
1112 return val;
1115 static void
1116 lisp_align_free (void *block)
1118 struct ablock *ablock = block;
1119 struct ablocks *abase = ABLOCK_ABASE (ablock);
1121 MALLOC_BLOCK_INPUT;
1122 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1123 mem_delete (mem_find (block));
1124 #endif
1125 /* Put on free list. */
1126 ablock->x.next_free = free_ablock;
1127 free_ablock = ablock;
1128 /* Update busy count. */
1129 ABLOCKS_BUSY (abase)
1130 = (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
1132 if (2 > (intptr_t) ABLOCKS_BUSY (abase))
1133 { /* All the blocks are free. */
1134 int i = 0, aligned = (intptr_t) ABLOCKS_BUSY (abase);
1135 struct ablock **tem = &free_ablock;
1136 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1138 while (*tem)
1140 if (*tem >= (struct ablock *) abase && *tem < atop)
1142 i++;
1143 *tem = (*tem)->x.next_free;
1145 else
1146 tem = &(*tem)->x.next_free;
1148 eassert ((aligned & 1) == aligned);
1149 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1150 #ifdef USE_POSIX_MEMALIGN
1151 eassert ((uintptr_t) ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1152 #endif
1153 free (ABLOCKS_BASE (abase));
1155 MALLOC_UNBLOCK_INPUT;
1159 /***********************************************************************
1160 Interval Allocation
1161 ***********************************************************************/
1163 /* Number of intervals allocated in an interval_block structure.
1164 The 1020 is 1024 minus malloc overhead. */
1166 #define INTERVAL_BLOCK_SIZE \
1167 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1169 /* Intervals are allocated in chunks in form of an interval_block
1170 structure. */
1172 struct interval_block
1174 /* Place `intervals' first, to preserve alignment. */
1175 struct interval intervals[INTERVAL_BLOCK_SIZE];
1176 struct interval_block *next;
1179 /* Current interval block. Its `next' pointer points to older
1180 blocks. */
1182 static struct interval_block *interval_block;
1184 /* Index in interval_block above of the next unused interval
1185 structure. */
1187 static int interval_block_index = INTERVAL_BLOCK_SIZE;
1189 /* Number of free and live intervals. */
1191 static EMACS_INT total_free_intervals, total_intervals;
1193 /* List of free intervals. */
1195 static INTERVAL interval_free_list;
1197 /* Return a new interval. */
1199 INTERVAL
1200 make_interval (void)
1202 INTERVAL val;
1204 MALLOC_BLOCK_INPUT;
1206 if (interval_free_list)
1208 val = interval_free_list;
1209 interval_free_list = INTERVAL_PARENT (interval_free_list);
1211 else
1213 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1215 struct interval_block *newi
1216 = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP);
1218 newi->next = interval_block;
1219 interval_block = newi;
1220 interval_block_index = 0;
1221 total_free_intervals += INTERVAL_BLOCK_SIZE;
1223 val = &interval_block->intervals[interval_block_index++];
1226 MALLOC_UNBLOCK_INPUT;
1228 consing_since_gc += sizeof (struct interval);
1229 intervals_consed++;
1230 total_free_intervals--;
1231 RESET_INTERVAL (val);
1232 val->gcmarkbit = 0;
1233 return val;
1237 /* Mark Lisp objects in interval I. */
1239 static void
1240 mark_interval (register INTERVAL i, Lisp_Object dummy)
1242 /* Intervals should never be shared. So, if extra internal checking is
1243 enabled, GC aborts if it seems to have visited an interval twice. */
1244 eassert (!i->gcmarkbit);
1245 i->gcmarkbit = 1;
1246 mark_object (i->plist);
1249 /* Mark the interval tree rooted in I. */
1251 #define MARK_INTERVAL_TREE(i) \
1252 do { \
1253 if (i && !i->gcmarkbit) \
1254 traverse_intervals_noorder (i, mark_interval, Qnil); \
1255 } while (0)
1257 /***********************************************************************
1258 String Allocation
1259 ***********************************************************************/
1261 /* Lisp_Strings are allocated in string_block structures. When a new
1262 string_block is allocated, all the Lisp_Strings it contains are
1263 added to a free-list string_free_list. When a new Lisp_String is
1264 needed, it is taken from that list. During the sweep phase of GC,
1265 string_blocks that are entirely free are freed, except two which
1266 we keep.
1268 String data is allocated from sblock structures. Strings larger
1269 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1270 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1272 Sblocks consist internally of sdata structures, one for each
1273 Lisp_String. The sdata structure points to the Lisp_String it
1274 belongs to. The Lisp_String points back to the `u.data' member of
1275 its sdata structure.
1277 When a Lisp_String is freed during GC, it is put back on
1278 string_free_list, and its `data' member and its sdata's `string'
1279 pointer is set to null. The size of the string is recorded in the
1280 `u.nbytes' member of the sdata. So, sdata structures that are no
1281 longer used, can be easily recognized, and it's easy to compact the
1282 sblocks of small strings which we do in compact_small_strings. */
1284 /* Size in bytes of an sblock structure used for small strings. This
1285 is 8192 minus malloc overhead. */
1287 #define SBLOCK_SIZE 8188
1289 /* Strings larger than this are considered large strings. String data
1290 for large strings is allocated from individual sblocks. */
1292 #define LARGE_STRING_BYTES 1024
1294 /* Structure describing string memory sub-allocated from an sblock.
1295 This is where the contents of Lisp strings are stored. */
1297 struct sdata
1299 /* Back-pointer to the string this sdata belongs to. If null, this
1300 structure is free, and the NBYTES member of the union below
1301 contains the string's byte size (the same value that STRING_BYTES
1302 would return if STRING were non-null). If non-null, STRING_BYTES
1303 (STRING) is the size of the data, and DATA contains the string's
1304 contents. */
1305 struct Lisp_String *string;
1307 #ifdef GC_CHECK_STRING_BYTES
1309 ptrdiff_t nbytes;
1310 unsigned char data[1];
1312 #define SDATA_NBYTES(S) (S)->nbytes
1313 #define SDATA_DATA(S) (S)->data
1314 #define SDATA_SELECTOR(member) member
1316 #else /* not GC_CHECK_STRING_BYTES */
1318 union
1320 /* When STRING is non-null. */
1321 unsigned char data[1];
1323 /* When STRING is null. */
1324 ptrdiff_t nbytes;
1325 } u;
1327 #define SDATA_NBYTES(S) (S)->u.nbytes
1328 #define SDATA_DATA(S) (S)->u.data
1329 #define SDATA_SELECTOR(member) u.member
1331 #endif /* not GC_CHECK_STRING_BYTES */
1333 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1337 /* Structure describing a block of memory which is sub-allocated to
1338 obtain string data memory for strings. Blocks for small strings
1339 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1340 as large as needed. */
1342 struct sblock
1344 /* Next in list. */
1345 struct sblock *next;
1347 /* Pointer to the next free sdata block. This points past the end
1348 of the sblock if there isn't any space left in this block. */
1349 struct sdata *next_free;
1351 /* Start of data. */
1352 struct sdata first_data;
1355 /* Number of Lisp strings in a string_block structure. The 1020 is
1356 1024 minus malloc overhead. */
1358 #define STRING_BLOCK_SIZE \
1359 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1361 /* Structure describing a block from which Lisp_String structures
1362 are allocated. */
1364 struct string_block
1366 /* Place `strings' first, to preserve alignment. */
1367 struct Lisp_String strings[STRING_BLOCK_SIZE];
1368 struct string_block *next;
1371 /* Head and tail of the list of sblock structures holding Lisp string
1372 data. We always allocate from current_sblock. The NEXT pointers
1373 in the sblock structures go from oldest_sblock to current_sblock. */
1375 static struct sblock *oldest_sblock, *current_sblock;
1377 /* List of sblocks for large strings. */
1379 static struct sblock *large_sblocks;
1381 /* List of string_block structures. */
1383 static struct string_block *string_blocks;
1385 /* Free-list of Lisp_Strings. */
1387 static struct Lisp_String *string_free_list;
1389 /* Number of live and free Lisp_Strings. */
1391 static EMACS_INT total_strings, total_free_strings;
1393 /* Number of bytes used by live strings. */
1395 static EMACS_INT total_string_bytes;
1397 /* Given a pointer to a Lisp_String S which is on the free-list
1398 string_free_list, return a pointer to its successor in the
1399 free-list. */
1401 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1403 /* Return a pointer to the sdata structure belonging to Lisp string S.
1404 S must be live, i.e. S->data must not be null. S->data is actually
1405 a pointer to the `u.data' member of its sdata structure; the
1406 structure starts at a constant offset in front of that. */
1408 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1411 #ifdef GC_CHECK_STRING_OVERRUN
1413 /* We check for overrun in string data blocks by appending a small
1414 "cookie" after each allocated string data block, and check for the
1415 presence of this cookie during GC. */
1417 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1418 static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1419 { '\xde', '\xad', '\xbe', '\xef' };
1421 #else
1422 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1423 #endif
1425 /* Value is the size of an sdata structure large enough to hold NBYTES
1426 bytes of string data. The value returned includes a terminating
1427 NUL byte, the size of the sdata structure, and padding. */
1429 #ifdef GC_CHECK_STRING_BYTES
1431 #define SDATA_SIZE(NBYTES) \
1432 ((SDATA_DATA_OFFSET \
1433 + (NBYTES) + 1 \
1434 + sizeof (ptrdiff_t) - 1) \
1435 & ~(sizeof (ptrdiff_t) - 1))
1437 #else /* not GC_CHECK_STRING_BYTES */
1439 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1440 less than the size of that member. The 'max' is not needed when
1441 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1442 alignment code reserves enough space. */
1444 #define SDATA_SIZE(NBYTES) \
1445 ((SDATA_DATA_OFFSET \
1446 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1447 ? NBYTES \
1448 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1449 + 1 \
1450 + sizeof (ptrdiff_t) - 1) \
1451 & ~(sizeof (ptrdiff_t) - 1))
1453 #endif /* not GC_CHECK_STRING_BYTES */
1455 /* Extra bytes to allocate for each string. */
1457 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1459 /* Exact bound on the number of bytes in a string, not counting the
1460 terminating null. A string cannot contain more bytes than
1461 STRING_BYTES_BOUND, nor can it be so long that the size_t
1462 arithmetic in allocate_string_data would overflow while it is
1463 calculating a value to be passed to malloc. */
1464 static ptrdiff_t const STRING_BYTES_MAX =
1465 min (STRING_BYTES_BOUND,
1466 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
1467 - GC_STRING_EXTRA
1468 - offsetof (struct sblock, first_data)
1469 - SDATA_DATA_OFFSET)
1470 & ~(sizeof (EMACS_INT) - 1)));
1472 /* Initialize string allocation. Called from init_alloc_once. */
1474 static void
1475 init_strings (void)
1477 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1478 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1482 #ifdef GC_CHECK_STRING_BYTES
1484 static int check_string_bytes_count;
1486 /* Like STRING_BYTES, but with debugging check. Can be
1487 called during GC, so pay attention to the mark bit. */
1489 ptrdiff_t
1490 string_bytes (struct Lisp_String *s)
1492 ptrdiff_t nbytes =
1493 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1495 if (!PURE_POINTER_P (s)
1496 && s->data
1497 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1498 emacs_abort ();
1499 return nbytes;
1502 /* Check validity of Lisp strings' string_bytes member in B. */
1504 static void
1505 check_sblock (struct sblock *b)
1507 struct sdata *from, *end, *from_end;
1509 end = b->next_free;
1511 for (from = &b->first_data; from < end; from = from_end)
1513 /* Compute the next FROM here because copying below may
1514 overwrite data we need to compute it. */
1515 ptrdiff_t nbytes;
1517 /* Check that the string size recorded in the string is the
1518 same as the one recorded in the sdata structure. */
1519 nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
1520 : SDATA_NBYTES (from));
1521 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1526 /* Check validity of Lisp strings' string_bytes member. ALL_P
1527 means check all strings, otherwise check only most
1528 recently allocated strings. Used for hunting a bug. */
1530 static void
1531 check_string_bytes (bool all_p)
1533 if (all_p)
1535 struct sblock *b;
1537 for (b = large_sblocks; b; b = b->next)
1539 struct Lisp_String *s = b->first_data.string;
1540 if (s)
1541 string_bytes (s);
1544 for (b = oldest_sblock; b; b = b->next)
1545 check_sblock (b);
1547 else if (current_sblock)
1548 check_sblock (current_sblock);
1551 #else /* not GC_CHECK_STRING_BYTES */
1553 #define check_string_bytes(all) ((void) 0)
1555 #endif /* GC_CHECK_STRING_BYTES */
1557 #ifdef GC_CHECK_STRING_FREE_LIST
1559 /* Walk through the string free list looking for bogus next pointers.
1560 This may catch buffer overrun from a previous string. */
1562 static void
1563 check_string_free_list (void)
1565 struct Lisp_String *s;
1567 /* Pop a Lisp_String off the free-list. */
1568 s = string_free_list;
1569 while (s != NULL)
1571 if ((uintptr_t) s < 1024)
1572 emacs_abort ();
1573 s = NEXT_FREE_LISP_STRING (s);
1576 #else
1577 #define check_string_free_list()
1578 #endif
1580 /* Return a new Lisp_String. */
1582 static struct Lisp_String *
1583 allocate_string (void)
1585 struct Lisp_String *s;
1587 MALLOC_BLOCK_INPUT;
1589 /* If the free-list is empty, allocate a new string_block, and
1590 add all the Lisp_Strings in it to the free-list. */
1591 if (string_free_list == NULL)
1593 struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1594 int i;
1596 b->next = string_blocks;
1597 string_blocks = b;
1599 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1601 s = b->strings + i;
1602 /* Every string on a free list should have NULL data pointer. */
1603 s->data = NULL;
1604 NEXT_FREE_LISP_STRING (s) = string_free_list;
1605 string_free_list = s;
1608 total_free_strings += STRING_BLOCK_SIZE;
1611 check_string_free_list ();
1613 /* Pop a Lisp_String off the free-list. */
1614 s = string_free_list;
1615 string_free_list = NEXT_FREE_LISP_STRING (s);
1617 MALLOC_UNBLOCK_INPUT;
1619 --total_free_strings;
1620 ++total_strings;
1621 ++strings_consed;
1622 consing_since_gc += sizeof *s;
1624 #ifdef GC_CHECK_STRING_BYTES
1625 if (!noninteractive)
1627 if (++check_string_bytes_count == 200)
1629 check_string_bytes_count = 0;
1630 check_string_bytes (1);
1632 else
1633 check_string_bytes (0);
1635 #endif /* GC_CHECK_STRING_BYTES */
1637 return s;
1641 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1642 plus a NUL byte at the end. Allocate an sdata structure for S, and
1643 set S->data to its `u.data' member. Store a NUL byte at the end of
1644 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1645 S->data if it was initially non-null. */
1647 void
1648 allocate_string_data (struct Lisp_String *s,
1649 EMACS_INT nchars, EMACS_INT nbytes)
1651 struct sdata *data, *old_data;
1652 struct sblock *b;
1653 ptrdiff_t needed, old_nbytes;
1655 if (STRING_BYTES_MAX < nbytes)
1656 string_overflow ();
1658 /* Determine the number of bytes needed to store NBYTES bytes
1659 of string data. */
1660 needed = SDATA_SIZE (nbytes);
1661 if (s->data)
1663 old_data = SDATA_OF_STRING (s);
1664 old_nbytes = STRING_BYTES (s);
1666 else
1667 old_data = NULL;
1669 MALLOC_BLOCK_INPUT;
1671 if (nbytes > LARGE_STRING_BYTES)
1673 size_t size = offsetof (struct sblock, first_data) + needed;
1675 #ifdef DOUG_LEA_MALLOC
1676 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1677 because mapped region contents are not preserved in
1678 a dumped Emacs.
1680 In case you think of allowing it in a dumped Emacs at the
1681 cost of not being able to re-dump, there's another reason:
1682 mmap'ed data typically have an address towards the top of the
1683 address space, which won't fit into an EMACS_INT (at least on
1684 32-bit systems with the current tagging scheme). --fx */
1685 mallopt (M_MMAP_MAX, 0);
1686 #endif
1688 b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
1690 #ifdef DOUG_LEA_MALLOC
1691 /* Back to a reasonable maximum of mmap'ed areas. */
1692 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1693 #endif
1695 b->next_free = &b->first_data;
1696 b->first_data.string = NULL;
1697 b->next = large_sblocks;
1698 large_sblocks = b;
1700 else if (current_sblock == NULL
1701 || (((char *) current_sblock + SBLOCK_SIZE
1702 - (char *) current_sblock->next_free)
1703 < (needed + GC_STRING_EXTRA)))
1705 /* Not enough room in the current sblock. */
1706 b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
1707 b->next_free = &b->first_data;
1708 b->first_data.string = NULL;
1709 b->next = NULL;
1711 if (current_sblock)
1712 current_sblock->next = b;
1713 else
1714 oldest_sblock = b;
1715 current_sblock = b;
1717 else
1718 b = current_sblock;
1720 data = b->next_free;
1721 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
1723 MALLOC_UNBLOCK_INPUT;
1725 data->string = s;
1726 s->data = SDATA_DATA (data);
1727 #ifdef GC_CHECK_STRING_BYTES
1728 SDATA_NBYTES (data) = nbytes;
1729 #endif
1730 s->size = nchars;
1731 s->size_byte = nbytes;
1732 s->data[nbytes] = '\0';
1733 #ifdef GC_CHECK_STRING_OVERRUN
1734 memcpy ((char *) data + needed, string_overrun_cookie,
1735 GC_STRING_OVERRUN_COOKIE_SIZE);
1736 #endif
1738 /* Note that Faset may call to this function when S has already data
1739 assigned. In this case, mark data as free by setting it's string
1740 back-pointer to null, and record the size of the data in it. */
1741 if (old_data)
1743 SDATA_NBYTES (old_data) = old_nbytes;
1744 old_data->string = NULL;
1747 consing_since_gc += needed;
1751 /* Sweep and compact strings. */
1753 static void
1754 sweep_strings (void)
1756 struct string_block *b, *next;
1757 struct string_block *live_blocks = NULL;
1759 string_free_list = NULL;
1760 total_strings = total_free_strings = 0;
1761 total_string_bytes = 0;
1763 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1764 for (b = string_blocks; b; b = next)
1766 int i, nfree = 0;
1767 struct Lisp_String *free_list_before = string_free_list;
1769 next = b->next;
1771 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
1773 struct Lisp_String *s = b->strings + i;
1775 if (s->data)
1777 /* String was not on free-list before. */
1778 if (STRING_MARKED_P (s))
1780 /* String is live; unmark it and its intervals. */
1781 UNMARK_STRING (s);
1783 /* Do not use string_(set|get)_intervals here. */
1784 s->intervals = balance_intervals (s->intervals);
1786 ++total_strings;
1787 total_string_bytes += STRING_BYTES (s);
1789 else
1791 /* String is dead. Put it on the free-list. */
1792 struct sdata *data = SDATA_OF_STRING (s);
1794 /* Save the size of S in its sdata so that we know
1795 how large that is. Reset the sdata's string
1796 back-pointer so that we know it's free. */
1797 #ifdef GC_CHECK_STRING_BYTES
1798 if (string_bytes (s) != SDATA_NBYTES (data))
1799 emacs_abort ();
1800 #else
1801 data->u.nbytes = STRING_BYTES (s);
1802 #endif
1803 data->string = NULL;
1805 /* Reset the strings's `data' member so that we
1806 know it's free. */
1807 s->data = NULL;
1809 /* Put the string on the free-list. */
1810 NEXT_FREE_LISP_STRING (s) = string_free_list;
1811 string_free_list = s;
1812 ++nfree;
1815 else
1817 /* S was on the free-list before. Put it there again. */
1818 NEXT_FREE_LISP_STRING (s) = string_free_list;
1819 string_free_list = s;
1820 ++nfree;
1824 /* Free blocks that contain free Lisp_Strings only, except
1825 the first two of them. */
1826 if (nfree == STRING_BLOCK_SIZE
1827 && total_free_strings > STRING_BLOCK_SIZE)
1829 lisp_free (b);
1830 string_free_list = free_list_before;
1832 else
1834 total_free_strings += nfree;
1835 b->next = live_blocks;
1836 live_blocks = b;
1840 check_string_free_list ();
1842 string_blocks = live_blocks;
1843 free_large_strings ();
1844 compact_small_strings ();
1846 check_string_free_list ();
1850 /* Free dead large strings. */
1852 static void
1853 free_large_strings (void)
1855 struct sblock *b, *next;
1856 struct sblock *live_blocks = NULL;
1858 for (b = large_sblocks; b; b = next)
1860 next = b->next;
1862 if (b->first_data.string == NULL)
1863 lisp_free (b);
1864 else
1866 b->next = live_blocks;
1867 live_blocks = b;
1871 large_sblocks = live_blocks;
1875 /* Compact data of small strings. Free sblocks that don't contain
1876 data of live strings after compaction. */
1878 static void
1879 compact_small_strings (void)
1881 struct sblock *b, *tb, *next;
1882 struct sdata *from, *to, *end, *tb_end;
1883 struct sdata *to_end, *from_end;
1885 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1886 to, and TB_END is the end of TB. */
1887 tb = oldest_sblock;
1888 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
1889 to = &tb->first_data;
1891 /* Step through the blocks from the oldest to the youngest. We
1892 expect that old blocks will stabilize over time, so that less
1893 copying will happen this way. */
1894 for (b = oldest_sblock; b; b = b->next)
1896 end = b->next_free;
1897 eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
1899 for (from = &b->first_data; from < end; from = from_end)
1901 /* Compute the next FROM here because copying below may
1902 overwrite data we need to compute it. */
1903 ptrdiff_t nbytes;
1904 struct Lisp_String *s = from->string;
1906 #ifdef GC_CHECK_STRING_BYTES
1907 /* Check that the string size recorded in the string is the
1908 same as the one recorded in the sdata structure. */
1909 if (s && string_bytes (s) != SDATA_NBYTES (from))
1910 emacs_abort ();
1911 #endif /* GC_CHECK_STRING_BYTES */
1913 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
1914 eassert (nbytes <= LARGE_STRING_BYTES);
1916 nbytes = SDATA_SIZE (nbytes);
1917 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1919 #ifdef GC_CHECK_STRING_OVERRUN
1920 if (memcmp (string_overrun_cookie,
1921 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
1922 GC_STRING_OVERRUN_COOKIE_SIZE))
1923 emacs_abort ();
1924 #endif
1926 /* Non-NULL S means it's alive. Copy its data. */
1927 if (s)
1929 /* If TB is full, proceed with the next sblock. */
1930 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
1931 if (to_end > tb_end)
1933 tb->next_free = to;
1934 tb = tb->next;
1935 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
1936 to = &tb->first_data;
1937 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
1940 /* Copy, and update the string's `data' pointer. */
1941 if (from != to)
1943 eassert (tb != b || to < from);
1944 memmove (to, from, nbytes + GC_STRING_EXTRA);
1945 to->string->data = SDATA_DATA (to);
1948 /* Advance past the sdata we copied to. */
1949 to = to_end;
1954 /* The rest of the sblocks following TB don't contain live data, so
1955 we can free them. */
1956 for (b = tb->next; b; b = next)
1958 next = b->next;
1959 lisp_free (b);
1962 tb->next_free = to;
1963 tb->next = NULL;
1964 current_sblock = tb;
1967 void
1968 string_overflow (void)
1970 error ("Maximum string size exceeded");
1973 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
1974 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
1975 LENGTH must be an integer.
1976 INIT must be an integer that represents a character. */)
1977 (Lisp_Object length, Lisp_Object init)
1979 register Lisp_Object val;
1980 register unsigned char *p, *end;
1981 int c;
1982 EMACS_INT nbytes;
1984 CHECK_NATNUM (length);
1985 CHECK_CHARACTER (init);
1987 c = XFASTINT (init);
1988 if (ASCII_CHAR_P (c))
1990 nbytes = XINT (length);
1991 val = make_uninit_string (nbytes);
1992 p = SDATA (val);
1993 end = p + SCHARS (val);
1994 while (p != end)
1995 *p++ = c;
1997 else
1999 unsigned char str[MAX_MULTIBYTE_LENGTH];
2000 int len = CHAR_STRING (c, str);
2001 EMACS_INT string_len = XINT (length);
2003 if (string_len > STRING_BYTES_MAX / len)
2004 string_overflow ();
2005 nbytes = len * string_len;
2006 val = make_uninit_multibyte_string (string_len, nbytes);
2007 p = SDATA (val);
2008 end = p + nbytes;
2009 while (p != end)
2011 memcpy (p, str, len);
2012 p += len;
2016 *p = 0;
2017 return val;
2021 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2022 doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2023 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2024 (Lisp_Object length, Lisp_Object init)
2026 register Lisp_Object val;
2027 struct Lisp_Bool_Vector *p;
2028 ptrdiff_t length_in_chars;
2029 EMACS_INT length_in_elts;
2030 int bits_per_value;
2031 int extra_bool_elts = ((bool_header_size - header_size + word_size - 1)
2032 / word_size);
2034 CHECK_NATNUM (length);
2036 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2038 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2040 val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
2042 /* No Lisp_Object to trace in there. */
2043 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0);
2045 p = XBOOL_VECTOR (val);
2046 p->size = XFASTINT (length);
2048 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2049 / BOOL_VECTOR_BITS_PER_CHAR);
2050 if (length_in_chars)
2052 memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars);
2054 /* Clear any extraneous bits in the last byte. */
2055 p->data[length_in_chars - 1]
2056 &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
2059 return val;
2063 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2064 of characters from the contents. This string may be unibyte or
2065 multibyte, depending on the contents. */
2067 Lisp_Object
2068 make_string (const char *contents, ptrdiff_t nbytes)
2070 register Lisp_Object val;
2071 ptrdiff_t nchars, multibyte_nbytes;
2073 parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
2074 &nchars, &multibyte_nbytes);
2075 if (nbytes == nchars || nbytes != multibyte_nbytes)
2076 /* CONTENTS contains no multibyte sequences or contains an invalid
2077 multibyte sequence. We must make unibyte string. */
2078 val = make_unibyte_string (contents, nbytes);
2079 else
2080 val = make_multibyte_string (contents, nchars, nbytes);
2081 return val;
2085 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2087 Lisp_Object
2088 make_unibyte_string (const char *contents, ptrdiff_t length)
2090 register Lisp_Object val;
2091 val = make_uninit_string (length);
2092 memcpy (SDATA (val), contents, length);
2093 return val;
2097 /* Make a multibyte string from NCHARS characters occupying NBYTES
2098 bytes at CONTENTS. */
2100 Lisp_Object
2101 make_multibyte_string (const char *contents,
2102 ptrdiff_t nchars, ptrdiff_t nbytes)
2104 register Lisp_Object val;
2105 val = make_uninit_multibyte_string (nchars, nbytes);
2106 memcpy (SDATA (val), contents, nbytes);
2107 return val;
2111 /* Make a string from NCHARS characters occupying NBYTES bytes at
2112 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2114 Lisp_Object
2115 make_string_from_bytes (const char *contents,
2116 ptrdiff_t nchars, ptrdiff_t nbytes)
2118 register Lisp_Object val;
2119 val = make_uninit_multibyte_string (nchars, nbytes);
2120 memcpy (SDATA (val), contents, nbytes);
2121 if (SBYTES (val) == SCHARS (val))
2122 STRING_SET_UNIBYTE (val);
2123 return val;
2127 /* Make a string from NCHARS characters occupying NBYTES bytes at
2128 CONTENTS. The argument MULTIBYTE controls whether to label the
2129 string as multibyte. If NCHARS is negative, it counts the number of
2130 characters by itself. */
2132 Lisp_Object
2133 make_specified_string (const char *contents,
2134 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
2136 Lisp_Object val;
2138 if (nchars < 0)
2140 if (multibyte)
2141 nchars = multibyte_chars_in_text ((const unsigned char *) contents,
2142 nbytes);
2143 else
2144 nchars = nbytes;
2146 val = make_uninit_multibyte_string (nchars, nbytes);
2147 memcpy (SDATA (val), contents, nbytes);
2148 if (!multibyte)
2149 STRING_SET_UNIBYTE (val);
2150 return val;
2154 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2155 occupying LENGTH bytes. */
2157 Lisp_Object
2158 make_uninit_string (EMACS_INT length)
2160 Lisp_Object val;
2162 if (!length)
2163 return empty_unibyte_string;
2164 val = make_uninit_multibyte_string (length, length);
2165 STRING_SET_UNIBYTE (val);
2166 return val;
2170 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2171 which occupy NBYTES bytes. */
2173 Lisp_Object
2174 make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2176 Lisp_Object string;
2177 struct Lisp_String *s;
2179 if (nchars < 0)
2180 emacs_abort ();
2181 if (!nbytes)
2182 return empty_multibyte_string;
2184 s = allocate_string ();
2185 s->intervals = NULL;
2186 allocate_string_data (s, nchars, nbytes);
2187 XSETSTRING (string, s);
2188 string_chars_consed += nbytes;
2189 return string;
2192 /* Print arguments to BUF according to a FORMAT, then return
2193 a Lisp_String initialized with the data from BUF. */
2195 Lisp_Object
2196 make_formatted_string (char *buf, const char *format, ...)
2198 va_list ap;
2199 int length;
2201 va_start (ap, format);
2202 length = vsprintf (buf, format, ap);
2203 va_end (ap);
2204 return make_string (buf, length);
2208 /***********************************************************************
2209 Float Allocation
2210 ***********************************************************************/
2212 /* We store float cells inside of float_blocks, allocating a new
2213 float_block with malloc whenever necessary. Float cells reclaimed
2214 by GC are put on a free list to be reallocated before allocating
2215 any new float cells from the latest float_block. */
2217 #define FLOAT_BLOCK_SIZE \
2218 (((BLOCK_BYTES - sizeof (struct float_block *) \
2219 /* The compiler might add padding at the end. */ \
2220 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2221 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2223 #define GETMARKBIT(block,n) \
2224 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2225 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2226 & 1)
2228 #define SETMARKBIT(block,n) \
2229 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2230 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2232 #define UNSETMARKBIT(block,n) \
2233 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2234 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2236 #define FLOAT_BLOCK(fptr) \
2237 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2239 #define FLOAT_INDEX(fptr) \
2240 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2242 struct float_block
2244 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2245 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2246 int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
2247 struct float_block *next;
2250 #define FLOAT_MARKED_P(fptr) \
2251 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2253 #define FLOAT_MARK(fptr) \
2254 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2256 #define FLOAT_UNMARK(fptr) \
2257 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2259 /* Current float_block. */
2261 static struct float_block *float_block;
2263 /* Index of first unused Lisp_Float in the current float_block. */
2265 static int float_block_index = FLOAT_BLOCK_SIZE;
2267 /* Free-list of Lisp_Floats. */
2269 static struct Lisp_Float *float_free_list;
2271 /* Return a new float object with value FLOAT_VALUE. */
2273 Lisp_Object
2274 make_float (double float_value)
2276 register Lisp_Object val;
2278 MALLOC_BLOCK_INPUT;
2280 if (float_free_list)
2282 /* We use the data field for chaining the free list
2283 so that we won't use the same field that has the mark bit. */
2284 XSETFLOAT (val, float_free_list);
2285 float_free_list = float_free_list->u.chain;
2287 else
2289 if (float_block_index == FLOAT_BLOCK_SIZE)
2291 struct float_block *new
2292 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
2293 new->next = float_block;
2294 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2295 float_block = new;
2296 float_block_index = 0;
2297 total_free_floats += FLOAT_BLOCK_SIZE;
2299 XSETFLOAT (val, &float_block->floats[float_block_index]);
2300 float_block_index++;
2303 MALLOC_UNBLOCK_INPUT;
2305 XFLOAT_INIT (val, float_value);
2306 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2307 consing_since_gc += sizeof (struct Lisp_Float);
2308 floats_consed++;
2309 total_free_floats--;
2310 return val;
2315 /***********************************************************************
2316 Cons Allocation
2317 ***********************************************************************/
2319 /* We store cons cells inside of cons_blocks, allocating a new
2320 cons_block with malloc whenever necessary. Cons cells reclaimed by
2321 GC are put on a free list to be reallocated before allocating
2322 any new cons cells from the latest cons_block. */
2324 #define CONS_BLOCK_SIZE \
2325 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2326 /* The compiler might add padding at the end. */ \
2327 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2328 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2330 #define CONS_BLOCK(fptr) \
2331 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2333 #define CONS_INDEX(fptr) \
2334 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2336 struct cons_block
2338 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2339 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2340 int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
2341 struct cons_block *next;
2344 #define CONS_MARKED_P(fptr) \
2345 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2347 #define CONS_MARK(fptr) \
2348 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2350 #define CONS_UNMARK(fptr) \
2351 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2353 /* Current cons_block. */
2355 static struct cons_block *cons_block;
2357 /* Index of first unused Lisp_Cons in the current block. */
2359 static int cons_block_index = CONS_BLOCK_SIZE;
2361 /* Free-list of Lisp_Cons structures. */
2363 static struct Lisp_Cons *cons_free_list;
2365 /* Explicitly free a cons cell by putting it on the free-list. */
2367 void
2368 free_cons (struct Lisp_Cons *ptr)
2370 ptr->u.chain = cons_free_list;
2371 #if GC_MARK_STACK
2372 ptr->car = Vdead;
2373 #endif
2374 cons_free_list = ptr;
2375 consing_since_gc -= sizeof *ptr;
2376 total_free_conses++;
2379 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2380 doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2381 (Lisp_Object car, Lisp_Object cdr)
2383 register Lisp_Object val;
2385 MALLOC_BLOCK_INPUT;
2387 if (cons_free_list)
2389 /* We use the cdr for chaining the free list
2390 so that we won't use the same field that has the mark bit. */
2391 XSETCONS (val, cons_free_list);
2392 cons_free_list = cons_free_list->u.chain;
2394 else
2396 if (cons_block_index == CONS_BLOCK_SIZE)
2398 struct cons_block *new
2399 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
2400 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2401 new->next = cons_block;
2402 cons_block = new;
2403 cons_block_index = 0;
2404 total_free_conses += CONS_BLOCK_SIZE;
2406 XSETCONS (val, &cons_block->conses[cons_block_index]);
2407 cons_block_index++;
2410 MALLOC_UNBLOCK_INPUT;
2412 XSETCAR (val, car);
2413 XSETCDR (val, cdr);
2414 eassert (!CONS_MARKED_P (XCONS (val)));
2415 consing_since_gc += sizeof (struct Lisp_Cons);
2416 total_free_conses--;
2417 cons_cells_consed++;
2418 return val;
2421 #ifdef GC_CHECK_CONS_LIST
2422 /* Get an error now if there's any junk in the cons free list. */
2423 void
2424 check_cons_list (void)
2426 struct Lisp_Cons *tail = cons_free_list;
2428 while (tail)
2429 tail = tail->u.chain;
2431 #endif
2433 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2435 Lisp_Object
2436 list1 (Lisp_Object arg1)
2438 return Fcons (arg1, Qnil);
2441 Lisp_Object
2442 list2 (Lisp_Object arg1, Lisp_Object arg2)
2444 return Fcons (arg1, Fcons (arg2, Qnil));
2448 Lisp_Object
2449 list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2451 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2455 Lisp_Object
2456 list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
2458 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2462 Lisp_Object
2463 list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
2465 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2466 Fcons (arg5, Qnil)))));
2469 /* Make a list of COUNT Lisp_Objects, where ARG is the
2470 first one. Allocate conses from pure space if TYPE
2471 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2473 Lisp_Object
2474 listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
2476 va_list ap;
2477 ptrdiff_t i;
2478 Lisp_Object val, *objp;
2480 /* Change to SAFE_ALLOCA if you hit this eassert. */
2481 eassert (count <= MAX_ALLOCA / word_size);
2483 objp = alloca (count * word_size);
2484 objp[0] = arg;
2485 va_start (ap, arg);
2486 for (i = 1; i < count; i++)
2487 objp[i] = va_arg (ap, Lisp_Object);
2488 va_end (ap);
2490 for (val = Qnil, i = count - 1; i >= 0; i--)
2492 if (type == CONSTYPE_PURE)
2493 val = pure_cons (objp[i], val);
2494 else if (type == CONSTYPE_HEAP)
2495 val = Fcons (objp[i], val);
2496 else
2497 emacs_abort ();
2499 return val;
2502 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2503 doc: /* Return a newly created list with specified arguments as elements.
2504 Any number of arguments, even zero arguments, are allowed.
2505 usage: (list &rest OBJECTS) */)
2506 (ptrdiff_t nargs, Lisp_Object *args)
2508 register Lisp_Object val;
2509 val = Qnil;
2511 while (nargs > 0)
2513 nargs--;
2514 val = Fcons (args[nargs], val);
2516 return val;
2520 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2521 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2522 (register Lisp_Object length, Lisp_Object init)
2524 register Lisp_Object val;
2525 register EMACS_INT size;
2527 CHECK_NATNUM (length);
2528 size = XFASTINT (length);
2530 val = Qnil;
2531 while (size > 0)
2533 val = Fcons (init, val);
2534 --size;
2536 if (size > 0)
2538 val = Fcons (init, val);
2539 --size;
2541 if (size > 0)
2543 val = Fcons (init, val);
2544 --size;
2546 if (size > 0)
2548 val = Fcons (init, val);
2549 --size;
2551 if (size > 0)
2553 val = Fcons (init, val);
2554 --size;
2560 QUIT;
2563 return val;
2568 /***********************************************************************
2569 Vector Allocation
2570 ***********************************************************************/
2572 /* This value is balanced well enough to avoid too much internal overhead
2573 for the most common cases; it's not required to be a power of two, but
2574 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2576 #define VECTOR_BLOCK_SIZE 4096
2578 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2579 enum
2581 roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
2584 /* ROUNDUP_SIZE must be a power of 2. */
2585 verify ((roundup_size & (roundup_size - 1)) == 0);
2587 /* Verify assumptions described above. */
2588 verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0);
2589 verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
2591 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2593 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2595 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2597 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2599 /* Size of the minimal vector allocated from block. */
2601 #define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2603 /* Size of the largest vector allocated from block. */
2605 #define VBLOCK_BYTES_MAX \
2606 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2608 /* We maintain one free list for each possible block-allocated
2609 vector size, and this is the number of free lists we have. */
2611 #define VECTOR_MAX_FREE_LIST_INDEX \
2612 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2614 /* Common shortcut to advance vector pointer over a block data. */
2616 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2618 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2620 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2622 /* Common shortcut to setup vector on a free list. */
2624 #define SETUP_ON_FREE_LIST(v, nbytes, index) \
2625 do { \
2626 XSETPVECTYPESIZE (v, PVEC_FREE, nbytes); \
2627 eassert ((nbytes) % roundup_size == 0); \
2628 (index) = VINDEX (nbytes); \
2629 eassert ((index) < VECTOR_MAX_FREE_LIST_INDEX); \
2630 (v)->header.next.vector = vector_free_lists[index]; \
2631 vector_free_lists[index] = (v); \
2632 total_free_vector_slots += (nbytes) / word_size; \
2633 } while (0)
2635 struct vector_block
2637 char data[VECTOR_BLOCK_BYTES];
2638 struct vector_block *next;
2641 /* Chain of vector blocks. */
2643 static struct vector_block *vector_blocks;
2645 /* Vector free lists, where NTH item points to a chain of free
2646 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2648 static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
2650 /* Singly-linked list of large vectors. */
2652 static struct Lisp_Vector *large_vectors;
2654 /* The only vector with 0 slots, allocated from pure space. */
2656 Lisp_Object zero_vector;
2658 /* Number of live vectors. */
2660 static EMACS_INT total_vectors;
2662 /* Total size of live and free vectors, in Lisp_Object units. */
2664 static EMACS_INT total_vector_slots, total_free_vector_slots;
2666 /* Get a new vector block. */
2668 static struct vector_block *
2669 allocate_vector_block (void)
2671 struct vector_block *block = xmalloc (sizeof *block);
2673 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2674 mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
2675 MEM_TYPE_VECTOR_BLOCK);
2676 #endif
2678 block->next = vector_blocks;
2679 vector_blocks = block;
2680 return block;
2683 /* Called once to initialize vector allocation. */
2685 static void
2686 init_vectors (void)
2688 zero_vector = make_pure_vector (0);
2691 /* Allocate vector from a vector block. */
2693 static struct Lisp_Vector *
2694 allocate_vector_from_block (size_t nbytes)
2696 struct Lisp_Vector *vector, *rest;
2697 struct vector_block *block;
2698 size_t index, restbytes;
2700 eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
2701 eassert (nbytes % roundup_size == 0);
2703 /* First, try to allocate from a free list
2704 containing vectors of the requested size. */
2705 index = VINDEX (nbytes);
2706 if (vector_free_lists[index])
2708 vector = vector_free_lists[index];
2709 vector_free_lists[index] = vector->header.next.vector;
2710 vector->header.next.nbytes = nbytes;
2711 total_free_vector_slots -= nbytes / word_size;
2712 return vector;
2715 /* Next, check free lists containing larger vectors. Since
2716 we will split the result, we should have remaining space
2717 large enough to use for one-slot vector at least. */
2718 for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
2719 index < VECTOR_MAX_FREE_LIST_INDEX; index++)
2720 if (vector_free_lists[index])
2722 /* This vector is larger than requested. */
2723 vector = vector_free_lists[index];
2724 vector_free_lists[index] = vector->header.next.vector;
2725 vector->header.next.nbytes = nbytes;
2726 total_free_vector_slots -= nbytes / word_size;
2728 /* Excess bytes are used for the smaller vector,
2729 which should be set on an appropriate free list. */
2730 restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
2731 eassert (restbytes % roundup_size == 0);
2732 rest = ADVANCE (vector, nbytes);
2733 SETUP_ON_FREE_LIST (rest, restbytes, index);
2734 return vector;
2737 /* Finally, need a new vector block. */
2738 block = allocate_vector_block ();
2740 /* New vector will be at the beginning of this block. */
2741 vector = (struct Lisp_Vector *) block->data;
2742 vector->header.next.nbytes = nbytes;
2744 /* If the rest of space from this block is large enough
2745 for one-slot vector at least, set up it on a free list. */
2746 restbytes = VECTOR_BLOCK_BYTES - nbytes;
2747 if (restbytes >= VBLOCK_BYTES_MIN)
2749 eassert (restbytes % roundup_size == 0);
2750 rest = ADVANCE (vector, nbytes);
2751 SETUP_ON_FREE_LIST (rest, restbytes, index);
2753 return vector;
2756 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2758 #define VECTOR_IN_BLOCK(vector, block) \
2759 ((char *) (vector) <= (block)->data \
2760 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2762 /* Number of bytes used by vector-block-allocated object. This is the only
2763 place where we actually use the `nbytes' field of the vector-header.
2764 I.e. we could get rid of the `nbytes' field by computing it based on the
2765 vector-type. */
2767 #define PSEUDOVECTOR_NBYTES(vector) \
2768 (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) \
2769 ? vector->header.size & PSEUDOVECTOR_SIZE_MASK \
2770 : vector->header.next.nbytes)
2772 /* Reclaim space used by unmarked vectors. */
2774 static void
2775 sweep_vectors (void)
2777 struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
2778 struct Lisp_Vector *vector, *next, **vprev = &large_vectors;
2780 total_vectors = total_vector_slots = total_free_vector_slots = 0;
2781 memset (vector_free_lists, 0, sizeof (vector_free_lists));
2783 /* Looking through vector blocks. */
2785 for (block = vector_blocks; block; block = *bprev)
2787 bool free_this_block = 0;
2789 for (vector = (struct Lisp_Vector *) block->data;
2790 VECTOR_IN_BLOCK (vector, block); vector = next)
2792 if (VECTOR_MARKED_P (vector))
2794 VECTOR_UNMARK (vector);
2795 total_vectors++;
2796 total_vector_slots += vector->header.next.nbytes / word_size;
2797 next = ADVANCE (vector, vector->header.next.nbytes);
2799 else
2801 ptrdiff_t nbytes = PSEUDOVECTOR_NBYTES (vector);
2802 ptrdiff_t total_bytes = nbytes;
2804 next = ADVANCE (vector, nbytes);
2806 /* While NEXT is not marked, try to coalesce with VECTOR,
2807 thus making VECTOR of the largest possible size. */
2809 while (VECTOR_IN_BLOCK (next, block))
2811 if (VECTOR_MARKED_P (next))
2812 break;
2813 nbytes = PSEUDOVECTOR_NBYTES (next);
2814 total_bytes += nbytes;
2815 next = ADVANCE (next, nbytes);
2818 eassert (total_bytes % roundup_size == 0);
2820 if (vector == (struct Lisp_Vector *) block->data
2821 && !VECTOR_IN_BLOCK (next, block))
2822 /* This block should be freed because all of it's
2823 space was coalesced into the only free vector. */
2824 free_this_block = 1;
2825 else
2827 int tmp;
2828 SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
2833 if (free_this_block)
2835 *bprev = block->next;
2836 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2837 mem_delete (mem_find (block->data));
2838 #endif
2839 xfree (block);
2841 else
2842 bprev = &block->next;
2845 /* Sweep large vectors. */
2847 for (vector = large_vectors; vector; vector = *vprev)
2849 if (VECTOR_MARKED_P (vector))
2851 VECTOR_UNMARK (vector);
2852 total_vectors++;
2853 if (vector->header.size & PSEUDOVECTOR_FLAG)
2855 struct Lisp_Bool_Vector *b = (struct Lisp_Bool_Vector *) vector;
2857 /* All non-bool pseudovectors are small enough to be allocated
2858 from vector blocks. This code should be redesigned if some
2859 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2860 eassert (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR));
2862 total_vector_slots
2863 += (bool_header_size
2864 + ((b->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2865 / BOOL_VECTOR_BITS_PER_CHAR)) / word_size;
2867 else
2868 total_vector_slots
2869 += header_size / word_size + vector->header.size;
2870 vprev = &vector->header.next.vector;
2872 else
2874 *vprev = vector->header.next.vector;
2875 lisp_free (vector);
2880 /* Value is a pointer to a newly allocated Lisp_Vector structure
2881 with room for LEN Lisp_Objects. */
2883 static struct Lisp_Vector *
2884 allocate_vectorlike (ptrdiff_t len)
2886 struct Lisp_Vector *p;
2888 MALLOC_BLOCK_INPUT;
2890 if (len == 0)
2891 p = XVECTOR (zero_vector);
2892 else
2894 size_t nbytes = header_size + len * word_size;
2896 #ifdef DOUG_LEA_MALLOC
2897 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2898 because mapped region contents are not preserved in
2899 a dumped Emacs. */
2900 mallopt (M_MMAP_MAX, 0);
2901 #endif
2903 if (nbytes <= VBLOCK_BYTES_MAX)
2904 p = allocate_vector_from_block (vroundup (nbytes));
2905 else
2907 p = lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
2908 p->header.next.vector = large_vectors;
2909 large_vectors = p;
2912 #ifdef DOUG_LEA_MALLOC
2913 /* Back to a reasonable maximum of mmap'ed areas. */
2914 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2915 #endif
2917 consing_since_gc += nbytes;
2918 vector_cells_consed += len;
2921 MALLOC_UNBLOCK_INPUT;
2923 return p;
2927 /* Allocate a vector with LEN slots. */
2929 struct Lisp_Vector *
2930 allocate_vector (EMACS_INT len)
2932 struct Lisp_Vector *v;
2933 ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX);
2935 if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
2936 memory_full (SIZE_MAX);
2937 v = allocate_vectorlike (len);
2938 v->header.size = len;
2939 return v;
2943 /* Allocate other vector-like structures. */
2945 struct Lisp_Vector *
2946 allocate_pseudovector (int memlen, int lisplen, int tag)
2948 struct Lisp_Vector *v = allocate_vectorlike (memlen);
2949 int i;
2951 /* Only the first lisplen slots will be traced normally by the GC. */
2952 for (i = 0; i < lisplen; ++i)
2953 v->contents[i] = Qnil;
2955 XSETPVECTYPESIZE (v, tag, lisplen);
2956 return v;
2959 struct buffer *
2960 allocate_buffer (void)
2962 struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER);
2964 XSETPVECTYPESIZE (b, PVEC_BUFFER, (offsetof (struct buffer, own_text)
2965 - header_size) / word_size);
2966 /* Put B on the chain of all buffers including killed ones. */
2967 b->header.next.buffer = all_buffers;
2968 all_buffers = b;
2969 /* Note that the rest fields of B are not initialized. */
2970 return b;
2973 struct Lisp_Hash_Table *
2974 allocate_hash_table (void)
2976 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
2979 struct window *
2980 allocate_window (void)
2982 struct window *w;
2984 w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW);
2985 /* Users assumes that non-Lisp data is zeroed. */
2986 memset (&w->current_matrix, 0,
2987 sizeof (*w) - offsetof (struct window, current_matrix));
2988 return w;
2991 struct terminal *
2992 allocate_terminal (void)
2994 struct terminal *t;
2996 t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL);
2997 /* Users assumes that non-Lisp data is zeroed. */
2998 memset (&t->next_terminal, 0,
2999 sizeof (*t) - offsetof (struct terminal, next_terminal));
3000 return t;
3003 struct frame *
3004 allocate_frame (void)
3006 struct frame *f;
3008 f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME);
3009 /* Users assumes that non-Lisp data is zeroed. */
3010 memset (&f->face_cache, 0,
3011 sizeof (*f) - offsetof (struct frame, face_cache));
3012 return f;
3015 struct Lisp_Process *
3016 allocate_process (void)
3018 struct Lisp_Process *p;
3020 p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3021 /* Users assumes that non-Lisp data is zeroed. */
3022 memset (&p->pid, 0,
3023 sizeof (*p) - offsetof (struct Lisp_Process, pid));
3024 return p;
3027 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3028 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
3029 See also the function `vector'. */)
3030 (register Lisp_Object length, Lisp_Object init)
3032 Lisp_Object vector;
3033 register ptrdiff_t sizei;
3034 register ptrdiff_t i;
3035 register struct Lisp_Vector *p;
3037 CHECK_NATNUM (length);
3039 p = allocate_vector (XFASTINT (length));
3040 sizei = XFASTINT (length);
3041 for (i = 0; i < sizei; i++)
3042 p->contents[i] = init;
3044 XSETVECTOR (vector, p);
3045 return vector;
3049 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3050 doc: /* Return a newly created vector with specified arguments as elements.
3051 Any number of arguments, even zero arguments, are allowed.
3052 usage: (vector &rest OBJECTS) */)
3053 (ptrdiff_t nargs, Lisp_Object *args)
3055 register Lisp_Object len, val;
3056 ptrdiff_t i;
3057 register struct Lisp_Vector *p;
3059 XSETFASTINT (len, nargs);
3060 val = Fmake_vector (len, Qnil);
3061 p = XVECTOR (val);
3062 for (i = 0; i < nargs; i++)
3063 p->contents[i] = args[i];
3064 return val;
3067 void
3068 make_byte_code (struct Lisp_Vector *v)
3070 if (v->header.size > 1 && STRINGP (v->contents[1])
3071 && STRING_MULTIBYTE (v->contents[1]))
3072 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3073 earlier because they produced a raw 8-bit string for byte-code
3074 and now such a byte-code string is loaded as multibyte while
3075 raw 8-bit characters converted to multibyte form. Thus, now we
3076 must convert them back to the original unibyte form. */
3077 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3078 XSETPVECTYPE (v, PVEC_COMPILED);
3081 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3082 doc: /* Create a byte-code object with specified arguments as elements.
3083 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3084 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3085 and (optional) INTERACTIVE-SPEC.
3086 The first four arguments are required; at most six have any
3087 significance.
3088 The ARGLIST can be either like the one of `lambda', in which case the arguments
3089 will be dynamically bound before executing the byte code, or it can be an
3090 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3091 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3092 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3093 argument to catch the left-over arguments. If such an integer is used, the
3094 arguments will not be dynamically bound but will be instead pushed on the
3095 stack before executing the byte-code.
3096 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3097 (ptrdiff_t nargs, Lisp_Object *args)
3099 register Lisp_Object len, val;
3100 ptrdiff_t i;
3101 register struct Lisp_Vector *p;
3103 /* We used to purecopy everything here, if purify-flag was set. This worked
3104 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3105 dangerous, since make-byte-code is used during execution to build
3106 closures, so any closure built during the preload phase would end up
3107 copied into pure space, including its free variables, which is sometimes
3108 just wasteful and other times plainly wrong (e.g. those free vars may want
3109 to be setcar'd). */
3111 XSETFASTINT (len, nargs);
3112 val = Fmake_vector (len, Qnil);
3114 p = XVECTOR (val);
3115 for (i = 0; i < nargs; i++)
3116 p->contents[i] = args[i];
3117 make_byte_code (p);
3118 XSETCOMPILED (val, p);
3119 return val;
3124 /***********************************************************************
3125 Symbol Allocation
3126 ***********************************************************************/
3128 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3129 of the required alignment if LSB tags are used. */
3131 union aligned_Lisp_Symbol
3133 struct Lisp_Symbol s;
3134 #if USE_LSB_TAG
3135 unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
3136 & -GCALIGNMENT];
3137 #endif
3140 /* Each symbol_block is just under 1020 bytes long, since malloc
3141 really allocates in units of powers of two and uses 4 bytes for its
3142 own overhead. */
3144 #define SYMBOL_BLOCK_SIZE \
3145 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3147 struct symbol_block
3149 /* Place `symbols' first, to preserve alignment. */
3150 union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3151 struct symbol_block *next;
3154 /* Current symbol block and index of first unused Lisp_Symbol
3155 structure in it. */
3157 static struct symbol_block *symbol_block;
3158 static int symbol_block_index = SYMBOL_BLOCK_SIZE;
3160 /* List of free symbols. */
3162 static struct Lisp_Symbol *symbol_free_list;
3164 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3165 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3166 Its value and function definition are void, and its property list is nil. */)
3167 (Lisp_Object name)
3169 register Lisp_Object val;
3170 register struct Lisp_Symbol *p;
3172 CHECK_STRING (name);
3174 MALLOC_BLOCK_INPUT;
3176 if (symbol_free_list)
3178 XSETSYMBOL (val, symbol_free_list);
3179 symbol_free_list = symbol_free_list->next;
3181 else
3183 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3185 struct symbol_block *new
3186 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL);
3187 new->next = symbol_block;
3188 symbol_block = new;
3189 symbol_block_index = 0;
3190 total_free_symbols += SYMBOL_BLOCK_SIZE;
3192 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
3193 symbol_block_index++;
3196 MALLOC_UNBLOCK_INPUT;
3198 p = XSYMBOL (val);
3199 set_symbol_name (val, name);
3200 set_symbol_plist (val, Qnil);
3201 p->redirect = SYMBOL_PLAINVAL;
3202 SET_SYMBOL_VAL (p, Qunbound);
3203 set_symbol_function (val, Qunbound);
3204 set_symbol_next (val, NULL);
3205 p->gcmarkbit = 0;
3206 p->interned = SYMBOL_UNINTERNED;
3207 p->constant = 0;
3208 p->declared_special = 0;
3209 consing_since_gc += sizeof (struct Lisp_Symbol);
3210 symbols_consed++;
3211 total_free_symbols--;
3212 return val;
3217 /***********************************************************************
3218 Marker (Misc) Allocation
3219 ***********************************************************************/
3221 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3222 the required alignment when LSB tags are used. */
3224 union aligned_Lisp_Misc
3226 union Lisp_Misc m;
3227 #if USE_LSB_TAG
3228 unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
3229 & -GCALIGNMENT];
3230 #endif
3233 /* Allocation of markers and other objects that share that structure.
3234 Works like allocation of conses. */
3236 #define MARKER_BLOCK_SIZE \
3237 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3239 struct marker_block
3241 /* Place `markers' first, to preserve alignment. */
3242 union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
3243 struct marker_block *next;
3246 static struct marker_block *marker_block;
3247 static int marker_block_index = MARKER_BLOCK_SIZE;
3249 static union Lisp_Misc *marker_free_list;
3251 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3253 static Lisp_Object
3254 allocate_misc (enum Lisp_Misc_Type type)
3256 Lisp_Object val;
3258 MALLOC_BLOCK_INPUT;
3260 if (marker_free_list)
3262 XSETMISC (val, marker_free_list);
3263 marker_free_list = marker_free_list->u_free.chain;
3265 else
3267 if (marker_block_index == MARKER_BLOCK_SIZE)
3269 struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
3270 new->next = marker_block;
3271 marker_block = new;
3272 marker_block_index = 0;
3273 total_free_markers += MARKER_BLOCK_SIZE;
3275 XSETMISC (val, &marker_block->markers[marker_block_index].m);
3276 marker_block_index++;
3279 MALLOC_UNBLOCK_INPUT;
3281 --total_free_markers;
3282 consing_since_gc += sizeof (union Lisp_Misc);
3283 misc_objects_consed++;
3284 XMISCTYPE (val) = type;
3285 XMISCANY (val)->gcmarkbit = 0;
3286 return val;
3289 /* Free a Lisp_Misc object */
3291 static void
3292 free_misc (Lisp_Object misc)
3294 XMISCTYPE (misc) = Lisp_Misc_Free;
3295 XMISC (misc)->u_free.chain = marker_free_list;
3296 marker_free_list = XMISC (misc);
3297 consing_since_gc -= sizeof (union Lisp_Misc);
3298 total_free_markers++;
3301 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3302 INTEGER. This is used to package C values to call record_unwind_protect.
3303 The unwind function can get the C values back using XSAVE_VALUE. */
3305 Lisp_Object
3306 make_save_value (void *pointer, ptrdiff_t integer)
3308 register Lisp_Object val;
3309 register struct Lisp_Save_Value *p;
3311 val = allocate_misc (Lisp_Misc_Save_Value);
3312 p = XSAVE_VALUE (val);
3313 p->pointer = pointer;
3314 p->integer = integer;
3315 p->dogc = 0;
3316 return val;
3319 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3321 Lisp_Object
3322 build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
3324 register Lisp_Object overlay;
3326 overlay = allocate_misc (Lisp_Misc_Overlay);
3327 OVERLAY_START (overlay) = start;
3328 OVERLAY_END (overlay) = end;
3329 set_overlay_plist (overlay, plist);
3330 XOVERLAY (overlay)->next = NULL;
3331 return overlay;
3334 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3335 doc: /* Return a newly allocated marker which does not point at any place. */)
3336 (void)
3338 register Lisp_Object val;
3339 register struct Lisp_Marker *p;
3341 val = allocate_misc (Lisp_Misc_Marker);
3342 p = XMARKER (val);
3343 p->buffer = 0;
3344 p->bytepos = 0;
3345 p->charpos = 0;
3346 p->next = NULL;
3347 p->insertion_type = 0;
3348 return val;
3351 /* Return a newly allocated marker which points into BUF
3352 at character position CHARPOS and byte position BYTEPOS. */
3354 Lisp_Object
3355 build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3357 Lisp_Object obj;
3358 struct Lisp_Marker *m;
3360 /* No dead buffers here. */
3361 eassert (BUFFER_LIVE_P (buf));
3363 /* Every character is at least one byte. */
3364 eassert (charpos <= bytepos);
3366 obj = allocate_misc (Lisp_Misc_Marker);
3367 m = XMARKER (obj);
3368 m->buffer = buf;
3369 m->charpos = charpos;
3370 m->bytepos = bytepos;
3371 m->insertion_type = 0;
3372 m->next = BUF_MARKERS (buf);
3373 BUF_MARKERS (buf) = m;
3374 return obj;
3377 /* Put MARKER back on the free list after using it temporarily. */
3379 void
3380 free_marker (Lisp_Object marker)
3382 unchain_marker (XMARKER (marker));
3383 free_misc (marker);
3387 /* Return a newly created vector or string with specified arguments as
3388 elements. If all the arguments are characters that can fit
3389 in a string of events, make a string; otherwise, make a vector.
3391 Any number of arguments, even zero arguments, are allowed. */
3393 Lisp_Object
3394 make_event_array (register int nargs, Lisp_Object *args)
3396 int i;
3398 for (i = 0; i < nargs; i++)
3399 /* The things that fit in a string
3400 are characters that are in 0...127,
3401 after discarding the meta bit and all the bits above it. */
3402 if (!INTEGERP (args[i])
3403 || (XINT (args[i]) & ~(-CHAR_META)) >= 0200)
3404 return Fvector (nargs, args);
3406 /* Since the loop exited, we know that all the things in it are
3407 characters, so we can make a string. */
3409 Lisp_Object result;
3411 result = Fmake_string (make_number (nargs), make_number (0));
3412 for (i = 0; i < nargs; i++)
3414 SSET (result, i, XINT (args[i]));
3415 /* Move the meta bit to the right place for a string char. */
3416 if (XINT (args[i]) & CHAR_META)
3417 SSET (result, i, SREF (result, i) | 0x80);
3420 return result;
3426 /************************************************************************
3427 Memory Full Handling
3428 ************************************************************************/
3431 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3432 there may have been size_t overflow so that malloc was never
3433 called, or perhaps malloc was invoked successfully but the
3434 resulting pointer had problems fitting into a tagged EMACS_INT. In
3435 either case this counts as memory being full even though malloc did
3436 not fail. */
3438 void
3439 memory_full (size_t nbytes)
3441 /* Do not go into hysterics merely because a large request failed. */
3442 bool enough_free_memory = 0;
3443 if (SPARE_MEMORY < nbytes)
3445 void *p;
3447 MALLOC_BLOCK_INPUT;
3448 p = malloc (SPARE_MEMORY);
3449 if (p)
3451 free (p);
3452 enough_free_memory = 1;
3454 MALLOC_UNBLOCK_INPUT;
3457 if (! enough_free_memory)
3459 int i;
3461 Vmemory_full = Qt;
3463 memory_full_cons_threshold = sizeof (struct cons_block);
3465 /* The first time we get here, free the spare memory. */
3466 for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
3467 if (spare_memory[i])
3469 if (i == 0)
3470 free (spare_memory[i]);
3471 else if (i >= 1 && i <= 4)
3472 lisp_align_free (spare_memory[i]);
3473 else
3474 lisp_free (spare_memory[i]);
3475 spare_memory[i] = 0;
3479 /* This used to call error, but if we've run out of memory, we could
3480 get infinite recursion trying to build the string. */
3481 xsignal (Qnil, Vmemory_signal_data);
3484 /* If we released our reserve (due to running out of memory),
3485 and we have a fair amount free once again,
3486 try to set aside another reserve in case we run out once more.
3488 This is called when a relocatable block is freed in ralloc.c,
3489 and also directly from this file, in case we're not using ralloc.c. */
3491 void
3492 refill_memory_reserve (void)
3494 #ifndef SYSTEM_MALLOC
3495 if (spare_memory[0] == 0)
3496 spare_memory[0] = malloc (SPARE_MEMORY);
3497 if (spare_memory[1] == 0)
3498 spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
3499 MEM_TYPE_SPARE);
3500 if (spare_memory[2] == 0)
3501 spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
3502 MEM_TYPE_SPARE);
3503 if (spare_memory[3] == 0)
3504 spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
3505 MEM_TYPE_SPARE);
3506 if (spare_memory[4] == 0)
3507 spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
3508 MEM_TYPE_SPARE);
3509 if (spare_memory[5] == 0)
3510 spare_memory[5] = lisp_malloc (sizeof (struct string_block),
3511 MEM_TYPE_SPARE);
3512 if (spare_memory[6] == 0)
3513 spare_memory[6] = lisp_malloc (sizeof (struct string_block),
3514 MEM_TYPE_SPARE);
3515 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3516 Vmemory_full = Qnil;
3517 #endif
3520 /************************************************************************
3521 C Stack Marking
3522 ************************************************************************/
3524 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3526 /* Conservative C stack marking requires a method to identify possibly
3527 live Lisp objects given a pointer value. We do this by keeping
3528 track of blocks of Lisp data that are allocated in a red-black tree
3529 (see also the comment of mem_node which is the type of nodes in
3530 that tree). Function lisp_malloc adds information for an allocated
3531 block to the red-black tree with calls to mem_insert, and function
3532 lisp_free removes it with mem_delete. Functions live_string_p etc
3533 call mem_find to lookup information about a given pointer in the
3534 tree, and use that to determine if the pointer points to a Lisp
3535 object or not. */
3537 /* Initialize this part of alloc.c. */
3539 static void
3540 mem_init (void)
3542 mem_z.left = mem_z.right = MEM_NIL;
3543 mem_z.parent = NULL;
3544 mem_z.color = MEM_BLACK;
3545 mem_z.start = mem_z.end = NULL;
3546 mem_root = MEM_NIL;
3550 /* Value is a pointer to the mem_node containing START. Value is
3551 MEM_NIL if there is no node in the tree containing START. */
3553 static struct mem_node *
3554 mem_find (void *start)
3556 struct mem_node *p;
3558 if (start < min_heap_address || start > max_heap_address)
3559 return MEM_NIL;
3561 /* Make the search always successful to speed up the loop below. */
3562 mem_z.start = start;
3563 mem_z.end = (char *) start + 1;
3565 p = mem_root;
3566 while (start < p->start || start >= p->end)
3567 p = start < p->start ? p->left : p->right;
3568 return p;
3572 /* Insert a new node into the tree for a block of memory with start
3573 address START, end address END, and type TYPE. Value is a
3574 pointer to the node that was inserted. */
3576 static struct mem_node *
3577 mem_insert (void *start, void *end, enum mem_type type)
3579 struct mem_node *c, *parent, *x;
3581 if (min_heap_address == NULL || start < min_heap_address)
3582 min_heap_address = start;
3583 if (max_heap_address == NULL || end > max_heap_address)
3584 max_heap_address = end;
3586 /* See where in the tree a node for START belongs. In this
3587 particular application, it shouldn't happen that a node is already
3588 present. For debugging purposes, let's check that. */
3589 c = mem_root;
3590 parent = NULL;
3592 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3594 while (c != MEM_NIL)
3596 if (start >= c->start && start < c->end)
3597 emacs_abort ();
3598 parent = c;
3599 c = start < c->start ? c->left : c->right;
3602 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3604 while (c != MEM_NIL)
3606 parent = c;
3607 c = start < c->start ? c->left : c->right;
3610 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3612 /* Create a new node. */
3613 #ifdef GC_MALLOC_CHECK
3614 x = malloc (sizeof *x);
3615 if (x == NULL)
3616 emacs_abort ();
3617 #else
3618 x = xmalloc (sizeof *x);
3619 #endif
3620 x->start = start;
3621 x->end = end;
3622 x->type = type;
3623 x->parent = parent;
3624 x->left = x->right = MEM_NIL;
3625 x->color = MEM_RED;
3627 /* Insert it as child of PARENT or install it as root. */
3628 if (parent)
3630 if (start < parent->start)
3631 parent->left = x;
3632 else
3633 parent->right = x;
3635 else
3636 mem_root = x;
3638 /* Re-establish red-black tree properties. */
3639 mem_insert_fixup (x);
3641 return x;
3645 /* Re-establish the red-black properties of the tree, and thereby
3646 balance the tree, after node X has been inserted; X is always red. */
3648 static void
3649 mem_insert_fixup (struct mem_node *x)
3651 while (x != mem_root && x->parent->color == MEM_RED)
3653 /* X is red and its parent is red. This is a violation of
3654 red-black tree property #3. */
3656 if (x->parent == x->parent->parent->left)
3658 /* We're on the left side of our grandparent, and Y is our
3659 "uncle". */
3660 struct mem_node *y = x->parent->parent->right;
3662 if (y->color == MEM_RED)
3664 /* Uncle and parent are red but should be black because
3665 X is red. Change the colors accordingly and proceed
3666 with the grandparent. */
3667 x->parent->color = MEM_BLACK;
3668 y->color = MEM_BLACK;
3669 x->parent->parent->color = MEM_RED;
3670 x = x->parent->parent;
3672 else
3674 /* Parent and uncle have different colors; parent is
3675 red, uncle is black. */
3676 if (x == x->parent->right)
3678 x = x->parent;
3679 mem_rotate_left (x);
3682 x->parent->color = MEM_BLACK;
3683 x->parent->parent->color = MEM_RED;
3684 mem_rotate_right (x->parent->parent);
3687 else
3689 /* This is the symmetrical case of above. */
3690 struct mem_node *y = x->parent->parent->left;
3692 if (y->color == MEM_RED)
3694 x->parent->color = MEM_BLACK;
3695 y->color = MEM_BLACK;
3696 x->parent->parent->color = MEM_RED;
3697 x = x->parent->parent;
3699 else
3701 if (x == x->parent->left)
3703 x = x->parent;
3704 mem_rotate_right (x);
3707 x->parent->color = MEM_BLACK;
3708 x->parent->parent->color = MEM_RED;
3709 mem_rotate_left (x->parent->parent);
3714 /* The root may have been changed to red due to the algorithm. Set
3715 it to black so that property #5 is satisfied. */
3716 mem_root->color = MEM_BLACK;
3720 /* (x) (y)
3721 / \ / \
3722 a (y) ===> (x) c
3723 / \ / \
3724 b c a b */
3726 static void
3727 mem_rotate_left (struct mem_node *x)
3729 struct mem_node *y;
3731 /* Turn y's left sub-tree into x's right sub-tree. */
3732 y = x->right;
3733 x->right = y->left;
3734 if (y->left != MEM_NIL)
3735 y->left->parent = x;
3737 /* Y's parent was x's parent. */
3738 if (y != MEM_NIL)
3739 y->parent = x->parent;
3741 /* Get the parent to point to y instead of x. */
3742 if (x->parent)
3744 if (x == x->parent->left)
3745 x->parent->left = y;
3746 else
3747 x->parent->right = y;
3749 else
3750 mem_root = y;
3752 /* Put x on y's left. */
3753 y->left = x;
3754 if (x != MEM_NIL)
3755 x->parent = y;
3759 /* (x) (Y)
3760 / \ / \
3761 (y) c ===> a (x)
3762 / \ / \
3763 a b b c */
3765 static void
3766 mem_rotate_right (struct mem_node *x)
3768 struct mem_node *y = x->left;
3770 x->left = y->right;
3771 if (y->right != MEM_NIL)
3772 y->right->parent = x;
3774 if (y != MEM_NIL)
3775 y->parent = x->parent;
3776 if (x->parent)
3778 if (x == x->parent->right)
3779 x->parent->right = y;
3780 else
3781 x->parent->left = y;
3783 else
3784 mem_root = y;
3786 y->right = x;
3787 if (x != MEM_NIL)
3788 x->parent = y;
3792 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3794 static void
3795 mem_delete (struct mem_node *z)
3797 struct mem_node *x, *y;
3799 if (!z || z == MEM_NIL)
3800 return;
3802 if (z->left == MEM_NIL || z->right == MEM_NIL)
3803 y = z;
3804 else
3806 y = z->right;
3807 while (y->left != MEM_NIL)
3808 y = y->left;
3811 if (y->left != MEM_NIL)
3812 x = y->left;
3813 else
3814 x = y->right;
3816 x->parent = y->parent;
3817 if (y->parent)
3819 if (y == y->parent->left)
3820 y->parent->left = x;
3821 else
3822 y->parent->right = x;
3824 else
3825 mem_root = x;
3827 if (y != z)
3829 z->start = y->start;
3830 z->end = y->end;
3831 z->type = y->type;
3834 if (y->color == MEM_BLACK)
3835 mem_delete_fixup (x);
3837 #ifdef GC_MALLOC_CHECK
3838 free (y);
3839 #else
3840 xfree (y);
3841 #endif
3845 /* Re-establish the red-black properties of the tree, after a
3846 deletion. */
3848 static void
3849 mem_delete_fixup (struct mem_node *x)
3851 while (x != mem_root && x->color == MEM_BLACK)
3853 if (x == x->parent->left)
3855 struct mem_node *w = x->parent->right;
3857 if (w->color == MEM_RED)
3859 w->color = MEM_BLACK;
3860 x->parent->color = MEM_RED;
3861 mem_rotate_left (x->parent);
3862 w = x->parent->right;
3865 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
3867 w->color = MEM_RED;
3868 x = x->parent;
3870 else
3872 if (w->right->color == MEM_BLACK)
3874 w->left->color = MEM_BLACK;
3875 w->color = MEM_RED;
3876 mem_rotate_right (w);
3877 w = x->parent->right;
3879 w->color = x->parent->color;
3880 x->parent->color = MEM_BLACK;
3881 w->right->color = MEM_BLACK;
3882 mem_rotate_left (x->parent);
3883 x = mem_root;
3886 else
3888 struct mem_node *w = x->parent->left;
3890 if (w->color == MEM_RED)
3892 w->color = MEM_BLACK;
3893 x->parent->color = MEM_RED;
3894 mem_rotate_right (x->parent);
3895 w = x->parent->left;
3898 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
3900 w->color = MEM_RED;
3901 x = x->parent;
3903 else
3905 if (w->left->color == MEM_BLACK)
3907 w->right->color = MEM_BLACK;
3908 w->color = MEM_RED;
3909 mem_rotate_left (w);
3910 w = x->parent->left;
3913 w->color = x->parent->color;
3914 x->parent->color = MEM_BLACK;
3915 w->left->color = MEM_BLACK;
3916 mem_rotate_right (x->parent);
3917 x = mem_root;
3922 x->color = MEM_BLACK;
3926 /* Value is non-zero if P is a pointer to a live Lisp string on
3927 the heap. M is a pointer to the mem_block for P. */
3929 static bool
3930 live_string_p (struct mem_node *m, void *p)
3932 if (m->type == MEM_TYPE_STRING)
3934 struct string_block *b = (struct string_block *) m->start;
3935 ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
3937 /* P must point to the start of a Lisp_String structure, and it
3938 must not be on the free-list. */
3939 return (offset >= 0
3940 && offset % sizeof b->strings[0] == 0
3941 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
3942 && ((struct Lisp_String *) p)->data != NULL);
3944 else
3945 return 0;
3949 /* Value is non-zero if P is a pointer to a live Lisp cons on
3950 the heap. M is a pointer to the mem_block for P. */
3952 static bool
3953 live_cons_p (struct mem_node *m, void *p)
3955 if (m->type == MEM_TYPE_CONS)
3957 struct cons_block *b = (struct cons_block *) m->start;
3958 ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
3960 /* P must point to the start of a Lisp_Cons, not be
3961 one of the unused cells in the current cons block,
3962 and not be on the free-list. */
3963 return (offset >= 0
3964 && offset % sizeof b->conses[0] == 0
3965 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
3966 && (b != cons_block
3967 || offset / sizeof b->conses[0] < cons_block_index)
3968 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
3970 else
3971 return 0;
3975 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3976 the heap. M is a pointer to the mem_block for P. */
3978 static bool
3979 live_symbol_p (struct mem_node *m, void *p)
3981 if (m->type == MEM_TYPE_SYMBOL)
3983 struct symbol_block *b = (struct symbol_block *) m->start;
3984 ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
3986 /* P must point to the start of a Lisp_Symbol, not be
3987 one of the unused cells in the current symbol block,
3988 and not be on the free-list. */
3989 return (offset >= 0
3990 && offset % sizeof b->symbols[0] == 0
3991 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3992 && (b != symbol_block
3993 || offset / sizeof b->symbols[0] < symbol_block_index)
3994 && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
3996 else
3997 return 0;
4001 /* Value is non-zero if P is a pointer to a live Lisp float on
4002 the heap. M is a pointer to the mem_block for P. */
4004 static bool
4005 live_float_p (struct mem_node *m, void *p)
4007 if (m->type == MEM_TYPE_FLOAT)
4009 struct float_block *b = (struct float_block *) m->start;
4010 ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
4012 /* P must point to the start of a Lisp_Float and not be
4013 one of the unused cells in the current float block. */
4014 return (offset >= 0
4015 && offset % sizeof b->floats[0] == 0
4016 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
4017 && (b != float_block
4018 || offset / sizeof b->floats[0] < float_block_index));
4020 else
4021 return 0;
4025 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4026 the heap. M is a pointer to the mem_block for P. */
4028 static bool
4029 live_misc_p (struct mem_node *m, void *p)
4031 if (m->type == MEM_TYPE_MISC)
4033 struct marker_block *b = (struct marker_block *) m->start;
4034 ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
4036 /* P must point to the start of a Lisp_Misc, not be
4037 one of the unused cells in the current misc block,
4038 and not be on the free-list. */
4039 return (offset >= 0
4040 && offset % sizeof b->markers[0] == 0
4041 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4042 && (b != marker_block
4043 || offset / sizeof b->markers[0] < marker_block_index)
4044 && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4046 else
4047 return 0;
4051 /* Value is non-zero if P is a pointer to a live vector-like object.
4052 M is a pointer to the mem_block for P. */
4054 static bool
4055 live_vector_p (struct mem_node *m, void *p)
4057 if (m->type == MEM_TYPE_VECTOR_BLOCK)
4059 /* This memory node corresponds to a vector block. */
4060 struct vector_block *block = (struct vector_block *) m->start;
4061 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4063 /* P is in the block's allocation range. Scan the block
4064 up to P and see whether P points to the start of some
4065 vector which is not on a free list. FIXME: check whether
4066 some allocation patterns (probably a lot of short vectors)
4067 may cause a substantial overhead of this loop. */
4068 while (VECTOR_IN_BLOCK (vector, block)
4069 && vector <= (struct Lisp_Vector *) p)
4071 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
4072 vector = ADVANCE (vector, (vector->header.size
4073 & PSEUDOVECTOR_SIZE_MASK));
4074 else if (vector == p)
4075 return 1;
4076 else
4077 vector = ADVANCE (vector, vector->header.next.nbytes);
4080 else if (m->type == MEM_TYPE_VECTORLIKE && p == m->start)
4081 /* This memory node corresponds to a large vector. */
4082 return 1;
4083 return 0;
4087 /* Value is non-zero if P is a pointer to a live buffer. M is a
4088 pointer to the mem_block for P. */
4090 static bool
4091 live_buffer_p (struct mem_node *m, void *p)
4093 /* P must point to the start of the block, and the buffer
4094 must not have been killed. */
4095 return (m->type == MEM_TYPE_BUFFER
4096 && p == m->start
4097 && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name)));
4100 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4102 #if GC_MARK_STACK
4104 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4106 /* Array of objects that are kept alive because the C stack contains
4107 a pattern that looks like a reference to them . */
4109 #define MAX_ZOMBIES 10
4110 static Lisp_Object zombies[MAX_ZOMBIES];
4112 /* Number of zombie objects. */
4114 static EMACS_INT nzombies;
4116 /* Number of garbage collections. */
4118 static EMACS_INT ngcs;
4120 /* Average percentage of zombies per collection. */
4122 static double avg_zombies;
4124 /* Max. number of live and zombie objects. */
4126 static EMACS_INT max_live, max_zombies;
4128 /* Average number of live objects per GC. */
4130 static double avg_live;
4132 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4133 doc: /* Show information about live and zombie objects. */)
4134 (void)
4136 Lisp_Object args[8], zombie_list = Qnil;
4137 EMACS_INT i;
4138 for (i = 0; i < min (MAX_ZOMBIES, nzombies); i++)
4139 zombie_list = Fcons (zombies[i], zombie_list);
4140 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4141 args[1] = make_number (ngcs);
4142 args[2] = make_float (avg_live);
4143 args[3] = make_float (avg_zombies);
4144 args[4] = make_float (avg_zombies / avg_live / 100);
4145 args[5] = make_number (max_live);
4146 args[6] = make_number (max_zombies);
4147 args[7] = zombie_list;
4148 return Fmessage (8, args);
4151 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4154 /* Mark OBJ if we can prove it's a Lisp_Object. */
4156 static void
4157 mark_maybe_object (Lisp_Object obj)
4159 void *po;
4160 struct mem_node *m;
4162 if (INTEGERP (obj))
4163 return;
4165 po = (void *) XPNTR (obj);
4166 m = mem_find (po);
4168 if (m != MEM_NIL)
4170 bool mark_p = 0;
4172 switch (XTYPE (obj))
4174 case Lisp_String:
4175 mark_p = (live_string_p (m, po)
4176 && !STRING_MARKED_P ((struct Lisp_String *) po));
4177 break;
4179 case Lisp_Cons:
4180 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4181 break;
4183 case Lisp_Symbol:
4184 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4185 break;
4187 case Lisp_Float:
4188 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4189 break;
4191 case Lisp_Vectorlike:
4192 /* Note: can't check BUFFERP before we know it's a
4193 buffer because checking that dereferences the pointer
4194 PO which might point anywhere. */
4195 if (live_vector_p (m, po))
4196 mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4197 else if (live_buffer_p (m, po))
4198 mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4199 break;
4201 case Lisp_Misc:
4202 mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4203 break;
4205 default:
4206 break;
4209 if (mark_p)
4211 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4212 if (nzombies < MAX_ZOMBIES)
4213 zombies[nzombies] = obj;
4214 ++nzombies;
4215 #endif
4216 mark_object (obj);
4222 /* If P points to Lisp data, mark that as live if it isn't already
4223 marked. */
4225 static void
4226 mark_maybe_pointer (void *p)
4228 struct mem_node *m;
4230 /* Quickly rule out some values which can't point to Lisp data.
4231 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4232 Otherwise, assume that Lisp data is aligned on even addresses. */
4233 if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
4234 return;
4236 m = mem_find (p);
4237 if (m != MEM_NIL)
4239 Lisp_Object obj = Qnil;
4241 switch (m->type)
4243 case MEM_TYPE_NON_LISP:
4244 case MEM_TYPE_SPARE:
4245 /* Nothing to do; not a pointer to Lisp memory. */
4246 break;
4248 case MEM_TYPE_BUFFER:
4249 if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p))
4250 XSETVECTOR (obj, p);
4251 break;
4253 case MEM_TYPE_CONS:
4254 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4255 XSETCONS (obj, p);
4256 break;
4258 case MEM_TYPE_STRING:
4259 if (live_string_p (m, p)
4260 && !STRING_MARKED_P ((struct Lisp_String *) p))
4261 XSETSTRING (obj, p);
4262 break;
4264 case MEM_TYPE_MISC:
4265 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4266 XSETMISC (obj, p);
4267 break;
4269 case MEM_TYPE_SYMBOL:
4270 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4271 XSETSYMBOL (obj, p);
4272 break;
4274 case MEM_TYPE_FLOAT:
4275 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4276 XSETFLOAT (obj, p);
4277 break;
4279 case MEM_TYPE_VECTORLIKE:
4280 case MEM_TYPE_VECTOR_BLOCK:
4281 if (live_vector_p (m, p))
4283 Lisp_Object tem;
4284 XSETVECTOR (tem, p);
4285 if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4286 obj = tem;
4288 break;
4290 default:
4291 emacs_abort ();
4294 if (!NILP (obj))
4295 mark_object (obj);
4300 /* Alignment of pointer values. Use alignof, as it sometimes returns
4301 a smaller alignment than GCC's __alignof__ and mark_memory might
4302 miss objects if __alignof__ were used. */
4303 #define GC_POINTER_ALIGNMENT alignof (void *)
4305 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4306 not suffice, which is the typical case. A host where a Lisp_Object is
4307 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4308 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4309 suffice to widen it to to a Lisp_Object and check it that way. */
4310 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4311 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4312 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4313 nor mark_maybe_object can follow the pointers. This should not occur on
4314 any practical porting target. */
4315 # error "MSB type bits straddle pointer-word boundaries"
4316 # endif
4317 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4318 pointer words that hold pointers ORed with type bits. */
4319 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4320 #else
4321 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4322 words that hold unmodified pointers. */
4323 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4324 #endif
4326 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4327 or END+OFFSET..START. */
4329 static void
4330 mark_memory (void *start, void *end)
4331 #if defined (__clang__) && defined (__has_feature)
4332 #if __has_feature(address_sanitizer)
4333 /* Do not allow -faddress-sanitizer to check this function, since it
4334 crosses the function stack boundary, and thus would yield many
4335 false positives. */
4336 __attribute__((no_address_safety_analysis))
4337 #endif
4338 #endif
4340 void **pp;
4341 int i;
4343 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4344 nzombies = 0;
4345 #endif
4347 /* Make START the pointer to the start of the memory region,
4348 if it isn't already. */
4349 if (end < start)
4351 void *tem = start;
4352 start = end;
4353 end = tem;
4356 /* Mark Lisp data pointed to. This is necessary because, in some
4357 situations, the C compiler optimizes Lisp objects away, so that
4358 only a pointer to them remains. Example:
4360 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4363 Lisp_Object obj = build_string ("test");
4364 struct Lisp_String *s = XSTRING (obj);
4365 Fgarbage_collect ();
4366 fprintf (stderr, "test `%s'\n", s->data);
4367 return Qnil;
4370 Here, `obj' isn't really used, and the compiler optimizes it
4371 away. The only reference to the life string is through the
4372 pointer `s'. */
4374 for (pp = start; (void *) pp < end; pp++)
4375 for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
4377 void *p = *(void **) ((char *) pp + i);
4378 mark_maybe_pointer (p);
4379 if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
4380 mark_maybe_object (XIL ((intptr_t) p));
4384 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4385 the GCC system configuration. In gcc 3.2, the only systems for
4386 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4387 by others?) and ns32k-pc532-min. */
4389 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4391 static bool setjmp_tested_p;
4392 static int longjmps_done;
4394 #define SETJMP_WILL_LIKELY_WORK "\
4396 Emacs garbage collector has been changed to use conservative stack\n\
4397 marking. Emacs has determined that the method it uses to do the\n\
4398 marking will likely work on your system, but this isn't sure.\n\
4400 If you are a system-programmer, or can get the help of a local wizard\n\
4401 who is, please take a look at the function mark_stack in alloc.c, and\n\
4402 verify that the methods used are appropriate for your system.\n\
4404 Please mail the result to <emacs-devel@gnu.org>.\n\
4407 #define SETJMP_WILL_NOT_WORK "\
4409 Emacs garbage collector has been changed to use conservative stack\n\
4410 marking. Emacs has determined that the default method it uses to do the\n\
4411 marking will not work on your system. We will need a system-dependent\n\
4412 solution for your system.\n\
4414 Please take a look at the function mark_stack in alloc.c, and\n\
4415 try to find a way to make it work on your system.\n\
4417 Note that you may get false negatives, depending on the compiler.\n\
4418 In particular, you need to use -O with GCC for this test.\n\
4420 Please mail the result to <emacs-devel@gnu.org>.\n\
4424 /* Perform a quick check if it looks like setjmp saves registers in a
4425 jmp_buf. Print a message to stderr saying so. When this test
4426 succeeds, this is _not_ a proof that setjmp is sufficient for
4427 conservative stack marking. Only the sources or a disassembly
4428 can prove that. */
4430 static void
4431 test_setjmp (void)
4433 char buf[10];
4434 register int x;
4435 sys_jmp_buf jbuf;
4437 /* Arrange for X to be put in a register. */
4438 sprintf (buf, "1");
4439 x = strlen (buf);
4440 x = 2 * x - 1;
4442 sys_setjmp (jbuf);
4443 if (longjmps_done == 1)
4445 /* Came here after the longjmp at the end of the function.
4447 If x == 1, the longjmp has restored the register to its
4448 value before the setjmp, and we can hope that setjmp
4449 saves all such registers in the jmp_buf, although that
4450 isn't sure.
4452 For other values of X, either something really strange is
4453 taking place, or the setjmp just didn't save the register. */
4455 if (x == 1)
4456 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
4457 else
4459 fprintf (stderr, SETJMP_WILL_NOT_WORK);
4460 exit (1);
4464 ++longjmps_done;
4465 x = 2;
4466 if (longjmps_done == 1)
4467 sys_longjmp (jbuf, 1);
4470 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4473 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4475 /* Abort if anything GCPRO'd doesn't survive the GC. */
4477 static void
4478 check_gcpros (void)
4480 struct gcpro *p;
4481 ptrdiff_t i;
4483 for (p = gcprolist; p; p = p->next)
4484 for (i = 0; i < p->nvars; ++i)
4485 if (!survives_gc_p (p->var[i]))
4486 /* FIXME: It's not necessarily a bug. It might just be that the
4487 GCPRO is unnecessary or should release the object sooner. */
4488 emacs_abort ();
4491 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4493 static void
4494 dump_zombies (void)
4496 int i;
4498 fprintf (stderr, "\nZombies kept alive = %"pI"d:\n", nzombies);
4499 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
4501 fprintf (stderr, " %d = ", i);
4502 debug_print (zombies[i]);
4506 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4509 /* Mark live Lisp objects on the C stack.
4511 There are several system-dependent problems to consider when
4512 porting this to new architectures:
4514 Processor Registers
4516 We have to mark Lisp objects in CPU registers that can hold local
4517 variables or are used to pass parameters.
4519 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4520 something that either saves relevant registers on the stack, or
4521 calls mark_maybe_object passing it each register's contents.
4523 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4524 implementation assumes that calling setjmp saves registers we need
4525 to see in a jmp_buf which itself lies on the stack. This doesn't
4526 have to be true! It must be verified for each system, possibly
4527 by taking a look at the source code of setjmp.
4529 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4530 can use it as a machine independent method to store all registers
4531 to the stack. In this case the macros described in the previous
4532 two paragraphs are not used.
4534 Stack Layout
4536 Architectures differ in the way their processor stack is organized.
4537 For example, the stack might look like this
4539 +----------------+
4540 | Lisp_Object | size = 4
4541 +----------------+
4542 | something else | size = 2
4543 +----------------+
4544 | Lisp_Object | size = 4
4545 +----------------+
4546 | ... |
4548 In such a case, not every Lisp_Object will be aligned equally. To
4549 find all Lisp_Object on the stack it won't be sufficient to walk
4550 the stack in steps of 4 bytes. Instead, two passes will be
4551 necessary, one starting at the start of the stack, and a second
4552 pass starting at the start of the stack + 2. Likewise, if the
4553 minimal alignment of Lisp_Objects on the stack is 1, four passes
4554 would be necessary, each one starting with one byte more offset
4555 from the stack start. */
4557 static void
4558 mark_stack (void)
4560 void *end;
4562 #ifdef HAVE___BUILTIN_UNWIND_INIT
4563 /* Force callee-saved registers and register windows onto the stack.
4564 This is the preferred method if available, obviating the need for
4565 machine dependent methods. */
4566 __builtin_unwind_init ();
4567 end = &end;
4568 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4569 #ifndef GC_SAVE_REGISTERS_ON_STACK
4570 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4571 union aligned_jmpbuf {
4572 Lisp_Object o;
4573 sys_jmp_buf j;
4574 } j;
4575 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
4576 #endif
4577 /* This trick flushes the register windows so that all the state of
4578 the process is contained in the stack. */
4579 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4580 needed on ia64 too. See mach_dep.c, where it also says inline
4581 assembler doesn't work with relevant proprietary compilers. */
4582 #ifdef __sparc__
4583 #if defined (__sparc64__) && defined (__FreeBSD__)
4584 /* FreeBSD does not have a ta 3 handler. */
4585 asm ("flushw");
4586 #else
4587 asm ("ta 3");
4588 #endif
4589 #endif
4591 /* Save registers that we need to see on the stack. We need to see
4592 registers used to hold register variables and registers used to
4593 pass parameters. */
4594 #ifdef GC_SAVE_REGISTERS_ON_STACK
4595 GC_SAVE_REGISTERS_ON_STACK (end);
4596 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4598 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4599 setjmp will definitely work, test it
4600 and print a message with the result
4601 of the test. */
4602 if (!setjmp_tested_p)
4604 setjmp_tested_p = 1;
4605 test_setjmp ();
4607 #endif /* GC_SETJMP_WORKS */
4609 sys_setjmp (j.j);
4610 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4611 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4612 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4614 /* This assumes that the stack is a contiguous region in memory. If
4615 that's not the case, something has to be done here to iterate
4616 over the stack segments. */
4617 mark_memory (stack_base, end);
4619 /* Allow for marking a secondary stack, like the register stack on the
4620 ia64. */
4621 #ifdef GC_MARK_SECONDARY_STACK
4622 GC_MARK_SECONDARY_STACK ();
4623 #endif
4625 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4626 check_gcpros ();
4627 #endif
4630 #endif /* GC_MARK_STACK != 0 */
4633 /* Determine whether it is safe to access memory at address P. */
4634 static int
4635 valid_pointer_p (void *p)
4637 #ifdef WINDOWSNT
4638 return w32_valid_pointer_p (p, 16);
4639 #else
4640 int fd[2];
4642 /* Obviously, we cannot just access it (we would SEGV trying), so we
4643 trick the o/s to tell us whether p is a valid pointer.
4644 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4645 not validate p in that case. */
4647 if (pipe (fd) == 0)
4649 bool valid = emacs_write (fd[1], (char *) p, 16) == 16;
4650 emacs_close (fd[1]);
4651 emacs_close (fd[0]);
4652 return valid;
4655 return -1;
4656 #endif
4659 /* Return 2 if OBJ is a killed or special buffer object.
4660 Return 1 if OBJ is a valid lisp object.
4661 Return 0 if OBJ is NOT a valid lisp object.
4662 Return -1 if we cannot validate OBJ.
4663 This function can be quite slow,
4664 so it should only be used in code for manual debugging. */
4667 valid_lisp_object_p (Lisp_Object obj)
4669 void *p;
4670 #if GC_MARK_STACK
4671 struct mem_node *m;
4672 #endif
4674 if (INTEGERP (obj))
4675 return 1;
4677 p = (void *) XPNTR (obj);
4678 if (PURE_POINTER_P (p))
4679 return 1;
4681 if (p == &buffer_defaults || p == &buffer_local_symbols)
4682 return 2;
4684 #if !GC_MARK_STACK
4685 return valid_pointer_p (p);
4686 #else
4688 m = mem_find (p);
4690 if (m == MEM_NIL)
4692 int valid = valid_pointer_p (p);
4693 if (valid <= 0)
4694 return valid;
4696 if (SUBRP (obj))
4697 return 1;
4699 return 0;
4702 switch (m->type)
4704 case MEM_TYPE_NON_LISP:
4705 case MEM_TYPE_SPARE:
4706 return 0;
4708 case MEM_TYPE_BUFFER:
4709 return live_buffer_p (m, p) ? 1 : 2;
4711 case MEM_TYPE_CONS:
4712 return live_cons_p (m, p);
4714 case MEM_TYPE_STRING:
4715 return live_string_p (m, p);
4717 case MEM_TYPE_MISC:
4718 return live_misc_p (m, p);
4720 case MEM_TYPE_SYMBOL:
4721 return live_symbol_p (m, p);
4723 case MEM_TYPE_FLOAT:
4724 return live_float_p (m, p);
4726 case MEM_TYPE_VECTORLIKE:
4727 case MEM_TYPE_VECTOR_BLOCK:
4728 return live_vector_p (m, p);
4730 default:
4731 break;
4734 return 0;
4735 #endif
4741 /***********************************************************************
4742 Pure Storage Management
4743 ***********************************************************************/
4745 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4746 pointer to it. TYPE is the Lisp type for which the memory is
4747 allocated. TYPE < 0 means it's not used for a Lisp object. */
4749 static void *
4750 pure_alloc (size_t size, int type)
4752 void *result;
4753 #if USE_LSB_TAG
4754 size_t alignment = GCALIGNMENT;
4755 #else
4756 size_t alignment = alignof (EMACS_INT);
4758 /* Give Lisp_Floats an extra alignment. */
4759 if (type == Lisp_Float)
4760 alignment = alignof (struct Lisp_Float);
4761 #endif
4763 again:
4764 if (type >= 0)
4766 /* Allocate space for a Lisp object from the beginning of the free
4767 space with taking account of alignment. */
4768 result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
4769 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
4771 else
4773 /* Allocate space for a non-Lisp object from the end of the free
4774 space. */
4775 pure_bytes_used_non_lisp += size;
4776 result = purebeg + pure_size - pure_bytes_used_non_lisp;
4778 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
4780 if (pure_bytes_used <= pure_size)
4781 return result;
4783 /* Don't allocate a large amount here,
4784 because it might get mmap'd and then its address
4785 might not be usable. */
4786 purebeg = xmalloc (10000);
4787 pure_size = 10000;
4788 pure_bytes_used_before_overflow += pure_bytes_used - size;
4789 pure_bytes_used = 0;
4790 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
4791 goto again;
4795 /* Print a warning if PURESIZE is too small. */
4797 void
4798 check_pure_size (void)
4800 if (pure_bytes_used_before_overflow)
4801 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d"
4802 " bytes needed)"),
4803 pure_bytes_used + pure_bytes_used_before_overflow);
4807 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4808 the non-Lisp data pool of the pure storage, and return its start
4809 address. Return NULL if not found. */
4811 static char *
4812 find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
4814 int i;
4815 ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4816 const unsigned char *p;
4817 char *non_lisp_beg;
4819 if (pure_bytes_used_non_lisp <= nbytes)
4820 return NULL;
4822 /* Set up the Boyer-Moore table. */
4823 skip = nbytes + 1;
4824 for (i = 0; i < 256; i++)
4825 bm_skip[i] = skip;
4827 p = (const unsigned char *) data;
4828 while (--skip > 0)
4829 bm_skip[*p++] = skip;
4831 last_char_skip = bm_skip['\0'];
4833 non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
4834 start_max = pure_bytes_used_non_lisp - (nbytes + 1);
4836 /* See the comments in the function `boyer_moore' (search.c) for the
4837 use of `infinity'. */
4838 infinity = pure_bytes_used_non_lisp + 1;
4839 bm_skip['\0'] = infinity;
4841 p = (const unsigned char *) non_lisp_beg + nbytes;
4842 start = 0;
4845 /* Check the last character (== '\0'). */
4848 start += bm_skip[*(p + start)];
4850 while (start <= start_max);
4852 if (start < infinity)
4853 /* Couldn't find the last character. */
4854 return NULL;
4856 /* No less than `infinity' means we could find the last
4857 character at `p[start - infinity]'. */
4858 start -= infinity;
4860 /* Check the remaining characters. */
4861 if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
4862 /* Found. */
4863 return non_lisp_beg + start;
4865 start += last_char_skip;
4867 while (start <= start_max);
4869 return NULL;
4873 /* Return a string allocated in pure space. DATA is a buffer holding
4874 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4875 means make the result string multibyte.
4877 Must get an error if pure storage is full, since if it cannot hold
4878 a large string it may be able to hold conses that point to that
4879 string; then the string is not protected from gc. */
4881 Lisp_Object
4882 make_pure_string (const char *data,
4883 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
4885 Lisp_Object string;
4886 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4887 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
4888 if (s->data == NULL)
4890 s->data = pure_alloc (nbytes + 1, -1);
4891 memcpy (s->data, data, nbytes);
4892 s->data[nbytes] = '\0';
4894 s->size = nchars;
4895 s->size_byte = multibyte ? nbytes : -1;
4896 s->intervals = NULL;
4897 XSETSTRING (string, s);
4898 return string;
4901 /* Return a string allocated in pure space. Do not
4902 allocate the string data, just point to DATA. */
4904 Lisp_Object
4905 make_pure_c_string (const char *data, ptrdiff_t nchars)
4907 Lisp_Object string;
4908 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4909 s->size = nchars;
4910 s->size_byte = -1;
4911 s->data = (unsigned char *) data;
4912 s->intervals = NULL;
4913 XSETSTRING (string, s);
4914 return string;
4917 /* Return a cons allocated from pure space. Give it pure copies
4918 of CAR as car and CDR as cdr. */
4920 Lisp_Object
4921 pure_cons (Lisp_Object car, Lisp_Object cdr)
4923 Lisp_Object new;
4924 struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
4925 XSETCONS (new, p);
4926 XSETCAR (new, Fpurecopy (car));
4927 XSETCDR (new, Fpurecopy (cdr));
4928 return new;
4932 /* Value is a float object with value NUM allocated from pure space. */
4934 static Lisp_Object
4935 make_pure_float (double num)
4937 Lisp_Object new;
4938 struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
4939 XSETFLOAT (new, p);
4940 XFLOAT_INIT (new, num);
4941 return new;
4945 /* Return a vector with room for LEN Lisp_Objects allocated from
4946 pure space. */
4948 static Lisp_Object
4949 make_pure_vector (ptrdiff_t len)
4951 Lisp_Object new;
4952 size_t size = header_size + len * word_size;
4953 struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
4954 XSETVECTOR (new, p);
4955 XVECTOR (new)->header.size = len;
4956 return new;
4960 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
4961 doc: /* Make a copy of object OBJ in pure storage.
4962 Recursively copies contents of vectors and cons cells.
4963 Does not copy symbols. Copies strings without text properties. */)
4964 (register Lisp_Object obj)
4966 if (NILP (Vpurify_flag))
4967 return obj;
4969 if (PURE_POINTER_P (XPNTR (obj)))
4970 return obj;
4972 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
4974 Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
4975 if (!NILP (tmp))
4976 return tmp;
4979 if (CONSP (obj))
4980 obj = pure_cons (XCAR (obj), XCDR (obj));
4981 else if (FLOATP (obj))
4982 obj = make_pure_float (XFLOAT_DATA (obj));
4983 else if (STRINGP (obj))
4984 obj = make_pure_string (SSDATA (obj), SCHARS (obj),
4985 SBYTES (obj),
4986 STRING_MULTIBYTE (obj));
4987 else if (COMPILEDP (obj) || VECTORP (obj))
4989 register struct Lisp_Vector *vec;
4990 register ptrdiff_t i;
4991 ptrdiff_t size;
4993 size = ASIZE (obj);
4994 if (size & PSEUDOVECTOR_FLAG)
4995 size &= PSEUDOVECTOR_SIZE_MASK;
4996 vec = XVECTOR (make_pure_vector (size));
4997 for (i = 0; i < size; i++)
4998 vec->contents[i] = Fpurecopy (AREF (obj, i));
4999 if (COMPILEDP (obj))
5001 XSETPVECTYPE (vec, PVEC_COMPILED);
5002 XSETCOMPILED (obj, vec);
5004 else
5005 XSETVECTOR (obj, vec);
5007 else if (MARKERP (obj))
5008 error ("Attempt to copy a marker to pure storage");
5009 else
5010 /* Not purified, don't hash-cons. */
5011 return obj;
5013 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
5014 Fputhash (obj, obj, Vpurify_flag);
5016 return obj;
5021 /***********************************************************************
5022 Protection from GC
5023 ***********************************************************************/
5025 /* Put an entry in staticvec, pointing at the variable with address
5026 VARADDRESS. */
5028 void
5029 staticpro (Lisp_Object *varaddress)
5031 staticvec[staticidx++] = varaddress;
5032 if (staticidx >= NSTATICS)
5033 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5037 /***********************************************************************
5038 Protection from GC
5039 ***********************************************************************/
5041 /* Temporarily prevent garbage collection. */
5043 ptrdiff_t
5044 inhibit_garbage_collection (void)
5046 ptrdiff_t count = SPECPDL_INDEX ();
5048 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
5049 return count;
5052 /* Used to avoid possible overflows when
5053 converting from C to Lisp integers. */
5055 static Lisp_Object
5056 bounded_number (EMACS_INT number)
5058 return make_number (min (MOST_POSITIVE_FIXNUM, number));
5061 /* Calculate total bytes of live objects. */
5063 static size_t
5064 total_bytes_of_live_objects (void)
5066 size_t tot = 0;
5067 tot += total_conses * sizeof (struct Lisp_Cons);
5068 tot += total_symbols * sizeof (struct Lisp_Symbol);
5069 tot += total_markers * sizeof (union Lisp_Misc);
5070 tot += total_string_bytes;
5071 tot += total_vector_slots * word_size;
5072 tot += total_floats * sizeof (struct Lisp_Float);
5073 tot += total_intervals * sizeof (struct interval);
5074 tot += total_strings * sizeof (struct Lisp_String);
5075 return tot;
5078 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
5079 doc: /* Reclaim storage for Lisp objects no longer needed.
5080 Garbage collection happens automatically if you cons more than
5081 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5082 `garbage-collect' normally returns a list with info on amount of space in use,
5083 where each entry has the form (NAME SIZE USED FREE), where:
5084 - NAME is a symbol describing the kind of objects this entry represents,
5085 - SIZE is the number of bytes used by each one,
5086 - USED is the number of those objects that were found live in the heap,
5087 - FREE is the number of those objects that are not live but that Emacs
5088 keeps around for future allocations (maybe because it does not know how
5089 to return them to the OS).
5090 However, if there was overflow in pure space, `garbage-collect'
5091 returns nil, because real GC can't be done.
5092 See Info node `(elisp)Garbage Collection'. */)
5093 (void)
5095 struct specbinding *bind;
5096 struct buffer *nextb;
5097 char stack_top_variable;
5098 ptrdiff_t i;
5099 bool message_p;
5100 ptrdiff_t count = SPECPDL_INDEX ();
5101 EMACS_TIME start;
5102 Lisp_Object retval = Qnil;
5103 size_t tot_before = 0;
5104 struct backtrace backtrace;
5106 if (abort_on_gc)
5107 emacs_abort ();
5109 /* Can't GC if pure storage overflowed because we can't determine
5110 if something is a pure object or not. */
5111 if (pure_bytes_used_before_overflow)
5112 return Qnil;
5114 /* Record this function, so it appears on the profiler's backtraces. */
5115 backtrace.next = backtrace_list;
5116 backtrace.function = Qautomatic_gc;
5117 backtrace.args = &Qnil;
5118 backtrace.nargs = 0;
5119 backtrace.debug_on_exit = 0;
5120 backtrace_list = &backtrace;
5122 check_cons_list ();
5124 /* Don't keep undo information around forever.
5125 Do this early on, so it is no problem if the user quits. */
5126 FOR_EACH_BUFFER (nextb)
5127 compact_buffer (nextb);
5129 if (profiler_memory_running)
5130 tot_before = total_bytes_of_live_objects ();
5132 start = current_emacs_time ();
5134 /* In case user calls debug_print during GC,
5135 don't let that cause a recursive GC. */
5136 consing_since_gc = 0;
5138 /* Save what's currently displayed in the echo area. */
5139 message_p = push_message ();
5140 record_unwind_protect (pop_message_unwind, Qnil);
5142 /* Save a copy of the contents of the stack, for debugging. */
5143 #if MAX_SAVE_STACK > 0
5144 if (NILP (Vpurify_flag))
5146 char *stack;
5147 ptrdiff_t stack_size;
5148 if (&stack_top_variable < stack_bottom)
5150 stack = &stack_top_variable;
5151 stack_size = stack_bottom - &stack_top_variable;
5153 else
5155 stack = stack_bottom;
5156 stack_size = &stack_top_variable - stack_bottom;
5158 if (stack_size <= MAX_SAVE_STACK)
5160 if (stack_copy_size < stack_size)
5162 stack_copy = xrealloc (stack_copy, stack_size);
5163 stack_copy_size = stack_size;
5165 memcpy (stack_copy, stack, stack_size);
5168 #endif /* MAX_SAVE_STACK > 0 */
5170 if (garbage_collection_messages)
5171 message1_nolog ("Garbage collecting...");
5173 block_input ();
5175 shrink_regexp_cache ();
5177 gc_in_progress = 1;
5179 /* Mark all the special slots that serve as the roots of accessibility. */
5181 mark_buffer (&buffer_defaults);
5182 mark_buffer (&buffer_local_symbols);
5184 for (i = 0; i < staticidx; i++)
5185 mark_object (*staticvec[i]);
5187 for (bind = specpdl; bind != specpdl_ptr; bind++)
5189 mark_object (bind->symbol);
5190 mark_object (bind->old_value);
5192 mark_terminals ();
5193 mark_kboards ();
5195 #ifdef USE_GTK
5196 xg_mark_data ();
5197 #endif
5199 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5200 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5201 mark_stack ();
5202 #else
5204 register struct gcpro *tail;
5205 for (tail = gcprolist; tail; tail = tail->next)
5206 for (i = 0; i < tail->nvars; i++)
5207 mark_object (tail->var[i]);
5209 mark_byte_stack ();
5211 struct catchtag *catch;
5212 struct handler *handler;
5214 for (catch = catchlist; catch; catch = catch->next)
5216 mark_object (catch->tag);
5217 mark_object (catch->val);
5219 for (handler = handlerlist; handler; handler = handler->next)
5221 mark_object (handler->handler);
5222 mark_object (handler->var);
5225 mark_backtrace ();
5226 #endif
5228 #ifdef HAVE_WINDOW_SYSTEM
5229 mark_fringe_data ();
5230 #endif
5232 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5233 mark_stack ();
5234 #endif
5236 /* Everything is now marked, except for the things that require special
5237 finalization, i.e. the undo_list.
5238 Look thru every buffer's undo list
5239 for elements that update markers that were not marked,
5240 and delete them. */
5241 FOR_EACH_BUFFER (nextb)
5243 /* If a buffer's undo list is Qt, that means that undo is
5244 turned off in that buffer. Calling truncate_undo_list on
5245 Qt tends to return NULL, which effectively turns undo back on.
5246 So don't call truncate_undo_list if undo_list is Qt. */
5247 if (! EQ (nextb->INTERNAL_FIELD (undo_list), Qt))
5249 Lisp_Object tail, prev;
5250 tail = nextb->INTERNAL_FIELD (undo_list);
5251 prev = Qnil;
5252 while (CONSP (tail))
5254 if (CONSP (XCAR (tail))
5255 && MARKERP (XCAR (XCAR (tail)))
5256 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5258 if (NILP (prev))
5259 nextb->INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
5260 else
5262 tail = XCDR (tail);
5263 XSETCDR (prev, tail);
5266 else
5268 prev = tail;
5269 tail = XCDR (tail);
5273 /* Now that we have stripped the elements that need not be in the
5274 undo_list any more, we can finally mark the list. */
5275 mark_object (nextb->INTERNAL_FIELD (undo_list));
5278 gc_sweep ();
5280 /* Clear the mark bits that we set in certain root slots. */
5282 unmark_byte_stack ();
5283 VECTOR_UNMARK (&buffer_defaults);
5284 VECTOR_UNMARK (&buffer_local_symbols);
5286 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5287 dump_zombies ();
5288 #endif
5290 unblock_input ();
5292 check_cons_list ();
5294 gc_in_progress = 0;
5296 consing_since_gc = 0;
5297 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
5298 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
5300 gc_relative_threshold = 0;
5301 if (FLOATP (Vgc_cons_percentage))
5302 { /* Set gc_cons_combined_threshold. */
5303 double tot = total_bytes_of_live_objects ();
5305 tot *= XFLOAT_DATA (Vgc_cons_percentage);
5306 if (0 < tot)
5308 if (tot < TYPE_MAXIMUM (EMACS_INT))
5309 gc_relative_threshold = tot;
5310 else
5311 gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
5315 if (garbage_collection_messages)
5317 if (message_p || minibuf_level > 0)
5318 restore_message ();
5319 else
5320 message1_nolog ("Garbage collecting...done");
5323 unbind_to (count, Qnil);
5325 Lisp_Object total[11];
5326 int total_size = 10;
5328 total[0] = list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
5329 bounded_number (total_conses),
5330 bounded_number (total_free_conses));
5332 total[1] = list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
5333 bounded_number (total_symbols),
5334 bounded_number (total_free_symbols));
5336 total[2] = list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
5337 bounded_number (total_markers),
5338 bounded_number (total_free_markers));
5340 total[3] = list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
5341 bounded_number (total_strings),
5342 bounded_number (total_free_strings));
5344 total[4] = list3 (Qstring_bytes, make_number (1),
5345 bounded_number (total_string_bytes));
5347 total[5] = list3 (Qvectors, make_number (sizeof (struct Lisp_Vector)),
5348 bounded_number (total_vectors));
5350 total[6] = list4 (Qvector_slots, make_number (word_size),
5351 bounded_number (total_vector_slots),
5352 bounded_number (total_free_vector_slots));
5354 total[7] = list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
5355 bounded_number (total_floats),
5356 bounded_number (total_free_floats));
5358 total[8] = list4 (Qintervals, make_number (sizeof (struct interval)),
5359 bounded_number (total_intervals),
5360 bounded_number (total_free_intervals));
5362 total[9] = list3 (Qbuffers, make_number (sizeof (struct buffer)),
5363 bounded_number (total_buffers));
5365 #ifdef DOUG_LEA_MALLOC
5366 total_size++;
5367 total[10] = list4 (Qheap, make_number (1024),
5368 bounded_number ((mallinfo ().uordblks + 1023) >> 10),
5369 bounded_number ((mallinfo ().fordblks + 1023) >> 10));
5370 #endif
5371 retval = Flist (total_size, total);
5374 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5376 /* Compute average percentage of zombies. */
5377 double nlive
5378 = (total_conses + total_symbols + total_markers + total_strings
5379 + total_vectors + total_floats + total_intervals + total_buffers);
5381 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5382 max_live = max (nlive, max_live);
5383 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5384 max_zombies = max (nzombies, max_zombies);
5385 ++ngcs;
5387 #endif
5389 if (!NILP (Vpost_gc_hook))
5391 ptrdiff_t gc_count = inhibit_garbage_collection ();
5392 safe_run_hooks (Qpost_gc_hook);
5393 unbind_to (gc_count, Qnil);
5396 /* Accumulate statistics. */
5397 if (FLOATP (Vgc_elapsed))
5399 EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start);
5400 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
5401 + EMACS_TIME_TO_DOUBLE (since_start));
5404 gcs_done++;
5406 /* Collect profiling data. */
5407 if (profiler_memory_running)
5409 size_t swept = 0;
5410 size_t tot_after = total_bytes_of_live_objects ();
5411 if (tot_before > tot_after)
5412 swept = tot_before - tot_after;
5413 malloc_probe (swept);
5416 backtrace_list = backtrace.next;
5417 return retval;
5421 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5422 only interesting objects referenced from glyphs are strings. */
5424 static void
5425 mark_glyph_matrix (struct glyph_matrix *matrix)
5427 struct glyph_row *row = matrix->rows;
5428 struct glyph_row *end = row + matrix->nrows;
5430 for (; row < end; ++row)
5431 if (row->enabled_p)
5433 int area;
5434 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
5436 struct glyph *glyph = row->glyphs[area];
5437 struct glyph *end_glyph = glyph + row->used[area];
5439 for (; glyph < end_glyph; ++glyph)
5440 if (STRINGP (glyph->object)
5441 && !STRING_MARKED_P (XSTRING (glyph->object)))
5442 mark_object (glyph->object);
5448 /* Mark Lisp faces in the face cache C. */
5450 static void
5451 mark_face_cache (struct face_cache *c)
5453 if (c)
5455 int i, j;
5456 for (i = 0; i < c->used; ++i)
5458 struct face *face = FACE_FROM_ID (c->f, i);
5460 if (face)
5462 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
5463 mark_object (face->lface[j]);
5471 /* Mark reference to a Lisp_Object.
5472 If the object referred to has not been seen yet, recursively mark
5473 all the references contained in it. */
5475 #define LAST_MARKED_SIZE 500
5476 static Lisp_Object last_marked[LAST_MARKED_SIZE];
5477 static int last_marked_index;
5479 /* For debugging--call abort when we cdr down this many
5480 links of a list, in mark_object. In debugging,
5481 the call to abort will hit a breakpoint.
5482 Normally this is zero and the check never goes off. */
5483 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
5485 static void
5486 mark_vectorlike (struct Lisp_Vector *ptr)
5488 ptrdiff_t size = ptr->header.size;
5489 ptrdiff_t i;
5491 eassert (!VECTOR_MARKED_P (ptr));
5492 VECTOR_MARK (ptr); /* Else mark it. */
5493 if (size & PSEUDOVECTOR_FLAG)
5494 size &= PSEUDOVECTOR_SIZE_MASK;
5496 /* Note that this size is not the memory-footprint size, but only
5497 the number of Lisp_Object fields that we should trace.
5498 The distinction is used e.g. by Lisp_Process which places extra
5499 non-Lisp_Object fields at the end of the structure... */
5500 for (i = 0; i < size; i++) /* ...and then mark its elements. */
5501 mark_object (ptr->contents[i]);
5504 /* Like mark_vectorlike but optimized for char-tables (and
5505 sub-char-tables) assuming that the contents are mostly integers or
5506 symbols. */
5508 static void
5509 mark_char_table (struct Lisp_Vector *ptr)
5511 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5512 int i;
5514 eassert (!VECTOR_MARKED_P (ptr));
5515 VECTOR_MARK (ptr);
5516 for (i = 0; i < size; i++)
5518 Lisp_Object val = ptr->contents[i];
5520 if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
5521 continue;
5522 if (SUB_CHAR_TABLE_P (val))
5524 if (! VECTOR_MARKED_P (XVECTOR (val)))
5525 mark_char_table (XVECTOR (val));
5527 else
5528 mark_object (val);
5532 /* Mark the chain of overlays starting at PTR. */
5534 static void
5535 mark_overlay (struct Lisp_Overlay *ptr)
5537 for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
5539 ptr->gcmarkbit = 1;
5540 mark_object (ptr->start);
5541 mark_object (ptr->end);
5542 mark_object (ptr->plist);
5546 /* Mark Lisp_Objects and special pointers in BUFFER. */
5548 static void
5549 mark_buffer (struct buffer *buffer)
5551 /* This is handled much like other pseudovectors... */
5552 mark_vectorlike ((struct Lisp_Vector *) buffer);
5554 /* ...but there are some buffer-specific things. */
5556 MARK_INTERVAL_TREE (buffer_intervals (buffer));
5558 /* For now, we just don't mark the undo_list. It's done later in
5559 a special way just before the sweep phase, and after stripping
5560 some of its elements that are not needed any more. */
5562 mark_overlay (buffer->overlays_before);
5563 mark_overlay (buffer->overlays_after);
5565 /* If this is an indirect buffer, mark its base buffer. */
5566 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5567 mark_buffer (buffer->base_buffer);
5570 /* Remove killed buffers or items whose car is a killed buffer from
5571 LIST, and mark other items. Return changed LIST, which is marked. */
5573 static Lisp_Object
5574 mark_discard_killed_buffers (Lisp_Object list)
5576 Lisp_Object tail, *prev = &list;
5578 for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
5579 tail = XCDR (tail))
5581 Lisp_Object tem = XCAR (tail);
5582 if (CONSP (tem))
5583 tem = XCAR (tem);
5584 if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem)))
5585 *prev = XCDR (tail);
5586 else
5588 CONS_MARK (XCONS (tail));
5589 mark_object (XCAR (tail));
5590 prev = &XCDR_AS_LVALUE (tail);
5593 mark_object (tail);
5594 return list;
5597 /* Determine type of generic Lisp_Object and mark it accordingly. */
5599 void
5600 mark_object (Lisp_Object arg)
5602 register Lisp_Object obj = arg;
5603 #ifdef GC_CHECK_MARKED_OBJECTS
5604 void *po;
5605 struct mem_node *m;
5606 #endif
5607 ptrdiff_t cdr_count = 0;
5609 loop:
5611 if (PURE_POINTER_P (XPNTR (obj)))
5612 return;
5614 last_marked[last_marked_index++] = obj;
5615 if (last_marked_index == LAST_MARKED_SIZE)
5616 last_marked_index = 0;
5618 /* Perform some sanity checks on the objects marked here. Abort if
5619 we encounter an object we know is bogus. This increases GC time
5620 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5621 #ifdef GC_CHECK_MARKED_OBJECTS
5623 po = (void *) XPNTR (obj);
5625 /* Check that the object pointed to by PO is known to be a Lisp
5626 structure allocated from the heap. */
5627 #define CHECK_ALLOCATED() \
5628 do { \
5629 m = mem_find (po); \
5630 if (m == MEM_NIL) \
5631 emacs_abort (); \
5632 } while (0)
5634 /* Check that the object pointed to by PO is live, using predicate
5635 function LIVEP. */
5636 #define CHECK_LIVE(LIVEP) \
5637 do { \
5638 if (!LIVEP (m, po)) \
5639 emacs_abort (); \
5640 } while (0)
5642 /* Check both of the above conditions. */
5643 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5644 do { \
5645 CHECK_ALLOCATED (); \
5646 CHECK_LIVE (LIVEP); \
5647 } while (0) \
5649 #else /* not GC_CHECK_MARKED_OBJECTS */
5651 #define CHECK_LIVE(LIVEP) (void) 0
5652 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5654 #endif /* not GC_CHECK_MARKED_OBJECTS */
5656 switch (XTYPE (obj))
5658 case Lisp_String:
5660 register struct Lisp_String *ptr = XSTRING (obj);
5661 if (STRING_MARKED_P (ptr))
5662 break;
5663 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5664 MARK_STRING (ptr);
5665 MARK_INTERVAL_TREE (ptr->intervals);
5666 #ifdef GC_CHECK_STRING_BYTES
5667 /* Check that the string size recorded in the string is the
5668 same as the one recorded in the sdata structure. */
5669 string_bytes (ptr);
5670 #endif /* GC_CHECK_STRING_BYTES */
5672 break;
5674 case Lisp_Vectorlike:
5676 register struct Lisp_Vector *ptr = XVECTOR (obj);
5677 register ptrdiff_t pvectype;
5679 if (VECTOR_MARKED_P (ptr))
5680 break;
5682 #ifdef GC_CHECK_MARKED_OBJECTS
5683 m = mem_find (po);
5684 if (m == MEM_NIL && !SUBRP (obj))
5685 emacs_abort ();
5686 #endif /* GC_CHECK_MARKED_OBJECTS */
5688 if (ptr->header.size & PSEUDOVECTOR_FLAG)
5689 pvectype = ((ptr->header.size & PVEC_TYPE_MASK)
5690 >> PSEUDOVECTOR_SIZE_BITS);
5691 else
5692 pvectype = PVEC_NORMAL_VECTOR;
5694 if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER)
5695 CHECK_LIVE (live_vector_p);
5697 switch (pvectype)
5699 case PVEC_BUFFER:
5700 #ifdef GC_CHECK_MARKED_OBJECTS
5702 struct buffer *b;
5703 FOR_EACH_BUFFER (b)
5704 if (b == po)
5705 break;
5706 if (b == NULL)
5707 emacs_abort ();
5709 #endif /* GC_CHECK_MARKED_OBJECTS */
5710 mark_buffer ((struct buffer *) ptr);
5711 break;
5713 case PVEC_COMPILED:
5714 { /* We could treat this just like a vector, but it is better
5715 to save the COMPILED_CONSTANTS element for last and avoid
5716 recursion there. */
5717 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5718 int i;
5720 VECTOR_MARK (ptr);
5721 for (i = 0; i < size; i++)
5722 if (i != COMPILED_CONSTANTS)
5723 mark_object (ptr->contents[i]);
5724 if (size > COMPILED_CONSTANTS)
5726 obj = ptr->contents[COMPILED_CONSTANTS];
5727 goto loop;
5730 break;
5732 case PVEC_FRAME:
5733 mark_vectorlike (ptr);
5734 mark_face_cache (((struct frame *) ptr)->face_cache);
5735 break;
5737 case PVEC_WINDOW:
5739 struct window *w = (struct window *) ptr;
5740 bool leaf = NILP (w->hchild) && NILP (w->vchild);
5742 mark_vectorlike (ptr);
5744 /* Mark glyphs for leaf windows. Marking window
5745 matrices is sufficient because frame matrices
5746 use the same glyph memory. */
5747 if (leaf && w->current_matrix)
5749 mark_glyph_matrix (w->current_matrix);
5750 mark_glyph_matrix (w->desired_matrix);
5753 /* Filter out killed buffers from both buffer lists
5754 in attempt to help GC to reclaim killed buffers faster.
5755 We can do it elsewhere for live windows, but this is the
5756 best place to do it for dead windows. */
5757 wset_prev_buffers
5758 (w, mark_discard_killed_buffers (w->prev_buffers));
5759 wset_next_buffers
5760 (w, mark_discard_killed_buffers (w->next_buffers));
5762 break;
5764 case PVEC_HASH_TABLE:
5766 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
5768 mark_vectorlike (ptr);
5769 /* If hash table is not weak, mark all keys and values.
5770 For weak tables, mark only the vector. */
5771 if (NILP (h->weak))
5772 mark_object (h->key_and_value);
5773 else
5774 VECTOR_MARK (XVECTOR (h->key_and_value));
5776 break;
5778 case PVEC_CHAR_TABLE:
5779 mark_char_table (ptr);
5780 break;
5782 case PVEC_BOOL_VECTOR:
5783 /* No Lisp_Objects to mark in a bool vector. */
5784 VECTOR_MARK (ptr);
5785 break;
5787 case PVEC_SUBR:
5788 break;
5790 case PVEC_FREE:
5791 emacs_abort ();
5793 default:
5794 mark_vectorlike (ptr);
5797 break;
5799 case Lisp_Symbol:
5801 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
5802 struct Lisp_Symbol *ptrx;
5804 if (ptr->gcmarkbit)
5805 break;
5806 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
5807 ptr->gcmarkbit = 1;
5808 mark_object (ptr->function);
5809 mark_object (ptr->plist);
5810 switch (ptr->redirect)
5812 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
5813 case SYMBOL_VARALIAS:
5815 Lisp_Object tem;
5816 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
5817 mark_object (tem);
5818 break;
5820 case SYMBOL_LOCALIZED:
5822 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5823 Lisp_Object where = blv->where;
5824 /* If the value is set up for a killed buffer or deleted
5825 frame, restore it's global binding. If the value is
5826 forwarded to a C variable, either it's not a Lisp_Object
5827 var, or it's staticpro'd already. */
5828 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
5829 || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
5830 swap_in_global_binding (ptr);
5831 mark_object (blv->where);
5832 mark_object (blv->valcell);
5833 mark_object (blv->defcell);
5834 break;
5836 case SYMBOL_FORWARDED:
5837 /* If the value is forwarded to a buffer or keyboard field,
5838 these are marked when we see the corresponding object.
5839 And if it's forwarded to a C variable, either it's not
5840 a Lisp_Object var, or it's staticpro'd already. */
5841 break;
5842 default: emacs_abort ();
5844 if (!PURE_POINTER_P (XSTRING (ptr->name)))
5845 MARK_STRING (XSTRING (ptr->name));
5846 MARK_INTERVAL_TREE (string_intervals (ptr->name));
5848 ptr = ptr->next;
5849 if (ptr)
5851 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
5852 XSETSYMBOL (obj, ptrx);
5853 goto loop;
5856 break;
5858 case Lisp_Misc:
5859 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5861 if (XMISCANY (obj)->gcmarkbit)
5862 break;
5864 switch (XMISCTYPE (obj))
5866 case Lisp_Misc_Marker:
5867 /* DO NOT mark thru the marker's chain.
5868 The buffer's markers chain does not preserve markers from gc;
5869 instead, markers are removed from the chain when freed by gc. */
5870 XMISCANY (obj)->gcmarkbit = 1;
5871 break;
5873 case Lisp_Misc_Save_Value:
5874 XMISCANY (obj)->gcmarkbit = 1;
5875 #if GC_MARK_STACK
5877 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5878 /* If DOGC is set, POINTER is the address of a memory
5879 area containing INTEGER potential Lisp_Objects. */
5880 if (ptr->dogc)
5882 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
5883 ptrdiff_t nelt;
5884 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
5885 mark_maybe_object (*p);
5888 #endif
5889 break;
5891 case Lisp_Misc_Overlay:
5892 mark_overlay (XOVERLAY (obj));
5893 break;
5895 default:
5896 emacs_abort ();
5898 break;
5900 case Lisp_Cons:
5902 register struct Lisp_Cons *ptr = XCONS (obj);
5903 if (CONS_MARKED_P (ptr))
5904 break;
5905 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
5906 CONS_MARK (ptr);
5907 /* If the cdr is nil, avoid recursion for the car. */
5908 if (EQ (ptr->u.cdr, Qnil))
5910 obj = ptr->car;
5911 cdr_count = 0;
5912 goto loop;
5914 mark_object (ptr->car);
5915 obj = ptr->u.cdr;
5916 cdr_count++;
5917 if (cdr_count == mark_object_loop_halt)
5918 emacs_abort ();
5919 goto loop;
5922 case Lisp_Float:
5923 CHECK_ALLOCATED_AND_LIVE (live_float_p);
5924 FLOAT_MARK (XFLOAT (obj));
5925 break;
5927 case_Lisp_Int:
5928 break;
5930 default:
5931 emacs_abort ();
5934 #undef CHECK_LIVE
5935 #undef CHECK_ALLOCATED
5936 #undef CHECK_ALLOCATED_AND_LIVE
5938 /* Mark the Lisp pointers in the terminal objects.
5939 Called by Fgarbage_collect. */
5941 static void
5942 mark_terminals (void)
5944 struct terminal *t;
5945 for (t = terminal_list; t; t = t->next_terminal)
5947 eassert (t->name != NULL);
5948 #ifdef HAVE_WINDOW_SYSTEM
5949 /* If a terminal object is reachable from a stacpro'ed object,
5950 it might have been marked already. Make sure the image cache
5951 gets marked. */
5952 mark_image_cache (t->image_cache);
5953 #endif /* HAVE_WINDOW_SYSTEM */
5954 if (!VECTOR_MARKED_P (t))
5955 mark_vectorlike ((struct Lisp_Vector *)t);
5961 /* Value is non-zero if OBJ will survive the current GC because it's
5962 either marked or does not need to be marked to survive. */
5964 bool
5965 survives_gc_p (Lisp_Object obj)
5967 bool survives_p;
5969 switch (XTYPE (obj))
5971 case_Lisp_Int:
5972 survives_p = 1;
5973 break;
5975 case Lisp_Symbol:
5976 survives_p = XSYMBOL (obj)->gcmarkbit;
5977 break;
5979 case Lisp_Misc:
5980 survives_p = XMISCANY (obj)->gcmarkbit;
5981 break;
5983 case Lisp_String:
5984 survives_p = STRING_MARKED_P (XSTRING (obj));
5985 break;
5987 case Lisp_Vectorlike:
5988 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
5989 break;
5991 case Lisp_Cons:
5992 survives_p = CONS_MARKED_P (XCONS (obj));
5993 break;
5995 case Lisp_Float:
5996 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
5997 break;
5999 default:
6000 emacs_abort ();
6003 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
6008 /* Sweep: find all structures not marked, and free them. */
6010 static void
6011 gc_sweep (void)
6013 /* Remove or mark entries in weak hash tables.
6014 This must be done before any object is unmarked. */
6015 sweep_weak_hash_tables ();
6017 sweep_strings ();
6018 check_string_bytes (!noninteractive);
6020 /* Put all unmarked conses on free list */
6022 register struct cons_block *cblk;
6023 struct cons_block **cprev = &cons_block;
6024 register int lim = cons_block_index;
6025 EMACS_INT num_free = 0, num_used = 0;
6027 cons_free_list = 0;
6029 for (cblk = cons_block; cblk; cblk = *cprev)
6031 register int i = 0;
6032 int this_free = 0;
6033 int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
6035 /* Scan the mark bits an int at a time. */
6036 for (i = 0; i < ilim; i++)
6038 if (cblk->gcmarkbits[i] == -1)
6040 /* Fast path - all cons cells for this int are marked. */
6041 cblk->gcmarkbits[i] = 0;
6042 num_used += BITS_PER_INT;
6044 else
6046 /* Some cons cells for this int are not marked.
6047 Find which ones, and free them. */
6048 int start, pos, stop;
6050 start = i * BITS_PER_INT;
6051 stop = lim - start;
6052 if (stop > BITS_PER_INT)
6053 stop = BITS_PER_INT;
6054 stop += start;
6056 for (pos = start; pos < stop; pos++)
6058 if (!CONS_MARKED_P (&cblk->conses[pos]))
6060 this_free++;
6061 cblk->conses[pos].u.chain = cons_free_list;
6062 cons_free_list = &cblk->conses[pos];
6063 #if GC_MARK_STACK
6064 cons_free_list->car = Vdead;
6065 #endif
6067 else
6069 num_used++;
6070 CONS_UNMARK (&cblk->conses[pos]);
6076 lim = CONS_BLOCK_SIZE;
6077 /* If this block contains only free conses and we have already
6078 seen more than two blocks worth of free conses then deallocate
6079 this block. */
6080 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
6082 *cprev = cblk->next;
6083 /* Unhook from the free list. */
6084 cons_free_list = cblk->conses[0].u.chain;
6085 lisp_align_free (cblk);
6087 else
6089 num_free += this_free;
6090 cprev = &cblk->next;
6093 total_conses = num_used;
6094 total_free_conses = num_free;
6097 /* Put all unmarked floats on free list */
6099 register struct float_block *fblk;
6100 struct float_block **fprev = &float_block;
6101 register int lim = float_block_index;
6102 EMACS_INT num_free = 0, num_used = 0;
6104 float_free_list = 0;
6106 for (fblk = float_block; fblk; fblk = *fprev)
6108 register int i;
6109 int this_free = 0;
6110 for (i = 0; i < lim; i++)
6111 if (!FLOAT_MARKED_P (&fblk->floats[i]))
6113 this_free++;
6114 fblk->floats[i].u.chain = float_free_list;
6115 float_free_list = &fblk->floats[i];
6117 else
6119 num_used++;
6120 FLOAT_UNMARK (&fblk->floats[i]);
6122 lim = FLOAT_BLOCK_SIZE;
6123 /* If this block contains only free floats and we have already
6124 seen more than two blocks worth of free floats then deallocate
6125 this block. */
6126 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
6128 *fprev = fblk->next;
6129 /* Unhook from the free list. */
6130 float_free_list = fblk->floats[0].u.chain;
6131 lisp_align_free (fblk);
6133 else
6135 num_free += this_free;
6136 fprev = &fblk->next;
6139 total_floats = num_used;
6140 total_free_floats = num_free;
6143 /* Put all unmarked intervals on free list */
6145 register struct interval_block *iblk;
6146 struct interval_block **iprev = &interval_block;
6147 register int lim = interval_block_index;
6148 EMACS_INT num_free = 0, num_used = 0;
6150 interval_free_list = 0;
6152 for (iblk = interval_block; iblk; iblk = *iprev)
6154 register int i;
6155 int this_free = 0;
6157 for (i = 0; i < lim; i++)
6159 if (!iblk->intervals[i].gcmarkbit)
6161 set_interval_parent (&iblk->intervals[i], interval_free_list);
6162 interval_free_list = &iblk->intervals[i];
6163 this_free++;
6165 else
6167 num_used++;
6168 iblk->intervals[i].gcmarkbit = 0;
6171 lim = INTERVAL_BLOCK_SIZE;
6172 /* If this block contains only free intervals and we have already
6173 seen more than two blocks worth of free intervals then
6174 deallocate this block. */
6175 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6177 *iprev = iblk->next;
6178 /* Unhook from the free list. */
6179 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
6180 lisp_free (iblk);
6182 else
6184 num_free += this_free;
6185 iprev = &iblk->next;
6188 total_intervals = num_used;
6189 total_free_intervals = num_free;
6192 /* Put all unmarked symbols on free list */
6194 register struct symbol_block *sblk;
6195 struct symbol_block **sprev = &symbol_block;
6196 register int lim = symbol_block_index;
6197 EMACS_INT num_free = 0, num_used = 0;
6199 symbol_free_list = NULL;
6201 for (sblk = symbol_block; sblk; sblk = *sprev)
6203 int this_free = 0;
6204 union aligned_Lisp_Symbol *sym = sblk->symbols;
6205 union aligned_Lisp_Symbol *end = sym + lim;
6207 for (; sym < end; ++sym)
6209 /* Check if the symbol was created during loadup. In such a case
6210 it might be pointed to by pure bytecode which we don't trace,
6211 so we conservatively assume that it is live. */
6212 bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
6214 if (!sym->s.gcmarkbit && !pure_p)
6216 if (sym->s.redirect == SYMBOL_LOCALIZED)
6217 xfree (SYMBOL_BLV (&sym->s));
6218 sym->s.next = symbol_free_list;
6219 symbol_free_list = &sym->s;
6220 #if GC_MARK_STACK
6221 symbol_free_list->function = Vdead;
6222 #endif
6223 ++this_free;
6225 else
6227 ++num_used;
6228 if (!pure_p)
6229 UNMARK_STRING (XSTRING (sym->s.name));
6230 sym->s.gcmarkbit = 0;
6234 lim = SYMBOL_BLOCK_SIZE;
6235 /* If this block contains only free symbols and we have already
6236 seen more than two blocks worth of free symbols then deallocate
6237 this block. */
6238 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6240 *sprev = sblk->next;
6241 /* Unhook from the free list. */
6242 symbol_free_list = sblk->symbols[0].s.next;
6243 lisp_free (sblk);
6245 else
6247 num_free += this_free;
6248 sprev = &sblk->next;
6251 total_symbols = num_used;
6252 total_free_symbols = num_free;
6255 /* Put all unmarked misc's on free list.
6256 For a marker, first unchain it from the buffer it points into. */
6258 register struct marker_block *mblk;
6259 struct marker_block **mprev = &marker_block;
6260 register int lim = marker_block_index;
6261 EMACS_INT num_free = 0, num_used = 0;
6263 marker_free_list = 0;
6265 for (mblk = marker_block; mblk; mblk = *mprev)
6267 register int i;
6268 int this_free = 0;
6270 for (i = 0; i < lim; i++)
6272 if (!mblk->markers[i].m.u_any.gcmarkbit)
6274 if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
6275 unchain_marker (&mblk->markers[i].m.u_marker);
6276 /* Set the type of the freed object to Lisp_Misc_Free.
6277 We could leave the type alone, since nobody checks it,
6278 but this might catch bugs faster. */
6279 mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
6280 mblk->markers[i].m.u_free.chain = marker_free_list;
6281 marker_free_list = &mblk->markers[i].m;
6282 this_free++;
6284 else
6286 num_used++;
6287 mblk->markers[i].m.u_any.gcmarkbit = 0;
6290 lim = MARKER_BLOCK_SIZE;
6291 /* If this block contains only free markers and we have already
6292 seen more than two blocks worth of free markers then deallocate
6293 this block. */
6294 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6296 *mprev = mblk->next;
6297 /* Unhook from the free list. */
6298 marker_free_list = mblk->markers[0].m.u_free.chain;
6299 lisp_free (mblk);
6301 else
6303 num_free += this_free;
6304 mprev = &mblk->next;
6308 total_markers = num_used;
6309 total_free_markers = num_free;
6312 /* Free all unmarked buffers */
6314 register struct buffer *buffer, **bprev = &all_buffers;
6316 total_buffers = 0;
6317 for (buffer = all_buffers; buffer; buffer = *bprev)
6318 if (!VECTOR_MARKED_P (buffer))
6320 *bprev = buffer->header.next.buffer;
6321 lisp_free (buffer);
6323 else
6325 VECTOR_UNMARK (buffer);
6326 /* Do not use buffer_(set|get)_intervals here. */
6327 buffer->text->intervals = balance_intervals (buffer->text->intervals);
6328 total_buffers++;
6329 bprev = &buffer->header.next.buffer;
6333 sweep_vectors ();
6334 check_string_bytes (!noninteractive);
6340 /* Debugging aids. */
6342 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
6343 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6344 This may be helpful in debugging Emacs's memory usage.
6345 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6346 (void)
6348 Lisp_Object end;
6350 XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
6352 return end;
6355 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
6356 doc: /* Return a list of counters that measure how much consing there has been.
6357 Each of these counters increments for a certain kind of object.
6358 The counters wrap around from the largest positive integer to zero.
6359 Garbage collection does not decrease them.
6360 The elements of the value are as follows:
6361 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6362 All are in units of 1 = one object consed
6363 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6364 objects consed.
6365 MISCS include overlays, markers, and some internal types.
6366 Frames, windows, buffers, and subprocesses count as vectors
6367 (but the contents of a buffer's text do not count here). */)
6368 (void)
6370 return listn (CONSTYPE_HEAP, 8,
6371 bounded_number (cons_cells_consed),
6372 bounded_number (floats_consed),
6373 bounded_number (vector_cells_consed),
6374 bounded_number (symbols_consed),
6375 bounded_number (string_chars_consed),
6376 bounded_number (misc_objects_consed),
6377 bounded_number (intervals_consed),
6378 bounded_number (strings_consed));
6381 /* Find at most FIND_MAX symbols which have OBJ as their value or
6382 function. This is used in gdbinit's `xwhichsymbols' command. */
6384 Lisp_Object
6385 which_symbols (Lisp_Object obj, EMACS_INT find_max)
6387 struct symbol_block *sblk;
6388 ptrdiff_t gc_count = inhibit_garbage_collection ();
6389 Lisp_Object found = Qnil;
6391 if (! DEADP (obj))
6393 for (sblk = symbol_block; sblk; sblk = sblk->next)
6395 union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
6396 int bn;
6398 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++)
6400 struct Lisp_Symbol *sym = &aligned_sym->s;
6401 Lisp_Object val;
6402 Lisp_Object tem;
6404 if (sblk == symbol_block && bn >= symbol_block_index)
6405 break;
6407 XSETSYMBOL (tem, sym);
6408 val = find_symbol_value (tem);
6409 if (EQ (val, obj)
6410 || EQ (sym->function, obj)
6411 || (!NILP (sym->function)
6412 && COMPILEDP (sym->function)
6413 && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
6414 || (!NILP (val)
6415 && COMPILEDP (val)
6416 && EQ (AREF (val, COMPILED_BYTECODE), obj)))
6418 found = Fcons (tem, found);
6419 if (--find_max == 0)
6420 goto out;
6426 out:
6427 unbind_to (gc_count, Qnil);
6428 return found;
6431 #ifdef ENABLE_CHECKING
6433 bool suppress_checking;
6435 void
6436 die (const char *msg, const char *file, int line)
6438 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6439 file, line, msg);
6440 terminate_due_to_signal (SIGABRT, INT_MAX);
6442 #endif
6444 /* Initialization */
6446 void
6447 init_alloc_once (void)
6449 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6450 purebeg = PUREBEG;
6451 pure_size = PURESIZE;
6453 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6454 mem_init ();
6455 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6456 #endif
6458 #ifdef DOUG_LEA_MALLOC
6459 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
6460 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
6461 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
6462 #endif
6463 init_strings ();
6464 init_vectors ();
6466 refill_memory_reserve ();
6467 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
6470 void
6471 init_alloc (void)
6473 gcprolist = 0;
6474 byte_stack_list = 0;
6475 #if GC_MARK_STACK
6476 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6477 setjmp_tested_p = longjmps_done = 0;
6478 #endif
6479 #endif
6480 Vgc_elapsed = make_float (0.0);
6481 gcs_done = 0;
6484 void
6485 syms_of_alloc (void)
6487 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
6488 doc: /* Number of bytes of consing between garbage collections.
6489 Garbage collection can happen automatically once this many bytes have been
6490 allocated since the last garbage collection. All data types count.
6492 Garbage collection happens automatically only when `eval' is called.
6494 By binding this temporarily to a large number, you can effectively
6495 prevent garbage collection during a part of the program.
6496 See also `gc-cons-percentage'. */);
6498 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
6499 doc: /* Portion of the heap used for allocation.
6500 Garbage collection can happen automatically once this portion of the heap
6501 has been allocated since the last garbage collection.
6502 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6503 Vgc_cons_percentage = make_float (0.1);
6505 DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
6506 doc: /* Number of bytes of shareable Lisp data allocated so far. */);
6508 DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
6509 doc: /* Number of cons cells that have been consed so far. */);
6511 DEFVAR_INT ("floats-consed", floats_consed,
6512 doc: /* Number of floats that have been consed so far. */);
6514 DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
6515 doc: /* Number of vector cells that have been consed so far. */);
6517 DEFVAR_INT ("symbols-consed", symbols_consed,
6518 doc: /* Number of symbols that have been consed so far. */);
6520 DEFVAR_INT ("string-chars-consed", string_chars_consed,
6521 doc: /* Number of string characters that have been consed so far. */);
6523 DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
6524 doc: /* Number of miscellaneous objects that have been consed so far.
6525 These include markers and overlays, plus certain objects not visible
6526 to users. */);
6528 DEFVAR_INT ("intervals-consed", intervals_consed,
6529 doc: /* Number of intervals that have been consed so far. */);
6531 DEFVAR_INT ("strings-consed", strings_consed,
6532 doc: /* Number of strings that have been consed so far. */);
6534 DEFVAR_LISP ("purify-flag", Vpurify_flag,
6535 doc: /* Non-nil means loading Lisp code in order to dump an executable.
6536 This means that certain objects should be allocated in shared (pure) space.
6537 It can also be set to a hash-table, in which case this table is used to
6538 do hash-consing of the objects allocated to pure space. */);
6540 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
6541 doc: /* Non-nil means display messages at start and end of garbage collection. */);
6542 garbage_collection_messages = 0;
6544 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
6545 doc: /* Hook run after garbage collection has finished. */);
6546 Vpost_gc_hook = Qnil;
6547 DEFSYM (Qpost_gc_hook, "post-gc-hook");
6549 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
6550 doc: /* Precomputed `signal' argument for memory-full error. */);
6551 /* We build this in advance because if we wait until we need it, we might
6552 not be able to allocate the memory to hold it. */
6553 Vmemory_signal_data
6554 = listn (CONSTYPE_PURE, 2, Qerror,
6555 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6557 DEFVAR_LISP ("memory-full", Vmemory_full,
6558 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6559 Vmemory_full = Qnil;
6561 DEFSYM (Qconses, "conses");
6562 DEFSYM (Qsymbols, "symbols");
6563 DEFSYM (Qmiscs, "miscs");
6564 DEFSYM (Qstrings, "strings");
6565 DEFSYM (Qvectors, "vectors");
6566 DEFSYM (Qfloats, "floats");
6567 DEFSYM (Qintervals, "intervals");
6568 DEFSYM (Qbuffers, "buffers");
6569 DEFSYM (Qstring_bytes, "string-bytes");
6570 DEFSYM (Qvector_slots, "vector-slots");
6571 DEFSYM (Qheap, "heap");
6572 DEFSYM (Qautomatic_gc, "Automatic GC");
6574 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
6575 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
6577 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
6578 doc: /* Accumulated time elapsed in garbage collections.
6579 The time is in seconds as a floating point value. */);
6580 DEFVAR_INT ("gcs-done", gcs_done,
6581 doc: /* Accumulated number of garbage collections done. */);
6583 defsubr (&Scons);
6584 defsubr (&Slist);
6585 defsubr (&Svector);
6586 defsubr (&Smake_byte_code);
6587 defsubr (&Smake_list);
6588 defsubr (&Smake_vector);
6589 defsubr (&Smake_string);
6590 defsubr (&Smake_bool_vector);
6591 defsubr (&Smake_symbol);
6592 defsubr (&Smake_marker);
6593 defsubr (&Spurecopy);
6594 defsubr (&Sgarbage_collect);
6595 defsubr (&Smemory_limit);
6596 defsubr (&Smemory_use_counts);
6598 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6599 defsubr (&Sgc_status);
6600 #endif
6603 /* When compiled with GCC, GDB might say "No enum type named
6604 pvec_type" if we don't have at least one symbol with that type, and
6605 then xbacktrace could fail. Similarly for the other enums and
6606 their values. Some non-GCC compilers don't like these constructs. */
6607 #ifdef __GNUC__
6608 union
6610 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
6611 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
6612 enum char_bits char_bits;
6613 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
6614 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
6615 enum enum_USE_LSB_TAG enum_USE_LSB_TAG;
6616 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
6617 enum Lisp_Bits Lisp_Bits;
6618 enum Lisp_Compiled Lisp_Compiled;
6619 enum maxargs maxargs;
6620 enum MAX_ALLOCA MAX_ALLOCA;
6621 enum More_Lisp_Bits More_Lisp_Bits;
6622 enum pvec_type pvec_type;
6623 #if USE_LSB_TAG
6624 enum lsb_bits lsb_bits;
6625 #endif
6626 } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
6627 #endif /* __GNUC__ */