1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
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/>. */
24 #include <limits.h> /* For CHAR_BIT. */
26 #ifdef ENABLE_CHECKING
27 #include <signal.h> /* For SIGABRT. */
36 #include "intervals.h"
38 #include "character.h"
43 #include "blockinput.h"
44 #include "termhooks.h" /* For struct terminal. */
45 #ifdef HAVE_WINDOW_SYSTEM
47 #endif /* HAVE_WINDOW_SYSTEM */
50 #include <execinfo.h> /* For backtrace. */
52 #ifdef HAVE_LINUX_SYSINFO
53 #include <sys/sysinfo.h>
57 #include "dosfns.h" /* For dos_memory_info. */
60 #if (defined ENABLE_CHECKING \
61 && defined HAVE_VALGRIND_VALGRIND_H \
62 && !defined USE_VALGRIND)
63 # define USE_VALGRIND 1
67 #include <valgrind/valgrind.h>
68 #include <valgrind/memcheck.h>
69 static bool valgrind_p
;
72 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
73 Doable only if GC_MARK_STACK. */
75 # undef GC_CHECK_MARKED_OBJECTS
78 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
79 memory. Can do this only if using gmalloc.c and if not checking
82 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
83 || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
84 #undef GC_MALLOC_CHECK
95 #include "w32heap.h" /* for sbrk */
98 #ifdef DOUG_LEA_MALLOC
102 /* Specify maximum number of areas to mmap. It would be nice to use a
103 value that explicitly means "no limit". */
105 #define MMAP_MAX_AREAS 100000000
107 #endif /* not DOUG_LEA_MALLOC */
109 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
110 to a struct Lisp_String. */
112 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
113 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
114 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
116 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
117 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
118 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
120 /* Default value of gc_cons_threshold (see below). */
122 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
124 /* Global variables. */
125 struct emacs_globals globals
;
127 /* Number of bytes of consing done since the last gc. */
129 EMACS_INT consing_since_gc
;
131 /* Similar minimum, computed from Vgc_cons_percentage. */
133 EMACS_INT gc_relative_threshold
;
135 /* Minimum number of bytes of consing since GC before next GC,
136 when memory is full. */
138 EMACS_INT memory_full_cons_threshold
;
140 /* True during GC. */
144 /* True means abort if try to GC.
145 This is for code which is written on the assumption that
146 no GC will happen, so as to verify that assumption. */
150 /* Number of live and free conses etc. */
152 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
153 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
154 static EMACS_INT total_free_floats
, total_floats
;
156 /* Points to memory space allocated as "spare", to be freed if we run
157 out of memory. We keep one large block, four cons-blocks, and
158 two string blocks. */
160 static char *spare_memory
[7];
162 /* Amount of spare memory to keep in large reserve block, or to see
163 whether this much is available when malloc fails on a larger request. */
165 #define SPARE_MEMORY (1 << 14)
167 /* Initialize it to a nonzero value to force it into data space
168 (rather than bss space). That way unexec will remap it into text
169 space (pure), on some systems. We have not implemented the
170 remapping on more recent systems because this is less important
171 nowadays than in the days of small memories and timesharing. */
173 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
174 #define PUREBEG (char *) pure
176 /* Pointer to the pure area, and its size. */
178 static char *purebeg
;
179 static ptrdiff_t pure_size
;
181 /* Number of bytes of pure storage used before pure storage overflowed.
182 If this is non-zero, this implies that an overflow occurred. */
184 static ptrdiff_t pure_bytes_used_before_overflow
;
186 /* True if P points into pure space. */
188 #define PURE_POINTER_P(P) \
189 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
191 /* Index in pure at which next pure Lisp object will be allocated.. */
193 static ptrdiff_t pure_bytes_used_lisp
;
195 /* Number of bytes allocated for non-Lisp objects in pure storage. */
197 static ptrdiff_t pure_bytes_used_non_lisp
;
199 /* If nonzero, this is a warning delivered by malloc and not yet
202 const char *pending_malloc_warning
;
204 #if 0 /* Normally, pointer sanity only on request... */
205 #ifdef ENABLE_CHECKING
206 #define SUSPICIOUS_OBJECT_CHECKING 1
210 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
211 bug is unresolved. */
212 #define SUSPICIOUS_OBJECT_CHECKING 1
214 #ifdef SUSPICIOUS_OBJECT_CHECKING
215 struct suspicious_free_record
217 void *suspicious_object
;
218 void *backtrace
[128];
220 static void *suspicious_objects
[32];
221 static int suspicious_object_index
;
222 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
223 static int suspicious_free_history_index
;
224 /* Find the first currently-monitored suspicious pointer in range
225 [begin,end) or NULL if no such pointer exists. */
226 static void *find_suspicious_object_in_range (void *begin
, void *end
);
227 static void detect_suspicious_free (void *ptr
);
229 # define find_suspicious_object_in_range(begin, end) NULL
230 # define detect_suspicious_free(ptr) (void)
233 /* Maximum amount of C stack to save when a GC happens. */
235 #ifndef MAX_SAVE_STACK
236 #define MAX_SAVE_STACK 16000
239 /* Buffer in which we save a copy of the C stack at each GC. */
241 #if MAX_SAVE_STACK > 0
242 static char *stack_copy
;
243 static ptrdiff_t stack_copy_size
;
245 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
246 avoiding any address sanitization. */
248 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
249 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
251 if (! ADDRESS_SANITIZER
)
252 return memcpy (dest
, src
, size
);
258 for (i
= 0; i
< size
; i
++)
264 #endif /* MAX_SAVE_STACK > 0 */
266 static Lisp_Object Qconses
;
267 static Lisp_Object Qsymbols
;
268 static Lisp_Object Qmiscs
;
269 static Lisp_Object Qstrings
;
270 static Lisp_Object Qvectors
;
271 static Lisp_Object Qfloats
;
272 static Lisp_Object Qintervals
;
273 static Lisp_Object Qbuffers
;
274 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
275 static Lisp_Object Qgc_cons_threshold
;
276 Lisp_Object Qautomatic_gc
;
277 Lisp_Object Qchar_table_extra_slots
;
279 /* Hook run after GC has finished. */
281 static Lisp_Object Qpost_gc_hook
;
283 static void mark_terminals (void);
284 static void gc_sweep (void);
285 static Lisp_Object
make_pure_vector (ptrdiff_t);
286 static void mark_buffer (struct buffer
*);
288 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
289 static void refill_memory_reserve (void);
291 static void compact_small_strings (void);
292 static void free_large_strings (void);
293 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
295 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
296 what memory allocated via lisp_malloc and lisp_align_malloc is intended
297 for what purpose. This enumeration specifies the type of memory. */
308 /* Since all non-bool pseudovectors are small enough to be
309 allocated from vector blocks, this memory type denotes
310 large regular vectors and large bool pseudovectors. */
312 /* Special type to denote vector blocks. */
313 MEM_TYPE_VECTOR_BLOCK
,
314 /* Special type to denote reserved memory. */
318 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
320 /* A unique object in pure space used to make some Lisp objects
321 on free lists recognizable in O(1). */
323 static Lisp_Object Vdead
;
324 #define DEADP(x) EQ (x, Vdead)
326 #ifdef GC_MALLOC_CHECK
328 enum mem_type allocated_mem_type
;
330 #endif /* GC_MALLOC_CHECK */
332 /* A node in the red-black tree describing allocated memory containing
333 Lisp data. Each such block is recorded with its start and end
334 address when it is allocated, and removed from the tree when it
337 A red-black tree is a balanced binary tree with the following
340 1. Every node is either red or black.
341 2. Every leaf is black.
342 3. If a node is red, then both of its children are black.
343 4. Every simple path from a node to a descendant leaf contains
344 the same number of black nodes.
345 5. The root is always black.
347 When nodes are inserted into the tree, or deleted from the tree,
348 the tree is "fixed" so that these properties are always true.
350 A red-black tree with N internal nodes has height at most 2
351 log(N+1). Searches, insertions and deletions are done in O(log N).
352 Please see a text book about data structures for a detailed
353 description of red-black trees. Any book worth its salt should
358 /* Children of this node. These pointers are never NULL. When there
359 is no child, the value is MEM_NIL, which points to a dummy node. */
360 struct mem_node
*left
, *right
;
362 /* The parent of this node. In the root node, this is NULL. */
363 struct mem_node
*parent
;
365 /* Start and end of allocated region. */
369 enum {MEM_BLACK
, MEM_RED
} color
;
375 /* Base address of stack. Set in main. */
377 Lisp_Object
*stack_base
;
379 /* Root of the tree describing allocated Lisp memory. */
381 static struct mem_node
*mem_root
;
383 /* Lowest and highest known address in the heap. */
385 static void *min_heap_address
, *max_heap_address
;
387 /* Sentinel node of the tree. */
389 static struct mem_node mem_z
;
390 #define MEM_NIL &mem_z
392 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
393 static void mem_insert_fixup (struct mem_node
*);
394 static void mem_rotate_left (struct mem_node
*);
395 static void mem_rotate_right (struct mem_node
*);
396 static void mem_delete (struct mem_node
*);
397 static void mem_delete_fixup (struct mem_node
*);
398 static struct mem_node
*mem_find (void *);
400 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
406 /* Recording what needs to be marked for gc. */
408 struct gcpro
*gcprolist
;
410 /* Addresses of staticpro'd variables. Initialize it to a nonzero
411 value; otherwise some compilers put it into BSS. */
413 enum { NSTATICS
= 2048 };
414 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
416 /* Index of next unused slot in staticvec. */
418 static int staticidx
;
420 static void *pure_alloc (size_t, int);
422 /* Return X rounded to the next multiple of Y. Arguments should not
423 have side effects, as they are evaluated more than once. Assume X
424 + Y - 1 does not overflow. Tune for Y being a power of 2. */
426 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
427 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
428 : ((x) + (y) - 1) & ~ ((y) - 1))
430 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
433 ALIGN (void *ptr
, int alignment
)
435 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
439 XFLOAT_INIT (Lisp_Object f
, double n
)
441 XFLOAT (f
)->u
.data
= n
;
445 pointers_fit_in_lispobj_p (void)
447 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
451 mmap_lisp_allowed_p (void)
453 /* If we can't store all memory addresses in our lisp objects, it's
454 risky to let the heap use mmap and give us addresses from all
455 over our address space. We also can't use mmap for lisp objects
456 if we might dump: unexec doesn't preserve the contents of mmaped
458 return pointers_fit_in_lispobj_p () && !might_dump
;
462 /************************************************************************
464 ************************************************************************/
466 /* Function malloc calls this if it finds we are near exhausting storage. */
469 malloc_warning (const char *str
)
471 pending_malloc_warning
= str
;
475 /* Display an already-pending malloc warning. */
478 display_malloc_warning (void)
480 call3 (intern ("display-warning"),
482 build_string (pending_malloc_warning
),
483 intern ("emergency"));
484 pending_malloc_warning
= 0;
487 /* Called if we can't allocate relocatable space for a buffer. */
490 buffer_memory_full (ptrdiff_t nbytes
)
492 /* If buffers use the relocating allocator, no need to free
493 spare_memory, because we may have plenty of malloc space left
494 that we could get, and if we don't, the malloc that fails will
495 itself cause spare_memory to be freed. If buffers don't use the
496 relocating allocator, treat this like any other failing
500 memory_full (nbytes
);
502 /* This used to call error, but if we've run out of memory, we could
503 get infinite recursion trying to build the string. */
504 xsignal (Qnil
, Vmemory_signal_data
);
508 /* A common multiple of the positive integers A and B. Ideally this
509 would be the least common multiple, but there's no way to do that
510 as a constant expression in C, so do the best that we can easily do. */
511 #define COMMON_MULTIPLE(a, b) \
512 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
514 #ifndef XMALLOC_OVERRUN_CHECK
515 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
518 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
521 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
522 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
523 block size in little-endian order. The trailer consists of
524 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
526 The header is used to detect whether this block has been allocated
527 through these functions, as some low-level libc functions may
528 bypass the malloc hooks. */
530 #define XMALLOC_OVERRUN_CHECK_SIZE 16
531 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
532 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
534 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
535 hold a size_t value and (2) the header size is a multiple of the
536 alignment that Emacs needs for C types and for USE_LSB_TAG. */
537 #define XMALLOC_BASE_ALIGNMENT \
538 alignof (union { long double d; intmax_t i; void *p; })
541 # define XMALLOC_HEADER_ALIGNMENT \
542 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
544 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
546 #define XMALLOC_OVERRUN_SIZE_SIZE \
547 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
548 + XMALLOC_HEADER_ALIGNMENT - 1) \
549 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
550 - XMALLOC_OVERRUN_CHECK_SIZE)
552 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
553 { '\x9a', '\x9b', '\xae', '\xaf',
554 '\xbf', '\xbe', '\xce', '\xcf',
555 '\xea', '\xeb', '\xec', '\xed',
556 '\xdf', '\xde', '\x9c', '\x9d' };
558 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
559 { '\xaa', '\xab', '\xac', '\xad',
560 '\xba', '\xbb', '\xbc', '\xbd',
561 '\xca', '\xcb', '\xcc', '\xcd',
562 '\xda', '\xdb', '\xdc', '\xdd' };
564 /* Insert and extract the block size in the header. */
567 xmalloc_put_size (unsigned char *ptr
, size_t size
)
570 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
572 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
578 xmalloc_get_size (unsigned char *ptr
)
582 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
583 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
592 /* Like malloc, but wraps allocated block with header and trailer. */
595 overrun_check_malloc (size_t size
)
597 register unsigned char *val
;
598 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
601 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
604 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
605 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
606 xmalloc_put_size (val
, size
);
607 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
608 XMALLOC_OVERRUN_CHECK_SIZE
);
614 /* Like realloc, but checks old block for overrun, and wraps new block
615 with header and trailer. */
618 overrun_check_realloc (void *block
, size_t size
)
620 register unsigned char *val
= (unsigned char *) block
;
621 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
625 && memcmp (xmalloc_overrun_check_header
,
626 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
627 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
629 size_t osize
= xmalloc_get_size (val
);
630 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
631 XMALLOC_OVERRUN_CHECK_SIZE
))
633 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
634 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
635 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
638 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
642 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
643 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
644 xmalloc_put_size (val
, size
);
645 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
646 XMALLOC_OVERRUN_CHECK_SIZE
);
651 /* Like free, but checks block for overrun. */
654 overrun_check_free (void *block
)
656 unsigned char *val
= (unsigned char *) block
;
659 && memcmp (xmalloc_overrun_check_header
,
660 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
661 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
663 size_t osize
= xmalloc_get_size (val
);
664 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
665 XMALLOC_OVERRUN_CHECK_SIZE
))
667 #ifdef XMALLOC_CLEAR_FREE_MEMORY
668 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
669 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
671 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
672 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
673 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
683 #define malloc overrun_check_malloc
684 #define realloc overrun_check_realloc
685 #define free overrun_check_free
688 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
689 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
690 If that variable is set, block input while in one of Emacs's memory
691 allocation functions. There should be no need for this debugging
692 option, since signal handlers do not allocate memory, but Emacs
693 formerly allocated memory in signal handlers and this compile-time
694 option remains as a way to help debug the issue should it rear its
696 #ifdef XMALLOC_BLOCK_INPUT_CHECK
697 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
699 malloc_block_input (void)
701 if (block_input_in_memory_allocators
)
705 malloc_unblock_input (void)
707 if (block_input_in_memory_allocators
)
710 # define MALLOC_BLOCK_INPUT malloc_block_input ()
711 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
713 # define MALLOC_BLOCK_INPUT ((void) 0)
714 # define MALLOC_UNBLOCK_INPUT ((void) 0)
717 #define MALLOC_PROBE(size) \
719 if (profiler_memory_running) \
720 malloc_probe (size); \
724 /* Like malloc but check for no memory and block interrupt input.. */
727 xmalloc (size_t size
)
733 MALLOC_UNBLOCK_INPUT
;
741 /* Like the above, but zeroes out the memory just allocated. */
744 xzalloc (size_t size
)
750 MALLOC_UNBLOCK_INPUT
;
754 memset (val
, 0, size
);
759 /* Like realloc but check for no memory and block interrupt input.. */
762 xrealloc (void *block
, size_t size
)
767 /* We must call malloc explicitly when BLOCK is 0, since some
768 reallocs don't do this. */
772 val
= realloc (block
, size
);
773 MALLOC_UNBLOCK_INPUT
;
782 /* Like free but block interrupt input. */
791 MALLOC_UNBLOCK_INPUT
;
792 /* We don't call refill_memory_reserve here
793 because in practice the call in r_alloc_free seems to suffice. */
797 /* Other parts of Emacs pass large int values to allocator functions
798 expecting ptrdiff_t. This is portable in practice, but check it to
800 verify (INT_MAX
<= PTRDIFF_MAX
);
803 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
804 Signal an error on memory exhaustion, and block interrupt input. */
807 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
809 eassert (0 <= nitems
&& 0 < item_size
);
810 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
811 memory_full (SIZE_MAX
);
812 return xmalloc (nitems
* item_size
);
816 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
817 Signal an error on memory exhaustion, and block interrupt input. */
820 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
822 eassert (0 <= nitems
&& 0 < item_size
);
823 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
824 memory_full (SIZE_MAX
);
825 return xrealloc (pa
, nitems
* item_size
);
829 /* Grow PA, which points to an array of *NITEMS items, and return the
830 location of the reallocated array, updating *NITEMS to reflect its
831 new size. The new array will contain at least NITEMS_INCR_MIN more
832 items, but will not contain more than NITEMS_MAX items total.
833 ITEM_SIZE is the size of each item, in bytes.
835 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
836 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
839 If PA is null, then allocate a new array instead of reallocating
842 Block interrupt input as needed. If memory exhaustion occurs, set
843 *NITEMS to zero if PA is null, and signal an error (i.e., do not
846 Thus, to grow an array A without saving its old contents, do
847 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
848 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
849 and signals an error, and later this code is reexecuted and
850 attempts to free A. */
853 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
854 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
856 /* The approximate size to use for initial small allocation
857 requests. This is the largest "small" request for the GNU C
859 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
861 /* If the array is tiny, grow it to about (but no greater than)
862 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
863 ptrdiff_t n
= *nitems
;
864 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
865 ptrdiff_t half_again
= n
>> 1;
866 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
868 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
869 NITEMS_MAX, and what the C language can represent safely. */
870 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
871 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
872 ? nitems_max
: C_language_max
);
873 ptrdiff_t nitems_incr_max
= n_max
- n
;
874 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
876 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
879 if (nitems_incr_max
< incr
)
880 memory_full (SIZE_MAX
);
882 pa
= xrealloc (pa
, n
* item_size
);
888 /* Like strdup, but uses xmalloc. */
891 xstrdup (const char *s
)
895 size
= strlen (s
) + 1;
896 return memcpy (xmalloc (size
), s
, size
);
899 /* Like above, but duplicates Lisp string to C string. */
902 xlispstrdup (Lisp_Object string
)
904 ptrdiff_t size
= SBYTES (string
) + 1;
905 return memcpy (xmalloc (size
), SSDATA (string
), size
);
908 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
909 pointed to. If STRING is null, assign it without copying anything.
910 Allocate before freeing, to avoid a dangling pointer if allocation
914 dupstring (char **ptr
, char const *string
)
917 *ptr
= string
? xstrdup (string
) : 0;
922 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
923 argument is a const pointer. */
926 xputenv (char const *string
)
928 if (putenv ((char *) string
) != 0)
932 /* Return a newly allocated memory block of SIZE bytes, remembering
933 to free it when unwinding. */
935 record_xmalloc (size_t size
)
937 void *p
= xmalloc (size
);
938 record_unwind_protect_ptr (xfree
, p
);
943 /* Like malloc but used for allocating Lisp data. NBYTES is the
944 number of bytes to allocate, TYPE describes the intended use of the
945 allocated memory block (for strings, for conses, ...). */
948 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
952 lisp_malloc (size_t nbytes
, enum mem_type type
)
958 #ifdef GC_MALLOC_CHECK
959 allocated_mem_type
= type
;
962 val
= malloc (nbytes
);
965 /* If the memory just allocated cannot be addressed thru a Lisp
966 object's pointer, and it needs to be,
967 that's equivalent to running out of memory. */
968 if (val
&& type
!= MEM_TYPE_NON_LISP
)
971 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
972 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
974 lisp_malloc_loser
= val
;
981 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
982 if (val
&& type
!= MEM_TYPE_NON_LISP
)
983 mem_insert (val
, (char *) val
+ nbytes
, type
);
986 MALLOC_UNBLOCK_INPUT
;
988 memory_full (nbytes
);
989 MALLOC_PROBE (nbytes
);
993 /* Free BLOCK. This must be called to free memory allocated with a
994 call to lisp_malloc. */
997 lisp_free (void *block
)
1001 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1002 mem_delete (mem_find (block
));
1004 MALLOC_UNBLOCK_INPUT
;
1007 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1009 /* The entry point is lisp_align_malloc which returns blocks of at most
1010 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1012 /* Use aligned_alloc if it or a simple substitute is available.
1013 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1014 clang 3.3 anyway. */
1016 #if ! ADDRESS_SANITIZER
1017 # if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
1018 # define USE_ALIGNED_ALLOC 1
1019 /* Defined in gmalloc.c. */
1020 void *aligned_alloc (size_t, size_t);
1021 # elif defined HYBRID_MALLOC
1022 # if defined ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
1023 # define USE_ALIGNED_ALLOC 1
1024 # define aligned_alloc hybrid_aligned_alloc
1025 /* Defined in gmalloc.c. */
1026 void *aligned_alloc (size_t, size_t);
1028 # elif defined HAVE_ALIGNED_ALLOC
1029 # define USE_ALIGNED_ALLOC 1
1030 # elif defined HAVE_POSIX_MEMALIGN
1031 # define USE_ALIGNED_ALLOC 1
1033 aligned_alloc (size_t alignment
, size_t size
)
1036 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1041 /* BLOCK_ALIGN has to be a power of 2. */
1042 #define BLOCK_ALIGN (1 << 10)
1044 /* Padding to leave at the end of a malloc'd block. This is to give
1045 malloc a chance to minimize the amount of memory wasted to alignment.
1046 It should be tuned to the particular malloc library used.
1047 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1048 aligned_alloc on the other hand would ideally prefer a value of 4
1049 because otherwise, there's 1020 bytes wasted between each ablocks.
1050 In Emacs, testing shows that those 1020 can most of the time be
1051 efficiently used by malloc to place other objects, so a value of 0 can
1052 still preferable unless you have a lot of aligned blocks and virtually
1054 #define BLOCK_PADDING 0
1055 #define BLOCK_BYTES \
1056 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1058 /* Internal data structures and constants. */
1060 #define ABLOCKS_SIZE 16
1062 /* An aligned block of memory. */
1067 char payload
[BLOCK_BYTES
];
1068 struct ablock
*next_free
;
1070 /* `abase' is the aligned base of the ablocks. */
1071 /* It is overloaded to hold the virtual `busy' field that counts
1072 the number of used ablock in the parent ablocks.
1073 The first ablock has the `busy' field, the others have the `abase'
1074 field. To tell the difference, we assume that pointers will have
1075 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1076 is used to tell whether the real base of the parent ablocks is `abase'
1077 (if not, the word before the first ablock holds a pointer to the
1079 struct ablocks
*abase
;
1080 /* The padding of all but the last ablock is unused. The padding of
1081 the last ablock in an ablocks is not allocated. */
1083 char padding
[BLOCK_PADDING
];
1087 /* A bunch of consecutive aligned blocks. */
1090 struct ablock blocks
[ABLOCKS_SIZE
];
1093 /* Size of the block requested from malloc or aligned_alloc. */
1094 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1096 #define ABLOCK_ABASE(block) \
1097 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1098 ? (struct ablocks *)(block) \
1101 /* Virtual `busy' field. */
1102 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1104 /* Pointer to the (not necessarily aligned) malloc block. */
1105 #ifdef USE_ALIGNED_ALLOC
1106 #define ABLOCKS_BASE(abase) (abase)
1108 #define ABLOCKS_BASE(abase) \
1109 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1112 /* The list of free ablock. */
1113 static struct ablock
*free_ablock
;
1115 /* Allocate an aligned block of nbytes.
1116 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1117 smaller or equal to BLOCK_BYTES. */
1119 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1122 struct ablocks
*abase
;
1124 eassert (nbytes
<= BLOCK_BYTES
);
1128 #ifdef GC_MALLOC_CHECK
1129 allocated_mem_type
= type
;
1135 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1137 #ifdef DOUG_LEA_MALLOC
1138 if (!mmap_lisp_allowed_p ())
1139 mallopt (M_MMAP_MAX
, 0);
1142 #ifdef USE_ALIGNED_ALLOC
1143 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1145 base
= malloc (ABLOCKS_BYTES
);
1146 abase
= ALIGN (base
, BLOCK_ALIGN
);
1151 MALLOC_UNBLOCK_INPUT
;
1152 memory_full (ABLOCKS_BYTES
);
1155 aligned
= (base
== abase
);
1157 ((void **) abase
)[-1] = base
;
1159 #ifdef DOUG_LEA_MALLOC
1160 if (!mmap_lisp_allowed_p ())
1161 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1165 /* If the memory just allocated cannot be addressed thru a Lisp
1166 object's pointer, and it needs to be, that's equivalent to
1167 running out of memory. */
1168 if (type
!= MEM_TYPE_NON_LISP
)
1171 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1172 XSETCONS (tem
, end
);
1173 if ((char *) XCONS (tem
) != end
)
1175 lisp_malloc_loser
= base
;
1177 MALLOC_UNBLOCK_INPUT
;
1178 memory_full (SIZE_MAX
);
1183 /* Initialize the blocks and put them on the free list.
1184 If `base' was not properly aligned, we can't use the last block. */
1185 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1187 abase
->blocks
[i
].abase
= abase
;
1188 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1189 free_ablock
= &abase
->blocks
[i
];
1191 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1193 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1194 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1195 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1196 eassert (ABLOCKS_BASE (abase
) == base
);
1197 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1200 abase
= ABLOCK_ABASE (free_ablock
);
1201 ABLOCKS_BUSY (abase
)
1202 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1204 free_ablock
= free_ablock
->x
.next_free
;
1206 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1207 if (type
!= MEM_TYPE_NON_LISP
)
1208 mem_insert (val
, (char *) val
+ nbytes
, type
);
1211 MALLOC_UNBLOCK_INPUT
;
1213 MALLOC_PROBE (nbytes
);
1215 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1220 lisp_align_free (void *block
)
1222 struct ablock
*ablock
= block
;
1223 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1226 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1227 mem_delete (mem_find (block
));
1229 /* Put on free list. */
1230 ablock
->x
.next_free
= free_ablock
;
1231 free_ablock
= ablock
;
1232 /* Update busy count. */
1233 ABLOCKS_BUSY (abase
)
1234 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1236 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1237 { /* All the blocks are free. */
1238 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1239 struct ablock
**tem
= &free_ablock
;
1240 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1244 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1247 *tem
= (*tem
)->x
.next_free
;
1250 tem
= &(*tem
)->x
.next_free
;
1252 eassert ((aligned
& 1) == aligned
);
1253 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1254 #ifdef USE_POSIX_MEMALIGN
1255 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1257 free (ABLOCKS_BASE (abase
));
1259 MALLOC_UNBLOCK_INPUT
;
1263 /***********************************************************************
1265 ***********************************************************************/
1267 /* Number of intervals allocated in an interval_block structure.
1268 The 1020 is 1024 minus malloc overhead. */
1270 #define INTERVAL_BLOCK_SIZE \
1271 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1273 /* Intervals are allocated in chunks in the form of an interval_block
1276 struct interval_block
1278 /* Place `intervals' first, to preserve alignment. */
1279 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1280 struct interval_block
*next
;
1283 /* Current interval block. Its `next' pointer points to older
1286 static struct interval_block
*interval_block
;
1288 /* Index in interval_block above of the next unused interval
1291 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1293 /* Number of free and live intervals. */
1295 static EMACS_INT total_free_intervals
, total_intervals
;
1297 /* List of free intervals. */
1299 static INTERVAL interval_free_list
;
1301 /* Return a new interval. */
1304 make_interval (void)
1310 if (interval_free_list
)
1312 val
= interval_free_list
;
1313 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1317 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1319 struct interval_block
*newi
1320 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1322 newi
->next
= interval_block
;
1323 interval_block
= newi
;
1324 interval_block_index
= 0;
1325 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1327 val
= &interval_block
->intervals
[interval_block_index
++];
1330 MALLOC_UNBLOCK_INPUT
;
1332 consing_since_gc
+= sizeof (struct interval
);
1334 total_free_intervals
--;
1335 RESET_INTERVAL (val
);
1341 /* Mark Lisp objects in interval I. */
1344 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1346 /* Intervals should never be shared. So, if extra internal checking is
1347 enabled, GC aborts if it seems to have visited an interval twice. */
1348 eassert (!i
->gcmarkbit
);
1350 mark_object (i
->plist
);
1353 /* Mark the interval tree rooted in I. */
1355 #define MARK_INTERVAL_TREE(i) \
1357 if (i && !i->gcmarkbit) \
1358 traverse_intervals_noorder (i, mark_interval, Qnil); \
1361 /***********************************************************************
1363 ***********************************************************************/
1365 /* Lisp_Strings are allocated in string_block structures. When a new
1366 string_block is allocated, all the Lisp_Strings it contains are
1367 added to a free-list string_free_list. When a new Lisp_String is
1368 needed, it is taken from that list. During the sweep phase of GC,
1369 string_blocks that are entirely free are freed, except two which
1372 String data is allocated from sblock structures. Strings larger
1373 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1374 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1376 Sblocks consist internally of sdata structures, one for each
1377 Lisp_String. The sdata structure points to the Lisp_String it
1378 belongs to. The Lisp_String points back to the `u.data' member of
1379 its sdata structure.
1381 When a Lisp_String is freed during GC, it is put back on
1382 string_free_list, and its `data' member and its sdata's `string'
1383 pointer is set to null. The size of the string is recorded in the
1384 `n.nbytes' member of the sdata. So, sdata structures that are no
1385 longer used, can be easily recognized, and it's easy to compact the
1386 sblocks of small strings which we do in compact_small_strings. */
1388 /* Size in bytes of an sblock structure used for small strings. This
1389 is 8192 minus malloc overhead. */
1391 #define SBLOCK_SIZE 8188
1393 /* Strings larger than this are considered large strings. String data
1394 for large strings is allocated from individual sblocks. */
1396 #define LARGE_STRING_BYTES 1024
1398 /* The SDATA typedef is a struct or union describing string memory
1399 sub-allocated from an sblock. This is where the contents of Lisp
1400 strings are stored. */
1404 /* Back-pointer to the string this sdata belongs to. If null, this
1405 structure is free, and NBYTES (in this structure or in the union below)
1406 contains the string's byte size (the same value that STRING_BYTES
1407 would return if STRING were non-null). If non-null, STRING_BYTES
1408 (STRING) is the size of the data, and DATA contains the string's
1410 struct Lisp_String
*string
;
1412 #ifdef GC_CHECK_STRING_BYTES
1416 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1419 #ifdef GC_CHECK_STRING_BYTES
1421 typedef struct sdata sdata
;
1422 #define SDATA_NBYTES(S) (S)->nbytes
1423 #define SDATA_DATA(S) (S)->data
1429 struct Lisp_String
*string
;
1431 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1432 which has a flexible array member. However, if implemented by
1433 giving this union a member of type 'struct sdata', the union
1434 could not be the last (flexible) member of 'struct sblock',
1435 because C99 prohibits a flexible array member from having a type
1436 that is itself a flexible array. So, comment this member out here,
1437 but remember that the option's there when using this union. */
1442 /* When STRING is null. */
1445 struct Lisp_String
*string
;
1450 #define SDATA_NBYTES(S) (S)->n.nbytes
1451 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1453 #endif /* not GC_CHECK_STRING_BYTES */
1455 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1457 /* Structure describing a block of memory which is sub-allocated to
1458 obtain string data memory for strings. Blocks for small strings
1459 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1460 as large as needed. */
1465 struct sblock
*next
;
1467 /* Pointer to the next free sdata block. This points past the end
1468 of the sblock if there isn't any space left in this block. */
1472 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1475 /* Number of Lisp strings in a string_block structure. The 1020 is
1476 1024 minus malloc overhead. */
1478 #define STRING_BLOCK_SIZE \
1479 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1481 /* Structure describing a block from which Lisp_String structures
1486 /* Place `strings' first, to preserve alignment. */
1487 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1488 struct string_block
*next
;
1491 /* Head and tail of the list of sblock structures holding Lisp string
1492 data. We always allocate from current_sblock. The NEXT pointers
1493 in the sblock structures go from oldest_sblock to current_sblock. */
1495 static struct sblock
*oldest_sblock
, *current_sblock
;
1497 /* List of sblocks for large strings. */
1499 static struct sblock
*large_sblocks
;
1501 /* List of string_block structures. */
1503 static struct string_block
*string_blocks
;
1505 /* Free-list of Lisp_Strings. */
1507 static struct Lisp_String
*string_free_list
;
1509 /* Number of live and free Lisp_Strings. */
1511 static EMACS_INT total_strings
, total_free_strings
;
1513 /* Number of bytes used by live strings. */
1515 static EMACS_INT total_string_bytes
;
1517 /* Given a pointer to a Lisp_String S which is on the free-list
1518 string_free_list, return a pointer to its successor in the
1521 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1523 /* Return a pointer to the sdata structure belonging to Lisp string S.
1524 S must be live, i.e. S->data must not be null. S->data is actually
1525 a pointer to the `u.data' member of its sdata structure; the
1526 structure starts at a constant offset in front of that. */
1528 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1531 #ifdef GC_CHECK_STRING_OVERRUN
1533 /* We check for overrun in string data blocks by appending a small
1534 "cookie" after each allocated string data block, and check for the
1535 presence of this cookie during GC. */
1537 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1538 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1539 { '\xde', '\xad', '\xbe', '\xef' };
1542 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1545 /* Value is the size of an sdata structure large enough to hold NBYTES
1546 bytes of string data. The value returned includes a terminating
1547 NUL byte, the size of the sdata structure, and padding. */
1549 #ifdef GC_CHECK_STRING_BYTES
1551 #define SDATA_SIZE(NBYTES) \
1552 ((SDATA_DATA_OFFSET \
1554 + sizeof (ptrdiff_t) - 1) \
1555 & ~(sizeof (ptrdiff_t) - 1))
1557 #else /* not GC_CHECK_STRING_BYTES */
1559 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1560 less than the size of that member. The 'max' is not needed when
1561 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1562 alignment code reserves enough space. */
1564 #define SDATA_SIZE(NBYTES) \
1565 ((SDATA_DATA_OFFSET \
1566 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1568 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1570 + sizeof (ptrdiff_t) - 1) \
1571 & ~(sizeof (ptrdiff_t) - 1))
1573 #endif /* not GC_CHECK_STRING_BYTES */
1575 /* Extra bytes to allocate for each string. */
1577 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1579 /* Exact bound on the number of bytes in a string, not counting the
1580 terminating null. A string cannot contain more bytes than
1581 STRING_BYTES_BOUND, nor can it be so long that the size_t
1582 arithmetic in allocate_string_data would overflow while it is
1583 calculating a value to be passed to malloc. */
1584 static ptrdiff_t const STRING_BYTES_MAX
=
1585 min (STRING_BYTES_BOUND
,
1586 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1588 - offsetof (struct sblock
, data
)
1589 - SDATA_DATA_OFFSET
)
1590 & ~(sizeof (EMACS_INT
) - 1)));
1592 /* Initialize string allocation. Called from init_alloc_once. */
1597 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1598 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1602 #ifdef GC_CHECK_STRING_BYTES
1604 static int check_string_bytes_count
;
1606 /* Like STRING_BYTES, but with debugging check. Can be
1607 called during GC, so pay attention to the mark bit. */
1610 string_bytes (struct Lisp_String
*s
)
1613 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1615 if (!PURE_POINTER_P (s
)
1617 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1622 /* Check validity of Lisp strings' string_bytes member in B. */
1625 check_sblock (struct sblock
*b
)
1627 sdata
*from
, *end
, *from_end
;
1631 for (from
= b
->data
; from
< end
; from
= from_end
)
1633 /* Compute the next FROM here because copying below may
1634 overwrite data we need to compute it. */
1637 /* Check that the string size recorded in the string is the
1638 same as the one recorded in the sdata structure. */
1639 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1640 : SDATA_NBYTES (from
));
1641 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1646 /* Check validity of Lisp strings' string_bytes member. ALL_P
1647 means check all strings, otherwise check only most
1648 recently allocated strings. Used for hunting a bug. */
1651 check_string_bytes (bool all_p
)
1657 for (b
= large_sblocks
; b
; b
= b
->next
)
1659 struct Lisp_String
*s
= b
->data
[0].string
;
1664 for (b
= oldest_sblock
; b
; b
= b
->next
)
1667 else if (current_sblock
)
1668 check_sblock (current_sblock
);
1671 #else /* not GC_CHECK_STRING_BYTES */
1673 #define check_string_bytes(all) ((void) 0)
1675 #endif /* GC_CHECK_STRING_BYTES */
1677 #ifdef GC_CHECK_STRING_FREE_LIST
1679 /* Walk through the string free list looking for bogus next pointers.
1680 This may catch buffer overrun from a previous string. */
1683 check_string_free_list (void)
1685 struct Lisp_String
*s
;
1687 /* Pop a Lisp_String off the free-list. */
1688 s
= string_free_list
;
1691 if ((uintptr_t) s
< 1024)
1693 s
= NEXT_FREE_LISP_STRING (s
);
1697 #define check_string_free_list()
1700 /* Return a new Lisp_String. */
1702 static struct Lisp_String
*
1703 allocate_string (void)
1705 struct Lisp_String
*s
;
1709 /* If the free-list is empty, allocate a new string_block, and
1710 add all the Lisp_Strings in it to the free-list. */
1711 if (string_free_list
== NULL
)
1713 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1716 b
->next
= string_blocks
;
1719 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1722 /* Every string on a free list should have NULL data pointer. */
1724 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1725 string_free_list
= s
;
1728 total_free_strings
+= STRING_BLOCK_SIZE
;
1731 check_string_free_list ();
1733 /* Pop a Lisp_String off the free-list. */
1734 s
= string_free_list
;
1735 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1737 MALLOC_UNBLOCK_INPUT
;
1739 --total_free_strings
;
1742 consing_since_gc
+= sizeof *s
;
1744 #ifdef GC_CHECK_STRING_BYTES
1745 if (!noninteractive
)
1747 if (++check_string_bytes_count
== 200)
1749 check_string_bytes_count
= 0;
1750 check_string_bytes (1);
1753 check_string_bytes (0);
1755 #endif /* GC_CHECK_STRING_BYTES */
1761 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1762 plus a NUL byte at the end. Allocate an sdata structure for S, and
1763 set S->data to its `u.data' member. Store a NUL byte at the end of
1764 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1765 S->data if it was initially non-null. */
1768 allocate_string_data (struct Lisp_String
*s
,
1769 EMACS_INT nchars
, EMACS_INT nbytes
)
1771 sdata
*data
, *old_data
;
1773 ptrdiff_t needed
, old_nbytes
;
1775 if (STRING_BYTES_MAX
< nbytes
)
1778 /* Determine the number of bytes needed to store NBYTES bytes
1780 needed
= SDATA_SIZE (nbytes
);
1783 old_data
= SDATA_OF_STRING (s
);
1784 old_nbytes
= STRING_BYTES (s
);
1791 if (nbytes
> LARGE_STRING_BYTES
)
1793 size_t size
= offsetof (struct sblock
, data
) + needed
;
1795 #ifdef DOUG_LEA_MALLOC
1796 if (!mmap_lisp_allowed_p ())
1797 mallopt (M_MMAP_MAX
, 0);
1800 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1802 #ifdef DOUG_LEA_MALLOC
1803 if (!mmap_lisp_allowed_p ())
1804 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1807 b
->next_free
= b
->data
;
1808 b
->data
[0].string
= NULL
;
1809 b
->next
= large_sblocks
;
1812 else if (current_sblock
== NULL
1813 || (((char *) current_sblock
+ SBLOCK_SIZE
1814 - (char *) current_sblock
->next_free
)
1815 < (needed
+ GC_STRING_EXTRA
)))
1817 /* Not enough room in the current sblock. */
1818 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1819 b
->next_free
= b
->data
;
1820 b
->data
[0].string
= NULL
;
1824 current_sblock
->next
= b
;
1832 data
= b
->next_free
;
1833 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1835 MALLOC_UNBLOCK_INPUT
;
1838 s
->data
= SDATA_DATA (data
);
1839 #ifdef GC_CHECK_STRING_BYTES
1840 SDATA_NBYTES (data
) = nbytes
;
1843 s
->size_byte
= nbytes
;
1844 s
->data
[nbytes
] = '\0';
1845 #ifdef GC_CHECK_STRING_OVERRUN
1846 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1847 GC_STRING_OVERRUN_COOKIE_SIZE
);
1850 /* Note that Faset may call to this function when S has already data
1851 assigned. In this case, mark data as free by setting it's string
1852 back-pointer to null, and record the size of the data in it. */
1855 SDATA_NBYTES (old_data
) = old_nbytes
;
1856 old_data
->string
= NULL
;
1859 consing_since_gc
+= needed
;
1863 /* Sweep and compact strings. */
1865 NO_INLINE
/* For better stack traces */
1867 sweep_strings (void)
1869 struct string_block
*b
, *next
;
1870 struct string_block
*live_blocks
= NULL
;
1872 string_free_list
= NULL
;
1873 total_strings
= total_free_strings
= 0;
1874 total_string_bytes
= 0;
1876 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1877 for (b
= string_blocks
; b
; b
= next
)
1880 struct Lisp_String
*free_list_before
= string_free_list
;
1884 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1886 struct Lisp_String
*s
= b
->strings
+ i
;
1890 /* String was not on free-list before. */
1891 if (STRING_MARKED_P (s
))
1893 /* String is live; unmark it and its intervals. */
1896 /* Do not use string_(set|get)_intervals here. */
1897 s
->intervals
= balance_intervals (s
->intervals
);
1900 total_string_bytes
+= STRING_BYTES (s
);
1904 /* String is dead. Put it on the free-list. */
1905 sdata
*data
= SDATA_OF_STRING (s
);
1907 /* Save the size of S in its sdata so that we know
1908 how large that is. Reset the sdata's string
1909 back-pointer so that we know it's free. */
1910 #ifdef GC_CHECK_STRING_BYTES
1911 if (string_bytes (s
) != SDATA_NBYTES (data
))
1914 data
->n
.nbytes
= STRING_BYTES (s
);
1916 data
->string
= NULL
;
1918 /* Reset the strings's `data' member so that we
1922 /* Put the string on the free-list. */
1923 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1924 string_free_list
= s
;
1930 /* S was on the free-list before. Put it there again. */
1931 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1932 string_free_list
= s
;
1937 /* Free blocks that contain free Lisp_Strings only, except
1938 the first two of them. */
1939 if (nfree
== STRING_BLOCK_SIZE
1940 && total_free_strings
> STRING_BLOCK_SIZE
)
1943 string_free_list
= free_list_before
;
1947 total_free_strings
+= nfree
;
1948 b
->next
= live_blocks
;
1953 check_string_free_list ();
1955 string_blocks
= live_blocks
;
1956 free_large_strings ();
1957 compact_small_strings ();
1959 check_string_free_list ();
1963 /* Free dead large strings. */
1966 free_large_strings (void)
1968 struct sblock
*b
, *next
;
1969 struct sblock
*live_blocks
= NULL
;
1971 for (b
= large_sblocks
; b
; b
= next
)
1975 if (b
->data
[0].string
== NULL
)
1979 b
->next
= live_blocks
;
1984 large_sblocks
= live_blocks
;
1988 /* Compact data of small strings. Free sblocks that don't contain
1989 data of live strings after compaction. */
1992 compact_small_strings (void)
1994 struct sblock
*b
, *tb
, *next
;
1995 sdata
*from
, *to
, *end
, *tb_end
;
1996 sdata
*to_end
, *from_end
;
1998 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1999 to, and TB_END is the end of TB. */
2001 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2004 /* Step through the blocks from the oldest to the youngest. We
2005 expect that old blocks will stabilize over time, so that less
2006 copying will happen this way. */
2007 for (b
= oldest_sblock
; b
; b
= b
->next
)
2010 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2012 for (from
= b
->data
; from
< end
; from
= from_end
)
2014 /* Compute the next FROM here because copying below may
2015 overwrite data we need to compute it. */
2017 struct Lisp_String
*s
= from
->string
;
2019 #ifdef GC_CHECK_STRING_BYTES
2020 /* Check that the string size recorded in the string is the
2021 same as the one recorded in the sdata structure. */
2022 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2024 #endif /* GC_CHECK_STRING_BYTES */
2026 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2027 eassert (nbytes
<= LARGE_STRING_BYTES
);
2029 nbytes
= SDATA_SIZE (nbytes
);
2030 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2032 #ifdef GC_CHECK_STRING_OVERRUN
2033 if (memcmp (string_overrun_cookie
,
2034 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2035 GC_STRING_OVERRUN_COOKIE_SIZE
))
2039 /* Non-NULL S means it's alive. Copy its data. */
2042 /* If TB is full, proceed with the next sblock. */
2043 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2044 if (to_end
> tb_end
)
2048 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2050 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2053 /* Copy, and update the string's `data' pointer. */
2056 eassert (tb
!= b
|| to
< from
);
2057 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2058 to
->string
->data
= SDATA_DATA (to
);
2061 /* Advance past the sdata we copied to. */
2067 /* The rest of the sblocks following TB don't contain live data, so
2068 we can free them. */
2069 for (b
= tb
->next
; b
; b
= next
)
2077 current_sblock
= tb
;
2081 string_overflow (void)
2083 error ("Maximum string size exceeded");
2086 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2087 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2088 LENGTH must be an integer.
2089 INIT must be an integer that represents a character. */)
2090 (Lisp_Object length
, Lisp_Object init
)
2092 register Lisp_Object val
;
2096 CHECK_NATNUM (length
);
2097 CHECK_CHARACTER (init
);
2099 c
= XFASTINT (init
);
2100 if (ASCII_CHAR_P (c
))
2102 nbytes
= XINT (length
);
2103 val
= make_uninit_string (nbytes
);
2104 memset (SDATA (val
), c
, nbytes
);
2105 SDATA (val
)[nbytes
] = 0;
2109 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2110 ptrdiff_t len
= CHAR_STRING (c
, str
);
2111 EMACS_INT string_len
= XINT (length
);
2112 unsigned char *p
, *beg
, *end
;
2114 if (string_len
> STRING_BYTES_MAX
/ len
)
2116 nbytes
= len
* string_len
;
2117 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2118 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2120 /* First time we just copy `str' to the data of `val'. */
2122 memcpy (p
, str
, len
);
2125 /* Next time we copy largest possible chunk from
2126 initialized to uninitialized part of `val'. */
2127 len
= min (p
- beg
, end
- p
);
2128 memcpy (p
, beg
, len
);
2137 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2141 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2143 EMACS_INT nbits
= bool_vector_size (a
);
2146 unsigned char *data
= bool_vector_uchar_data (a
);
2147 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2148 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2149 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2150 memset (data
, pattern
, nbytes
- 1);
2151 data
[nbytes
- 1] = pattern
& last_mask
;
2156 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2159 make_uninit_bool_vector (EMACS_INT nbits
)
2162 EMACS_INT words
= bool_vector_words (nbits
);
2163 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2164 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2167 struct Lisp_Bool_Vector
*p
2168 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2169 XSETVECTOR (val
, p
);
2170 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2173 /* Clear padding at the end. */
2175 p
->data
[words
- 1] = 0;
2180 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2181 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2182 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2183 (Lisp_Object length
, Lisp_Object init
)
2187 CHECK_NATNUM (length
);
2188 val
= make_uninit_bool_vector (XFASTINT (length
));
2189 return bool_vector_fill (val
, init
);
2192 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2193 doc
: /* Return a new bool-vector with specified arguments as elements.
2194 Any number of arguments, even zero arguments, are allowed.
2195 usage: (bool-vector &rest OBJECTS) */)
2196 (ptrdiff_t nargs
, Lisp_Object
*args
)
2201 vector
= make_uninit_bool_vector (nargs
);
2202 for (i
= 0; i
< nargs
; i
++)
2203 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2208 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2209 of characters from the contents. This string may be unibyte or
2210 multibyte, depending on the contents. */
2213 make_string (const char *contents
, ptrdiff_t nbytes
)
2215 register Lisp_Object val
;
2216 ptrdiff_t nchars
, multibyte_nbytes
;
2218 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2219 &nchars
, &multibyte_nbytes
);
2220 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2221 /* CONTENTS contains no multibyte sequences or contains an invalid
2222 multibyte sequence. We must make unibyte string. */
2223 val
= make_unibyte_string (contents
, nbytes
);
2225 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2230 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2233 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2235 register Lisp_Object val
;
2236 val
= make_uninit_string (length
);
2237 memcpy (SDATA (val
), contents
, length
);
2242 /* Make a multibyte string from NCHARS characters occupying NBYTES
2243 bytes at CONTENTS. */
2246 make_multibyte_string (const char *contents
,
2247 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2249 register Lisp_Object val
;
2250 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2251 memcpy (SDATA (val
), contents
, nbytes
);
2256 /* Make a string from NCHARS characters occupying NBYTES bytes at
2257 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2260 make_string_from_bytes (const char *contents
,
2261 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2263 register Lisp_Object val
;
2264 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2265 memcpy (SDATA (val
), contents
, nbytes
);
2266 if (SBYTES (val
) == SCHARS (val
))
2267 STRING_SET_UNIBYTE (val
);
2272 /* Make a string from NCHARS characters occupying NBYTES bytes at
2273 CONTENTS. The argument MULTIBYTE controls whether to label the
2274 string as multibyte. If NCHARS is negative, it counts the number of
2275 characters by itself. */
2278 make_specified_string (const char *contents
,
2279 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2286 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2291 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2292 memcpy (SDATA (val
), contents
, nbytes
);
2294 STRING_SET_UNIBYTE (val
);
2299 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2300 occupying LENGTH bytes. */
2303 make_uninit_string (EMACS_INT length
)
2308 return empty_unibyte_string
;
2309 val
= make_uninit_multibyte_string (length
, length
);
2310 STRING_SET_UNIBYTE (val
);
2315 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2316 which occupy NBYTES bytes. */
2319 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2322 struct Lisp_String
*s
;
2327 return empty_multibyte_string
;
2329 s
= allocate_string ();
2330 s
->intervals
= NULL
;
2331 allocate_string_data (s
, nchars
, nbytes
);
2332 XSETSTRING (string
, s
);
2333 string_chars_consed
+= nbytes
;
2337 /* Print arguments to BUF according to a FORMAT, then return
2338 a Lisp_String initialized with the data from BUF. */
2341 make_formatted_string (char *buf
, const char *format
, ...)
2346 va_start (ap
, format
);
2347 length
= vsprintf (buf
, format
, ap
);
2349 return make_string (buf
, length
);
2353 /***********************************************************************
2355 ***********************************************************************/
2357 /* We store float cells inside of float_blocks, allocating a new
2358 float_block with malloc whenever necessary. Float cells reclaimed
2359 by GC are put on a free list to be reallocated before allocating
2360 any new float cells from the latest float_block. */
2362 #define FLOAT_BLOCK_SIZE \
2363 (((BLOCK_BYTES - sizeof (struct float_block *) \
2364 /* The compiler might add padding at the end. */ \
2365 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2366 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2368 #define GETMARKBIT(block,n) \
2369 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2370 >> ((n) % BITS_PER_BITS_WORD)) \
2373 #define SETMARKBIT(block,n) \
2374 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2375 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2377 #define UNSETMARKBIT(block,n) \
2378 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2379 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2381 #define FLOAT_BLOCK(fptr) \
2382 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2384 #define FLOAT_INDEX(fptr) \
2385 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2389 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2390 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2391 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2392 struct float_block
*next
;
2395 #define FLOAT_MARKED_P(fptr) \
2396 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2398 #define FLOAT_MARK(fptr) \
2399 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2401 #define FLOAT_UNMARK(fptr) \
2402 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2404 /* Current float_block. */
2406 static struct float_block
*float_block
;
2408 /* Index of first unused Lisp_Float in the current float_block. */
2410 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2412 /* Free-list of Lisp_Floats. */
2414 static struct Lisp_Float
*float_free_list
;
2416 /* Return a new float object with value FLOAT_VALUE. */
2419 make_float (double float_value
)
2421 register Lisp_Object val
;
2425 if (float_free_list
)
2427 /* We use the data field for chaining the free list
2428 so that we won't use the same field that has the mark bit. */
2429 XSETFLOAT (val
, float_free_list
);
2430 float_free_list
= float_free_list
->u
.chain
;
2434 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2436 struct float_block
*new
2437 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2438 new->next
= float_block
;
2439 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2441 float_block_index
= 0;
2442 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2444 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2445 float_block_index
++;
2448 MALLOC_UNBLOCK_INPUT
;
2450 XFLOAT_INIT (val
, float_value
);
2451 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2452 consing_since_gc
+= sizeof (struct Lisp_Float
);
2454 total_free_floats
--;
2460 /***********************************************************************
2462 ***********************************************************************/
2464 /* We store cons cells inside of cons_blocks, allocating a new
2465 cons_block with malloc whenever necessary. Cons cells reclaimed by
2466 GC are put on a free list to be reallocated before allocating
2467 any new cons cells from the latest cons_block. */
2469 #define CONS_BLOCK_SIZE \
2470 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2471 /* The compiler might add padding at the end. */ \
2472 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2473 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2475 #define CONS_BLOCK(fptr) \
2476 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2478 #define CONS_INDEX(fptr) \
2479 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2483 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2484 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2485 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2486 struct cons_block
*next
;
2489 #define CONS_MARKED_P(fptr) \
2490 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2492 #define CONS_MARK(fptr) \
2493 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2495 #define CONS_UNMARK(fptr) \
2496 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2498 /* Current cons_block. */
2500 static struct cons_block
*cons_block
;
2502 /* Index of first unused Lisp_Cons in the current block. */
2504 static int cons_block_index
= CONS_BLOCK_SIZE
;
2506 /* Free-list of Lisp_Cons structures. */
2508 static struct Lisp_Cons
*cons_free_list
;
2510 /* Explicitly free a cons cell by putting it on the free-list. */
2513 free_cons (struct Lisp_Cons
*ptr
)
2515 ptr
->u
.chain
= cons_free_list
;
2519 cons_free_list
= ptr
;
2520 consing_since_gc
-= sizeof *ptr
;
2521 total_free_conses
++;
2524 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2525 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2526 (Lisp_Object car
, Lisp_Object cdr
)
2528 register Lisp_Object val
;
2534 /* We use the cdr for chaining the free list
2535 so that we won't use the same field that has the mark bit. */
2536 XSETCONS (val
, cons_free_list
);
2537 cons_free_list
= cons_free_list
->u
.chain
;
2541 if (cons_block_index
== CONS_BLOCK_SIZE
)
2543 struct cons_block
*new
2544 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2545 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2546 new->next
= cons_block
;
2548 cons_block_index
= 0;
2549 total_free_conses
+= CONS_BLOCK_SIZE
;
2551 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2555 MALLOC_UNBLOCK_INPUT
;
2559 eassert (!CONS_MARKED_P (XCONS (val
)));
2560 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2561 total_free_conses
--;
2562 cons_cells_consed
++;
2566 #ifdef GC_CHECK_CONS_LIST
2567 /* Get an error now if there's any junk in the cons free list. */
2569 check_cons_list (void)
2571 struct Lisp_Cons
*tail
= cons_free_list
;
2574 tail
= tail
->u
.chain
;
2578 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2581 list1 (Lisp_Object arg1
)
2583 return Fcons (arg1
, Qnil
);
2587 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2589 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2594 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2596 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2601 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2603 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2608 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2610 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2611 Fcons (arg5
, Qnil
)))));
2614 /* Make a list of COUNT Lisp_Objects, where ARG is the
2615 first one. Allocate conses from pure space if TYPE
2616 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2619 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2621 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2624 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2625 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2626 default: emacs_abort ();
2629 eassume (0 < count
);
2630 Lisp_Object val
= cons (arg
, Qnil
);
2631 Lisp_Object tail
= val
;
2635 for (ptrdiff_t i
= 1; i
< count
; i
++)
2637 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2638 XSETCDR (tail
, elem
);
2646 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2647 doc
: /* Return a newly created list with specified arguments as elements.
2648 Any number of arguments, even zero arguments, are allowed.
2649 usage: (list &rest OBJECTS) */)
2650 (ptrdiff_t nargs
, Lisp_Object
*args
)
2652 register Lisp_Object val
;
2658 val
= Fcons (args
[nargs
], val
);
2664 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2665 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2666 (register Lisp_Object length
, Lisp_Object init
)
2668 register Lisp_Object val
;
2669 register EMACS_INT size
;
2671 CHECK_NATNUM (length
);
2672 size
= XFASTINT (length
);
2677 val
= Fcons (init
, val
);
2682 val
= Fcons (init
, val
);
2687 val
= Fcons (init
, val
);
2692 val
= Fcons (init
, val
);
2697 val
= Fcons (init
, val
);
2712 /***********************************************************************
2714 ***********************************************************************/
2716 /* Sometimes a vector's contents are merely a pointer internally used
2717 in vector allocation code. On the rare platforms where a null
2718 pointer cannot be tagged, represent it with a Lisp 0.
2719 Usually you don't want to touch this. */
2721 static struct Lisp_Vector
*
2722 next_vector (struct Lisp_Vector
*v
)
2724 return XUNTAG (v
->contents
[0], 0);
2728 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2730 v
->contents
[0] = make_lisp_ptr (p
, 0);
2733 /* This value is balanced well enough to avoid too much internal overhead
2734 for the most common cases; it's not required to be a power of two, but
2735 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2737 #define VECTOR_BLOCK_SIZE 4096
2741 /* Alignment of struct Lisp_Vector objects. */
2742 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2743 USE_LSB_TAG
? GCALIGNMENT
: 1),
2745 /* Vector size requests are a multiple of this. */
2746 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2749 /* Verify assumptions described above. */
2750 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2751 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2753 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2754 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2755 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2756 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2758 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2760 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2762 /* Size of the minimal vector allocated from block. */
2764 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2766 /* Size of the largest vector allocated from block. */
2768 #define VBLOCK_BYTES_MAX \
2769 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2771 /* We maintain one free list for each possible block-allocated
2772 vector size, and this is the number of free lists we have. */
2774 #define VECTOR_MAX_FREE_LIST_INDEX \
2775 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2777 /* Common shortcut to advance vector pointer over a block data. */
2779 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2781 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2783 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2785 /* Common shortcut to setup vector on a free list. */
2787 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2789 (tmp) = ((nbytes - header_size) / word_size); \
2790 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2791 eassert ((nbytes) % roundup_size == 0); \
2792 (tmp) = VINDEX (nbytes); \
2793 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2794 set_next_vector (v, vector_free_lists[tmp]); \
2795 vector_free_lists[tmp] = (v); \
2796 total_free_vector_slots += (nbytes) / word_size; \
2799 /* This internal type is used to maintain the list of large vectors
2800 which are allocated at their own, e.g. outside of vector blocks.
2802 struct large_vector itself cannot contain a struct Lisp_Vector, as
2803 the latter contains a flexible array member and C99 does not allow
2804 such structs to be nested. Instead, each struct large_vector
2805 object LV is followed by a struct Lisp_Vector, which is at offset
2806 large_vector_offset from LV, and whose address is therefore
2807 large_vector_vec (&LV). */
2811 struct large_vector
*next
;
2816 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2819 static struct Lisp_Vector
*
2820 large_vector_vec (struct large_vector
*p
)
2822 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
2825 /* This internal type is used to maintain an underlying storage
2826 for small vectors. */
2830 char data
[VECTOR_BLOCK_BYTES
];
2831 struct vector_block
*next
;
2834 /* Chain of vector blocks. */
2836 static struct vector_block
*vector_blocks
;
2838 /* Vector free lists, where NTH item points to a chain of free
2839 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2841 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2843 /* Singly-linked list of large vectors. */
2845 static struct large_vector
*large_vectors
;
2847 /* The only vector with 0 slots, allocated from pure space. */
2849 Lisp_Object zero_vector
;
2851 /* Number of live vectors. */
2853 static EMACS_INT total_vectors
;
2855 /* Total size of live and free vectors, in Lisp_Object units. */
2857 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2859 /* Get a new vector block. */
2861 static struct vector_block
*
2862 allocate_vector_block (void)
2864 struct vector_block
*block
= xmalloc (sizeof *block
);
2866 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2867 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2868 MEM_TYPE_VECTOR_BLOCK
);
2871 block
->next
= vector_blocks
;
2872 vector_blocks
= block
;
2876 /* Called once to initialize vector allocation. */
2881 zero_vector
= make_pure_vector (0);
2884 /* Allocate vector from a vector block. */
2886 static struct Lisp_Vector
*
2887 allocate_vector_from_block (size_t nbytes
)
2889 struct Lisp_Vector
*vector
;
2890 struct vector_block
*block
;
2891 size_t index
, restbytes
;
2893 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2894 eassert (nbytes
% roundup_size
== 0);
2896 /* First, try to allocate from a free list
2897 containing vectors of the requested size. */
2898 index
= VINDEX (nbytes
);
2899 if (vector_free_lists
[index
])
2901 vector
= vector_free_lists
[index
];
2902 vector_free_lists
[index
] = next_vector (vector
);
2903 total_free_vector_slots
-= nbytes
/ word_size
;
2907 /* Next, check free lists containing larger vectors. Since
2908 we will split the result, we should have remaining space
2909 large enough to use for one-slot vector at least. */
2910 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2911 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2912 if (vector_free_lists
[index
])
2914 /* This vector is larger than requested. */
2915 vector
= vector_free_lists
[index
];
2916 vector_free_lists
[index
] = next_vector (vector
);
2917 total_free_vector_slots
-= nbytes
/ word_size
;
2919 /* Excess bytes are used for the smaller vector,
2920 which should be set on an appropriate free list. */
2921 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2922 eassert (restbytes
% roundup_size
== 0);
2923 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2927 /* Finally, need a new vector block. */
2928 block
= allocate_vector_block ();
2930 /* New vector will be at the beginning of this block. */
2931 vector
= (struct Lisp_Vector
*) block
->data
;
2933 /* If the rest of space from this block is large enough
2934 for one-slot vector at least, set up it on a free list. */
2935 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2936 if (restbytes
>= VBLOCK_BYTES_MIN
)
2938 eassert (restbytes
% roundup_size
== 0);
2939 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2944 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2946 #define VECTOR_IN_BLOCK(vector, block) \
2947 ((char *) (vector) <= (block)->data \
2948 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2950 /* Return the memory footprint of V in bytes. */
2953 vector_nbytes (struct Lisp_Vector
*v
)
2955 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2958 if (size
& PSEUDOVECTOR_FLAG
)
2960 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2962 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
2963 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
2964 * sizeof (bits_word
));
2965 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
2966 verify (header_size
<= bool_header_size
);
2967 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
2970 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
2971 + ((size
& PSEUDOVECTOR_REST_MASK
)
2972 >> PSEUDOVECTOR_SIZE_BITS
));
2976 return vroundup (header_size
+ word_size
* nwords
);
2979 /* Release extra resources still in use by VECTOR, which may be any
2980 vector-like object. For now, this is used just to free data in
2984 cleanup_vector (struct Lisp_Vector
*vector
)
2986 detect_suspicious_free (vector
);
2987 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
2988 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
2989 == FONT_OBJECT_MAX
))
2991 struct font_driver
*drv
= ((struct font
*) vector
)->driver
;
2993 /* The font driver might sometimes be NULL, e.g. if Emacs was
2994 interrupted before it had time to set it up. */
2997 /* Attempt to catch subtle bugs like Bug#16140. */
2998 eassert (valid_font_driver (drv
));
2999 drv
->close ((struct font
*) vector
);
3004 /* Reclaim space used by unmarked vectors. */
3006 NO_INLINE
/* For better stack traces */
3008 sweep_vectors (void)
3010 struct vector_block
*block
, **bprev
= &vector_blocks
;
3011 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3012 struct Lisp_Vector
*vector
, *next
;
3014 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3015 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3017 /* Looking through vector blocks. */
3019 for (block
= vector_blocks
; block
; block
= *bprev
)
3021 bool free_this_block
= 0;
3024 for (vector
= (struct Lisp_Vector
*) block
->data
;
3025 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3027 if (VECTOR_MARKED_P (vector
))
3029 VECTOR_UNMARK (vector
);
3031 nbytes
= vector_nbytes (vector
);
3032 total_vector_slots
+= nbytes
/ word_size
;
3033 next
= ADVANCE (vector
, nbytes
);
3037 ptrdiff_t total_bytes
;
3039 cleanup_vector (vector
);
3040 nbytes
= vector_nbytes (vector
);
3041 total_bytes
= nbytes
;
3042 next
= ADVANCE (vector
, nbytes
);
3044 /* While NEXT is not marked, try to coalesce with VECTOR,
3045 thus making VECTOR of the largest possible size. */
3047 while (VECTOR_IN_BLOCK (next
, block
))
3049 if (VECTOR_MARKED_P (next
))
3051 cleanup_vector (next
);
3052 nbytes
= vector_nbytes (next
);
3053 total_bytes
+= nbytes
;
3054 next
= ADVANCE (next
, nbytes
);
3057 eassert (total_bytes
% roundup_size
== 0);
3059 if (vector
== (struct Lisp_Vector
*) block
->data
3060 && !VECTOR_IN_BLOCK (next
, block
))
3061 /* This block should be freed because all of its
3062 space was coalesced into the only free vector. */
3063 free_this_block
= 1;
3067 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3072 if (free_this_block
)
3074 *bprev
= block
->next
;
3075 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
3076 mem_delete (mem_find (block
->data
));
3081 bprev
= &block
->next
;
3084 /* Sweep large vectors. */
3086 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3088 vector
= large_vector_vec (lv
);
3089 if (VECTOR_MARKED_P (vector
))
3091 VECTOR_UNMARK (vector
);
3093 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3095 /* All non-bool pseudovectors are small enough to be allocated
3096 from vector blocks. This code should be redesigned if some
3097 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3098 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3099 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3103 += header_size
/ word_size
+ vector
->header
.size
;
3114 /* Value is a pointer to a newly allocated Lisp_Vector structure
3115 with room for LEN Lisp_Objects. */
3117 static struct Lisp_Vector
*
3118 allocate_vectorlike (ptrdiff_t len
)
3120 struct Lisp_Vector
*p
;
3125 p
= XVECTOR (zero_vector
);
3128 size_t nbytes
= header_size
+ len
* word_size
;
3130 #ifdef DOUG_LEA_MALLOC
3131 if (!mmap_lisp_allowed_p ())
3132 mallopt (M_MMAP_MAX
, 0);
3135 if (nbytes
<= VBLOCK_BYTES_MAX
)
3136 p
= allocate_vector_from_block (vroundup (nbytes
));
3139 struct large_vector
*lv
3140 = lisp_malloc ((large_vector_offset
+ header_size
3142 MEM_TYPE_VECTORLIKE
);
3143 lv
->next
= large_vectors
;
3145 p
= large_vector_vec (lv
);
3148 #ifdef DOUG_LEA_MALLOC
3149 if (!mmap_lisp_allowed_p ())
3150 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3153 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3156 consing_since_gc
+= nbytes
;
3157 vector_cells_consed
+= len
;
3160 MALLOC_UNBLOCK_INPUT
;
3166 /* Allocate a vector with LEN slots. */
3168 struct Lisp_Vector
*
3169 allocate_vector (EMACS_INT len
)
3171 struct Lisp_Vector
*v
;
3172 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3174 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3175 memory_full (SIZE_MAX
);
3176 v
= allocate_vectorlike (len
);
3177 v
->header
.size
= len
;
3182 /* Allocate other vector-like structures. */
3184 struct Lisp_Vector
*
3185 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3187 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3190 /* Catch bogus values. */
3191 eassert (tag
<= PVEC_FONT
);
3192 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3193 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3195 /* Only the first lisplen slots will be traced normally by the GC. */
3196 for (i
= 0; i
< lisplen
; ++i
)
3197 v
->contents
[i
] = Qnil
;
3199 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3204 allocate_buffer (void)
3206 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3208 BUFFER_PVEC_INIT (b
);
3209 /* Put B on the chain of all buffers including killed ones. */
3210 b
->next
= all_buffers
;
3212 /* Note that the rest fields of B are not initialized. */
3216 struct Lisp_Hash_Table
*
3217 allocate_hash_table (void)
3219 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3223 allocate_window (void)
3227 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3228 /* Users assumes that non-Lisp data is zeroed. */
3229 memset (&w
->current_matrix
, 0,
3230 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3235 allocate_terminal (void)
3239 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3240 /* Users assumes that non-Lisp data is zeroed. */
3241 memset (&t
->next_terminal
, 0,
3242 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3247 allocate_frame (void)
3251 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3252 /* Users assumes that non-Lisp data is zeroed. */
3253 memset (&f
->face_cache
, 0,
3254 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3258 struct Lisp_Process
*
3259 allocate_process (void)
3261 struct Lisp_Process
*p
;
3263 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3264 /* Users assumes that non-Lisp data is zeroed. */
3266 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3270 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3271 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3272 See also the function `vector'. */)
3273 (register Lisp_Object length
, Lisp_Object init
)
3276 register ptrdiff_t sizei
;
3277 register ptrdiff_t i
;
3278 register struct Lisp_Vector
*p
;
3280 CHECK_NATNUM (length
);
3282 p
= allocate_vector (XFASTINT (length
));
3283 sizei
= XFASTINT (length
);
3284 for (i
= 0; i
< sizei
; i
++)
3285 p
->contents
[i
] = init
;
3287 XSETVECTOR (vector
, p
);
3292 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3293 doc
: /* Return a newly created vector with specified arguments as elements.
3294 Any number of arguments, even zero arguments, are allowed.
3295 usage: (vector &rest OBJECTS) */)
3296 (ptrdiff_t nargs
, Lisp_Object
*args
)
3299 register Lisp_Object val
= make_uninit_vector (nargs
);
3300 register struct Lisp_Vector
*p
= XVECTOR (val
);
3302 for (i
= 0; i
< nargs
; i
++)
3303 p
->contents
[i
] = args
[i
];
3308 make_byte_code (struct Lisp_Vector
*v
)
3310 /* Don't allow the global zero_vector to become a byte code object. */
3311 eassert (0 < v
->header
.size
);
3313 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3314 && STRING_MULTIBYTE (v
->contents
[1]))
3315 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3316 earlier because they produced a raw 8-bit string for byte-code
3317 and now such a byte-code string is loaded as multibyte while
3318 raw 8-bit characters converted to multibyte form. Thus, now we
3319 must convert them back to the original unibyte form. */
3320 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3321 XSETPVECTYPE (v
, PVEC_COMPILED
);
3324 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3325 doc
: /* Create a byte-code object with specified arguments as elements.
3326 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3327 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3328 and (optional) INTERACTIVE-SPEC.
3329 The first four arguments are required; at most six have any
3331 The ARGLIST can be either like the one of `lambda', in which case the arguments
3332 will be dynamically bound before executing the byte code, or it can be an
3333 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3334 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3335 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3336 argument to catch the left-over arguments. If such an integer is used, the
3337 arguments will not be dynamically bound but will be instead pushed on the
3338 stack before executing the byte-code.
3339 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3340 (ptrdiff_t nargs
, Lisp_Object
*args
)
3343 register Lisp_Object val
= make_uninit_vector (nargs
);
3344 register struct Lisp_Vector
*p
= XVECTOR (val
);
3346 /* We used to purecopy everything here, if purify-flag was set. This worked
3347 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3348 dangerous, since make-byte-code is used during execution to build
3349 closures, so any closure built during the preload phase would end up
3350 copied into pure space, including its free variables, which is sometimes
3351 just wasteful and other times plainly wrong (e.g. those free vars may want
3354 for (i
= 0; i
< nargs
; i
++)
3355 p
->contents
[i
] = args
[i
];
3357 XSETCOMPILED (val
, p
);
3363 /***********************************************************************
3365 ***********************************************************************/
3367 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3368 of the required alignment if LSB tags are used. */
3370 union aligned_Lisp_Symbol
3372 struct Lisp_Symbol s
;
3374 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3379 /* Each symbol_block is just under 1020 bytes long, since malloc
3380 really allocates in units of powers of two and uses 4 bytes for its
3383 #define SYMBOL_BLOCK_SIZE \
3384 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3388 /* Place `symbols' first, to preserve alignment. */
3389 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3390 struct symbol_block
*next
;
3393 /* Current symbol block and index of first unused Lisp_Symbol
3396 static struct symbol_block
*symbol_block
;
3397 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3398 /* Pointer to the first symbol_block that contains pinned symbols.
3399 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3400 10K of which are pinned (and all but 250 of them are interned in obarray),
3401 whereas a "typical session" has in the order of 30K symbols.
3402 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3403 than 30K to find the 10K symbols we need to mark. */
3404 static struct symbol_block
*symbol_block_pinned
;
3406 /* List of free symbols. */
3408 static struct Lisp_Symbol
*symbol_free_list
;
3411 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3413 XSYMBOL (sym
)->name
= name
;
3416 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3417 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3418 Its value is void, and its function definition and property list are nil. */)
3421 register Lisp_Object val
;
3422 register struct Lisp_Symbol
*p
;
3424 CHECK_STRING (name
);
3428 if (symbol_free_list
)
3430 XSETSYMBOL (val
, symbol_free_list
);
3431 symbol_free_list
= symbol_free_list
->next
;
3435 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3437 struct symbol_block
*new
3438 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3439 new->next
= symbol_block
;
3441 symbol_block_index
= 0;
3442 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3444 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3445 symbol_block_index
++;
3448 MALLOC_UNBLOCK_INPUT
;
3451 set_symbol_name (val
, name
);
3452 set_symbol_plist (val
, Qnil
);
3453 p
->redirect
= SYMBOL_PLAINVAL
;
3454 SET_SYMBOL_VAL (p
, Qunbound
);
3455 set_symbol_function (val
, Qnil
);
3456 set_symbol_next (val
, NULL
);
3457 p
->gcmarkbit
= false;
3458 p
->interned
= SYMBOL_UNINTERNED
;
3460 p
->declared_special
= false;
3462 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3464 total_free_symbols
--;
3470 /***********************************************************************
3471 Marker (Misc) Allocation
3472 ***********************************************************************/
3474 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3475 the required alignment when LSB tags are used. */
3477 union aligned_Lisp_Misc
3481 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3486 /* Allocation of markers and other objects that share that structure.
3487 Works like allocation of conses. */
3489 #define MARKER_BLOCK_SIZE \
3490 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3494 /* Place `markers' first, to preserve alignment. */
3495 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3496 struct marker_block
*next
;
3499 static struct marker_block
*marker_block
;
3500 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3502 static union Lisp_Misc
*marker_free_list
;
3504 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3507 allocate_misc (enum Lisp_Misc_Type type
)
3513 if (marker_free_list
)
3515 XSETMISC (val
, marker_free_list
);
3516 marker_free_list
= marker_free_list
->u_free
.chain
;
3520 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3522 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3523 new->next
= marker_block
;
3525 marker_block_index
= 0;
3526 total_free_markers
+= MARKER_BLOCK_SIZE
;
3528 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3529 marker_block_index
++;
3532 MALLOC_UNBLOCK_INPUT
;
3534 --total_free_markers
;
3535 consing_since_gc
+= sizeof (union Lisp_Misc
);
3536 misc_objects_consed
++;
3537 XMISCANY (val
)->type
= type
;
3538 XMISCANY (val
)->gcmarkbit
= 0;
3542 /* Free a Lisp_Misc object. */
3545 free_misc (Lisp_Object misc
)
3547 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3548 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3549 marker_free_list
= XMISC (misc
);
3550 consing_since_gc
-= sizeof (union Lisp_Misc
);
3551 total_free_markers
++;
3554 /* Verify properties of Lisp_Save_Value's representation
3555 that are assumed here and elsewhere. */
3557 verify (SAVE_UNUSED
== 0);
3558 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3562 /* Return Lisp_Save_Value objects for the various combinations
3563 that callers need. */
3566 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3568 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3569 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3570 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3571 p
->data
[0].integer
= a
;
3572 p
->data
[1].integer
= b
;
3573 p
->data
[2].integer
= c
;
3578 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3581 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3582 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3583 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3584 p
->data
[0].object
= a
;
3585 p
->data
[1].object
= b
;
3586 p
->data
[2].object
= c
;
3587 p
->data
[3].object
= d
;
3592 make_save_ptr (void *a
)
3594 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3595 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3596 p
->save_type
= SAVE_POINTER
;
3597 p
->data
[0].pointer
= a
;
3602 make_save_ptr_int (void *a
, ptrdiff_t b
)
3604 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3605 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3606 p
->save_type
= SAVE_TYPE_PTR_INT
;
3607 p
->data
[0].pointer
= a
;
3608 p
->data
[1].integer
= b
;
3613 make_save_int_obj (ptrdiff_t a
, Lisp_Object b
)
3615 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3616 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3617 p
->save_type
= SAVE_TYPE_INT_OBJ
;
3618 p
->data
[0].integer
= a
;
3619 p
->data
[1].object
= b
;
3623 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3625 make_save_ptr_ptr (void *a
, void *b
)
3627 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3628 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3629 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3630 p
->data
[0].pointer
= a
;
3631 p
->data
[1].pointer
= b
;
3637 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3639 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3640 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3641 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3642 p
->data
[0].funcpointer
= a
;
3643 p
->data
[1].pointer
= b
;
3644 p
->data
[2].object
= c
;
3648 /* Return a Lisp_Save_Value object that represents an array A
3649 of N Lisp objects. */
3652 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3654 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3655 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3656 p
->save_type
= SAVE_TYPE_MEMORY
;
3657 p
->data
[0].pointer
= a
;
3658 p
->data
[1].integer
= n
;
3662 /* Free a Lisp_Save_Value object. Do not use this function
3663 if SAVE contains pointer other than returned by xmalloc. */
3666 free_save_value (Lisp_Object save
)
3668 xfree (XSAVE_POINTER (save
, 0));
3672 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3675 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3677 register Lisp_Object overlay
;
3679 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3680 OVERLAY_START (overlay
) = start
;
3681 OVERLAY_END (overlay
) = end
;
3682 set_overlay_plist (overlay
, plist
);
3683 XOVERLAY (overlay
)->next
= NULL
;
3687 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3688 doc
: /* Return a newly allocated marker which does not point at any place. */)
3691 register Lisp_Object val
;
3692 register struct Lisp_Marker
*p
;
3694 val
= allocate_misc (Lisp_Misc_Marker
);
3700 p
->insertion_type
= 0;
3701 p
->need_adjustment
= 0;
3705 /* Return a newly allocated marker which points into BUF
3706 at character position CHARPOS and byte position BYTEPOS. */
3709 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3712 struct Lisp_Marker
*m
;
3714 /* No dead buffers here. */
3715 eassert (BUFFER_LIVE_P (buf
));
3717 /* Every character is at least one byte. */
3718 eassert (charpos
<= bytepos
);
3720 obj
= allocate_misc (Lisp_Misc_Marker
);
3723 m
->charpos
= charpos
;
3724 m
->bytepos
= bytepos
;
3725 m
->insertion_type
= 0;
3726 m
->need_adjustment
= 0;
3727 m
->next
= BUF_MARKERS (buf
);
3728 BUF_MARKERS (buf
) = m
;
3732 /* Put MARKER back on the free list after using it temporarily. */
3735 free_marker (Lisp_Object marker
)
3737 unchain_marker (XMARKER (marker
));
3742 /* Return a newly created vector or string with specified arguments as
3743 elements. If all the arguments are characters that can fit
3744 in a string of events, make a string; otherwise, make a vector.
3746 Any number of arguments, even zero arguments, are allowed. */
3749 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3753 for (i
= 0; i
< nargs
; i
++)
3754 /* The things that fit in a string
3755 are characters that are in 0...127,
3756 after discarding the meta bit and all the bits above it. */
3757 if (!INTEGERP (args
[i
])
3758 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3759 return Fvector (nargs
, args
);
3761 /* Since the loop exited, we know that all the things in it are
3762 characters, so we can make a string. */
3766 result
= Fmake_string (make_number (nargs
), make_number (0));
3767 for (i
= 0; i
< nargs
; i
++)
3769 SSET (result
, i
, XINT (args
[i
]));
3770 /* Move the meta bit to the right place for a string char. */
3771 if (XINT (args
[i
]) & CHAR_META
)
3772 SSET (result
, i
, SREF (result
, i
) | 0x80);
3781 /************************************************************************
3782 Memory Full Handling
3783 ************************************************************************/
3786 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3787 there may have been size_t overflow so that malloc was never
3788 called, or perhaps malloc was invoked successfully but the
3789 resulting pointer had problems fitting into a tagged EMACS_INT. In
3790 either case this counts as memory being full even though malloc did
3794 memory_full (size_t nbytes
)
3796 /* Do not go into hysterics merely because a large request failed. */
3797 bool enough_free_memory
= 0;
3798 if (SPARE_MEMORY
< nbytes
)
3803 p
= malloc (SPARE_MEMORY
);
3807 enough_free_memory
= 1;
3809 MALLOC_UNBLOCK_INPUT
;
3812 if (! enough_free_memory
)
3818 memory_full_cons_threshold
= sizeof (struct cons_block
);
3820 /* The first time we get here, free the spare memory. */
3821 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
3822 if (spare_memory
[i
])
3825 free (spare_memory
[i
]);
3826 else if (i
>= 1 && i
<= 4)
3827 lisp_align_free (spare_memory
[i
]);
3829 lisp_free (spare_memory
[i
]);
3830 spare_memory
[i
] = 0;
3834 /* This used to call error, but if we've run out of memory, we could
3835 get infinite recursion trying to build the string. */
3836 xsignal (Qnil
, Vmemory_signal_data
);
3839 /* If we released our reserve (due to running out of memory),
3840 and we have a fair amount free once again,
3841 try to set aside another reserve in case we run out once more.
3843 This is called when a relocatable block is freed in ralloc.c,
3844 and also directly from this file, in case we're not using ralloc.c. */
3847 refill_memory_reserve (void)
3849 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
3850 if (spare_memory
[0] == 0)
3851 spare_memory
[0] = malloc (SPARE_MEMORY
);
3852 if (spare_memory
[1] == 0)
3853 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3855 if (spare_memory
[2] == 0)
3856 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3858 if (spare_memory
[3] == 0)
3859 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3861 if (spare_memory
[4] == 0)
3862 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3864 if (spare_memory
[5] == 0)
3865 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3867 if (spare_memory
[6] == 0)
3868 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3870 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3871 Vmemory_full
= Qnil
;
3875 /************************************************************************
3877 ************************************************************************/
3879 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3881 /* Conservative C stack marking requires a method to identify possibly
3882 live Lisp objects given a pointer value. We do this by keeping
3883 track of blocks of Lisp data that are allocated in a red-black tree
3884 (see also the comment of mem_node which is the type of nodes in
3885 that tree). Function lisp_malloc adds information for an allocated
3886 block to the red-black tree with calls to mem_insert, and function
3887 lisp_free removes it with mem_delete. Functions live_string_p etc
3888 call mem_find to lookup information about a given pointer in the
3889 tree, and use that to determine if the pointer points to a Lisp
3892 /* Initialize this part of alloc.c. */
3897 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3898 mem_z
.parent
= NULL
;
3899 mem_z
.color
= MEM_BLACK
;
3900 mem_z
.start
= mem_z
.end
= NULL
;
3905 /* Value is a pointer to the mem_node containing START. Value is
3906 MEM_NIL if there is no node in the tree containing START. */
3908 static struct mem_node
*
3909 mem_find (void *start
)
3913 if (start
< min_heap_address
|| start
> max_heap_address
)
3916 /* Make the search always successful to speed up the loop below. */
3917 mem_z
.start
= start
;
3918 mem_z
.end
= (char *) start
+ 1;
3921 while (start
< p
->start
|| start
>= p
->end
)
3922 p
= start
< p
->start
? p
->left
: p
->right
;
3927 /* Insert a new node into the tree for a block of memory with start
3928 address START, end address END, and type TYPE. Value is a
3929 pointer to the node that was inserted. */
3931 static struct mem_node
*
3932 mem_insert (void *start
, void *end
, enum mem_type type
)
3934 struct mem_node
*c
, *parent
, *x
;
3936 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3937 min_heap_address
= start
;
3938 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3939 max_heap_address
= end
;
3941 /* See where in the tree a node for START belongs. In this
3942 particular application, it shouldn't happen that a node is already
3943 present. For debugging purposes, let's check that. */
3947 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3949 while (c
!= MEM_NIL
)
3951 if (start
>= c
->start
&& start
< c
->end
)
3954 c
= start
< c
->start
? c
->left
: c
->right
;
3957 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3959 while (c
!= MEM_NIL
)
3962 c
= start
< c
->start
? c
->left
: c
->right
;
3965 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3967 /* Create a new node. */
3968 #ifdef GC_MALLOC_CHECK
3969 x
= malloc (sizeof *x
);
3973 x
= xmalloc (sizeof *x
);
3979 x
->left
= x
->right
= MEM_NIL
;
3982 /* Insert it as child of PARENT or install it as root. */
3985 if (start
< parent
->start
)
3993 /* Re-establish red-black tree properties. */
3994 mem_insert_fixup (x
);
4000 /* Re-establish the red-black properties of the tree, and thereby
4001 balance the tree, after node X has been inserted; X is always red. */
4004 mem_insert_fixup (struct mem_node
*x
)
4006 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4008 /* X is red and its parent is red. This is a violation of
4009 red-black tree property #3. */
4011 if (x
->parent
== x
->parent
->parent
->left
)
4013 /* We're on the left side of our grandparent, and Y is our
4015 struct mem_node
*y
= x
->parent
->parent
->right
;
4017 if (y
->color
== MEM_RED
)
4019 /* Uncle and parent are red but should be black because
4020 X is red. Change the colors accordingly and proceed
4021 with the grandparent. */
4022 x
->parent
->color
= MEM_BLACK
;
4023 y
->color
= MEM_BLACK
;
4024 x
->parent
->parent
->color
= MEM_RED
;
4025 x
= x
->parent
->parent
;
4029 /* Parent and uncle have different colors; parent is
4030 red, uncle is black. */
4031 if (x
== x
->parent
->right
)
4034 mem_rotate_left (x
);
4037 x
->parent
->color
= MEM_BLACK
;
4038 x
->parent
->parent
->color
= MEM_RED
;
4039 mem_rotate_right (x
->parent
->parent
);
4044 /* This is the symmetrical case of above. */
4045 struct mem_node
*y
= x
->parent
->parent
->left
;
4047 if (y
->color
== MEM_RED
)
4049 x
->parent
->color
= MEM_BLACK
;
4050 y
->color
= MEM_BLACK
;
4051 x
->parent
->parent
->color
= MEM_RED
;
4052 x
= x
->parent
->parent
;
4056 if (x
== x
->parent
->left
)
4059 mem_rotate_right (x
);
4062 x
->parent
->color
= MEM_BLACK
;
4063 x
->parent
->parent
->color
= MEM_RED
;
4064 mem_rotate_left (x
->parent
->parent
);
4069 /* The root may have been changed to red due to the algorithm. Set
4070 it to black so that property #5 is satisfied. */
4071 mem_root
->color
= MEM_BLACK
;
4082 mem_rotate_left (struct mem_node
*x
)
4086 /* Turn y's left sub-tree into x's right sub-tree. */
4089 if (y
->left
!= MEM_NIL
)
4090 y
->left
->parent
= x
;
4092 /* Y's parent was x's parent. */
4094 y
->parent
= x
->parent
;
4096 /* Get the parent to point to y instead of x. */
4099 if (x
== x
->parent
->left
)
4100 x
->parent
->left
= y
;
4102 x
->parent
->right
= y
;
4107 /* Put x on y's left. */
4121 mem_rotate_right (struct mem_node
*x
)
4123 struct mem_node
*y
= x
->left
;
4126 if (y
->right
!= MEM_NIL
)
4127 y
->right
->parent
= x
;
4130 y
->parent
= x
->parent
;
4133 if (x
== x
->parent
->right
)
4134 x
->parent
->right
= y
;
4136 x
->parent
->left
= y
;
4147 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4150 mem_delete (struct mem_node
*z
)
4152 struct mem_node
*x
, *y
;
4154 if (!z
|| z
== MEM_NIL
)
4157 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4162 while (y
->left
!= MEM_NIL
)
4166 if (y
->left
!= MEM_NIL
)
4171 x
->parent
= y
->parent
;
4174 if (y
== y
->parent
->left
)
4175 y
->parent
->left
= x
;
4177 y
->parent
->right
= x
;
4184 z
->start
= y
->start
;
4189 if (y
->color
== MEM_BLACK
)
4190 mem_delete_fixup (x
);
4192 #ifdef GC_MALLOC_CHECK
4200 /* Re-establish the red-black properties of the tree, after a
4204 mem_delete_fixup (struct mem_node
*x
)
4206 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4208 if (x
== x
->parent
->left
)
4210 struct mem_node
*w
= x
->parent
->right
;
4212 if (w
->color
== MEM_RED
)
4214 w
->color
= MEM_BLACK
;
4215 x
->parent
->color
= MEM_RED
;
4216 mem_rotate_left (x
->parent
);
4217 w
= x
->parent
->right
;
4220 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4227 if (w
->right
->color
== MEM_BLACK
)
4229 w
->left
->color
= MEM_BLACK
;
4231 mem_rotate_right (w
);
4232 w
= x
->parent
->right
;
4234 w
->color
= x
->parent
->color
;
4235 x
->parent
->color
= MEM_BLACK
;
4236 w
->right
->color
= MEM_BLACK
;
4237 mem_rotate_left (x
->parent
);
4243 struct mem_node
*w
= x
->parent
->left
;
4245 if (w
->color
== MEM_RED
)
4247 w
->color
= MEM_BLACK
;
4248 x
->parent
->color
= MEM_RED
;
4249 mem_rotate_right (x
->parent
);
4250 w
= x
->parent
->left
;
4253 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4260 if (w
->left
->color
== MEM_BLACK
)
4262 w
->right
->color
= MEM_BLACK
;
4264 mem_rotate_left (w
);
4265 w
= x
->parent
->left
;
4268 w
->color
= x
->parent
->color
;
4269 x
->parent
->color
= MEM_BLACK
;
4270 w
->left
->color
= MEM_BLACK
;
4271 mem_rotate_right (x
->parent
);
4277 x
->color
= MEM_BLACK
;
4281 /* Value is non-zero if P is a pointer to a live Lisp string on
4282 the heap. M is a pointer to the mem_block for P. */
4285 live_string_p (struct mem_node
*m
, void *p
)
4287 if (m
->type
== MEM_TYPE_STRING
)
4289 struct string_block
*b
= m
->start
;
4290 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4292 /* P must point to the start of a Lisp_String structure, and it
4293 must not be on the free-list. */
4295 && offset
% sizeof b
->strings
[0] == 0
4296 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4297 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4304 /* Value is non-zero if P is a pointer to a live Lisp cons on
4305 the heap. M is a pointer to the mem_block for P. */
4308 live_cons_p (struct mem_node
*m
, void *p
)
4310 if (m
->type
== MEM_TYPE_CONS
)
4312 struct cons_block
*b
= m
->start
;
4313 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4315 /* P must point to the start of a Lisp_Cons, not be
4316 one of the unused cells in the current cons block,
4317 and not be on the free-list. */
4319 && offset
% sizeof b
->conses
[0] == 0
4320 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4322 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4323 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4330 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4331 the heap. M is a pointer to the mem_block for P. */
4334 live_symbol_p (struct mem_node
*m
, void *p
)
4336 if (m
->type
== MEM_TYPE_SYMBOL
)
4338 struct symbol_block
*b
= m
->start
;
4339 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4341 /* P must point to the start of a Lisp_Symbol, not be
4342 one of the unused cells in the current symbol block,
4343 and not be on the free-list. */
4345 && offset
% sizeof b
->symbols
[0] == 0
4346 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4347 && (b
!= symbol_block
4348 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4349 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4356 /* Value is non-zero if P is a pointer to a live Lisp float on
4357 the heap. M is a pointer to the mem_block for P. */
4360 live_float_p (struct mem_node
*m
, void *p
)
4362 if (m
->type
== MEM_TYPE_FLOAT
)
4364 struct float_block
*b
= m
->start
;
4365 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4367 /* P must point to the start of a Lisp_Float and not be
4368 one of the unused cells in the current float block. */
4370 && offset
% sizeof b
->floats
[0] == 0
4371 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4372 && (b
!= float_block
4373 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4380 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4381 the heap. M is a pointer to the mem_block for P. */
4384 live_misc_p (struct mem_node
*m
, void *p
)
4386 if (m
->type
== MEM_TYPE_MISC
)
4388 struct marker_block
*b
= m
->start
;
4389 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4391 /* P must point to the start of a Lisp_Misc, not be
4392 one of the unused cells in the current misc block,
4393 and not be on the free-list. */
4395 && offset
% sizeof b
->markers
[0] == 0
4396 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4397 && (b
!= marker_block
4398 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4399 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4406 /* Value is non-zero if P is a pointer to a live vector-like object.
4407 M is a pointer to the mem_block for P. */
4410 live_vector_p (struct mem_node
*m
, void *p
)
4412 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4414 /* This memory node corresponds to a vector block. */
4415 struct vector_block
*block
= m
->start
;
4416 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4418 /* P is in the block's allocation range. Scan the block
4419 up to P and see whether P points to the start of some
4420 vector which is not on a free list. FIXME: check whether
4421 some allocation patterns (probably a lot of short vectors)
4422 may cause a substantial overhead of this loop. */
4423 while (VECTOR_IN_BLOCK (vector
, block
)
4424 && vector
<= (struct Lisp_Vector
*) p
)
4426 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4429 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4432 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4433 /* This memory node corresponds to a large vector. */
4439 /* Value is non-zero if P is a pointer to a live buffer. M is a
4440 pointer to the mem_block for P. */
4443 live_buffer_p (struct mem_node
*m
, void *p
)
4445 /* P must point to the start of the block, and the buffer
4446 must not have been killed. */
4447 return (m
->type
== MEM_TYPE_BUFFER
4449 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4452 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4456 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4458 /* Currently not used, but may be called from gdb. */
4460 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4462 /* Array of objects that are kept alive because the C stack contains
4463 a pattern that looks like a reference to them. */
4465 #define MAX_ZOMBIES 10
4466 static Lisp_Object zombies
[MAX_ZOMBIES
];
4468 /* Number of zombie objects. */
4470 static EMACS_INT nzombies
;
4472 /* Number of garbage collections. */
4474 static EMACS_INT ngcs
;
4476 /* Average percentage of zombies per collection. */
4478 static double avg_zombies
;
4480 /* Max. number of live and zombie objects. */
4482 static EMACS_INT max_live
, max_zombies
;
4484 /* Average number of live objects per GC. */
4486 static double avg_live
;
4488 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4489 doc
: /* Show information about live and zombie objects. */)
4492 Lisp_Object args
[8], zombie_list
= Qnil
;
4494 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4495 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4496 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4497 args
[1] = make_number (ngcs
);
4498 args
[2] = make_float (avg_live
);
4499 args
[3] = make_float (avg_zombies
);
4500 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4501 args
[5] = make_number (max_live
);
4502 args
[6] = make_number (max_zombies
);
4503 args
[7] = zombie_list
;
4504 return Fmessage (8, args
);
4507 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4510 /* Mark OBJ if we can prove it's a Lisp_Object. */
4513 mark_maybe_object (Lisp_Object obj
)
4520 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4526 po
= (void *) XPNTR (obj
);
4533 switch (XTYPE (obj
))
4536 mark_p
= (live_string_p (m
, po
)
4537 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4541 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4545 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4549 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4552 case Lisp_Vectorlike
:
4553 /* Note: can't check BUFFERP before we know it's a
4554 buffer because checking that dereferences the pointer
4555 PO which might point anywhere. */
4556 if (live_vector_p (m
, po
))
4557 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4558 else if (live_buffer_p (m
, po
))
4559 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4563 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4572 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4573 if (nzombies
< MAX_ZOMBIES
)
4574 zombies
[nzombies
] = obj
;
4582 /* Return true if P can point to Lisp data, and false otherwise.
4583 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4584 Otherwise, assume that Lisp data is aligned on even addresses. */
4587 maybe_lisp_pointer (void *p
)
4589 return !((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2));
4592 /* If P points to Lisp data, mark that as live if it isn't already
4596 mark_maybe_pointer (void *p
)
4602 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4605 if (!maybe_lisp_pointer (p
))
4611 Lisp_Object obj
= Qnil
;
4615 case MEM_TYPE_NON_LISP
:
4616 case MEM_TYPE_SPARE
:
4617 /* Nothing to do; not a pointer to Lisp memory. */
4620 case MEM_TYPE_BUFFER
:
4621 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4622 XSETVECTOR (obj
, p
);
4626 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4630 case MEM_TYPE_STRING
:
4631 if (live_string_p (m
, p
)
4632 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4633 XSETSTRING (obj
, p
);
4637 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4641 case MEM_TYPE_SYMBOL
:
4642 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4643 XSETSYMBOL (obj
, p
);
4646 case MEM_TYPE_FLOAT
:
4647 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4651 case MEM_TYPE_VECTORLIKE
:
4652 case MEM_TYPE_VECTOR_BLOCK
:
4653 if (live_vector_p (m
, p
))
4656 XSETVECTOR (tem
, p
);
4657 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4672 /* Alignment of pointer values. Use alignof, as it sometimes returns
4673 a smaller alignment than GCC's __alignof__ and mark_memory might
4674 miss objects if __alignof__ were used. */
4675 #define GC_POINTER_ALIGNMENT alignof (void *)
4677 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4678 not suffice, which is the typical case. A host where a Lisp_Object is
4679 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4680 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4681 suffice to widen it to to a Lisp_Object and check it that way. */
4682 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4683 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4684 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4685 nor mark_maybe_object can follow the pointers. This should not occur on
4686 any practical porting target. */
4687 # error "MSB type bits straddle pointer-word boundaries"
4689 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4690 pointer words that hold pointers ORed with type bits. */
4691 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4693 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4694 words that hold unmodified pointers. */
4695 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4698 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4699 or END+OFFSET..START. */
4701 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4702 mark_memory (void *start
, void *end
)
4707 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4711 /* Make START the pointer to the start of the memory region,
4712 if it isn't already. */
4720 /* Mark Lisp data pointed to. This is necessary because, in some
4721 situations, the C compiler optimizes Lisp objects away, so that
4722 only a pointer to them remains. Example:
4724 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4727 Lisp_Object obj = build_string ("test");
4728 struct Lisp_String *s = XSTRING (obj);
4729 Fgarbage_collect ();
4730 fprintf (stderr, "test `%s'\n", s->data);
4734 Here, `obj' isn't really used, and the compiler optimizes it
4735 away. The only reference to the life string is through the
4738 for (pp
= start
; (void *) pp
< end
; pp
++)
4739 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4741 void *p
= *(void **) ((char *) pp
+ i
);
4742 mark_maybe_pointer (p
);
4743 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4744 mark_maybe_object (XIL ((intptr_t) p
));
4748 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4750 static bool setjmp_tested_p
;
4751 static int longjmps_done
;
4753 #define SETJMP_WILL_LIKELY_WORK "\
4755 Emacs garbage collector has been changed to use conservative stack\n\
4756 marking. Emacs has determined that the method it uses to do the\n\
4757 marking will likely work on your system, but this isn't sure.\n\
4759 If you are a system-programmer, or can get the help of a local wizard\n\
4760 who is, please take a look at the function mark_stack in alloc.c, and\n\
4761 verify that the methods used are appropriate for your system.\n\
4763 Please mail the result to <emacs-devel@gnu.org>.\n\
4766 #define SETJMP_WILL_NOT_WORK "\
4768 Emacs garbage collector has been changed to use conservative stack\n\
4769 marking. Emacs has determined that the default method it uses to do the\n\
4770 marking will not work on your system. We will need a system-dependent\n\
4771 solution for your system.\n\
4773 Please take a look at the function mark_stack in alloc.c, and\n\
4774 try to find a way to make it work on your system.\n\
4776 Note that you may get false negatives, depending on the compiler.\n\
4777 In particular, you need to use -O with GCC for this test.\n\
4779 Please mail the result to <emacs-devel@gnu.org>.\n\
4783 /* Perform a quick check if it looks like setjmp saves registers in a
4784 jmp_buf. Print a message to stderr saying so. When this test
4785 succeeds, this is _not_ a proof that setjmp is sufficient for
4786 conservative stack marking. Only the sources or a disassembly
4796 /* Arrange for X to be put in a register. */
4802 if (longjmps_done
== 1)
4804 /* Came here after the longjmp at the end of the function.
4806 If x == 1, the longjmp has restored the register to its
4807 value before the setjmp, and we can hope that setjmp
4808 saves all such registers in the jmp_buf, although that
4811 For other values of X, either something really strange is
4812 taking place, or the setjmp just didn't save the register. */
4815 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4818 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4825 if (longjmps_done
== 1)
4826 sys_longjmp (jbuf
, 1);
4829 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4832 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4834 /* Abort if anything GCPRO'd doesn't survive the GC. */
4842 for (p
= gcprolist
; p
; p
= p
->next
)
4843 for (i
= 0; i
< p
->nvars
; ++i
)
4844 if (!survives_gc_p (p
->var
[i
]))
4845 /* FIXME: It's not necessarily a bug. It might just be that the
4846 GCPRO is unnecessary or should release the object sooner. */
4850 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4857 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4858 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4860 fprintf (stderr
, " %d = ", i
);
4861 debug_print (zombies
[i
]);
4865 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4868 /* Mark live Lisp objects on the C stack.
4870 There are several system-dependent problems to consider when
4871 porting this to new architectures:
4875 We have to mark Lisp objects in CPU registers that can hold local
4876 variables or are used to pass parameters.
4878 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4879 something that either saves relevant registers on the stack, or
4880 calls mark_maybe_object passing it each register's contents.
4882 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4883 implementation assumes that calling setjmp saves registers we need
4884 to see in a jmp_buf which itself lies on the stack. This doesn't
4885 have to be true! It must be verified for each system, possibly
4886 by taking a look at the source code of setjmp.
4888 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4889 can use it as a machine independent method to store all registers
4890 to the stack. In this case the macros described in the previous
4891 two paragraphs are not used.
4895 Architectures differ in the way their processor stack is organized.
4896 For example, the stack might look like this
4899 | Lisp_Object | size = 4
4901 | something else | size = 2
4903 | Lisp_Object | size = 4
4907 In such a case, not every Lisp_Object will be aligned equally. To
4908 find all Lisp_Object on the stack it won't be sufficient to walk
4909 the stack in steps of 4 bytes. Instead, two passes will be
4910 necessary, one starting at the start of the stack, and a second
4911 pass starting at the start of the stack + 2. Likewise, if the
4912 minimal alignment of Lisp_Objects on the stack is 1, four passes
4913 would be necessary, each one starting with one byte more offset
4914 from the stack start. */
4917 mark_stack (void *end
)
4920 /* This assumes that the stack is a contiguous region in memory. If
4921 that's not the case, something has to be done here to iterate
4922 over the stack segments. */
4923 mark_memory (stack_base
, end
);
4925 /* Allow for marking a secondary stack, like the register stack on the
4927 #ifdef GC_MARK_SECONDARY_STACK
4928 GC_MARK_SECONDARY_STACK ();
4931 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4936 #else /* GC_MARK_STACK == 0 */
4938 #define mark_maybe_object(obj) emacs_abort ()
4940 #endif /* GC_MARK_STACK != 0 */
4943 /* Determine whether it is safe to access memory at address P. */
4945 valid_pointer_p (void *p
)
4948 return w32_valid_pointer_p (p
, 16);
4952 /* Obviously, we cannot just access it (we would SEGV trying), so we
4953 trick the o/s to tell us whether p is a valid pointer.
4954 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4955 not validate p in that case. */
4957 if (emacs_pipe (fd
) == 0)
4959 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4960 emacs_close (fd
[1]);
4961 emacs_close (fd
[0]);
4969 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4970 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4971 cannot validate OBJ. This function can be quite slow, so its primary
4972 use is the manual debugging. The only exception is print_object, where
4973 we use it to check whether the memory referenced by the pointer of
4974 Lisp_Save_Value object contains valid objects. */
4977 valid_lisp_object_p (Lisp_Object obj
)
4987 p
= (void *) XPNTR (obj
);
4988 if (PURE_POINTER_P (p
))
4991 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4995 return valid_pointer_p (p
);
5002 int valid
= valid_pointer_p (p
);
5014 case MEM_TYPE_NON_LISP
:
5015 case MEM_TYPE_SPARE
:
5018 case MEM_TYPE_BUFFER
:
5019 return live_buffer_p (m
, p
) ? 1 : 2;
5022 return live_cons_p (m
, p
);
5024 case MEM_TYPE_STRING
:
5025 return live_string_p (m
, p
);
5028 return live_misc_p (m
, p
);
5030 case MEM_TYPE_SYMBOL
:
5031 return live_symbol_p (m
, p
);
5033 case MEM_TYPE_FLOAT
:
5034 return live_float_p (m
, p
);
5036 case MEM_TYPE_VECTORLIKE
:
5037 case MEM_TYPE_VECTOR_BLOCK
:
5038 return live_vector_p (m
, p
);
5048 /* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String
5049 (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0
5050 if not. Otherwise we can't rely on valid_lisp_object_p and return -1.
5051 This function is slow and should be used for debugging purposes. */
5054 relocatable_string_data_p (const char *str
)
5056 if (PURE_POINTER_P (str
))
5062 = (struct sdata
*) (str
- offsetof (struct sdata
, data
));
5064 if (valid_pointer_p (sdata
)
5065 && valid_pointer_p (sdata
->string
)
5066 && maybe_lisp_pointer (sdata
->string
))
5067 return (valid_lisp_object_p
5068 (make_lisp_ptr (sdata
->string
, Lisp_String
))
5069 && (const char *) sdata
->string
->data
== str
);
5072 #endif /* GC_MARK_STACK */
5076 /***********************************************************************
5077 Pure Storage Management
5078 ***********************************************************************/
5080 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5081 pointer to it. TYPE is the Lisp type for which the memory is
5082 allocated. TYPE < 0 means it's not used for a Lisp object. */
5085 pure_alloc (size_t size
, int type
)
5089 size_t alignment
= GCALIGNMENT
;
5091 size_t alignment
= alignof (EMACS_INT
);
5093 /* Give Lisp_Floats an extra alignment. */
5094 if (type
== Lisp_Float
)
5095 alignment
= alignof (struct Lisp_Float
);
5101 /* Allocate space for a Lisp object from the beginning of the free
5102 space with taking account of alignment. */
5103 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
5104 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5108 /* Allocate space for a non-Lisp object from the end of the free
5110 pure_bytes_used_non_lisp
+= size
;
5111 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5113 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5115 if (pure_bytes_used
<= pure_size
)
5118 /* Don't allocate a large amount here,
5119 because it might get mmap'd and then its address
5120 might not be usable. */
5121 purebeg
= xmalloc (10000);
5123 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5124 pure_bytes_used
= 0;
5125 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5130 /* Print a warning if PURESIZE is too small. */
5133 check_pure_size (void)
5135 if (pure_bytes_used_before_overflow
)
5136 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5138 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5142 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5143 the non-Lisp data pool of the pure storage, and return its start
5144 address. Return NULL if not found. */
5147 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5150 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5151 const unsigned char *p
;
5154 if (pure_bytes_used_non_lisp
<= nbytes
)
5157 /* Set up the Boyer-Moore table. */
5159 for (i
= 0; i
< 256; i
++)
5162 p
= (const unsigned char *) data
;
5164 bm_skip
[*p
++] = skip
;
5166 last_char_skip
= bm_skip
['\0'];
5168 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5169 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5171 /* See the comments in the function `boyer_moore' (search.c) for the
5172 use of `infinity'. */
5173 infinity
= pure_bytes_used_non_lisp
+ 1;
5174 bm_skip
['\0'] = infinity
;
5176 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5180 /* Check the last character (== '\0'). */
5183 start
+= bm_skip
[*(p
+ start
)];
5185 while (start
<= start_max
);
5187 if (start
< infinity
)
5188 /* Couldn't find the last character. */
5191 /* No less than `infinity' means we could find the last
5192 character at `p[start - infinity]'. */
5195 /* Check the remaining characters. */
5196 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5198 return non_lisp_beg
+ start
;
5200 start
+= last_char_skip
;
5202 while (start
<= start_max
);
5208 /* Return a string allocated in pure space. DATA is a buffer holding
5209 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5210 means make the result string multibyte.
5212 Must get an error if pure storage is full, since if it cannot hold
5213 a large string it may be able to hold conses that point to that
5214 string; then the string is not protected from gc. */
5217 make_pure_string (const char *data
,
5218 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5221 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5222 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5223 if (s
->data
== NULL
)
5225 s
->data
= pure_alloc (nbytes
+ 1, -1);
5226 memcpy (s
->data
, data
, nbytes
);
5227 s
->data
[nbytes
] = '\0';
5230 s
->size_byte
= multibyte
? nbytes
: -1;
5231 s
->intervals
= NULL
;
5232 XSETSTRING (string
, s
);
5236 /* Return a string allocated in pure space. Do not
5237 allocate the string data, just point to DATA. */
5240 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5243 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5246 s
->data
= (unsigned char *) data
;
5247 s
->intervals
= NULL
;
5248 XSETSTRING (string
, s
);
5252 static Lisp_Object
purecopy (Lisp_Object obj
);
5254 /* Return a cons allocated from pure space. Give it pure copies
5255 of CAR as car and CDR as cdr. */
5258 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5261 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5263 XSETCAR (new, purecopy (car
));
5264 XSETCDR (new, purecopy (cdr
));
5269 /* Value is a float object with value NUM allocated from pure space. */
5272 make_pure_float (double num
)
5275 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5277 XFLOAT_INIT (new, num
);
5282 /* Return a vector with room for LEN Lisp_Objects allocated from
5286 make_pure_vector (ptrdiff_t len
)
5289 size_t size
= header_size
+ len
* word_size
;
5290 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5291 XSETVECTOR (new, p
);
5292 XVECTOR (new)->header
.size
= len
;
5297 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5298 doc
: /* Make a copy of object OBJ in pure storage.
5299 Recursively copies contents of vectors and cons cells.
5300 Does not copy symbols. Copies strings without text properties. */)
5301 (register Lisp_Object obj
)
5303 if (NILP (Vpurify_flag
))
5305 else if (MARKERP (obj
) || OVERLAYP (obj
)
5306 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5307 /* Can't purify those. */
5310 return purecopy (obj
);
5314 purecopy (Lisp_Object obj
)
5316 if (PURE_POINTER_P (XPNTR (obj
)) || INTEGERP (obj
) || SUBRP (obj
))
5317 return obj
; /* Already pure. */
5319 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5321 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5327 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5328 else if (FLOATP (obj
))
5329 obj
= make_pure_float (XFLOAT_DATA (obj
));
5330 else if (STRINGP (obj
))
5331 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5333 STRING_MULTIBYTE (obj
));
5334 else if (COMPILEDP (obj
) || VECTORP (obj
))
5336 register struct Lisp_Vector
*vec
;
5337 register ptrdiff_t i
;
5341 if (size
& PSEUDOVECTOR_FLAG
)
5342 size
&= PSEUDOVECTOR_SIZE_MASK
;
5343 vec
= XVECTOR (make_pure_vector (size
));
5344 for (i
= 0; i
< size
; i
++)
5345 vec
->contents
[i
] = purecopy (AREF (obj
, i
));
5346 if (COMPILEDP (obj
))
5348 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5349 XSETCOMPILED (obj
, vec
);
5352 XSETVECTOR (obj
, vec
);
5354 else if (SYMBOLP (obj
))
5356 if (!XSYMBOL (obj
)->pinned
)
5357 { /* We can't purify them, but they appear in many pure objects.
5358 Mark them as `pinned' so we know to mark them at every GC cycle. */
5359 XSYMBOL (obj
)->pinned
= true;
5360 symbol_block_pinned
= symbol_block
;
5366 Lisp_Object args
[2];
5367 args
[0] = build_pure_c_string ("Don't know how to purify: %S");
5369 Fsignal (Qerror
, (Fcons (Fformat (2, args
), Qnil
)));
5372 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5373 Fputhash (obj
, obj
, Vpurify_flag
);
5380 /***********************************************************************
5382 ***********************************************************************/
5384 /* Put an entry in staticvec, pointing at the variable with address
5388 staticpro (Lisp_Object
*varaddress
)
5390 if (staticidx
>= NSTATICS
)
5391 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5392 staticvec
[staticidx
++] = varaddress
;
5396 /***********************************************************************
5398 ***********************************************************************/
5400 /* Temporarily prevent garbage collection. */
5403 inhibit_garbage_collection (void)
5405 ptrdiff_t count
= SPECPDL_INDEX ();
5407 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5411 /* Used to avoid possible overflows when
5412 converting from C to Lisp integers. */
5415 bounded_number (EMACS_INT number
)
5417 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5420 /* Calculate total bytes of live objects. */
5423 total_bytes_of_live_objects (void)
5426 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5427 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5428 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5429 tot
+= total_string_bytes
;
5430 tot
+= total_vector_slots
* word_size
;
5431 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5432 tot
+= total_intervals
* sizeof (struct interval
);
5433 tot
+= total_strings
* sizeof (struct Lisp_String
);
5437 #ifdef HAVE_WINDOW_SYSTEM
5439 /* This code has a few issues on MS-Windows, see Bug#15876 and Bug#16140. */
5441 #if !defined (HAVE_NTGUI)
5443 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5444 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5447 compact_font_cache_entry (Lisp_Object entry
)
5449 Lisp_Object tail
, *prev
= &entry
;
5451 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5454 Lisp_Object obj
= XCAR (tail
);
5456 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5457 if (CONSP (obj
) && FONT_SPEC_P (XCAR (obj
))
5458 && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj
)))
5459 && VECTORP (XCDR (obj
)))
5461 ptrdiff_t i
, size
= ASIZE (XCDR (obj
)) & ~ARRAY_MARK_FLAG
;
5463 /* If font-spec is not marked, most likely all font-entities
5464 are not marked too. But we must be sure that nothing is
5465 marked within OBJ before we really drop it. */
5466 for (i
= 0; i
< size
; i
++)
5467 if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj
), i
))))
5474 *prev
= XCDR (tail
);
5476 prev
= xcdr_addr (tail
);
5481 #endif /* not HAVE_NTGUI */
5483 /* Compact font caches on all terminals and mark
5484 everything which is still here after compaction. */
5487 compact_font_caches (void)
5491 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5493 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5494 #if !defined (HAVE_NTGUI)
5499 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5500 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5502 #endif /* not HAVE_NTGUI */
5503 mark_object (cache
);
5507 #else /* not HAVE_WINDOW_SYSTEM */
5509 #define compact_font_caches() (void)(0)
5511 #endif /* HAVE_WINDOW_SYSTEM */
5513 /* Remove (MARKER . DATA) entries with unmarked MARKER
5514 from buffer undo LIST and return changed list. */
5517 compact_undo_list (Lisp_Object list
)
5519 Lisp_Object tail
, *prev
= &list
;
5521 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5523 if (CONSP (XCAR (tail
))
5524 && MARKERP (XCAR (XCAR (tail
)))
5525 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5526 *prev
= XCDR (tail
);
5528 prev
= xcdr_addr (tail
);
5534 mark_pinned_symbols (void)
5536 struct symbol_block
*sblk
;
5537 int lim
= (symbol_block_pinned
== symbol_block
5538 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5540 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5542 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5543 for (; sym
< end
; ++sym
)
5545 mark_object (make_lisp_ptr (&sym
->s
, Lisp_Symbol
));
5547 lim
= SYMBOL_BLOCK_SIZE
;
5551 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5552 separate function so that we could limit mark_stack in searching
5553 the stack frames below this function, thus avoiding the rare cases
5554 where mark_stack finds values that look like live Lisp objects on
5555 portions of stack that couldn't possibly contain such live objects.
5556 For more details of this, see the discussion at
5557 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5559 garbage_collect_1 (void *end
)
5561 struct buffer
*nextb
;
5562 char stack_top_variable
;
5565 ptrdiff_t count
= SPECPDL_INDEX ();
5566 struct timespec start
;
5567 Lisp_Object retval
= Qnil
;
5568 size_t tot_before
= 0;
5573 /* Can't GC if pure storage overflowed because we can't determine
5574 if something is a pure object or not. */
5575 if (pure_bytes_used_before_overflow
)
5578 /* Record this function, so it appears on the profiler's backtraces. */
5579 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5583 /* Don't keep undo information around forever.
5584 Do this early on, so it is no problem if the user quits. */
5585 FOR_EACH_BUFFER (nextb
)
5586 compact_buffer (nextb
);
5588 if (profiler_memory_running
)
5589 tot_before
= total_bytes_of_live_objects ();
5591 start
= current_timespec ();
5593 /* In case user calls debug_print during GC,
5594 don't let that cause a recursive GC. */
5595 consing_since_gc
= 0;
5597 /* Save what's currently displayed in the echo area. */
5598 message_p
= push_message ();
5599 record_unwind_protect_void (pop_message_unwind
);
5601 /* Save a copy of the contents of the stack, for debugging. */
5602 #if MAX_SAVE_STACK > 0
5603 if (NILP (Vpurify_flag
))
5606 ptrdiff_t stack_size
;
5607 if (&stack_top_variable
< stack_bottom
)
5609 stack
= &stack_top_variable
;
5610 stack_size
= stack_bottom
- &stack_top_variable
;
5614 stack
= stack_bottom
;
5615 stack_size
= &stack_top_variable
- stack_bottom
;
5617 if (stack_size
<= MAX_SAVE_STACK
)
5619 if (stack_copy_size
< stack_size
)
5621 stack_copy
= xrealloc (stack_copy
, stack_size
);
5622 stack_copy_size
= stack_size
;
5624 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5627 #endif /* MAX_SAVE_STACK > 0 */
5629 if (garbage_collection_messages
)
5630 message1_nolog ("Garbage collecting...");
5634 shrink_regexp_cache ();
5638 /* Mark all the special slots that serve as the roots of accessibility. */
5640 mark_buffer (&buffer_defaults
);
5641 mark_buffer (&buffer_local_symbols
);
5643 for (i
= 0; i
< staticidx
; i
++)
5644 mark_object (*staticvec
[i
]);
5646 mark_pinned_symbols ();
5655 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5656 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5660 register struct gcpro
*tail
;
5661 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5662 for (i
= 0; i
< tail
->nvars
; i
++)
5663 mark_object (tail
->var
[i
]);
5668 struct handler
*handler
;
5669 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5671 mark_object (handler
->tag_or_ch
);
5672 mark_object (handler
->val
);
5675 #ifdef HAVE_WINDOW_SYSTEM
5676 mark_fringe_data ();
5679 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5683 /* Everything is now marked, except for the data in font caches
5684 and undo lists. They're compacted by removing an items which
5685 aren't reachable otherwise. */
5687 compact_font_caches ();
5689 FOR_EACH_BUFFER (nextb
)
5691 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5692 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5693 /* Now that we have stripped the elements that need not be
5694 in the undo_list any more, we can finally mark the list. */
5695 mark_object (BVAR (nextb
, undo_list
));
5700 /* Clear the mark bits that we set in certain root slots. */
5702 unmark_byte_stack ();
5703 VECTOR_UNMARK (&buffer_defaults
);
5704 VECTOR_UNMARK (&buffer_local_symbols
);
5706 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5716 consing_since_gc
= 0;
5717 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5718 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5720 gc_relative_threshold
= 0;
5721 if (FLOATP (Vgc_cons_percentage
))
5722 { /* Set gc_cons_combined_threshold. */
5723 double tot
= total_bytes_of_live_objects ();
5725 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5728 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5729 gc_relative_threshold
= tot
;
5731 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5735 if (garbage_collection_messages
)
5737 if (message_p
|| minibuf_level
> 0)
5740 message1_nolog ("Garbage collecting...done");
5743 unbind_to (count
, Qnil
);
5745 Lisp_Object total
[11];
5746 int total_size
= 10;
5748 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5749 bounded_number (total_conses
),
5750 bounded_number (total_free_conses
));
5752 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5753 bounded_number (total_symbols
),
5754 bounded_number (total_free_symbols
));
5756 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5757 bounded_number (total_markers
),
5758 bounded_number (total_free_markers
));
5760 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5761 bounded_number (total_strings
),
5762 bounded_number (total_free_strings
));
5764 total
[4] = list3 (Qstring_bytes
, make_number (1),
5765 bounded_number (total_string_bytes
));
5767 total
[5] = list3 (Qvectors
,
5768 make_number (header_size
+ sizeof (Lisp_Object
)),
5769 bounded_number (total_vectors
));
5771 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5772 bounded_number (total_vector_slots
),
5773 bounded_number (total_free_vector_slots
));
5775 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5776 bounded_number (total_floats
),
5777 bounded_number (total_free_floats
));
5779 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5780 bounded_number (total_intervals
),
5781 bounded_number (total_free_intervals
));
5783 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5784 bounded_number (total_buffers
));
5786 #ifdef DOUG_LEA_MALLOC
5788 total
[10] = list4 (Qheap
, make_number (1024),
5789 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5790 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5792 retval
= Flist (total_size
, total
);
5795 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5797 /* Compute average percentage of zombies. */
5799 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5800 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5802 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5803 max_live
= max (nlive
, max_live
);
5804 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5805 max_zombies
= max (nzombies
, max_zombies
);
5810 if (!NILP (Vpost_gc_hook
))
5812 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5813 safe_run_hooks (Qpost_gc_hook
);
5814 unbind_to (gc_count
, Qnil
);
5817 /* Accumulate statistics. */
5818 if (FLOATP (Vgc_elapsed
))
5820 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5821 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5822 + timespectod (since_start
));
5827 /* Collect profiling data. */
5828 if (profiler_memory_running
)
5831 size_t tot_after
= total_bytes_of_live_objects ();
5832 if (tot_before
> tot_after
)
5833 swept
= tot_before
- tot_after
;
5834 malloc_probe (swept
);
5840 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5841 doc
: /* Reclaim storage for Lisp objects no longer needed.
5842 Garbage collection happens automatically if you cons more than
5843 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5844 `garbage-collect' normally returns a list with info on amount of space in use,
5845 where each entry has the form (NAME SIZE USED FREE), where:
5846 - NAME is a symbol describing the kind of objects this entry represents,
5847 - SIZE is the number of bytes used by each one,
5848 - USED is the number of those objects that were found live in the heap,
5849 - FREE is the number of those objects that are not live but that Emacs
5850 keeps around for future allocations (maybe because it does not know how
5851 to return them to the OS).
5852 However, if there was overflow in pure space, `garbage-collect'
5853 returns nil, because real GC can't be done.
5854 See Info node `(elisp)Garbage Collection'. */)
5857 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5858 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS \
5859 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
5862 #ifdef HAVE___BUILTIN_UNWIND_INIT
5863 /* Force callee-saved registers and register windows onto the stack.
5864 This is the preferred method if available, obviating the need for
5865 machine dependent methods. */
5866 __builtin_unwind_init ();
5868 #else /* not HAVE___BUILTIN_UNWIND_INIT */
5869 #ifndef GC_SAVE_REGISTERS_ON_STACK
5870 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5871 union aligned_jmpbuf
{
5875 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
5877 /* This trick flushes the register windows so that all the state of
5878 the process is contained in the stack. */
5879 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5880 needed on ia64 too. See mach_dep.c, where it also says inline
5881 assembler doesn't work with relevant proprietary compilers. */
5883 #if defined (__sparc64__) && defined (__FreeBSD__)
5884 /* FreeBSD does not have a ta 3 handler. */
5891 /* Save registers that we need to see on the stack. We need to see
5892 registers used to hold register variables and registers used to
5894 #ifdef GC_SAVE_REGISTERS_ON_STACK
5895 GC_SAVE_REGISTERS_ON_STACK (end
);
5896 #else /* not GC_SAVE_REGISTERS_ON_STACK */
5898 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5899 setjmp will definitely work, test it
5900 and print a message with the result
5902 if (!setjmp_tested_p
)
5904 setjmp_tested_p
= 1;
5907 #endif /* GC_SETJMP_WORKS */
5910 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
5911 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
5912 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
5913 return garbage_collect_1 (end
);
5914 #elif (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE)
5915 /* Old GCPROs-based method without stack marking. */
5916 return garbage_collect_1 (NULL
);
5919 #endif /* GC_MARK_STACK */
5922 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5923 only interesting objects referenced from glyphs are strings. */
5926 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5928 struct glyph_row
*row
= matrix
->rows
;
5929 struct glyph_row
*end
= row
+ matrix
->nrows
;
5931 for (; row
< end
; ++row
)
5935 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5937 struct glyph
*glyph
= row
->glyphs
[area
];
5938 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5940 for (; glyph
< end_glyph
; ++glyph
)
5941 if (STRINGP (glyph
->object
)
5942 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5943 mark_object (glyph
->object
);
5948 /* Mark reference to a Lisp_Object.
5949 If the object referred to has not been seen yet, recursively mark
5950 all the references contained in it. */
5952 #define LAST_MARKED_SIZE 500
5953 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5954 static int last_marked_index
;
5956 /* For debugging--call abort when we cdr down this many
5957 links of a list, in mark_object. In debugging,
5958 the call to abort will hit a breakpoint.
5959 Normally this is zero and the check never goes off. */
5960 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5963 mark_vectorlike (struct Lisp_Vector
*ptr
)
5965 ptrdiff_t size
= ptr
->header
.size
;
5968 eassert (!VECTOR_MARKED_P (ptr
));
5969 VECTOR_MARK (ptr
); /* Else mark it. */
5970 if (size
& PSEUDOVECTOR_FLAG
)
5971 size
&= PSEUDOVECTOR_SIZE_MASK
;
5973 /* Note that this size is not the memory-footprint size, but only
5974 the number of Lisp_Object fields that we should trace.
5975 The distinction is used e.g. by Lisp_Process which places extra
5976 non-Lisp_Object fields at the end of the structure... */
5977 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5978 mark_object (ptr
->contents
[i
]);
5981 /* Like mark_vectorlike but optimized for char-tables (and
5982 sub-char-tables) assuming that the contents are mostly integers or
5986 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
5988 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5989 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
5990 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
5992 eassert (!VECTOR_MARKED_P (ptr
));
5994 for (i
= idx
; i
< size
; i
++)
5996 Lisp_Object val
= ptr
->contents
[i
];
5998 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
6000 if (SUB_CHAR_TABLE_P (val
))
6002 if (! VECTOR_MARKED_P (XVECTOR (val
)))
6003 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
6010 NO_INLINE
/* To reduce stack depth in mark_object. */
6012 mark_compiled (struct Lisp_Vector
*ptr
)
6014 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6017 for (i
= 0; i
< size
; i
++)
6018 if (i
!= COMPILED_CONSTANTS
)
6019 mark_object (ptr
->contents
[i
]);
6020 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6023 /* Mark the chain of overlays starting at PTR. */
6026 mark_overlay (struct Lisp_Overlay
*ptr
)
6028 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6031 mark_object (ptr
->start
);
6032 mark_object (ptr
->end
);
6033 mark_object (ptr
->plist
);
6037 /* Mark Lisp_Objects and special pointers in BUFFER. */
6040 mark_buffer (struct buffer
*buffer
)
6042 /* This is handled much like other pseudovectors... */
6043 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6045 /* ...but there are some buffer-specific things. */
6047 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6049 /* For now, we just don't mark the undo_list. It's done later in
6050 a special way just before the sweep phase, and after stripping
6051 some of its elements that are not needed any more. */
6053 mark_overlay (buffer
->overlays_before
);
6054 mark_overlay (buffer
->overlays_after
);
6056 /* If this is an indirect buffer, mark its base buffer. */
6057 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6058 mark_buffer (buffer
->base_buffer
);
6061 /* Mark Lisp faces in the face cache C. */
6063 NO_INLINE
/* To reduce stack depth in mark_object. */
6065 mark_face_cache (struct face_cache
*c
)
6070 for (i
= 0; i
< c
->used
; ++i
)
6072 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
6076 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6077 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6079 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6080 mark_object (face
->lface
[j
]);
6086 NO_INLINE
/* To reduce stack depth in mark_object. */
6088 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6090 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6091 Lisp_Object where
= blv
->where
;
6092 /* If the value is set up for a killed buffer or deleted
6093 frame, restore its global binding. If the value is
6094 forwarded to a C variable, either it's not a Lisp_Object
6095 var, or it's staticpro'd already. */
6096 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6097 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6098 swap_in_global_binding (ptr
);
6099 mark_object (blv
->where
);
6100 mark_object (blv
->valcell
);
6101 mark_object (blv
->defcell
);
6104 NO_INLINE
/* To reduce stack depth in mark_object. */
6106 mark_save_value (struct Lisp_Save_Value
*ptr
)
6108 /* If `save_type' is zero, `data[0].pointer' is the address
6109 of a memory area containing `data[1].integer' potential
6111 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6113 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6115 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6116 mark_maybe_object (*p
);
6120 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6122 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6123 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6124 mark_object (ptr
->data
[i
].object
);
6128 /* Remove killed buffers or items whose car is a killed buffer from
6129 LIST, and mark other items. Return changed LIST, which is marked. */
6132 mark_discard_killed_buffers (Lisp_Object list
)
6134 Lisp_Object tail
, *prev
= &list
;
6136 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6139 Lisp_Object tem
= XCAR (tail
);
6142 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6143 *prev
= XCDR (tail
);
6146 CONS_MARK (XCONS (tail
));
6147 mark_object (XCAR (tail
));
6148 prev
= xcdr_addr (tail
);
6155 /* Determine type of generic Lisp_Object and mark it accordingly.
6157 This function implements a straightforward depth-first marking
6158 algorithm and so the recursion depth may be very high (a few
6159 tens of thousands is not uncommon). To minimize stack usage,
6160 a few cold paths are moved out to NO_INLINE functions above.
6161 In general, inlining them doesn't help you to gain more speed. */
6164 mark_object (Lisp_Object arg
)
6166 register Lisp_Object obj
= arg
;
6167 #ifdef GC_CHECK_MARKED_OBJECTS
6171 ptrdiff_t cdr_count
= 0;
6175 if (PURE_POINTER_P (XPNTR (obj
)))
6178 last_marked
[last_marked_index
++] = obj
;
6179 if (last_marked_index
== LAST_MARKED_SIZE
)
6180 last_marked_index
= 0;
6182 /* Perform some sanity checks on the objects marked here. Abort if
6183 we encounter an object we know is bogus. This increases GC time
6184 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
6185 #ifdef GC_CHECK_MARKED_OBJECTS
6187 po
= (void *) XPNTR (obj
);
6189 /* Check that the object pointed to by PO is known to be a Lisp
6190 structure allocated from the heap. */
6191 #define CHECK_ALLOCATED() \
6193 m = mem_find (po); \
6198 /* Check that the object pointed to by PO is live, using predicate
6200 #define CHECK_LIVE(LIVEP) \
6202 if (!LIVEP (m, po)) \
6206 /* Check both of the above conditions. */
6207 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6209 CHECK_ALLOCATED (); \
6210 CHECK_LIVE (LIVEP); \
6213 #else /* not GC_CHECK_MARKED_OBJECTS */
6215 #define CHECK_LIVE(LIVEP) (void) 0
6216 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
6218 #endif /* not GC_CHECK_MARKED_OBJECTS */
6220 switch (XTYPE (obj
))
6224 register struct Lisp_String
*ptr
= XSTRING (obj
);
6225 if (STRING_MARKED_P (ptr
))
6227 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6229 MARK_INTERVAL_TREE (ptr
->intervals
);
6230 #ifdef GC_CHECK_STRING_BYTES
6231 /* Check that the string size recorded in the string is the
6232 same as the one recorded in the sdata structure. */
6234 #endif /* GC_CHECK_STRING_BYTES */
6238 case Lisp_Vectorlike
:
6240 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6241 register ptrdiff_t pvectype
;
6243 if (VECTOR_MARKED_P (ptr
))
6246 #ifdef GC_CHECK_MARKED_OBJECTS
6248 if (m
== MEM_NIL
&& !SUBRP (obj
))
6250 #endif /* GC_CHECK_MARKED_OBJECTS */
6252 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6253 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6254 >> PSEUDOVECTOR_AREA_BITS
);
6256 pvectype
= PVEC_NORMAL_VECTOR
;
6258 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6259 CHECK_LIVE (live_vector_p
);
6264 #ifdef GC_CHECK_MARKED_OBJECTS
6273 #endif /* GC_CHECK_MARKED_OBJECTS */
6274 mark_buffer ((struct buffer
*) ptr
);
6278 /* Although we could treat this just like a vector, mark_compiled
6279 returns the COMPILED_CONSTANTS element, which is marked at the
6280 next iteration of goto-loop here. This is done to avoid a few
6281 recursive calls to mark_object. */
6282 obj
= mark_compiled (ptr
);
6289 struct frame
*f
= (struct frame
*) ptr
;
6291 mark_vectorlike (ptr
);
6292 mark_face_cache (f
->face_cache
);
6293 #ifdef HAVE_WINDOW_SYSTEM
6294 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6296 struct font
*font
= FRAME_FONT (f
);
6298 if (font
&& !VECTOR_MARKED_P (font
))
6299 mark_vectorlike ((struct Lisp_Vector
*) font
);
6307 struct window
*w
= (struct window
*) ptr
;
6309 mark_vectorlike (ptr
);
6311 /* Mark glyph matrices, if any. Marking window
6312 matrices is sufficient because frame matrices
6313 use the same glyph memory. */
6314 if (w
->current_matrix
)
6316 mark_glyph_matrix (w
->current_matrix
);
6317 mark_glyph_matrix (w
->desired_matrix
);
6320 /* Filter out killed buffers from both buffer lists
6321 in attempt to help GC to reclaim killed buffers faster.
6322 We can do it elsewhere for live windows, but this is the
6323 best place to do it for dead windows. */
6325 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6327 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6331 case PVEC_HASH_TABLE
:
6333 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6335 mark_vectorlike (ptr
);
6336 mark_object (h
->test
.name
);
6337 mark_object (h
->test
.user_hash_function
);
6338 mark_object (h
->test
.user_cmp_function
);
6339 /* If hash table is not weak, mark all keys and values.
6340 For weak tables, mark only the vector. */
6342 mark_object (h
->key_and_value
);
6344 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6348 case PVEC_CHAR_TABLE
:
6349 case PVEC_SUB_CHAR_TABLE
:
6350 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6353 case PVEC_BOOL_VECTOR
:
6354 /* No Lisp_Objects to mark in a bool vector. */
6365 mark_vectorlike (ptr
);
6372 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6376 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6378 /* Attempt to catch bogus objects. */
6379 eassert (valid_lisp_object_p (ptr
->function
) >= 1);
6380 mark_object (ptr
->function
);
6381 mark_object (ptr
->plist
);
6382 switch (ptr
->redirect
)
6384 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6385 case SYMBOL_VARALIAS
:
6388 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6392 case SYMBOL_LOCALIZED
:
6393 mark_localized_symbol (ptr
);
6395 case SYMBOL_FORWARDED
:
6396 /* If the value is forwarded to a buffer or keyboard field,
6397 these are marked when we see the corresponding object.
6398 And if it's forwarded to a C variable, either it's not
6399 a Lisp_Object var, or it's staticpro'd already. */
6401 default: emacs_abort ();
6403 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6404 MARK_STRING (XSTRING (ptr
->name
));
6405 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6406 /* Inner loop to mark next symbol in this bucket, if any. */
6414 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6416 if (XMISCANY (obj
)->gcmarkbit
)
6419 switch (XMISCTYPE (obj
))
6421 case Lisp_Misc_Marker
:
6422 /* DO NOT mark thru the marker's chain.
6423 The buffer's markers chain does not preserve markers from gc;
6424 instead, markers are removed from the chain when freed by gc. */
6425 XMISCANY (obj
)->gcmarkbit
= 1;
6428 case Lisp_Misc_Save_Value
:
6429 XMISCANY (obj
)->gcmarkbit
= 1;
6430 mark_save_value (XSAVE_VALUE (obj
));
6433 case Lisp_Misc_Overlay
:
6434 mark_overlay (XOVERLAY (obj
));
6444 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6445 if (CONS_MARKED_P (ptr
))
6447 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6449 /* If the cdr is nil, avoid recursion for the car. */
6450 if (EQ (ptr
->u
.cdr
, Qnil
))
6456 mark_object (ptr
->car
);
6459 if (cdr_count
== mark_object_loop_halt
)
6465 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6466 FLOAT_MARK (XFLOAT (obj
));
6477 #undef CHECK_ALLOCATED
6478 #undef CHECK_ALLOCATED_AND_LIVE
6480 /* Mark the Lisp pointers in the terminal objects.
6481 Called by Fgarbage_collect. */
6484 mark_terminals (void)
6487 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6489 eassert (t
->name
!= NULL
);
6490 #ifdef HAVE_WINDOW_SYSTEM
6491 /* If a terminal object is reachable from a stacpro'ed object,
6492 it might have been marked already. Make sure the image cache
6494 mark_image_cache (t
->image_cache
);
6495 #endif /* HAVE_WINDOW_SYSTEM */
6496 if (!VECTOR_MARKED_P (t
))
6497 mark_vectorlike ((struct Lisp_Vector
*)t
);
6503 /* Value is non-zero if OBJ will survive the current GC because it's
6504 either marked or does not need to be marked to survive. */
6507 survives_gc_p (Lisp_Object obj
)
6511 switch (XTYPE (obj
))
6518 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6522 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6526 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6529 case Lisp_Vectorlike
:
6530 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6534 survives_p
= CONS_MARKED_P (XCONS (obj
));
6538 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6545 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6551 NO_INLINE
/* For better stack traces */
6555 struct cons_block
*cblk
;
6556 struct cons_block
**cprev
= &cons_block
;
6557 int lim
= cons_block_index
;
6558 EMACS_INT num_free
= 0, num_used
= 0;
6562 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6566 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6568 /* Scan the mark bits an int at a time. */
6569 for (i
= 0; i
< ilim
; i
++)
6571 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6573 /* Fast path - all cons cells for this int are marked. */
6574 cblk
->gcmarkbits
[i
] = 0;
6575 num_used
+= BITS_PER_BITS_WORD
;
6579 /* Some cons cells for this int are not marked.
6580 Find which ones, and free them. */
6581 int start
, pos
, stop
;
6583 start
= i
* BITS_PER_BITS_WORD
;
6585 if (stop
> BITS_PER_BITS_WORD
)
6586 stop
= BITS_PER_BITS_WORD
;
6589 for (pos
= start
; pos
< stop
; pos
++)
6591 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6594 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6595 cons_free_list
= &cblk
->conses
[pos
];
6597 cons_free_list
->car
= Vdead
;
6603 CONS_UNMARK (&cblk
->conses
[pos
]);
6609 lim
= CONS_BLOCK_SIZE
;
6610 /* If this block contains only free conses and we have already
6611 seen more than two blocks worth of free conses then deallocate
6613 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6615 *cprev
= cblk
->next
;
6616 /* Unhook from the free list. */
6617 cons_free_list
= cblk
->conses
[0].u
.chain
;
6618 lisp_align_free (cblk
);
6622 num_free
+= this_free
;
6623 cprev
= &cblk
->next
;
6626 total_conses
= num_used
;
6627 total_free_conses
= num_free
;
6630 NO_INLINE
/* For better stack traces */
6634 register struct float_block
*fblk
;
6635 struct float_block
**fprev
= &float_block
;
6636 register int lim
= float_block_index
;
6637 EMACS_INT num_free
= 0, num_used
= 0;
6639 float_free_list
= 0;
6641 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6645 for (i
= 0; i
< lim
; i
++)
6646 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6649 fblk
->floats
[i
].u
.chain
= float_free_list
;
6650 float_free_list
= &fblk
->floats
[i
];
6655 FLOAT_UNMARK (&fblk
->floats
[i
]);
6657 lim
= FLOAT_BLOCK_SIZE
;
6658 /* If this block contains only free floats and we have already
6659 seen more than two blocks worth of free floats then deallocate
6661 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6663 *fprev
= fblk
->next
;
6664 /* Unhook from the free list. */
6665 float_free_list
= fblk
->floats
[0].u
.chain
;
6666 lisp_align_free (fblk
);
6670 num_free
+= this_free
;
6671 fprev
= &fblk
->next
;
6674 total_floats
= num_used
;
6675 total_free_floats
= num_free
;
6678 NO_INLINE
/* For better stack traces */
6680 sweep_intervals (void)
6682 register struct interval_block
*iblk
;
6683 struct interval_block
**iprev
= &interval_block
;
6684 register int lim
= interval_block_index
;
6685 EMACS_INT num_free
= 0, num_used
= 0;
6687 interval_free_list
= 0;
6689 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6694 for (i
= 0; i
< lim
; i
++)
6696 if (!iblk
->intervals
[i
].gcmarkbit
)
6698 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6699 interval_free_list
= &iblk
->intervals
[i
];
6705 iblk
->intervals
[i
].gcmarkbit
= 0;
6708 lim
= INTERVAL_BLOCK_SIZE
;
6709 /* If this block contains only free intervals and we have already
6710 seen more than two blocks worth of free intervals then
6711 deallocate this block. */
6712 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6714 *iprev
= iblk
->next
;
6715 /* Unhook from the free list. */
6716 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6721 num_free
+= this_free
;
6722 iprev
= &iblk
->next
;
6725 total_intervals
= num_used
;
6726 total_free_intervals
= num_free
;
6729 NO_INLINE
/* For better stack traces */
6731 sweep_symbols (void)
6733 register struct symbol_block
*sblk
;
6734 struct symbol_block
**sprev
= &symbol_block
;
6735 register int lim
= symbol_block_index
;
6736 EMACS_INT num_free
= 0, num_used
= 0;
6738 symbol_free_list
= NULL
;
6740 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6743 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6744 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6746 for (; sym
< end
; ++sym
)
6748 if (!sym
->s
.gcmarkbit
)
6750 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6751 xfree (SYMBOL_BLV (&sym
->s
));
6752 sym
->s
.next
= symbol_free_list
;
6753 symbol_free_list
= &sym
->s
;
6755 symbol_free_list
->function
= Vdead
;
6762 sym
->s
.gcmarkbit
= 0;
6763 /* Attempt to catch bogus objects. */
6764 eassert (valid_lisp_object_p (sym
->s
.function
) >= 1);
6768 lim
= SYMBOL_BLOCK_SIZE
;
6769 /* If this block contains only free symbols and we have already
6770 seen more than two blocks worth of free symbols then deallocate
6772 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6774 *sprev
= sblk
->next
;
6775 /* Unhook from the free list. */
6776 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6781 num_free
+= this_free
;
6782 sprev
= &sblk
->next
;
6785 total_symbols
= num_used
;
6786 total_free_symbols
= num_free
;
6789 NO_INLINE
/* For better stack traces */
6793 register struct marker_block
*mblk
;
6794 struct marker_block
**mprev
= &marker_block
;
6795 register int lim
= marker_block_index
;
6796 EMACS_INT num_free
= 0, num_used
= 0;
6798 /* Put all unmarked misc's on free list. For a marker, first
6799 unchain it from the buffer it points into. */
6801 marker_free_list
= 0;
6803 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6808 for (i
= 0; i
< lim
; i
++)
6810 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6812 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6813 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6814 /* Set the type of the freed object to Lisp_Misc_Free.
6815 We could leave the type alone, since nobody checks it,
6816 but this might catch bugs faster. */
6817 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6818 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6819 marker_free_list
= &mblk
->markers
[i
].m
;
6825 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6828 lim
= MARKER_BLOCK_SIZE
;
6829 /* If this block contains only free markers and we have already
6830 seen more than two blocks worth of free markers then deallocate
6832 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6834 *mprev
= mblk
->next
;
6835 /* Unhook from the free list. */
6836 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6841 num_free
+= this_free
;
6842 mprev
= &mblk
->next
;
6846 total_markers
= num_used
;
6847 total_free_markers
= num_free
;
6850 NO_INLINE
/* For better stack traces */
6852 sweep_buffers (void)
6854 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6857 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6858 if (!VECTOR_MARKED_P (buffer
))
6860 *bprev
= buffer
->next
;
6865 VECTOR_UNMARK (buffer
);
6866 /* Do not use buffer_(set|get)_intervals here. */
6867 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6869 bprev
= &buffer
->next
;
6873 /* Sweep: find all structures not marked, and free them. */
6877 /* Remove or mark entries in weak hash tables.
6878 This must be done before any object is unmarked. */
6879 sweep_weak_hash_tables ();
6882 check_string_bytes (!noninteractive
);
6890 check_string_bytes (!noninteractive
);
6893 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
6894 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
6895 All values are in Kbytes. If there is no swap space,
6896 last two values are zero. If the system is not supported
6897 or memory information can't be obtained, return nil. */)
6900 #if defined HAVE_LINUX_SYSINFO
6906 #ifdef LINUX_SYSINFO_UNIT
6907 units
= si
.mem_unit
;
6911 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
6912 (uintmax_t) si
.freeram
* units
/ 1024,
6913 (uintmax_t) si
.totalswap
* units
/ 1024,
6914 (uintmax_t) si
.freeswap
* units
/ 1024);
6915 #elif defined WINDOWSNT
6916 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
6918 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6919 return list4i ((uintmax_t) totalram
/ 1024,
6920 (uintmax_t) freeram
/ 1024,
6921 (uintmax_t) totalswap
/ 1024,
6922 (uintmax_t) freeswap
/ 1024);
6926 unsigned long totalram
, freeram
, totalswap
, freeswap
;
6928 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6929 return list4i ((uintmax_t) totalram
/ 1024,
6930 (uintmax_t) freeram
/ 1024,
6931 (uintmax_t) totalswap
/ 1024,
6932 (uintmax_t) freeswap
/ 1024);
6935 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6936 /* FIXME: add more systems. */
6938 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6941 /* Debugging aids. */
6943 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6944 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6945 This may be helpful in debugging Emacs's memory usage.
6946 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6952 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
6955 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6961 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6962 doc
: /* Return a list of counters that measure how much consing there has been.
6963 Each of these counters increments for a certain kind of object.
6964 The counters wrap around from the largest positive integer to zero.
6965 Garbage collection does not decrease them.
6966 The elements of the value are as follows:
6967 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6968 All are in units of 1 = one object consed
6969 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6971 MISCS include overlays, markers, and some internal types.
6972 Frames, windows, buffers, and subprocesses count as vectors
6973 (but the contents of a buffer's text do not count here). */)
6976 return listn (CONSTYPE_HEAP
, 8,
6977 bounded_number (cons_cells_consed
),
6978 bounded_number (floats_consed
),
6979 bounded_number (vector_cells_consed
),
6980 bounded_number (symbols_consed
),
6981 bounded_number (string_chars_consed
),
6982 bounded_number (misc_objects_consed
),
6983 bounded_number (intervals_consed
),
6984 bounded_number (strings_consed
));
6987 /* Find at most FIND_MAX symbols which have OBJ as their value or
6988 function. This is used in gdbinit's `xwhichsymbols' command. */
6991 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6993 struct symbol_block
*sblk
;
6994 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6995 Lisp_Object found
= Qnil
;
6999 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7001 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
7004 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
7006 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
7010 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7013 XSETSYMBOL (tem
, sym
);
7014 val
= find_symbol_value (tem
);
7016 || EQ (sym
->function
, obj
)
7017 || (!NILP (sym
->function
)
7018 && COMPILEDP (sym
->function
)
7019 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
7022 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
7024 found
= Fcons (tem
, found
);
7025 if (--find_max
== 0)
7033 unbind_to (gc_count
, Qnil
);
7037 #ifdef SUSPICIOUS_OBJECT_CHECKING
7040 find_suspicious_object_in_range (void *begin
, void *end
)
7042 char *begin_a
= begin
;
7046 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7048 char *suspicious_object
= suspicious_objects
[i
];
7049 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7050 return suspicious_object
;
7057 note_suspicious_free (void* ptr
)
7059 struct suspicious_free_record
* rec
;
7061 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7062 if (suspicious_free_history_index
==
7063 ARRAYELTS (suspicious_free_history
))
7065 suspicious_free_history_index
= 0;
7068 memset (rec
, 0, sizeof (*rec
));
7069 rec
->suspicious_object
= ptr
;
7070 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7074 detect_suspicious_free (void* ptr
)
7078 eassert (ptr
!= NULL
);
7080 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7081 if (suspicious_objects
[i
] == ptr
)
7083 note_suspicious_free (ptr
);
7084 suspicious_objects
[i
] = NULL
;
7088 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7090 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7091 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7092 If Emacs is compiled with suspicous object checking, capture
7093 a stack trace when OBJ is freed in order to help track down
7094 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7097 #ifdef SUSPICIOUS_OBJECT_CHECKING
7098 /* Right now, we care only about vectors. */
7099 if (VECTORLIKEP (obj
))
7101 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7102 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7103 suspicious_object_index
= 0;
7109 #ifdef ENABLE_CHECKING
7111 bool suppress_checking
;
7114 die (const char *msg
, const char *file
, int line
)
7116 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7118 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7122 /* Initialization. */
7125 init_alloc_once (void)
7127 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
7129 pure_size
= PURESIZE
;
7131 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
7133 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7136 #ifdef DOUG_LEA_MALLOC
7137 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7138 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7139 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7144 refill_memory_reserve ();
7145 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7152 byte_stack_list
= 0;
7154 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7155 setjmp_tested_p
= longjmps_done
= 0;
7158 Vgc_elapsed
= make_float (0.0);
7162 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7167 syms_of_alloc (void)
7169 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7170 doc
: /* Number of bytes of consing between garbage collections.
7171 Garbage collection can happen automatically once this many bytes have been
7172 allocated since the last garbage collection. All data types count.
7174 Garbage collection happens automatically only when `eval' is called.
7176 By binding this temporarily to a large number, you can effectively
7177 prevent garbage collection during a part of the program.
7178 See also `gc-cons-percentage'. */);
7180 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7181 doc
: /* Portion of the heap used for allocation.
7182 Garbage collection can happen automatically once this portion of the heap
7183 has been allocated since the last garbage collection.
7184 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7185 Vgc_cons_percentage
= make_float (0.1);
7187 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7188 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7190 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7191 doc
: /* Number of cons cells that have been consed so far. */);
7193 DEFVAR_INT ("floats-consed", floats_consed
,
7194 doc
: /* Number of floats that have been consed so far. */);
7196 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7197 doc
: /* Number of vector cells that have been consed so far. */);
7199 DEFVAR_INT ("symbols-consed", symbols_consed
,
7200 doc
: /* Number of symbols that have been consed so far. */);
7202 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7203 doc
: /* Number of string characters that have been consed so far. */);
7205 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7206 doc
: /* Number of miscellaneous objects that have been consed so far.
7207 These include markers and overlays, plus certain objects not visible
7210 DEFVAR_INT ("intervals-consed", intervals_consed
,
7211 doc
: /* Number of intervals that have been consed so far. */);
7213 DEFVAR_INT ("strings-consed", strings_consed
,
7214 doc
: /* Number of strings that have been consed so far. */);
7216 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7217 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7218 This means that certain objects should be allocated in shared (pure) space.
7219 It can also be set to a hash-table, in which case this table is used to
7220 do hash-consing of the objects allocated to pure space. */);
7222 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7223 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7224 garbage_collection_messages
= 0;
7226 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7227 doc
: /* Hook run after garbage collection has finished. */);
7228 Vpost_gc_hook
= Qnil
;
7229 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7231 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7232 doc
: /* Precomputed `signal' argument for memory-full error. */);
7233 /* We build this in advance because if we wait until we need it, we might
7234 not be able to allocate the memory to hold it. */
7236 = listn (CONSTYPE_PURE
, 2, Qerror
,
7237 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7239 DEFVAR_LISP ("memory-full", Vmemory_full
,
7240 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7241 Vmemory_full
= Qnil
;
7243 DEFSYM (Qconses
, "conses");
7244 DEFSYM (Qsymbols
, "symbols");
7245 DEFSYM (Qmiscs
, "miscs");
7246 DEFSYM (Qstrings
, "strings");
7247 DEFSYM (Qvectors
, "vectors");
7248 DEFSYM (Qfloats
, "floats");
7249 DEFSYM (Qintervals
, "intervals");
7250 DEFSYM (Qbuffers
, "buffers");
7251 DEFSYM (Qstring_bytes
, "string-bytes");
7252 DEFSYM (Qvector_slots
, "vector-slots");
7253 DEFSYM (Qheap
, "heap");
7254 DEFSYM (Qautomatic_gc
, "Automatic GC");
7256 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7257 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7259 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7260 doc
: /* Accumulated time elapsed in garbage collections.
7261 The time is in seconds as a floating point value. */);
7262 DEFVAR_INT ("gcs-done", gcs_done
,
7263 doc
: /* Accumulated number of garbage collections done. */);
7268 defsubr (&Sbool_vector
);
7269 defsubr (&Smake_byte_code
);
7270 defsubr (&Smake_list
);
7271 defsubr (&Smake_vector
);
7272 defsubr (&Smake_string
);
7273 defsubr (&Smake_bool_vector
);
7274 defsubr (&Smake_symbol
);
7275 defsubr (&Smake_marker
);
7276 defsubr (&Spurecopy
);
7277 defsubr (&Sgarbage_collect
);
7278 defsubr (&Smemory_limit
);
7279 defsubr (&Smemory_info
);
7280 defsubr (&Smemory_use_counts
);
7281 defsubr (&Ssuspicious_object
);
7283 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
7284 defsubr (&Sgc_status
);
7288 /* When compiled with GCC, GDB might say "No enum type named
7289 pvec_type" if we don't have at least one symbol with that type, and
7290 then xbacktrace could fail. Similarly for the other enums and
7291 their values. Some non-GCC compilers don't like these constructs. */
7295 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7296 enum char_table_specials char_table_specials
;
7297 enum char_bits char_bits
;
7298 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7299 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7300 enum Lisp_Bits Lisp_Bits
;
7301 enum Lisp_Compiled Lisp_Compiled
;
7302 enum maxargs maxargs
;
7303 enum MAX_ALLOCA MAX_ALLOCA
;
7304 enum More_Lisp_Bits More_Lisp_Bits
;
7305 enum pvec_type pvec_type
;
7306 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7307 #endif /* __GNUC__ */