1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 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/>. */
23 #define LISP_INLINE EXTERN_INLINE
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
38 #include "intervals.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
53 # undef GC_CHECK_MARKED_OBJECTS
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
73 #include "w32heap.h" /* for sbrk */
76 #ifdef DOUG_LEA_MALLOC
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #endif /* not DOUG_LEA_MALLOC */
87 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
88 to a struct Lisp_String. */
90 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
91 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
92 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
94 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
95 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
96 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
98 /* Default value of gc_cons_threshold (see below). */
100 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
102 /* Global variables. */
103 struct emacs_globals globals
;
105 /* Number of bytes of consing done since the last gc. */
107 EMACS_INT consing_since_gc
;
109 /* Similar minimum, computed from Vgc_cons_percentage. */
111 EMACS_INT gc_relative_threshold
;
113 /* Minimum number of bytes of consing since GC before next GC,
114 when memory is full. */
116 EMACS_INT memory_full_cons_threshold
;
118 /* True during GC. */
122 /* True means abort if try to GC.
123 This is for code which is written on the assumption that
124 no GC will happen, so as to verify that assumption. */
128 /* Number of live and free conses etc. */
130 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
131 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
132 static EMACS_INT total_free_floats
, total_floats
;
134 /* Points to memory space allocated as "spare", to be freed if we run
135 out of memory. We keep one large block, four cons-blocks, and
136 two string blocks. */
138 static char *spare_memory
[7];
140 /* Amount of spare memory to keep in large reserve block, or to see
141 whether this much is available when malloc fails on a larger request. */
143 #define SPARE_MEMORY (1 << 14)
145 /* Initialize it to a nonzero value to force it into data space
146 (rather than bss space). That way unexec will remap it into text
147 space (pure), on some systems. We have not implemented the
148 remapping on more recent systems because this is less important
149 nowadays than in the days of small memories and timesharing. */
151 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
152 #define PUREBEG (char *) pure
154 /* Pointer to the pure area, and its size. */
156 static char *purebeg
;
157 static ptrdiff_t pure_size
;
159 /* Number of bytes of pure storage used before pure storage overflowed.
160 If this is non-zero, this implies that an overflow occurred. */
162 static ptrdiff_t pure_bytes_used_before_overflow
;
164 /* True if P points into pure space. */
166 #define PURE_POINTER_P(P) \
167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
169 /* Index in pure at which next pure Lisp object will be allocated.. */
171 static ptrdiff_t pure_bytes_used_lisp
;
173 /* Number of bytes allocated for non-Lisp objects in pure storage. */
175 static ptrdiff_t pure_bytes_used_non_lisp
;
177 /* If nonzero, this is a warning delivered by malloc and not yet
180 const char *pending_malloc_warning
;
182 /* Maximum amount of C stack to save when a GC happens. */
184 #ifndef MAX_SAVE_STACK
185 #define MAX_SAVE_STACK 16000
188 /* Buffer in which we save a copy of the C stack at each GC. */
190 #if MAX_SAVE_STACK > 0
191 static char *stack_copy
;
192 static ptrdiff_t stack_copy_size
;
195 static Lisp_Object Qconses
;
196 static Lisp_Object Qsymbols
;
197 static Lisp_Object Qmiscs
;
198 static Lisp_Object Qstrings
;
199 static Lisp_Object Qvectors
;
200 static Lisp_Object Qfloats
;
201 static Lisp_Object Qintervals
;
202 static Lisp_Object Qbuffers
;
203 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
204 static Lisp_Object Qgc_cons_threshold
;
205 Lisp_Object Qautomatic_gc
;
206 Lisp_Object Qchar_table_extra_slots
;
208 /* Hook run after GC has finished. */
210 static Lisp_Object Qpost_gc_hook
;
212 static void free_save_value (Lisp_Object
);
213 static void mark_terminals (void);
214 static void gc_sweep (void);
215 static Lisp_Object
make_pure_vector (ptrdiff_t);
216 static void mark_buffer (struct buffer
*);
218 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
219 static void refill_memory_reserve (void);
221 static void compact_small_strings (void);
222 static void free_large_strings (void);
223 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
225 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
226 what memory allocated via lisp_malloc and lisp_align_malloc is intended
227 for what purpose. This enumeration specifies the type of memory. */
238 /* Since all non-bool pseudovectors are small enough to be
239 allocated from vector blocks, this memory type denotes
240 large regular vectors and large bool pseudovectors. */
242 /* Special type to denote vector blocks. */
243 MEM_TYPE_VECTOR_BLOCK
,
244 /* Special type to denote reserved memory. */
248 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
250 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
251 #include <stdio.h> /* For fprintf. */
254 /* A unique object in pure space used to make some Lisp objects
255 on free lists recognizable in O(1). */
257 static Lisp_Object Vdead
;
258 #define DEADP(x) EQ (x, Vdead)
260 #ifdef GC_MALLOC_CHECK
262 enum mem_type allocated_mem_type
;
264 #endif /* GC_MALLOC_CHECK */
266 /* A node in the red-black tree describing allocated memory containing
267 Lisp data. Each such block is recorded with its start and end
268 address when it is allocated, and removed from the tree when it
271 A red-black tree is a balanced binary tree with the following
274 1. Every node is either red or black.
275 2. Every leaf is black.
276 3. If a node is red, then both of its children are black.
277 4. Every simple path from a node to a descendant leaf contains
278 the same number of black nodes.
279 5. The root is always black.
281 When nodes are inserted into the tree, or deleted from the tree,
282 the tree is "fixed" so that these properties are always true.
284 A red-black tree with N internal nodes has height at most 2
285 log(N+1). Searches, insertions and deletions are done in O(log N).
286 Please see a text book about data structures for a detailed
287 description of red-black trees. Any book worth its salt should
292 /* Children of this node. These pointers are never NULL. When there
293 is no child, the value is MEM_NIL, which points to a dummy node. */
294 struct mem_node
*left
, *right
;
296 /* The parent of this node. In the root node, this is NULL. */
297 struct mem_node
*parent
;
299 /* Start and end of allocated region. */
303 enum {MEM_BLACK
, MEM_RED
} color
;
309 /* Root of the tree describing allocated Lisp memory. */
311 static struct mem_node
*mem_root
;
313 /* Lowest and highest known address in the heap. */
315 static void *min_heap_address
, *max_heap_address
;
317 /* Sentinel node of the tree. */
319 static struct mem_node mem_z
;
320 #define MEM_NIL &mem_z
322 static struct Lisp_Vector
*allocate_vectorlike (ptrdiff_t);
323 static void lisp_free (void *);
324 static bool live_vector_p (struct mem_node
*, void *);
325 static bool live_buffer_p (struct mem_node
*, void *);
326 static bool live_string_p (struct mem_node
*, void *);
327 static bool live_cons_p (struct mem_node
*, void *);
328 static bool live_symbol_p (struct mem_node
*, void *);
329 static bool live_float_p (struct mem_node
*, void *);
330 static bool live_misc_p (struct mem_node
*, void *);
331 static void mark_maybe_object (Lisp_Object
);
332 static void mark_memory (void *, void *);
333 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
334 static void mem_init (void);
335 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
336 static void mem_insert_fixup (struct mem_node
*);
337 static void mem_rotate_left (struct mem_node
*);
338 static void mem_rotate_right (struct mem_node
*);
339 static void mem_delete (struct mem_node
*);
340 static void mem_delete_fixup (struct mem_node
*);
341 static struct mem_node
*mem_find (void *);
345 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
346 static void check_gcpros (void);
349 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
355 /* Addresses of staticpro'd variables. Initialize it to a nonzero
356 value; otherwise some compilers put it into BSS. */
358 #define NSTATICS 0x800
359 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
361 /* Index of next unused slot in staticvec. */
363 static int staticidx
;
365 static void *pure_alloc (size_t, int);
368 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
369 ALIGNMENT must be a power of 2. */
371 #define ALIGN(ptr, ALIGNMENT) \
372 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
373 & ~ ((ALIGNMENT) - 1)))
377 /************************************************************************
379 ************************************************************************/
381 /* Function malloc calls this if it finds we are near exhausting storage. */
384 malloc_warning (const char *str
)
386 pending_malloc_warning
= str
;
390 /* Display an already-pending malloc warning. */
393 display_malloc_warning (void)
395 call3 (intern ("display-warning"),
397 build_string (pending_malloc_warning
),
398 intern ("emergency"));
399 pending_malloc_warning
= 0;
402 /* Called if we can't allocate relocatable space for a buffer. */
405 buffer_memory_full (ptrdiff_t nbytes
)
407 /* If buffers use the relocating allocator, no need to free
408 spare_memory, because we may have plenty of malloc space left
409 that we could get, and if we don't, the malloc that fails will
410 itself cause spare_memory to be freed. If buffers don't use the
411 relocating allocator, treat this like any other failing
415 memory_full (nbytes
);
417 /* This used to call error, but if we've run out of memory, we could
418 get infinite recursion trying to build the string. */
419 xsignal (Qnil
, Vmemory_signal_data
);
423 /* A common multiple of the positive integers A and B. Ideally this
424 would be the least common multiple, but there's no way to do that
425 as a constant expression in C, so do the best that we can easily do. */
426 #define COMMON_MULTIPLE(a, b) \
427 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
429 #ifndef XMALLOC_OVERRUN_CHECK
430 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
433 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
436 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
437 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
438 block size in little-endian order. The trailer consists of
439 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
441 The header is used to detect whether this block has been allocated
442 through these functions, as some low-level libc functions may
443 bypass the malloc hooks. */
445 #define XMALLOC_OVERRUN_CHECK_SIZE 16
446 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
447 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
449 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
450 hold a size_t value and (2) the header size is a multiple of the
451 alignment that Emacs needs for C types and for USE_LSB_TAG. */
452 #define XMALLOC_BASE_ALIGNMENT \
453 alignof (union { long double d; intmax_t i; void *p; })
456 # define XMALLOC_HEADER_ALIGNMENT \
457 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
459 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
461 #define XMALLOC_OVERRUN_SIZE_SIZE \
462 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
463 + XMALLOC_HEADER_ALIGNMENT - 1) \
464 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
465 - XMALLOC_OVERRUN_CHECK_SIZE)
467 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
468 { '\x9a', '\x9b', '\xae', '\xaf',
469 '\xbf', '\xbe', '\xce', '\xcf',
470 '\xea', '\xeb', '\xec', '\xed',
471 '\xdf', '\xde', '\x9c', '\x9d' };
473 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
474 { '\xaa', '\xab', '\xac', '\xad',
475 '\xba', '\xbb', '\xbc', '\xbd',
476 '\xca', '\xcb', '\xcc', '\xcd',
477 '\xda', '\xdb', '\xdc', '\xdd' };
479 /* Insert and extract the block size in the header. */
482 xmalloc_put_size (unsigned char *ptr
, size_t size
)
485 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
487 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
493 xmalloc_get_size (unsigned char *ptr
)
497 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
498 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
507 /* Like malloc, but wraps allocated block with header and trailer. */
510 overrun_check_malloc (size_t size
)
512 register unsigned char *val
;
513 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
516 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
519 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
520 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
521 xmalloc_put_size (val
, size
);
522 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
523 XMALLOC_OVERRUN_CHECK_SIZE
);
529 /* Like realloc, but checks old block for overrun, and wraps new block
530 with header and trailer. */
533 overrun_check_realloc (void *block
, size_t size
)
535 register unsigned char *val
= (unsigned char *) block
;
536 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
540 && memcmp (xmalloc_overrun_check_header
,
541 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
542 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
544 size_t osize
= xmalloc_get_size (val
);
545 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
546 XMALLOC_OVERRUN_CHECK_SIZE
))
548 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
549 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
550 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
553 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
557 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
558 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
559 xmalloc_put_size (val
, size
);
560 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
561 XMALLOC_OVERRUN_CHECK_SIZE
);
566 /* Like free, but checks block for overrun. */
569 overrun_check_free (void *block
)
571 unsigned char *val
= (unsigned char *) block
;
574 && memcmp (xmalloc_overrun_check_header
,
575 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
576 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
578 size_t osize
= xmalloc_get_size (val
);
579 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
580 XMALLOC_OVERRUN_CHECK_SIZE
))
582 #ifdef XMALLOC_CLEAR_FREE_MEMORY
583 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
584 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
586 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
587 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
588 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
598 #define malloc overrun_check_malloc
599 #define realloc overrun_check_realloc
600 #define free overrun_check_free
603 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
604 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
605 If that variable is set, block input while in one of Emacs's memory
606 allocation functions. There should be no need for this debugging
607 option, since signal handlers do not allocate memory, but Emacs
608 formerly allocated memory in signal handlers and this compile-time
609 option remains as a way to help debug the issue should it rear its
611 #ifdef XMALLOC_BLOCK_INPUT_CHECK
612 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
614 malloc_block_input (void)
616 if (block_input_in_memory_allocators
)
620 malloc_unblock_input (void)
622 if (block_input_in_memory_allocators
)
625 # define MALLOC_BLOCK_INPUT malloc_block_input ()
626 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
628 # define MALLOC_BLOCK_INPUT ((void) 0)
629 # define MALLOC_UNBLOCK_INPUT ((void) 0)
632 #define MALLOC_PROBE(size) \
634 if (profiler_memory_running) \
635 malloc_probe (size); \
639 /* Like malloc but check for no memory and block interrupt input.. */
642 xmalloc (size_t size
)
648 MALLOC_UNBLOCK_INPUT
;
656 /* Like the above, but zeroes out the memory just allocated. */
659 xzalloc (size_t size
)
665 MALLOC_UNBLOCK_INPUT
;
669 memset (val
, 0, size
);
674 /* Like realloc but check for no memory and block interrupt input.. */
677 xrealloc (void *block
, size_t size
)
682 /* We must call malloc explicitly when BLOCK is 0, since some
683 reallocs don't do this. */
687 val
= realloc (block
, size
);
688 MALLOC_UNBLOCK_INPUT
;
697 /* Like free but block interrupt input. */
706 MALLOC_UNBLOCK_INPUT
;
707 /* We don't call refill_memory_reserve here
708 because in practice the call in r_alloc_free seems to suffice. */
712 /* Other parts of Emacs pass large int values to allocator functions
713 expecting ptrdiff_t. This is portable in practice, but check it to
715 verify (INT_MAX
<= PTRDIFF_MAX
);
718 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
719 Signal an error on memory exhaustion, and block interrupt input. */
722 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
724 eassert (0 <= nitems
&& 0 < item_size
);
725 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
726 memory_full (SIZE_MAX
);
727 return xmalloc (nitems
* item_size
);
731 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
732 Signal an error on memory exhaustion, and block interrupt input. */
735 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
737 eassert (0 <= nitems
&& 0 < item_size
);
738 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
739 memory_full (SIZE_MAX
);
740 return xrealloc (pa
, nitems
* item_size
);
744 /* Grow PA, which points to an array of *NITEMS items, and return the
745 location of the reallocated array, updating *NITEMS to reflect its
746 new size. The new array will contain at least NITEMS_INCR_MIN more
747 items, but will not contain more than NITEMS_MAX items total.
748 ITEM_SIZE is the size of each item, in bytes.
750 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
751 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
754 If PA is null, then allocate a new array instead of reallocating
757 Block interrupt input as needed. If memory exhaustion occurs, set
758 *NITEMS to zero if PA is null, and signal an error (i.e., do not
761 Thus, to grow an array A without saving its old contents, do
762 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
763 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
764 and signals an error, and later this code is reexecuted and
765 attempts to free A. */
768 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
769 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
771 /* The approximate size to use for initial small allocation
772 requests. This is the largest "small" request for the GNU C
774 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
776 /* If the array is tiny, grow it to about (but no greater than)
777 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
778 ptrdiff_t n
= *nitems
;
779 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
780 ptrdiff_t half_again
= n
>> 1;
781 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
783 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
784 NITEMS_MAX, and what the C language can represent safely. */
785 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
786 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
787 ? nitems_max
: C_language_max
);
788 ptrdiff_t nitems_incr_max
= n_max
- n
;
789 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
791 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
794 if (nitems_incr_max
< incr
)
795 memory_full (SIZE_MAX
);
797 pa
= xrealloc (pa
, n
* item_size
);
803 /* Like strdup, but uses xmalloc. */
806 xstrdup (const char *s
)
808 size_t len
= strlen (s
) + 1;
809 char *p
= xmalloc (len
);
814 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
815 argument is a const pointer. */
818 xputenv (char const *string
)
820 if (putenv ((char *) string
) != 0)
824 /* Unwind for SAFE_ALLOCA */
827 safe_alloca_unwind (Lisp_Object arg
)
829 free_save_value (arg
);
833 /* Return a newly allocated memory block of SIZE bytes, remembering
834 to free it when unwinding. */
836 record_xmalloc (size_t size
)
838 void *p
= xmalloc (size
);
839 record_unwind_protect (safe_alloca_unwind
, make_save_pointer (p
));
844 /* Like malloc but used for allocating Lisp data. NBYTES is the
845 number of bytes to allocate, TYPE describes the intended use of the
846 allocated memory block (for strings, for conses, ...). */
849 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
853 lisp_malloc (size_t nbytes
, enum mem_type type
)
859 #ifdef GC_MALLOC_CHECK
860 allocated_mem_type
= type
;
863 val
= malloc (nbytes
);
866 /* If the memory just allocated cannot be addressed thru a Lisp
867 object's pointer, and it needs to be,
868 that's equivalent to running out of memory. */
869 if (val
&& type
!= MEM_TYPE_NON_LISP
)
872 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
873 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
875 lisp_malloc_loser
= val
;
882 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
883 if (val
&& type
!= MEM_TYPE_NON_LISP
)
884 mem_insert (val
, (char *) val
+ nbytes
, type
);
887 MALLOC_UNBLOCK_INPUT
;
889 memory_full (nbytes
);
890 MALLOC_PROBE (nbytes
);
894 /* Free BLOCK. This must be called to free memory allocated with a
895 call to lisp_malloc. */
898 lisp_free (void *block
)
902 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
903 mem_delete (mem_find (block
));
905 MALLOC_UNBLOCK_INPUT
;
908 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
910 /* The entry point is lisp_align_malloc which returns blocks of at most
911 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
913 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
914 #define USE_POSIX_MEMALIGN 1
917 /* BLOCK_ALIGN has to be a power of 2. */
918 #define BLOCK_ALIGN (1 << 10)
920 /* Padding to leave at the end of a malloc'd block. This is to give
921 malloc a chance to minimize the amount of memory wasted to alignment.
922 It should be tuned to the particular malloc library used.
923 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
924 posix_memalign on the other hand would ideally prefer a value of 4
925 because otherwise, there's 1020 bytes wasted between each ablocks.
926 In Emacs, testing shows that those 1020 can most of the time be
927 efficiently used by malloc to place other objects, so a value of 0 can
928 still preferable unless you have a lot of aligned blocks and virtually
930 #define BLOCK_PADDING 0
931 #define BLOCK_BYTES \
932 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
934 /* Internal data structures and constants. */
936 #define ABLOCKS_SIZE 16
938 /* An aligned block of memory. */
943 char payload
[BLOCK_BYTES
];
944 struct ablock
*next_free
;
946 /* `abase' is the aligned base of the ablocks. */
947 /* It is overloaded to hold the virtual `busy' field that counts
948 the number of used ablock in the parent ablocks.
949 The first ablock has the `busy' field, the others have the `abase'
950 field. To tell the difference, we assume that pointers will have
951 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
952 is used to tell whether the real base of the parent ablocks is `abase'
953 (if not, the word before the first ablock holds a pointer to the
955 struct ablocks
*abase
;
956 /* The padding of all but the last ablock is unused. The padding of
957 the last ablock in an ablocks is not allocated. */
959 char padding
[BLOCK_PADDING
];
963 /* A bunch of consecutive aligned blocks. */
966 struct ablock blocks
[ABLOCKS_SIZE
];
969 /* Size of the block requested from malloc or posix_memalign. */
970 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
972 #define ABLOCK_ABASE(block) \
973 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
974 ? (struct ablocks *)(block) \
977 /* Virtual `busy' field. */
978 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
980 /* Pointer to the (not necessarily aligned) malloc block. */
981 #ifdef USE_POSIX_MEMALIGN
982 #define ABLOCKS_BASE(abase) (abase)
984 #define ABLOCKS_BASE(abase) \
985 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
988 /* The list of free ablock. */
989 static struct ablock
*free_ablock
;
991 /* Allocate an aligned block of nbytes.
992 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
993 smaller or equal to BLOCK_BYTES. */
995 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
998 struct ablocks
*abase
;
1000 eassert (nbytes
<= BLOCK_BYTES
);
1004 #ifdef GC_MALLOC_CHECK
1005 allocated_mem_type
= type
;
1011 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1013 #ifdef DOUG_LEA_MALLOC
1014 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1015 because mapped region contents are not preserved in
1017 mallopt (M_MMAP_MAX
, 0);
1020 #ifdef USE_POSIX_MEMALIGN
1022 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1028 base
= malloc (ABLOCKS_BYTES
);
1029 abase
= ALIGN (base
, BLOCK_ALIGN
);
1034 MALLOC_UNBLOCK_INPUT
;
1035 memory_full (ABLOCKS_BYTES
);
1038 aligned
= (base
== abase
);
1040 ((void**)abase
)[-1] = base
;
1042 #ifdef DOUG_LEA_MALLOC
1043 /* Back to a reasonable maximum of mmap'ed areas. */
1044 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1048 /* If the memory just allocated cannot be addressed thru a Lisp
1049 object's pointer, and it needs to be, that's equivalent to
1050 running out of memory. */
1051 if (type
!= MEM_TYPE_NON_LISP
)
1054 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1055 XSETCONS (tem
, end
);
1056 if ((char *) XCONS (tem
) != end
)
1058 lisp_malloc_loser
= base
;
1060 MALLOC_UNBLOCK_INPUT
;
1061 memory_full (SIZE_MAX
);
1066 /* Initialize the blocks and put them on the free list.
1067 If `base' was not properly aligned, we can't use the last block. */
1068 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1070 abase
->blocks
[i
].abase
= abase
;
1071 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1072 free_ablock
= &abase
->blocks
[i
];
1074 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1076 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1077 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1078 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1079 eassert (ABLOCKS_BASE (abase
) == base
);
1080 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1083 abase
= ABLOCK_ABASE (free_ablock
);
1084 ABLOCKS_BUSY (abase
) =
1085 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1087 free_ablock
= free_ablock
->x
.next_free
;
1089 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1090 if (type
!= MEM_TYPE_NON_LISP
)
1091 mem_insert (val
, (char *) val
+ nbytes
, type
);
1094 MALLOC_UNBLOCK_INPUT
;
1096 MALLOC_PROBE (nbytes
);
1098 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1103 lisp_align_free (void *block
)
1105 struct ablock
*ablock
= block
;
1106 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1109 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1110 mem_delete (mem_find (block
));
1112 /* Put on free list. */
1113 ablock
->x
.next_free
= free_ablock
;
1114 free_ablock
= ablock
;
1115 /* Update busy count. */
1116 ABLOCKS_BUSY (abase
)
1117 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1119 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1120 { /* All the blocks are free. */
1121 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1122 struct ablock
**tem
= &free_ablock
;
1123 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1127 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1130 *tem
= (*tem
)->x
.next_free
;
1133 tem
= &(*tem
)->x
.next_free
;
1135 eassert ((aligned
& 1) == aligned
);
1136 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1137 #ifdef USE_POSIX_MEMALIGN
1138 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1140 free (ABLOCKS_BASE (abase
));
1142 MALLOC_UNBLOCK_INPUT
;
1146 /***********************************************************************
1148 ***********************************************************************/
1150 /* Number of intervals allocated in an interval_block structure.
1151 The 1020 is 1024 minus malloc overhead. */
1153 #define INTERVAL_BLOCK_SIZE \
1154 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1156 /* Intervals are allocated in chunks in form of an interval_block
1159 struct interval_block
1161 /* Place `intervals' first, to preserve alignment. */
1162 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1163 struct interval_block
*next
;
1166 /* Current interval block. Its `next' pointer points to older
1169 static struct interval_block
*interval_block
;
1171 /* Index in interval_block above of the next unused interval
1174 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1176 /* Number of free and live intervals. */
1178 static EMACS_INT total_free_intervals
, total_intervals
;
1180 /* List of free intervals. */
1182 static INTERVAL interval_free_list
;
1184 /* Return a new interval. */
1187 make_interval (void)
1193 if (interval_free_list
)
1195 val
= interval_free_list
;
1196 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1200 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1202 struct interval_block
*newi
1203 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1205 newi
->next
= interval_block
;
1206 interval_block
= newi
;
1207 interval_block_index
= 0;
1208 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1210 val
= &interval_block
->intervals
[interval_block_index
++];
1213 MALLOC_UNBLOCK_INPUT
;
1215 consing_since_gc
+= sizeof (struct interval
);
1217 total_free_intervals
--;
1218 RESET_INTERVAL (val
);
1224 /* Mark Lisp objects in interval I. */
1227 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1229 /* Intervals should never be shared. So, if extra internal checking is
1230 enabled, GC aborts if it seems to have visited an interval twice. */
1231 eassert (!i
->gcmarkbit
);
1233 mark_object (i
->plist
);
1236 /* Mark the interval tree rooted in I. */
1238 #define MARK_INTERVAL_TREE(i) \
1240 if (i && !i->gcmarkbit) \
1241 traverse_intervals_noorder (i, mark_interval, Qnil); \
1244 /***********************************************************************
1246 ***********************************************************************/
1248 /* Lisp_Strings are allocated in string_block structures. When a new
1249 string_block is allocated, all the Lisp_Strings it contains are
1250 added to a free-list string_free_list. When a new Lisp_String is
1251 needed, it is taken from that list. During the sweep phase of GC,
1252 string_blocks that are entirely free are freed, except two which
1255 String data is allocated from sblock structures. Strings larger
1256 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1257 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1259 Sblocks consist internally of sdata structures, one for each
1260 Lisp_String. The sdata structure points to the Lisp_String it
1261 belongs to. The Lisp_String points back to the `u.data' member of
1262 its sdata structure.
1264 When a Lisp_String is freed during GC, it is put back on
1265 string_free_list, and its `data' member and its sdata's `string'
1266 pointer is set to null. The size of the string is recorded in the
1267 `u.nbytes' member of the sdata. So, sdata structures that are no
1268 longer used, can be easily recognized, and it's easy to compact the
1269 sblocks of small strings which we do in compact_small_strings. */
1271 /* Size in bytes of an sblock structure used for small strings. This
1272 is 8192 minus malloc overhead. */
1274 #define SBLOCK_SIZE 8188
1276 /* Strings larger than this are considered large strings. String data
1277 for large strings is allocated from individual sblocks. */
1279 #define LARGE_STRING_BYTES 1024
1281 /* Structure describing string memory sub-allocated from an sblock.
1282 This is where the contents of Lisp strings are stored. */
1286 /* Back-pointer to the string this sdata belongs to. If null, this
1287 structure is free, and the NBYTES member of the union below
1288 contains the string's byte size (the same value that STRING_BYTES
1289 would return if STRING were non-null). If non-null, STRING_BYTES
1290 (STRING) is the size of the data, and DATA contains the string's
1292 struct Lisp_String
*string
;
1294 #ifdef GC_CHECK_STRING_BYTES
1297 unsigned char data
[1];
1299 #define SDATA_NBYTES(S) (S)->nbytes
1300 #define SDATA_DATA(S) (S)->data
1301 #define SDATA_SELECTOR(member) member
1303 #else /* not GC_CHECK_STRING_BYTES */
1307 /* When STRING is non-null. */
1308 unsigned char data
[1];
1310 /* When STRING is null. */
1314 #define SDATA_NBYTES(S) (S)->u.nbytes
1315 #define SDATA_DATA(S) (S)->u.data
1316 #define SDATA_SELECTOR(member) u.member
1318 #endif /* not GC_CHECK_STRING_BYTES */
1320 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1324 /* Structure describing a block of memory which is sub-allocated to
1325 obtain string data memory for strings. Blocks for small strings
1326 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1327 as large as needed. */
1332 struct sblock
*next
;
1334 /* Pointer to the next free sdata block. This points past the end
1335 of the sblock if there isn't any space left in this block. */
1336 struct sdata
*next_free
;
1338 /* Start of data. */
1339 struct sdata first_data
;
1342 /* Number of Lisp strings in a string_block structure. The 1020 is
1343 1024 minus malloc overhead. */
1345 #define STRING_BLOCK_SIZE \
1346 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1348 /* Structure describing a block from which Lisp_String structures
1353 /* Place `strings' first, to preserve alignment. */
1354 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1355 struct string_block
*next
;
1358 /* Head and tail of the list of sblock structures holding Lisp string
1359 data. We always allocate from current_sblock. The NEXT pointers
1360 in the sblock structures go from oldest_sblock to current_sblock. */
1362 static struct sblock
*oldest_sblock
, *current_sblock
;
1364 /* List of sblocks for large strings. */
1366 static struct sblock
*large_sblocks
;
1368 /* List of string_block structures. */
1370 static struct string_block
*string_blocks
;
1372 /* Free-list of Lisp_Strings. */
1374 static struct Lisp_String
*string_free_list
;
1376 /* Number of live and free Lisp_Strings. */
1378 static EMACS_INT total_strings
, total_free_strings
;
1380 /* Number of bytes used by live strings. */
1382 static EMACS_INT total_string_bytes
;
1384 /* Given a pointer to a Lisp_String S which is on the free-list
1385 string_free_list, return a pointer to its successor in the
1388 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1390 /* Return a pointer to the sdata structure belonging to Lisp string S.
1391 S must be live, i.e. S->data must not be null. S->data is actually
1392 a pointer to the `u.data' member of its sdata structure; the
1393 structure starts at a constant offset in front of that. */
1395 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1398 #ifdef GC_CHECK_STRING_OVERRUN
1400 /* We check for overrun in string data blocks by appending a small
1401 "cookie" after each allocated string data block, and check for the
1402 presence of this cookie during GC. */
1404 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1405 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1406 { '\xde', '\xad', '\xbe', '\xef' };
1409 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1412 /* Value is the size of an sdata structure large enough to hold NBYTES
1413 bytes of string data. The value returned includes a terminating
1414 NUL byte, the size of the sdata structure, and padding. */
1416 #ifdef GC_CHECK_STRING_BYTES
1418 #define SDATA_SIZE(NBYTES) \
1419 ((SDATA_DATA_OFFSET \
1421 + sizeof (ptrdiff_t) - 1) \
1422 & ~(sizeof (ptrdiff_t) - 1))
1424 #else /* not GC_CHECK_STRING_BYTES */
1426 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1427 less than the size of that member. The 'max' is not needed when
1428 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1429 alignment code reserves enough space. */
1431 #define SDATA_SIZE(NBYTES) \
1432 ((SDATA_DATA_OFFSET \
1433 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1435 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1437 + sizeof (ptrdiff_t) - 1) \
1438 & ~(sizeof (ptrdiff_t) - 1))
1440 #endif /* not GC_CHECK_STRING_BYTES */
1442 /* Extra bytes to allocate for each string. */
1444 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1446 /* Exact bound on the number of bytes in a string, not counting the
1447 terminating null. A string cannot contain more bytes than
1448 STRING_BYTES_BOUND, nor can it be so long that the size_t
1449 arithmetic in allocate_string_data would overflow while it is
1450 calculating a value to be passed to malloc. */
1451 static ptrdiff_t const STRING_BYTES_MAX
=
1452 min (STRING_BYTES_BOUND
,
1453 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1455 - offsetof (struct sblock
, first_data
)
1456 - SDATA_DATA_OFFSET
)
1457 & ~(sizeof (EMACS_INT
) - 1)));
1459 /* Initialize string allocation. Called from init_alloc_once. */
1464 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1465 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1469 #ifdef GC_CHECK_STRING_BYTES
1471 static int check_string_bytes_count
;
1473 /* Like STRING_BYTES, but with debugging check. Can be
1474 called during GC, so pay attention to the mark bit. */
1477 string_bytes (struct Lisp_String
*s
)
1480 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1482 if (!PURE_POINTER_P (s
)
1484 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1489 /* Check validity of Lisp strings' string_bytes member in B. */
1492 check_sblock (struct sblock
*b
)
1494 struct sdata
*from
, *end
, *from_end
;
1498 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1500 /* Compute the next FROM here because copying below may
1501 overwrite data we need to compute it. */
1504 /* Check that the string size recorded in the string is the
1505 same as the one recorded in the sdata structure. */
1506 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1507 : SDATA_NBYTES (from
));
1508 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1513 /* Check validity of Lisp strings' string_bytes member. ALL_P
1514 means check all strings, otherwise check only most
1515 recently allocated strings. Used for hunting a bug. */
1518 check_string_bytes (bool all_p
)
1524 for (b
= large_sblocks
; b
; b
= b
->next
)
1526 struct Lisp_String
*s
= b
->first_data
.string
;
1531 for (b
= oldest_sblock
; b
; b
= b
->next
)
1534 else if (current_sblock
)
1535 check_sblock (current_sblock
);
1538 #else /* not GC_CHECK_STRING_BYTES */
1540 #define check_string_bytes(all) ((void) 0)
1542 #endif /* GC_CHECK_STRING_BYTES */
1544 #ifdef GC_CHECK_STRING_FREE_LIST
1546 /* Walk through the string free list looking for bogus next pointers.
1547 This may catch buffer overrun from a previous string. */
1550 check_string_free_list (void)
1552 struct Lisp_String
*s
;
1554 /* Pop a Lisp_String off the free-list. */
1555 s
= string_free_list
;
1558 if ((uintptr_t) s
< 1024)
1560 s
= NEXT_FREE_LISP_STRING (s
);
1564 #define check_string_free_list()
1567 /* Return a new Lisp_String. */
1569 static struct Lisp_String
*
1570 allocate_string (void)
1572 struct Lisp_String
*s
;
1576 /* If the free-list is empty, allocate a new string_block, and
1577 add all the Lisp_Strings in it to the free-list. */
1578 if (string_free_list
== NULL
)
1580 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1583 b
->next
= string_blocks
;
1586 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1589 /* Every string on a free list should have NULL data pointer. */
1591 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1592 string_free_list
= s
;
1595 total_free_strings
+= STRING_BLOCK_SIZE
;
1598 check_string_free_list ();
1600 /* Pop a Lisp_String off the free-list. */
1601 s
= string_free_list
;
1602 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1604 MALLOC_UNBLOCK_INPUT
;
1606 --total_free_strings
;
1609 consing_since_gc
+= sizeof *s
;
1611 #ifdef GC_CHECK_STRING_BYTES
1612 if (!noninteractive
)
1614 if (++check_string_bytes_count
== 200)
1616 check_string_bytes_count
= 0;
1617 check_string_bytes (1);
1620 check_string_bytes (0);
1622 #endif /* GC_CHECK_STRING_BYTES */
1628 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1629 plus a NUL byte at the end. Allocate an sdata structure for S, and
1630 set S->data to its `u.data' member. Store a NUL byte at the end of
1631 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1632 S->data if it was initially non-null. */
1635 allocate_string_data (struct Lisp_String
*s
,
1636 EMACS_INT nchars
, EMACS_INT nbytes
)
1638 struct sdata
*data
, *old_data
;
1640 ptrdiff_t needed
, old_nbytes
;
1642 if (STRING_BYTES_MAX
< nbytes
)
1645 /* Determine the number of bytes needed to store NBYTES bytes
1647 needed
= SDATA_SIZE (nbytes
);
1650 old_data
= SDATA_OF_STRING (s
);
1651 old_nbytes
= STRING_BYTES (s
);
1658 if (nbytes
> LARGE_STRING_BYTES
)
1660 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1662 #ifdef DOUG_LEA_MALLOC
1663 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1664 because mapped region contents are not preserved in
1667 In case you think of allowing it in a dumped Emacs at the
1668 cost of not being able to re-dump, there's another reason:
1669 mmap'ed data typically have an address towards the top of the
1670 address space, which won't fit into an EMACS_INT (at least on
1671 32-bit systems with the current tagging scheme). --fx */
1672 mallopt (M_MMAP_MAX
, 0);
1675 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1677 #ifdef DOUG_LEA_MALLOC
1678 /* Back to a reasonable maximum of mmap'ed areas. */
1679 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1682 b
->next_free
= &b
->first_data
;
1683 b
->first_data
.string
= NULL
;
1684 b
->next
= large_sblocks
;
1687 else if (current_sblock
== NULL
1688 || (((char *) current_sblock
+ SBLOCK_SIZE
1689 - (char *) current_sblock
->next_free
)
1690 < (needed
+ GC_STRING_EXTRA
)))
1692 /* Not enough room in the current sblock. */
1693 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1694 b
->next_free
= &b
->first_data
;
1695 b
->first_data
.string
= NULL
;
1699 current_sblock
->next
= b
;
1707 data
= b
->next_free
;
1708 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1710 MALLOC_UNBLOCK_INPUT
;
1713 s
->data
= SDATA_DATA (data
);
1714 #ifdef GC_CHECK_STRING_BYTES
1715 SDATA_NBYTES (data
) = nbytes
;
1718 s
->size_byte
= nbytes
;
1719 s
->data
[nbytes
] = '\0';
1720 #ifdef GC_CHECK_STRING_OVERRUN
1721 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1722 GC_STRING_OVERRUN_COOKIE_SIZE
);
1725 /* Note that Faset may call to this function when S has already data
1726 assigned. In this case, mark data as free by setting it's string
1727 back-pointer to null, and record the size of the data in it. */
1730 SDATA_NBYTES (old_data
) = old_nbytes
;
1731 old_data
->string
= NULL
;
1734 consing_since_gc
+= needed
;
1738 /* Sweep and compact strings. */
1741 sweep_strings (void)
1743 struct string_block
*b
, *next
;
1744 struct string_block
*live_blocks
= NULL
;
1746 string_free_list
= NULL
;
1747 total_strings
= total_free_strings
= 0;
1748 total_string_bytes
= 0;
1750 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1751 for (b
= string_blocks
; b
; b
= next
)
1754 struct Lisp_String
*free_list_before
= string_free_list
;
1758 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1760 struct Lisp_String
*s
= b
->strings
+ i
;
1764 /* String was not on free-list before. */
1765 if (STRING_MARKED_P (s
))
1767 /* String is live; unmark it and its intervals. */
1770 /* Do not use string_(set|get)_intervals here. */
1771 s
->intervals
= balance_intervals (s
->intervals
);
1774 total_string_bytes
+= STRING_BYTES (s
);
1778 /* String is dead. Put it on the free-list. */
1779 struct sdata
*data
= SDATA_OF_STRING (s
);
1781 /* Save the size of S in its sdata so that we know
1782 how large that is. Reset the sdata's string
1783 back-pointer so that we know it's free. */
1784 #ifdef GC_CHECK_STRING_BYTES
1785 if (string_bytes (s
) != SDATA_NBYTES (data
))
1788 data
->u
.nbytes
= STRING_BYTES (s
);
1790 data
->string
= NULL
;
1792 /* Reset the strings's `data' member so that we
1796 /* Put the string on the free-list. */
1797 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1798 string_free_list
= s
;
1804 /* S was on the free-list before. Put it there again. */
1805 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1806 string_free_list
= s
;
1811 /* Free blocks that contain free Lisp_Strings only, except
1812 the first two of them. */
1813 if (nfree
== STRING_BLOCK_SIZE
1814 && total_free_strings
> STRING_BLOCK_SIZE
)
1817 string_free_list
= free_list_before
;
1821 total_free_strings
+= nfree
;
1822 b
->next
= live_blocks
;
1827 check_string_free_list ();
1829 string_blocks
= live_blocks
;
1830 free_large_strings ();
1831 compact_small_strings ();
1833 check_string_free_list ();
1837 /* Free dead large strings. */
1840 free_large_strings (void)
1842 struct sblock
*b
, *next
;
1843 struct sblock
*live_blocks
= NULL
;
1845 for (b
= large_sblocks
; b
; b
= next
)
1849 if (b
->first_data
.string
== NULL
)
1853 b
->next
= live_blocks
;
1858 large_sblocks
= live_blocks
;
1862 /* Compact data of small strings. Free sblocks that don't contain
1863 data of live strings after compaction. */
1866 compact_small_strings (void)
1868 struct sblock
*b
, *tb
, *next
;
1869 struct sdata
*from
, *to
, *end
, *tb_end
;
1870 struct sdata
*to_end
, *from_end
;
1872 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1873 to, and TB_END is the end of TB. */
1875 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1876 to
= &tb
->first_data
;
1878 /* Step through the blocks from the oldest to the youngest. We
1879 expect that old blocks will stabilize over time, so that less
1880 copying will happen this way. */
1881 for (b
= oldest_sblock
; b
; b
= b
->next
)
1884 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1886 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1888 /* Compute the next FROM here because copying below may
1889 overwrite data we need to compute it. */
1891 struct Lisp_String
*s
= from
->string
;
1893 #ifdef GC_CHECK_STRING_BYTES
1894 /* Check that the string size recorded in the string is the
1895 same as the one recorded in the sdata structure. */
1896 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1898 #endif /* GC_CHECK_STRING_BYTES */
1900 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1901 eassert (nbytes
<= LARGE_STRING_BYTES
);
1903 nbytes
= SDATA_SIZE (nbytes
);
1904 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1906 #ifdef GC_CHECK_STRING_OVERRUN
1907 if (memcmp (string_overrun_cookie
,
1908 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1909 GC_STRING_OVERRUN_COOKIE_SIZE
))
1913 /* Non-NULL S means it's alive. Copy its data. */
1916 /* If TB is full, proceed with the next sblock. */
1917 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1918 if (to_end
> tb_end
)
1922 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1923 to
= &tb
->first_data
;
1924 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1927 /* Copy, and update the string's `data' pointer. */
1930 eassert (tb
!= b
|| to
< from
);
1931 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1932 to
->string
->data
= SDATA_DATA (to
);
1935 /* Advance past the sdata we copied to. */
1941 /* The rest of the sblocks following TB don't contain live data, so
1942 we can free them. */
1943 for (b
= tb
->next
; b
; b
= next
)
1951 current_sblock
= tb
;
1955 string_overflow (void)
1957 error ("Maximum string size exceeded");
1960 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1961 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1962 LENGTH must be an integer.
1963 INIT must be an integer that represents a character. */)
1964 (Lisp_Object length
, Lisp_Object init
)
1966 register Lisp_Object val
;
1967 register unsigned char *p
, *end
;
1971 CHECK_NATNUM (length
);
1972 CHECK_CHARACTER (init
);
1974 c
= XFASTINT (init
);
1975 if (ASCII_CHAR_P (c
))
1977 nbytes
= XINT (length
);
1978 val
= make_uninit_string (nbytes
);
1980 end
= p
+ SCHARS (val
);
1986 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1987 int len
= CHAR_STRING (c
, str
);
1988 EMACS_INT string_len
= XINT (length
);
1990 if (string_len
> STRING_BYTES_MAX
/ len
)
1992 nbytes
= len
* string_len
;
1993 val
= make_uninit_multibyte_string (string_len
, nbytes
);
1998 memcpy (p
, str
, len
);
2008 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2009 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2010 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2011 (Lisp_Object length
, Lisp_Object init
)
2013 register Lisp_Object val
;
2014 struct Lisp_Bool_Vector
*p
;
2015 ptrdiff_t length_in_chars
;
2016 EMACS_INT length_in_elts
;
2018 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2021 CHECK_NATNUM (length
);
2023 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2025 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2027 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2029 /* No Lisp_Object to trace in there. */
2030 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2032 p
= XBOOL_VECTOR (val
);
2033 p
->size
= XFASTINT (length
);
2035 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2036 / BOOL_VECTOR_BITS_PER_CHAR
);
2037 if (length_in_chars
)
2039 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2041 /* Clear any extraneous bits in the last byte. */
2042 p
->data
[length_in_chars
- 1]
2043 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2050 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2051 of characters from the contents. This string may be unibyte or
2052 multibyte, depending on the contents. */
2055 make_string (const char *contents
, ptrdiff_t nbytes
)
2057 register Lisp_Object val
;
2058 ptrdiff_t nchars
, multibyte_nbytes
;
2060 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2061 &nchars
, &multibyte_nbytes
);
2062 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2063 /* CONTENTS contains no multibyte sequences or contains an invalid
2064 multibyte sequence. We must make unibyte string. */
2065 val
= make_unibyte_string (contents
, nbytes
);
2067 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2072 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2075 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2077 register Lisp_Object val
;
2078 val
= make_uninit_string (length
);
2079 memcpy (SDATA (val
), contents
, length
);
2084 /* Make a multibyte string from NCHARS characters occupying NBYTES
2085 bytes at CONTENTS. */
2088 make_multibyte_string (const char *contents
,
2089 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2091 register Lisp_Object val
;
2092 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2093 memcpy (SDATA (val
), contents
, nbytes
);
2098 /* Make a string from NCHARS characters occupying NBYTES bytes at
2099 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2102 make_string_from_bytes (const char *contents
,
2103 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2105 register Lisp_Object val
;
2106 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2107 memcpy (SDATA (val
), contents
, nbytes
);
2108 if (SBYTES (val
) == SCHARS (val
))
2109 STRING_SET_UNIBYTE (val
);
2114 /* Make a string from NCHARS characters occupying NBYTES bytes at
2115 CONTENTS. The argument MULTIBYTE controls whether to label the
2116 string as multibyte. If NCHARS is negative, it counts the number of
2117 characters by itself. */
2120 make_specified_string (const char *contents
,
2121 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2128 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2133 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2134 memcpy (SDATA (val
), contents
, nbytes
);
2136 STRING_SET_UNIBYTE (val
);
2141 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2142 occupying LENGTH bytes. */
2145 make_uninit_string (EMACS_INT length
)
2150 return empty_unibyte_string
;
2151 val
= make_uninit_multibyte_string (length
, length
);
2152 STRING_SET_UNIBYTE (val
);
2157 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2158 which occupy NBYTES bytes. */
2161 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2164 struct Lisp_String
*s
;
2169 return empty_multibyte_string
;
2171 s
= allocate_string ();
2172 s
->intervals
= NULL
;
2173 allocate_string_data (s
, nchars
, nbytes
);
2174 XSETSTRING (string
, s
);
2175 string_chars_consed
+= nbytes
;
2179 /* Print arguments to BUF according to a FORMAT, then return
2180 a Lisp_String initialized with the data from BUF. */
2183 make_formatted_string (char *buf
, const char *format
, ...)
2188 va_start (ap
, format
);
2189 length
= vsprintf (buf
, format
, ap
);
2191 return make_string (buf
, length
);
2195 /***********************************************************************
2197 ***********************************************************************/
2199 /* We store float cells inside of float_blocks, allocating a new
2200 float_block with malloc whenever necessary. Float cells reclaimed
2201 by GC are put on a free list to be reallocated before allocating
2202 any new float cells from the latest float_block. */
2204 #define FLOAT_BLOCK_SIZE \
2205 (((BLOCK_BYTES - sizeof (struct float_block *) \
2206 /* The compiler might add padding at the end. */ \
2207 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2208 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2210 #define GETMARKBIT(block,n) \
2211 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2212 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2215 #define SETMARKBIT(block,n) \
2216 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2217 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2219 #define UNSETMARKBIT(block,n) \
2220 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2221 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2223 #define FLOAT_BLOCK(fptr) \
2224 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2226 #define FLOAT_INDEX(fptr) \
2227 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2231 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2232 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2233 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2234 struct float_block
*next
;
2237 #define FLOAT_MARKED_P(fptr) \
2238 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2240 #define FLOAT_MARK(fptr) \
2241 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2243 #define FLOAT_UNMARK(fptr) \
2244 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2246 /* Current float_block. */
2248 static struct float_block
*float_block
;
2250 /* Index of first unused Lisp_Float in the current float_block. */
2252 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2254 /* Free-list of Lisp_Floats. */
2256 static struct Lisp_Float
*float_free_list
;
2258 /* Return a new float object with value FLOAT_VALUE. */
2261 make_float (double float_value
)
2263 register Lisp_Object val
;
2267 if (float_free_list
)
2269 /* We use the data field for chaining the free list
2270 so that we won't use the same field that has the mark bit. */
2271 XSETFLOAT (val
, float_free_list
);
2272 float_free_list
= float_free_list
->u
.chain
;
2276 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2278 struct float_block
*new
2279 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2280 new->next
= float_block
;
2281 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2283 float_block_index
= 0;
2284 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2286 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2287 float_block_index
++;
2290 MALLOC_UNBLOCK_INPUT
;
2292 XFLOAT_INIT (val
, float_value
);
2293 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2294 consing_since_gc
+= sizeof (struct Lisp_Float
);
2296 total_free_floats
--;
2302 /***********************************************************************
2304 ***********************************************************************/
2306 /* We store cons cells inside of cons_blocks, allocating a new
2307 cons_block with malloc whenever necessary. Cons cells reclaimed by
2308 GC are put on a free list to be reallocated before allocating
2309 any new cons cells from the latest cons_block. */
2311 #define CONS_BLOCK_SIZE \
2312 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2313 /* The compiler might add padding at the end. */ \
2314 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2315 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2317 #define CONS_BLOCK(fptr) \
2318 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2320 #define CONS_INDEX(fptr) \
2321 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2325 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2326 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2327 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2328 struct cons_block
*next
;
2331 #define CONS_MARKED_P(fptr) \
2332 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2334 #define CONS_MARK(fptr) \
2335 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2337 #define CONS_UNMARK(fptr) \
2338 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2340 /* Current cons_block. */
2342 static struct cons_block
*cons_block
;
2344 /* Index of first unused Lisp_Cons in the current block. */
2346 static int cons_block_index
= CONS_BLOCK_SIZE
;
2348 /* Free-list of Lisp_Cons structures. */
2350 static struct Lisp_Cons
*cons_free_list
;
2352 /* Explicitly free a cons cell by putting it on the free-list. */
2355 free_cons (struct Lisp_Cons
*ptr
)
2357 ptr
->u
.chain
= cons_free_list
;
2361 cons_free_list
= ptr
;
2362 consing_since_gc
-= sizeof *ptr
;
2363 total_free_conses
++;
2366 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2367 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2368 (Lisp_Object car
, Lisp_Object cdr
)
2370 register Lisp_Object val
;
2376 /* We use the cdr for chaining the free list
2377 so that we won't use the same field that has the mark bit. */
2378 XSETCONS (val
, cons_free_list
);
2379 cons_free_list
= cons_free_list
->u
.chain
;
2383 if (cons_block_index
== CONS_BLOCK_SIZE
)
2385 struct cons_block
*new
2386 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2387 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2388 new->next
= cons_block
;
2390 cons_block_index
= 0;
2391 total_free_conses
+= CONS_BLOCK_SIZE
;
2393 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2397 MALLOC_UNBLOCK_INPUT
;
2401 eassert (!CONS_MARKED_P (XCONS (val
)));
2402 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2403 total_free_conses
--;
2404 cons_cells_consed
++;
2408 #ifdef GC_CHECK_CONS_LIST
2409 /* Get an error now if there's any junk in the cons free list. */
2411 check_cons_list (void)
2413 struct Lisp_Cons
*tail
= cons_free_list
;
2416 tail
= tail
->u
.chain
;
2420 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2423 list1 (Lisp_Object arg1
)
2425 return Fcons (arg1
, Qnil
);
2429 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2431 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2436 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2438 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2443 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2445 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2450 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2452 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2453 Fcons (arg5
, Qnil
)))));
2456 /* Make a list of COUNT Lisp_Objects, where ARG is the
2457 first one. Allocate conses from pure space if TYPE
2458 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2461 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2465 Lisp_Object val
, *objp
;
2467 /* Change to SAFE_ALLOCA if you hit this eassert. */
2468 eassert (count
<= MAX_ALLOCA
/ word_size
);
2470 objp
= alloca (count
* word_size
);
2473 for (i
= 1; i
< count
; i
++)
2474 objp
[i
] = va_arg (ap
, Lisp_Object
);
2477 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2479 if (type
== CONSTYPE_PURE
)
2480 val
= pure_cons (objp
[i
], val
);
2481 else if (type
== CONSTYPE_HEAP
)
2482 val
= Fcons (objp
[i
], val
);
2489 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2490 doc
: /* Return a newly created list with specified arguments as elements.
2491 Any number of arguments, even zero arguments, are allowed.
2492 usage: (list &rest OBJECTS) */)
2493 (ptrdiff_t nargs
, Lisp_Object
*args
)
2495 register Lisp_Object val
;
2501 val
= Fcons (args
[nargs
], val
);
2507 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2508 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2509 (register Lisp_Object length
, Lisp_Object init
)
2511 register Lisp_Object val
;
2512 register EMACS_INT size
;
2514 CHECK_NATNUM (length
);
2515 size
= XFASTINT (length
);
2520 val
= Fcons (init
, val
);
2525 val
= Fcons (init
, val
);
2530 val
= Fcons (init
, val
);
2535 val
= Fcons (init
, val
);
2540 val
= Fcons (init
, val
);
2555 /***********************************************************************
2557 ***********************************************************************/
2559 /* This value is balanced well enough to avoid too much internal overhead
2560 for the most common cases; it's not required to be a power of two, but
2561 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2563 #define VECTOR_BLOCK_SIZE 4096
2565 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2568 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2571 /* ROUNDUP_SIZE must be a power of 2. */
2572 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2574 /* Verify assumptions described above. */
2575 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2576 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2578 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2580 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2582 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2584 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2586 /* Size of the minimal vector allocated from block. */
2588 #define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2590 /* Size of the largest vector allocated from block. */
2592 #define VBLOCK_BYTES_MAX \
2593 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2595 /* We maintain one free list for each possible block-allocated
2596 vector size, and this is the number of free lists we have. */
2598 #define VECTOR_MAX_FREE_LIST_INDEX \
2599 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2601 /* Common shortcut to advance vector pointer over a block data. */
2603 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2605 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2607 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2609 /* Get and set the next field in block-allocated vectorlike objects on
2610 the free list. Doing it this way respects C's aliasing rules.
2611 We could instead make 'contents' a union, but that would mean
2612 changes everywhere that the code uses 'contents'. */
2613 static struct Lisp_Vector
*
2614 next_in_free_list (struct Lisp_Vector
*v
)
2616 intptr_t i
= XLI (v
->contents
[0]);
2617 return (struct Lisp_Vector
*) i
;
2620 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2622 v
->contents
[0] = XIL ((intptr_t) next
);
2625 /* Common shortcut to setup vector on a free list. */
2627 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2629 (tmp) = ((nbytes - header_size) / word_size); \
2630 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2631 eassert ((nbytes) % roundup_size == 0); \
2632 (tmp) = VINDEX (nbytes); \
2633 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2634 set_next_in_free_list (v, vector_free_lists[tmp]); \
2635 vector_free_lists[tmp] = (v); \
2636 total_free_vector_slots += (nbytes) / word_size; \
2639 /* This internal type is used to maintain the list of large vectors
2640 which are allocated at their own, e.g. outside of vector blocks. */
2645 struct large_vector
*vector
;
2647 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2648 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2651 struct Lisp_Vector v
;
2654 /* This internal type is used to maintain an underlying storage
2655 for small vectors. */
2659 char data
[VECTOR_BLOCK_BYTES
];
2660 struct vector_block
*next
;
2663 /* Chain of vector blocks. */
2665 static struct vector_block
*vector_blocks
;
2667 /* Vector free lists, where NTH item points to a chain of free
2668 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2670 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2672 /* Singly-linked list of large vectors. */
2674 static struct large_vector
*large_vectors
;
2676 /* The only vector with 0 slots, allocated from pure space. */
2678 Lisp_Object zero_vector
;
2680 /* Number of live vectors. */
2682 static EMACS_INT total_vectors
;
2684 /* Total size of live and free vectors, in Lisp_Object units. */
2686 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2688 /* Get a new vector block. */
2690 static struct vector_block
*
2691 allocate_vector_block (void)
2693 struct vector_block
*block
= xmalloc (sizeof *block
);
2695 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2696 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2697 MEM_TYPE_VECTOR_BLOCK
);
2700 block
->next
= vector_blocks
;
2701 vector_blocks
= block
;
2705 /* Called once to initialize vector allocation. */
2710 zero_vector
= make_pure_vector (0);
2713 /* Allocate vector from a vector block. */
2715 static struct Lisp_Vector
*
2716 allocate_vector_from_block (size_t nbytes
)
2718 struct Lisp_Vector
*vector
;
2719 struct vector_block
*block
;
2720 size_t index
, restbytes
;
2722 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2723 eassert (nbytes
% roundup_size
== 0);
2725 /* First, try to allocate from a free list
2726 containing vectors of the requested size. */
2727 index
= VINDEX (nbytes
);
2728 if (vector_free_lists
[index
])
2730 vector
= vector_free_lists
[index
];
2731 vector_free_lists
[index
] = next_in_free_list (vector
);
2732 total_free_vector_slots
-= nbytes
/ word_size
;
2736 /* Next, check free lists containing larger vectors. Since
2737 we will split the result, we should have remaining space
2738 large enough to use for one-slot vector at least. */
2739 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2740 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2741 if (vector_free_lists
[index
])
2743 /* This vector is larger than requested. */
2744 vector
= vector_free_lists
[index
];
2745 vector_free_lists
[index
] = next_in_free_list (vector
);
2746 total_free_vector_slots
-= nbytes
/ word_size
;
2748 /* Excess bytes are used for the smaller vector,
2749 which should be set on an appropriate free list. */
2750 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2751 eassert (restbytes
% roundup_size
== 0);
2752 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2756 /* Finally, need a new vector block. */
2757 block
= allocate_vector_block ();
2759 /* New vector will be at the beginning of this block. */
2760 vector
= (struct Lisp_Vector
*) block
->data
;
2762 /* If the rest of space from this block is large enough
2763 for one-slot vector at least, set up it on a free list. */
2764 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2765 if (restbytes
>= VBLOCK_BYTES_MIN
)
2767 eassert (restbytes
% roundup_size
== 0);
2768 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2773 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2775 #define VECTOR_IN_BLOCK(vector, block) \
2776 ((char *) (vector) <= (block)->data \
2777 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2779 /* Return the memory footprint of V in bytes. */
2782 vector_nbytes (struct Lisp_Vector
*v
)
2784 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2786 if (size
& PSEUDOVECTOR_FLAG
)
2788 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2789 size
= (bool_header_size
2790 + (((struct Lisp_Bool_Vector
*) v
)->size
2791 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2792 / BOOL_VECTOR_BITS_PER_CHAR
);
2795 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2796 + ((size
& PSEUDOVECTOR_REST_MASK
)
2797 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2800 size
= header_size
+ size
* word_size
;
2801 return vroundup (size
);
2804 /* Reclaim space used by unmarked vectors. */
2807 sweep_vectors (void)
2809 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2810 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2811 struct Lisp_Vector
*vector
, *next
;
2813 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2814 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2816 /* Looking through vector blocks. */
2818 for (block
= vector_blocks
; block
; block
= *bprev
)
2820 bool free_this_block
= 0;
2823 for (vector
= (struct Lisp_Vector
*) block
->data
;
2824 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2826 if (VECTOR_MARKED_P (vector
))
2828 VECTOR_UNMARK (vector
);
2830 nbytes
= vector_nbytes (vector
);
2831 total_vector_slots
+= nbytes
/ word_size
;
2832 next
= ADVANCE (vector
, nbytes
);
2836 ptrdiff_t total_bytes
;
2838 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_THREAD
))
2839 finalize_one_thread ((struct thread_state
*) vector
);
2840 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_MUTEX
))
2841 finalize_one_mutex ((struct Lisp_Mutex
*) vector
);
2842 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_CONDVAR
))
2843 finalize_one_condvar ((struct Lisp_CondVar
*) vector
);
2845 nbytes
= vector_nbytes (vector
);
2846 total_bytes
= nbytes
;
2847 next
= ADVANCE (vector
, nbytes
);
2849 /* While NEXT is not marked, try to coalesce with VECTOR,
2850 thus making VECTOR of the largest possible size. */
2852 while (VECTOR_IN_BLOCK (next
, block
))
2854 if (VECTOR_MARKED_P (next
))
2856 nbytes
= vector_nbytes (next
);
2857 total_bytes
+= nbytes
;
2858 next
= ADVANCE (next
, nbytes
);
2861 eassert (total_bytes
% roundup_size
== 0);
2863 if (vector
== (struct Lisp_Vector
*) block
->data
2864 && !VECTOR_IN_BLOCK (next
, block
))
2865 /* This block should be freed because all of it's
2866 space was coalesced into the only free vector. */
2867 free_this_block
= 1;
2871 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2876 if (free_this_block
)
2878 *bprev
= block
->next
;
2879 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2880 mem_delete (mem_find (block
->data
));
2885 bprev
= &block
->next
;
2888 /* Sweep large vectors. */
2890 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2893 if (VECTOR_MARKED_P (vector
))
2895 VECTOR_UNMARK (vector
);
2897 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2899 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2901 /* All non-bool pseudovectors are small enough to be allocated
2902 from vector blocks. This code should be redesigned if some
2903 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2904 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2907 += (bool_header_size
2908 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2909 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2913 += header_size
/ word_size
+ vector
->header
.size
;
2914 lvprev
= &lv
->next
.vector
;
2918 *lvprev
= lv
->next
.vector
;
2924 /* Value is a pointer to a newly allocated Lisp_Vector structure
2925 with room for LEN Lisp_Objects. */
2927 static struct Lisp_Vector
*
2928 allocate_vectorlike (ptrdiff_t len
)
2930 struct Lisp_Vector
*p
;
2935 p
= XVECTOR (zero_vector
);
2938 size_t nbytes
= header_size
+ len
* word_size
;
2940 #ifdef DOUG_LEA_MALLOC
2941 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2942 because mapped region contents are not preserved in
2944 mallopt (M_MMAP_MAX
, 0);
2947 if (nbytes
<= VBLOCK_BYTES_MAX
)
2948 p
= allocate_vector_from_block (vroundup (nbytes
));
2951 struct large_vector
*lv
2952 = lisp_malloc (sizeof (*lv
) + (len
- 1) * word_size
,
2953 MEM_TYPE_VECTORLIKE
);
2954 lv
->next
.vector
= large_vectors
;
2959 #ifdef DOUG_LEA_MALLOC
2960 /* Back to a reasonable maximum of mmap'ed areas. */
2961 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2964 consing_since_gc
+= nbytes
;
2965 vector_cells_consed
+= len
;
2968 MALLOC_UNBLOCK_INPUT
;
2974 /* Allocate a vector with LEN slots. */
2976 struct Lisp_Vector
*
2977 allocate_vector (EMACS_INT len
)
2979 struct Lisp_Vector
*v
;
2980 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2982 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2983 memory_full (SIZE_MAX
);
2984 v
= allocate_vectorlike (len
);
2985 v
->header
.size
= len
;
2990 /* Allocate other vector-like structures. */
2992 struct Lisp_Vector
*
2993 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2995 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2998 /* Catch bogus values. */
2999 eassert (tag
<= PVEC_FONT
);
3000 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3001 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3003 /* Only the first lisplen slots will be traced normally by the GC. */
3004 for (i
= 0; i
< lisplen
; ++i
)
3005 v
->contents
[i
] = Qnil
;
3007 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3012 allocate_buffer (void)
3014 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3016 BUFFER_PVEC_INIT (b
);
3017 /* Put B on the chain of all buffers including killed ones. */
3018 b
->next
= all_buffers
;
3020 /* Note that the rest fields of B are not initialized. */
3024 struct Lisp_Hash_Table
*
3025 allocate_hash_table (void)
3027 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3031 allocate_window (void)
3035 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3036 /* Users assumes that non-Lisp data is zeroed. */
3037 memset (&w
->current_matrix
, 0,
3038 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3043 allocate_terminal (void)
3047 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3048 /* Users assumes that non-Lisp data is zeroed. */
3049 memset (&t
->next_terminal
, 0,
3050 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3055 allocate_frame (void)
3059 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3060 /* Users assumes that non-Lisp data is zeroed. */
3061 memset (&f
->face_cache
, 0,
3062 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3066 struct Lisp_Process
*
3067 allocate_process (void)
3069 struct Lisp_Process
*p
;
3071 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3072 /* Users assumes that non-Lisp data is zeroed. */
3074 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3078 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3079 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3080 See also the function `vector'. */)
3081 (register Lisp_Object length
, Lisp_Object init
)
3084 register ptrdiff_t sizei
;
3085 register ptrdiff_t i
;
3086 register struct Lisp_Vector
*p
;
3088 CHECK_NATNUM (length
);
3090 p
= allocate_vector (XFASTINT (length
));
3091 sizei
= XFASTINT (length
);
3092 for (i
= 0; i
< sizei
; i
++)
3093 p
->contents
[i
] = init
;
3095 XSETVECTOR (vector
, p
);
3100 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3101 doc
: /* Return a newly created vector with specified arguments as elements.
3102 Any number of arguments, even zero arguments, are allowed.
3103 usage: (vector &rest OBJECTS) */)
3104 (ptrdiff_t nargs
, Lisp_Object
*args
)
3107 register Lisp_Object val
= make_uninit_vector (nargs
);
3108 register struct Lisp_Vector
*p
= XVECTOR (val
);
3110 for (i
= 0; i
< nargs
; i
++)
3111 p
->contents
[i
] = args
[i
];
3116 make_byte_code (struct Lisp_Vector
*v
)
3118 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3119 && STRING_MULTIBYTE (v
->contents
[1]))
3120 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3121 earlier because they produced a raw 8-bit string for byte-code
3122 and now such a byte-code string is loaded as multibyte while
3123 raw 8-bit characters converted to multibyte form. Thus, now we
3124 must convert them back to the original unibyte form. */
3125 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3126 XSETPVECTYPE (v
, PVEC_COMPILED
);
3129 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3130 doc
: /* Create a byte-code object with specified arguments as elements.
3131 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3132 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3133 and (optional) INTERACTIVE-SPEC.
3134 The first four arguments are required; at most six have any
3136 The ARGLIST can be either like the one of `lambda', in which case the arguments
3137 will be dynamically bound before executing the byte code, or it can be an
3138 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3139 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3140 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3141 argument to catch the left-over arguments. If such an integer is used, the
3142 arguments will not be dynamically bound but will be instead pushed on the
3143 stack before executing the byte-code.
3144 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3145 (ptrdiff_t nargs
, Lisp_Object
*args
)
3148 register Lisp_Object val
= make_uninit_vector (nargs
);
3149 register struct Lisp_Vector
*p
= XVECTOR (val
);
3151 /* We used to purecopy everything here, if purify-flag was set. This worked
3152 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3153 dangerous, since make-byte-code is used during execution to build
3154 closures, so any closure built during the preload phase would end up
3155 copied into pure space, including its free variables, which is sometimes
3156 just wasteful and other times plainly wrong (e.g. those free vars may want
3159 for (i
= 0; i
< nargs
; i
++)
3160 p
->contents
[i
] = args
[i
];
3162 XSETCOMPILED (val
, p
);
3168 /***********************************************************************
3170 ***********************************************************************/
3172 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3173 of the required alignment if LSB tags are used. */
3175 union aligned_Lisp_Symbol
3177 struct Lisp_Symbol s
;
3179 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3184 /* Each symbol_block is just under 1020 bytes long, since malloc
3185 really allocates in units of powers of two and uses 4 bytes for its
3188 #define SYMBOL_BLOCK_SIZE \
3189 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3193 /* Place `symbols' first, to preserve alignment. */
3194 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3195 struct symbol_block
*next
;
3198 /* Current symbol block and index of first unused Lisp_Symbol
3201 static struct symbol_block
*symbol_block
;
3202 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3204 /* List of free symbols. */
3206 static struct Lisp_Symbol
*symbol_free_list
;
3208 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3209 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3210 Its value is void, and its function definition and property list are nil. */)
3213 register Lisp_Object val
;
3214 register struct Lisp_Symbol
*p
;
3216 CHECK_STRING (name
);
3220 if (symbol_free_list
)
3222 XSETSYMBOL (val
, symbol_free_list
);
3223 symbol_free_list
= symbol_free_list
->next
;
3227 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3229 struct symbol_block
*new
3230 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3231 new->next
= symbol_block
;
3233 symbol_block_index
= 0;
3234 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3236 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3237 symbol_block_index
++;
3240 MALLOC_UNBLOCK_INPUT
;
3243 set_symbol_name (val
, name
);
3244 set_symbol_plist (val
, Qnil
);
3245 p
->redirect
= SYMBOL_PLAINVAL
;
3246 SET_SYMBOL_VAL (p
, Qunbound
);
3247 set_symbol_function (val
, Qnil
);
3248 set_symbol_next (val
, NULL
);
3250 p
->interned
= SYMBOL_UNINTERNED
;
3252 p
->declared_special
= 0;
3253 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3255 total_free_symbols
--;
3261 /***********************************************************************
3262 Marker (Misc) Allocation
3263 ***********************************************************************/
3265 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3266 the required alignment when LSB tags are used. */
3268 union aligned_Lisp_Misc
3272 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3277 /* Allocation of markers and other objects that share that structure.
3278 Works like allocation of conses. */
3280 #define MARKER_BLOCK_SIZE \
3281 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3285 /* Place `markers' first, to preserve alignment. */
3286 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3287 struct marker_block
*next
;
3290 static struct marker_block
*marker_block
;
3291 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3293 static union Lisp_Misc
*marker_free_list
;
3295 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3298 allocate_misc (enum Lisp_Misc_Type type
)
3304 if (marker_free_list
)
3306 XSETMISC (val
, marker_free_list
);
3307 marker_free_list
= marker_free_list
->u_free
.chain
;
3311 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3313 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3314 new->next
= marker_block
;
3316 marker_block_index
= 0;
3317 total_free_markers
+= MARKER_BLOCK_SIZE
;
3319 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3320 marker_block_index
++;
3323 MALLOC_UNBLOCK_INPUT
;
3325 --total_free_markers
;
3326 consing_since_gc
+= sizeof (union Lisp_Misc
);
3327 misc_objects_consed
++;
3328 XMISCTYPE (val
) = type
;
3329 XMISCANY (val
)->gcmarkbit
= 0;
3333 /* Free a Lisp_Misc object. */
3336 free_misc (Lisp_Object misc
)
3338 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3339 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3340 marker_free_list
= XMISC (misc
);
3341 consing_since_gc
-= sizeof (union Lisp_Misc
);
3342 total_free_markers
++;
3345 /* Return a Lisp_Save_Value object with the data saved according to
3346 FMT. Format specifiers are `i' for an integer, `p' for a pointer
3347 and `o' for Lisp_Object. Up to 4 objects can be specified. */
3350 make_save_value (const char *fmt
, ...)
3353 int len
= strlen (fmt
);
3354 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3355 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3357 eassert (0 < len
&& len
< 5);
3360 #define INITX(index) \
3363 p->type ## index = SAVE_UNUSED; \
3366 if (fmt[index] == 'i') \
3368 p->type ## index = SAVE_INTEGER; \
3369 p->data[index].integer = va_arg (ap, ptrdiff_t); \
3371 else if (fmt[index] == 'p') \
3373 p->type ## index = SAVE_POINTER; \
3374 p->data[index].pointer = va_arg (ap, void *); \
3376 else if (fmt[index] == 'o') \
3378 p->type ## index = SAVE_OBJECT; \
3379 p->data[index].object = va_arg (ap, Lisp_Object); \
3398 /* The most common task it to save just one C pointer. */
3401 make_save_pointer (void *pointer
)
3403 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3404 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3407 p
->type0
= SAVE_POINTER
;
3408 p
->data
[0].pointer
= pointer
;
3409 p
->type1
= p
->type2
= p
->type3
= SAVE_UNUSED
;
3413 /* Free a Lisp_Save_Value object. Do not use this function
3414 if SAVE contains pointer other than returned by xmalloc. */
3417 free_save_value (Lisp_Object save
)
3419 xfree (XSAVE_POINTER (save
, 0));
3423 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3426 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3428 register Lisp_Object overlay
;
3430 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3431 OVERLAY_START (overlay
) = start
;
3432 OVERLAY_END (overlay
) = end
;
3433 set_overlay_plist (overlay
, plist
);
3434 XOVERLAY (overlay
)->next
= NULL
;
3438 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3439 doc
: /* Return a newly allocated marker which does not point at any place. */)
3442 register Lisp_Object val
;
3443 register struct Lisp_Marker
*p
;
3445 val
= allocate_misc (Lisp_Misc_Marker
);
3451 p
->insertion_type
= 0;
3455 /* Return a newly allocated marker which points into BUF
3456 at character position CHARPOS and byte position BYTEPOS. */
3459 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3462 struct Lisp_Marker
*m
;
3464 /* No dead buffers here. */
3465 eassert (BUFFER_LIVE_P (buf
));
3467 /* Every character is at least one byte. */
3468 eassert (charpos
<= bytepos
);
3470 obj
= allocate_misc (Lisp_Misc_Marker
);
3473 m
->charpos
= charpos
;
3474 m
->bytepos
= bytepos
;
3475 m
->insertion_type
= 0;
3476 m
->next
= BUF_MARKERS (buf
);
3477 BUF_MARKERS (buf
) = m
;
3481 /* Put MARKER back on the free list after using it temporarily. */
3484 free_marker (Lisp_Object marker
)
3486 unchain_marker (XMARKER (marker
));
3491 /* Return a newly created vector or string with specified arguments as
3492 elements. If all the arguments are characters that can fit
3493 in a string of events, make a string; otherwise, make a vector.
3495 Any number of arguments, even zero arguments, are allowed. */
3498 make_event_array (register int nargs
, Lisp_Object
*args
)
3502 for (i
= 0; i
< nargs
; i
++)
3503 /* The things that fit in a string
3504 are characters that are in 0...127,
3505 after discarding the meta bit and all the bits above it. */
3506 if (!INTEGERP (args
[i
])
3507 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3508 return Fvector (nargs
, args
);
3510 /* Since the loop exited, we know that all the things in it are
3511 characters, so we can make a string. */
3515 result
= Fmake_string (make_number (nargs
), make_number (0));
3516 for (i
= 0; i
< nargs
; i
++)
3518 SSET (result
, i
, XINT (args
[i
]));
3519 /* Move the meta bit to the right place for a string char. */
3520 if (XINT (args
[i
]) & CHAR_META
)
3521 SSET (result
, i
, SREF (result
, i
) | 0x80);
3530 /************************************************************************
3531 Memory Full Handling
3532 ************************************************************************/
3535 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3536 there may have been size_t overflow so that malloc was never
3537 called, or perhaps malloc was invoked successfully but the
3538 resulting pointer had problems fitting into a tagged EMACS_INT. In
3539 either case this counts as memory being full even though malloc did
3543 memory_full (size_t nbytes
)
3545 /* Do not go into hysterics merely because a large request failed. */
3546 bool enough_free_memory
= 0;
3547 if (SPARE_MEMORY
< nbytes
)
3552 p
= malloc (SPARE_MEMORY
);
3556 enough_free_memory
= 1;
3558 MALLOC_UNBLOCK_INPUT
;
3561 if (! enough_free_memory
)
3567 memory_full_cons_threshold
= sizeof (struct cons_block
);
3569 /* The first time we get here, free the spare memory. */
3570 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3571 if (spare_memory
[i
])
3574 free (spare_memory
[i
]);
3575 else if (i
>= 1 && i
<= 4)
3576 lisp_align_free (spare_memory
[i
]);
3578 lisp_free (spare_memory
[i
]);
3579 spare_memory
[i
] = 0;
3583 /* This used to call error, but if we've run out of memory, we could
3584 get infinite recursion trying to build the string. */
3585 xsignal (Qnil
, Vmemory_signal_data
);
3588 /* If we released our reserve (due to running out of memory),
3589 and we have a fair amount free once again,
3590 try to set aside another reserve in case we run out once more.
3592 This is called when a relocatable block is freed in ralloc.c,
3593 and also directly from this file, in case we're not using ralloc.c. */
3596 refill_memory_reserve (void)
3598 #ifndef SYSTEM_MALLOC
3599 if (spare_memory
[0] == 0)
3600 spare_memory
[0] = malloc (SPARE_MEMORY
);
3601 if (spare_memory
[1] == 0)
3602 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3604 if (spare_memory
[2] == 0)
3605 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3607 if (spare_memory
[3] == 0)
3608 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3610 if (spare_memory
[4] == 0)
3611 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3613 if (spare_memory
[5] == 0)
3614 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3616 if (spare_memory
[6] == 0)
3617 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3619 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3620 Vmemory_full
= Qnil
;
3624 /************************************************************************
3626 ************************************************************************/
3628 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3630 /* Conservative C stack marking requires a method to identify possibly
3631 live Lisp objects given a pointer value. We do this by keeping
3632 track of blocks of Lisp data that are allocated in a red-black tree
3633 (see also the comment of mem_node which is the type of nodes in
3634 that tree). Function lisp_malloc adds information for an allocated
3635 block to the red-black tree with calls to mem_insert, and function
3636 lisp_free removes it with mem_delete. Functions live_string_p etc
3637 call mem_find to lookup information about a given pointer in the
3638 tree, and use that to determine if the pointer points to a Lisp
3641 /* Initialize this part of alloc.c. */
3646 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3647 mem_z
.parent
= NULL
;
3648 mem_z
.color
= MEM_BLACK
;
3649 mem_z
.start
= mem_z
.end
= NULL
;
3654 /* Value is a pointer to the mem_node containing START. Value is
3655 MEM_NIL if there is no node in the tree containing START. */
3657 static struct mem_node
*
3658 mem_find (void *start
)
3662 if (start
< min_heap_address
|| start
> max_heap_address
)
3665 /* Make the search always successful to speed up the loop below. */
3666 mem_z
.start
= start
;
3667 mem_z
.end
= (char *) start
+ 1;
3670 while (start
< p
->start
|| start
>= p
->end
)
3671 p
= start
< p
->start
? p
->left
: p
->right
;
3676 /* Insert a new node into the tree for a block of memory with start
3677 address START, end address END, and type TYPE. Value is a
3678 pointer to the node that was inserted. */
3680 static struct mem_node
*
3681 mem_insert (void *start
, void *end
, enum mem_type type
)
3683 struct mem_node
*c
, *parent
, *x
;
3685 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3686 min_heap_address
= start
;
3687 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3688 max_heap_address
= end
;
3690 /* See where in the tree a node for START belongs. In this
3691 particular application, it shouldn't happen that a node is already
3692 present. For debugging purposes, let's check that. */
3696 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3698 while (c
!= MEM_NIL
)
3700 if (start
>= c
->start
&& start
< c
->end
)
3703 c
= start
< c
->start
? c
->left
: c
->right
;
3706 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3708 while (c
!= MEM_NIL
)
3711 c
= start
< c
->start
? c
->left
: c
->right
;
3714 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3716 /* Create a new node. */
3717 #ifdef GC_MALLOC_CHECK
3718 x
= malloc (sizeof *x
);
3722 x
= xmalloc (sizeof *x
);
3728 x
->left
= x
->right
= MEM_NIL
;
3731 /* Insert it as child of PARENT or install it as root. */
3734 if (start
< parent
->start
)
3742 /* Re-establish red-black tree properties. */
3743 mem_insert_fixup (x
);
3749 /* Re-establish the red-black properties of the tree, and thereby
3750 balance the tree, after node X has been inserted; X is always red. */
3753 mem_insert_fixup (struct mem_node
*x
)
3755 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3757 /* X is red and its parent is red. This is a violation of
3758 red-black tree property #3. */
3760 if (x
->parent
== x
->parent
->parent
->left
)
3762 /* We're on the left side of our grandparent, and Y is our
3764 struct mem_node
*y
= x
->parent
->parent
->right
;
3766 if (y
->color
== MEM_RED
)
3768 /* Uncle and parent are red but should be black because
3769 X is red. Change the colors accordingly and proceed
3770 with the grandparent. */
3771 x
->parent
->color
= MEM_BLACK
;
3772 y
->color
= MEM_BLACK
;
3773 x
->parent
->parent
->color
= MEM_RED
;
3774 x
= x
->parent
->parent
;
3778 /* Parent and uncle have different colors; parent is
3779 red, uncle is black. */
3780 if (x
== x
->parent
->right
)
3783 mem_rotate_left (x
);
3786 x
->parent
->color
= MEM_BLACK
;
3787 x
->parent
->parent
->color
= MEM_RED
;
3788 mem_rotate_right (x
->parent
->parent
);
3793 /* This is the symmetrical case of above. */
3794 struct mem_node
*y
= x
->parent
->parent
->left
;
3796 if (y
->color
== MEM_RED
)
3798 x
->parent
->color
= MEM_BLACK
;
3799 y
->color
= MEM_BLACK
;
3800 x
->parent
->parent
->color
= MEM_RED
;
3801 x
= x
->parent
->parent
;
3805 if (x
== x
->parent
->left
)
3808 mem_rotate_right (x
);
3811 x
->parent
->color
= MEM_BLACK
;
3812 x
->parent
->parent
->color
= MEM_RED
;
3813 mem_rotate_left (x
->parent
->parent
);
3818 /* The root may have been changed to red due to the algorithm. Set
3819 it to black so that property #5 is satisfied. */
3820 mem_root
->color
= MEM_BLACK
;
3831 mem_rotate_left (struct mem_node
*x
)
3835 /* Turn y's left sub-tree into x's right sub-tree. */
3838 if (y
->left
!= MEM_NIL
)
3839 y
->left
->parent
= x
;
3841 /* Y's parent was x's parent. */
3843 y
->parent
= x
->parent
;
3845 /* Get the parent to point to y instead of x. */
3848 if (x
== x
->parent
->left
)
3849 x
->parent
->left
= y
;
3851 x
->parent
->right
= y
;
3856 /* Put x on y's left. */
3870 mem_rotate_right (struct mem_node
*x
)
3872 struct mem_node
*y
= x
->left
;
3875 if (y
->right
!= MEM_NIL
)
3876 y
->right
->parent
= x
;
3879 y
->parent
= x
->parent
;
3882 if (x
== x
->parent
->right
)
3883 x
->parent
->right
= y
;
3885 x
->parent
->left
= y
;
3896 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3899 mem_delete (struct mem_node
*z
)
3901 struct mem_node
*x
, *y
;
3903 if (!z
|| z
== MEM_NIL
)
3906 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3911 while (y
->left
!= MEM_NIL
)
3915 if (y
->left
!= MEM_NIL
)
3920 x
->parent
= y
->parent
;
3923 if (y
== y
->parent
->left
)
3924 y
->parent
->left
= x
;
3926 y
->parent
->right
= x
;
3933 z
->start
= y
->start
;
3938 if (y
->color
== MEM_BLACK
)
3939 mem_delete_fixup (x
);
3941 #ifdef GC_MALLOC_CHECK
3949 /* Re-establish the red-black properties of the tree, after a
3953 mem_delete_fixup (struct mem_node
*x
)
3955 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3957 if (x
== x
->parent
->left
)
3959 struct mem_node
*w
= x
->parent
->right
;
3961 if (w
->color
== MEM_RED
)
3963 w
->color
= MEM_BLACK
;
3964 x
->parent
->color
= MEM_RED
;
3965 mem_rotate_left (x
->parent
);
3966 w
= x
->parent
->right
;
3969 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3976 if (w
->right
->color
== MEM_BLACK
)
3978 w
->left
->color
= MEM_BLACK
;
3980 mem_rotate_right (w
);
3981 w
= x
->parent
->right
;
3983 w
->color
= x
->parent
->color
;
3984 x
->parent
->color
= MEM_BLACK
;
3985 w
->right
->color
= MEM_BLACK
;
3986 mem_rotate_left (x
->parent
);
3992 struct mem_node
*w
= x
->parent
->left
;
3994 if (w
->color
== MEM_RED
)
3996 w
->color
= MEM_BLACK
;
3997 x
->parent
->color
= MEM_RED
;
3998 mem_rotate_right (x
->parent
);
3999 w
= x
->parent
->left
;
4002 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4009 if (w
->left
->color
== MEM_BLACK
)
4011 w
->right
->color
= MEM_BLACK
;
4013 mem_rotate_left (w
);
4014 w
= x
->parent
->left
;
4017 w
->color
= x
->parent
->color
;
4018 x
->parent
->color
= MEM_BLACK
;
4019 w
->left
->color
= MEM_BLACK
;
4020 mem_rotate_right (x
->parent
);
4026 x
->color
= MEM_BLACK
;
4030 /* Value is non-zero if P is a pointer to a live Lisp string on
4031 the heap. M is a pointer to the mem_block for P. */
4034 live_string_p (struct mem_node
*m
, void *p
)
4036 if (m
->type
== MEM_TYPE_STRING
)
4038 struct string_block
*b
= (struct string_block
*) m
->start
;
4039 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4041 /* P must point to the start of a Lisp_String structure, and it
4042 must not be on the free-list. */
4044 && offset
% sizeof b
->strings
[0] == 0
4045 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4046 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4053 /* Value is non-zero if P is a pointer to a live Lisp cons on
4054 the heap. M is a pointer to the mem_block for P. */
4057 live_cons_p (struct mem_node
*m
, void *p
)
4059 if (m
->type
== MEM_TYPE_CONS
)
4061 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4062 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4064 /* P must point to the start of a Lisp_Cons, not be
4065 one of the unused cells in the current cons block,
4066 and not be on the free-list. */
4068 && offset
% sizeof b
->conses
[0] == 0
4069 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4071 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4072 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4079 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4080 the heap. M is a pointer to the mem_block for P. */
4083 live_symbol_p (struct mem_node
*m
, void *p
)
4085 if (m
->type
== MEM_TYPE_SYMBOL
)
4087 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4088 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4090 /* P must point to the start of a Lisp_Symbol, not be
4091 one of the unused cells in the current symbol block,
4092 and not be on the free-list. */
4094 && offset
% sizeof b
->symbols
[0] == 0
4095 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4096 && (b
!= symbol_block
4097 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4098 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4105 /* Value is non-zero if P is a pointer to a live Lisp float on
4106 the heap. M is a pointer to the mem_block for P. */
4109 live_float_p (struct mem_node
*m
, void *p
)
4111 if (m
->type
== MEM_TYPE_FLOAT
)
4113 struct float_block
*b
= (struct float_block
*) m
->start
;
4114 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4116 /* P must point to the start of a Lisp_Float and not be
4117 one of the unused cells in the current float block. */
4119 && offset
% sizeof b
->floats
[0] == 0
4120 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4121 && (b
!= float_block
4122 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4129 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4130 the heap. M is a pointer to the mem_block for P. */
4133 live_misc_p (struct mem_node
*m
, void *p
)
4135 if (m
->type
== MEM_TYPE_MISC
)
4137 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4138 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4140 /* P must point to the start of a Lisp_Misc, not be
4141 one of the unused cells in the current misc block,
4142 and not be on the free-list. */
4144 && offset
% sizeof b
->markers
[0] == 0
4145 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4146 && (b
!= marker_block
4147 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4148 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4155 /* Value is non-zero if P is a pointer to a live vector-like object.
4156 M is a pointer to the mem_block for P. */
4159 live_vector_p (struct mem_node
*m
, void *p
)
4161 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4163 /* This memory node corresponds to a vector block. */
4164 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4165 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4167 /* P is in the block's allocation range. Scan the block
4168 up to P and see whether P points to the start of some
4169 vector which is not on a free list. FIXME: check whether
4170 some allocation patterns (probably a lot of short vectors)
4171 may cause a substantial overhead of this loop. */
4172 while (VECTOR_IN_BLOCK (vector
, block
)
4173 && vector
<= (struct Lisp_Vector
*) p
)
4175 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4178 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4181 else if (m
->type
== MEM_TYPE_VECTORLIKE
4182 && (char *) p
== ((char *) m
->start
4183 + offsetof (struct large_vector
, v
)))
4184 /* This memory node corresponds to a large vector. */
4190 /* Value is non-zero if P is a pointer to a live buffer. M is a
4191 pointer to the mem_block for P. */
4194 live_buffer_p (struct mem_node
*m
, void *p
)
4196 /* P must point to the start of the block, and the buffer
4197 must not have been killed. */
4198 return (m
->type
== MEM_TYPE_BUFFER
4200 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4203 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4207 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4209 /* Array of objects that are kept alive because the C stack contains
4210 a pattern that looks like a reference to them . */
4212 #define MAX_ZOMBIES 10
4213 static Lisp_Object zombies
[MAX_ZOMBIES
];
4215 /* Number of zombie objects. */
4217 static EMACS_INT nzombies
;
4219 /* Number of garbage collections. */
4221 static EMACS_INT ngcs
;
4223 /* Average percentage of zombies per collection. */
4225 static double avg_zombies
;
4227 /* Max. number of live and zombie objects. */
4229 static EMACS_INT max_live
, max_zombies
;
4231 /* Average number of live objects per GC. */
4233 static double avg_live
;
4235 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4236 doc
: /* Show information about live and zombie objects. */)
4239 Lisp_Object args
[8], zombie_list
= Qnil
;
4241 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4242 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4243 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4244 args
[1] = make_number (ngcs
);
4245 args
[2] = make_float (avg_live
);
4246 args
[3] = make_float (avg_zombies
);
4247 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4248 args
[5] = make_number (max_live
);
4249 args
[6] = make_number (max_zombies
);
4250 args
[7] = zombie_list
;
4251 return Fmessage (8, args
);
4254 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4257 /* Mark OBJ if we can prove it's a Lisp_Object. */
4260 mark_maybe_object (Lisp_Object obj
)
4268 po
= (void *) XPNTR (obj
);
4275 switch (XTYPE (obj
))
4278 mark_p
= (live_string_p (m
, po
)
4279 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4283 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4287 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4291 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4294 case Lisp_Vectorlike
:
4295 /* Note: can't check BUFFERP before we know it's a
4296 buffer because checking that dereferences the pointer
4297 PO which might point anywhere. */
4298 if (live_vector_p (m
, po
))
4299 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4300 else if (live_buffer_p (m
, po
))
4301 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4305 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4314 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4315 if (nzombies
< MAX_ZOMBIES
)
4316 zombies
[nzombies
] = obj
;
4325 /* If P points to Lisp data, mark that as live if it isn't already
4329 mark_maybe_pointer (void *p
)
4333 /* Quickly rule out some values which can't point to Lisp data.
4334 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4335 Otherwise, assume that Lisp data is aligned on even addresses. */
4336 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4342 Lisp_Object obj
= Qnil
;
4346 case MEM_TYPE_NON_LISP
:
4347 case MEM_TYPE_SPARE
:
4348 /* Nothing to do; not a pointer to Lisp memory. */
4351 case MEM_TYPE_BUFFER
:
4352 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4353 XSETVECTOR (obj
, p
);
4357 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4361 case MEM_TYPE_STRING
:
4362 if (live_string_p (m
, p
)
4363 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4364 XSETSTRING (obj
, p
);
4368 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4372 case MEM_TYPE_SYMBOL
:
4373 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4374 XSETSYMBOL (obj
, p
);
4377 case MEM_TYPE_FLOAT
:
4378 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4382 case MEM_TYPE_VECTORLIKE
:
4383 case MEM_TYPE_VECTOR_BLOCK
:
4384 if (live_vector_p (m
, p
))
4387 XSETVECTOR (tem
, p
);
4388 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4403 /* Alignment of pointer values. Use alignof, as it sometimes returns
4404 a smaller alignment than GCC's __alignof__ and mark_memory might
4405 miss objects if __alignof__ were used. */
4406 #define GC_POINTER_ALIGNMENT alignof (void *)
4408 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4409 not suffice, which is the typical case. A host where a Lisp_Object is
4410 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4411 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4412 suffice to widen it to to a Lisp_Object and check it that way. */
4413 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4414 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4415 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4416 nor mark_maybe_object can follow the pointers. This should not occur on
4417 any practical porting target. */
4418 # error "MSB type bits straddle pointer-word boundaries"
4420 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4421 pointer words that hold pointers ORed with type bits. */
4422 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4424 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4425 words that hold unmodified pointers. */
4426 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4429 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4430 or END+OFFSET..START. */
4433 mark_memory (void *start
, void *end
)
4434 #if defined (__clang__) && defined (__has_feature)
4435 #if __has_feature(address_sanitizer)
4436 /* Do not allow -faddress-sanitizer to check this function, since it
4437 crosses the function stack boundary, and thus would yield many
4439 __attribute__((no_address_safety_analysis
))
4446 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4450 /* Make START the pointer to the start of the memory region,
4451 if it isn't already. */
4459 /* Mark Lisp data pointed to. This is necessary because, in some
4460 situations, the C compiler optimizes Lisp objects away, so that
4461 only a pointer to them remains. Example:
4463 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4466 Lisp_Object obj = build_string ("test");
4467 struct Lisp_String *s = XSTRING (obj);
4468 Fgarbage_collect ();
4469 fprintf (stderr, "test `%s'\n", s->data);
4473 Here, `obj' isn't really used, and the compiler optimizes it
4474 away. The only reference to the life string is through the
4477 for (pp
= start
; (void *) pp
< end
; pp
++)
4478 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4480 void *p
= *(void **) ((char *) pp
+ i
);
4481 mark_maybe_pointer (p
);
4482 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4483 mark_maybe_object (XIL ((intptr_t) p
));
4487 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4489 static bool setjmp_tested_p
;
4490 static int longjmps_done
;
4492 #define SETJMP_WILL_LIKELY_WORK "\
4494 Emacs garbage collector has been changed to use conservative stack\n\
4495 marking. Emacs has determined that the method it uses to do the\n\
4496 marking will likely work on your system, but this isn't sure.\n\
4498 If you are a system-programmer, or can get the help of a local wizard\n\
4499 who is, please take a look at the function mark_stack in alloc.c, and\n\
4500 verify that the methods used are appropriate for your system.\n\
4502 Please mail the result to <emacs-devel@gnu.org>.\n\
4505 #define SETJMP_WILL_NOT_WORK "\
4507 Emacs garbage collector has been changed to use conservative stack\n\
4508 marking. Emacs has determined that the default method it uses to do the\n\
4509 marking will not work on your system. We will need a system-dependent\n\
4510 solution for your system.\n\
4512 Please take a look at the function mark_stack in alloc.c, and\n\
4513 try to find a way to make it work on your system.\n\
4515 Note that you may get false negatives, depending on the compiler.\n\
4516 In particular, you need to use -O with GCC for this test.\n\
4518 Please mail the result to <emacs-devel@gnu.org>.\n\
4522 /* Perform a quick check if it looks like setjmp saves registers in a
4523 jmp_buf. Print a message to stderr saying so. When this test
4524 succeeds, this is _not_ a proof that setjmp is sufficient for
4525 conservative stack marking. Only the sources or a disassembly
4535 /* Arrange for X to be put in a register. */
4541 if (longjmps_done
== 1)
4543 /* Came here after the longjmp at the end of the function.
4545 If x == 1, the longjmp has restored the register to its
4546 value before the setjmp, and we can hope that setjmp
4547 saves all such registers in the jmp_buf, although that
4550 For other values of X, either something really strange is
4551 taking place, or the setjmp just didn't save the register. */
4554 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4557 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4564 if (longjmps_done
== 1)
4565 sys_longjmp (jbuf
, 1);
4568 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4571 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4573 /* Abort if anything GCPRO'd doesn't survive the GC. */
4581 for (p
= gcprolist
; p
; p
= p
->next
)
4582 for (i
= 0; i
< p
->nvars
; ++i
)
4583 if (!survives_gc_p (p
->var
[i
]))
4584 /* FIXME: It's not necessarily a bug. It might just be that the
4585 GCPRO is unnecessary or should release the object sooner. */
4589 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4596 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4597 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4599 fprintf (stderr
, " %d = ", i
);
4600 debug_print (zombies
[i
]);
4604 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4607 /* Mark live Lisp objects on the C stack.
4609 There are several system-dependent problems to consider when
4610 porting this to new architectures:
4614 We have to mark Lisp objects in CPU registers that can hold local
4615 variables or are used to pass parameters.
4617 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4618 something that either saves relevant registers on the stack, or
4619 calls mark_maybe_object passing it each register's contents.
4621 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4622 implementation assumes that calling setjmp saves registers we need
4623 to see in a jmp_buf which itself lies on the stack. This doesn't
4624 have to be true! It must be verified for each system, possibly
4625 by taking a look at the source code of setjmp.
4627 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4628 can use it as a machine independent method to store all registers
4629 to the stack. In this case the macros described in the previous
4630 two paragraphs are not used.
4634 Architectures differ in the way their processor stack is organized.
4635 For example, the stack might look like this
4638 | Lisp_Object | size = 4
4640 | something else | size = 2
4642 | Lisp_Object | size = 4
4646 In such a case, not every Lisp_Object will be aligned equally. To
4647 find all Lisp_Object on the stack it won't be sufficient to walk
4648 the stack in steps of 4 bytes. Instead, two passes will be
4649 necessary, one starting at the start of the stack, and a second
4650 pass starting at the start of the stack + 2. Likewise, if the
4651 minimal alignment of Lisp_Objects on the stack is 1, four passes
4652 would be necessary, each one starting with one byte more offset
4653 from the stack start. */
4656 mark_stack (char *bottom
, char *end
)
4658 /* This assumes that the stack is a contiguous region in memory. If
4659 that's not the case, something has to be done here to iterate
4660 over the stack segments. */
4661 mark_memory (bottom
, end
);
4663 /* Allow for marking a secondary stack, like the register stack on the
4665 #ifdef GC_MARK_SECONDARY_STACK
4666 GC_MARK_SECONDARY_STACK ();
4669 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4675 flush_stack_call_func (void (*func
) (void *arg
), void *arg
)
4679 #ifdef HAVE___BUILTIN_UNWIND_INIT
4680 /* Force callee-saved registers and register windows onto the stack.
4681 This is the preferred method if available, obviating the need for
4682 machine dependent methods. */
4683 __builtin_unwind_init ();
4685 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4686 #ifndef GC_SAVE_REGISTERS_ON_STACK
4687 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4688 union aligned_jmpbuf
{
4692 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_bottom
;
4694 /* This trick flushes the register windows so that all the state of
4695 the process is contained in the stack. */
4696 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4697 needed on ia64 too. See mach_dep.c, where it also says inline
4698 assembler doesn't work with relevant proprietary compilers. */
4700 #if defined (__sparc64__) && defined (__FreeBSD__)
4701 /* FreeBSD does not have a ta 3 handler. */
4708 /* Save registers that we need to see on the stack. We need to see
4709 registers used to hold register variables and registers used to
4711 #ifdef GC_SAVE_REGISTERS_ON_STACK
4712 GC_SAVE_REGISTERS_ON_STACK (end
);
4713 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4715 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4716 setjmp will definitely work, test it
4717 and print a message with the result
4719 if (!setjmp_tested_p
)
4721 setjmp_tested_p
= 1;
4724 #endif /* GC_SETJMP_WORKS */
4727 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4728 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4729 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4731 current_thread
->stack_top
= end
;
4735 #endif /* GC_MARK_STACK != 0 */
4738 /* Determine whether it is safe to access memory at address P. */
4740 valid_pointer_p (void *p
)
4743 return w32_valid_pointer_p (p
, 16);
4747 /* Obviously, we cannot just access it (we would SEGV trying), so we
4748 trick the o/s to tell us whether p is a valid pointer.
4749 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4750 not validate p in that case. */
4754 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4755 emacs_close (fd
[1]);
4756 emacs_close (fd
[0]);
4764 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4765 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4766 cannot validate OBJ. This function can be quite slow, so its primary
4767 use is the manual debugging. The only exception is print_object, where
4768 we use it to check whether the memory referenced by the pointer of
4769 Lisp_Save_Value object contains valid objects. */
4772 valid_lisp_object_p (Lisp_Object obj
)
4782 p
= (void *) XPNTR (obj
);
4783 if (PURE_POINTER_P (p
))
4786 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4790 return valid_pointer_p (p
);
4797 int valid
= valid_pointer_p (p
);
4809 case MEM_TYPE_NON_LISP
:
4810 case MEM_TYPE_SPARE
:
4813 case MEM_TYPE_BUFFER
:
4814 return live_buffer_p (m
, p
) ? 1 : 2;
4817 return live_cons_p (m
, p
);
4819 case MEM_TYPE_STRING
:
4820 return live_string_p (m
, p
);
4823 return live_misc_p (m
, p
);
4825 case MEM_TYPE_SYMBOL
:
4826 return live_symbol_p (m
, p
);
4828 case MEM_TYPE_FLOAT
:
4829 return live_float_p (m
, p
);
4831 case MEM_TYPE_VECTORLIKE
:
4832 case MEM_TYPE_VECTOR_BLOCK
:
4833 return live_vector_p (m
, p
);
4846 /***********************************************************************
4847 Pure Storage Management
4848 ***********************************************************************/
4850 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4851 pointer to it. TYPE is the Lisp type for which the memory is
4852 allocated. TYPE < 0 means it's not used for a Lisp object. */
4855 pure_alloc (size_t size
, int type
)
4859 size_t alignment
= GCALIGNMENT
;
4861 size_t alignment
= alignof (EMACS_INT
);
4863 /* Give Lisp_Floats an extra alignment. */
4864 if (type
== Lisp_Float
)
4865 alignment
= alignof (struct Lisp_Float
);
4871 /* Allocate space for a Lisp object from the beginning of the free
4872 space with taking account of alignment. */
4873 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4874 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4878 /* Allocate space for a non-Lisp object from the end of the free
4880 pure_bytes_used_non_lisp
+= size
;
4881 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4883 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4885 if (pure_bytes_used
<= pure_size
)
4888 /* Don't allocate a large amount here,
4889 because it might get mmap'd and then its address
4890 might not be usable. */
4891 purebeg
= xmalloc (10000);
4893 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4894 pure_bytes_used
= 0;
4895 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4900 /* Print a warning if PURESIZE is too small. */
4903 check_pure_size (void)
4905 if (pure_bytes_used_before_overflow
)
4906 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4908 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4912 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4913 the non-Lisp data pool of the pure storage, and return its start
4914 address. Return NULL if not found. */
4917 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4920 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4921 const unsigned char *p
;
4924 if (pure_bytes_used_non_lisp
<= nbytes
)
4927 /* Set up the Boyer-Moore table. */
4929 for (i
= 0; i
< 256; i
++)
4932 p
= (const unsigned char *) data
;
4934 bm_skip
[*p
++] = skip
;
4936 last_char_skip
= bm_skip
['\0'];
4938 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4939 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4941 /* See the comments in the function `boyer_moore' (search.c) for the
4942 use of `infinity'. */
4943 infinity
= pure_bytes_used_non_lisp
+ 1;
4944 bm_skip
['\0'] = infinity
;
4946 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4950 /* Check the last character (== '\0'). */
4953 start
+= bm_skip
[*(p
+ start
)];
4955 while (start
<= start_max
);
4957 if (start
< infinity
)
4958 /* Couldn't find the last character. */
4961 /* No less than `infinity' means we could find the last
4962 character at `p[start - infinity]'. */
4965 /* Check the remaining characters. */
4966 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4968 return non_lisp_beg
+ start
;
4970 start
+= last_char_skip
;
4972 while (start
<= start_max
);
4978 /* Return a string allocated in pure space. DATA is a buffer holding
4979 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4980 means make the result string multibyte.
4982 Must get an error if pure storage is full, since if it cannot hold
4983 a large string it may be able to hold conses that point to that
4984 string; then the string is not protected from gc. */
4987 make_pure_string (const char *data
,
4988 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
4991 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4992 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4993 if (s
->data
== NULL
)
4995 s
->data
= pure_alloc (nbytes
+ 1, -1);
4996 memcpy (s
->data
, data
, nbytes
);
4997 s
->data
[nbytes
] = '\0';
5000 s
->size_byte
= multibyte
? nbytes
: -1;
5001 s
->intervals
= NULL
;
5002 XSETSTRING (string
, s
);
5006 /* Return a string allocated in pure space. Do not
5007 allocate the string data, just point to DATA. */
5010 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5013 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5016 s
->data
= (unsigned char *) data
;
5017 s
->intervals
= NULL
;
5018 XSETSTRING (string
, s
);
5022 /* Return a cons allocated from pure space. Give it pure copies
5023 of CAR as car and CDR as cdr. */
5026 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5029 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5031 XSETCAR (new, Fpurecopy (car
));
5032 XSETCDR (new, Fpurecopy (cdr
));
5037 /* Value is a float object with value NUM allocated from pure space. */
5040 make_pure_float (double num
)
5043 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5045 XFLOAT_INIT (new, num
);
5050 /* Return a vector with room for LEN Lisp_Objects allocated from
5054 make_pure_vector (ptrdiff_t len
)
5057 size_t size
= header_size
+ len
* word_size
;
5058 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5059 XSETVECTOR (new, p
);
5060 XVECTOR (new)->header
.size
= len
;
5065 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5066 doc
: /* Make a copy of object OBJ in pure storage.
5067 Recursively copies contents of vectors and cons cells.
5068 Does not copy symbols. Copies strings without text properties. */)
5069 (register Lisp_Object obj
)
5071 if (NILP (Vpurify_flag
))
5074 if (PURE_POINTER_P (XPNTR (obj
)))
5077 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5079 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5085 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5086 else if (FLOATP (obj
))
5087 obj
= make_pure_float (XFLOAT_DATA (obj
));
5088 else if (STRINGP (obj
))
5089 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5091 STRING_MULTIBYTE (obj
));
5092 else if (COMPILEDP (obj
) || VECTORP (obj
))
5094 register struct Lisp_Vector
*vec
;
5095 register ptrdiff_t i
;
5099 if (size
& PSEUDOVECTOR_FLAG
)
5100 size
&= PSEUDOVECTOR_SIZE_MASK
;
5101 vec
= XVECTOR (make_pure_vector (size
));
5102 for (i
= 0; i
< size
; i
++)
5103 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5104 if (COMPILEDP (obj
))
5106 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5107 XSETCOMPILED (obj
, vec
);
5110 XSETVECTOR (obj
, vec
);
5112 else if (MARKERP (obj
))
5113 error ("Attempt to copy a marker to pure storage");
5115 /* Not purified, don't hash-cons. */
5118 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5119 Fputhash (obj
, obj
, Vpurify_flag
);
5126 /***********************************************************************
5128 ***********************************************************************/
5130 /* Put an entry in staticvec, pointing at the variable with address
5134 staticpro (Lisp_Object
*varaddress
)
5136 staticvec
[staticidx
++] = varaddress
;
5137 if (staticidx
>= NSTATICS
)
5138 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5142 /***********************************************************************
5144 ***********************************************************************/
5146 /* Temporarily prevent garbage collection. */
5149 inhibit_garbage_collection (void)
5151 ptrdiff_t count
= SPECPDL_INDEX ();
5153 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5157 /* Used to avoid possible overflows when
5158 converting from C to Lisp integers. */
5161 bounded_number (EMACS_INT number
)
5163 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5166 /* Calculate total bytes of live objects. */
5169 total_bytes_of_live_objects (void)
5172 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5173 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5174 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5175 tot
+= total_string_bytes
;
5176 tot
+= total_vector_slots
* word_size
;
5177 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5178 tot
+= total_intervals
* sizeof (struct interval
);
5179 tot
+= total_strings
* sizeof (struct Lisp_String
);
5183 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5184 doc
: /* Reclaim storage for Lisp objects no longer needed.
5185 Garbage collection happens automatically if you cons more than
5186 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5187 `garbage-collect' normally returns a list with info on amount of space in use,
5188 where each entry has the form (NAME SIZE USED FREE), where:
5189 - NAME is a symbol describing the kind of objects this entry represents,
5190 - SIZE is the number of bytes used by each one,
5191 - USED is the number of those objects that were found live in the heap,
5192 - FREE is the number of those objects that are not live but that Emacs
5193 keeps around for future allocations (maybe because it does not know how
5194 to return them to the OS).
5195 However, if there was overflow in pure space, `garbage-collect'
5196 returns nil, because real GC can't be done.
5197 See Info node `(elisp)Garbage Collection'. */)
5200 struct specbinding
*bind
;
5201 struct buffer
*nextb
;
5202 char stack_top_variable
;
5205 ptrdiff_t count
= SPECPDL_INDEX ();
5207 Lisp_Object retval
= Qnil
;
5208 size_t tot_before
= 0;
5209 struct backtrace backtrace
;
5214 /* Can't GC if pure storage overflowed because we can't determine
5215 if something is a pure object or not. */
5216 if (pure_bytes_used_before_overflow
)
5219 /* Record this function, so it appears on the profiler's backtraces. */
5220 backtrace
.next
= backtrace_list
;
5221 backtrace
.function
= Qautomatic_gc
;
5222 backtrace
.args
= &Qnil
;
5223 backtrace
.nargs
= 0;
5224 backtrace
.debug_on_exit
= 0;
5225 backtrace_list
= &backtrace
;
5229 /* Don't keep undo information around forever.
5230 Do this early on, so it is no problem if the user quits. */
5231 FOR_EACH_BUFFER (nextb
)
5232 compact_buffer (nextb
);
5234 if (profiler_memory_running
)
5235 tot_before
= total_bytes_of_live_objects ();
5237 start
= current_emacs_time ();
5239 /* In case user calls debug_print during GC,
5240 don't let that cause a recursive GC. */
5241 consing_since_gc
= 0;
5243 /* Save what's currently displayed in the echo area. */
5244 message_p
= push_message ();
5245 record_unwind_protect (pop_message_unwind
, Qnil
);
5247 /* Save a copy of the contents of the stack, for debugging. */
5248 #if MAX_SAVE_STACK > 0
5249 if (NILP (Vpurify_flag
))
5252 ptrdiff_t stack_size
;
5253 if (&stack_top_variable
< stack_bottom
)
5255 stack
= &stack_top_variable
;
5256 stack_size
= stack_bottom
- &stack_top_variable
;
5260 stack
= stack_bottom
;
5261 stack_size
= &stack_top_variable
- stack_bottom
;
5263 if (stack_size
<= MAX_SAVE_STACK
)
5265 if (stack_copy_size
< stack_size
)
5267 stack_copy
= xrealloc (stack_copy
, stack_size
);
5268 stack_copy_size
= stack_size
;
5270 memcpy (stack_copy
, stack
, stack_size
);
5273 #endif /* MAX_SAVE_STACK > 0 */
5275 if (garbage_collection_messages
)
5276 message1_nolog ("Garbage collecting...");
5280 shrink_regexp_cache ();
5284 /* Mark all the special slots that serve as the roots of accessibility. */
5286 mark_buffer (&buffer_defaults
);
5287 mark_buffer (&buffer_local_symbols
);
5289 for (i
= 0; i
< staticidx
; i
++)
5290 mark_object (*staticvec
[i
]);
5300 #ifdef HAVE_WINDOW_SYSTEM
5301 mark_fringe_data ();
5304 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5309 /* Everything is now marked, except for the things that require special
5310 finalization, i.e. the undo_list.
5311 Look thru every buffer's undo list
5312 for elements that update markers that were not marked,
5314 FOR_EACH_BUFFER (nextb
)
5316 /* If a buffer's undo list is Qt, that means that undo is
5317 turned off in that buffer. Calling truncate_undo_list on
5318 Qt tends to return NULL, which effectively turns undo back on.
5319 So don't call truncate_undo_list if undo_list is Qt. */
5320 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5322 Lisp_Object tail
, prev
;
5323 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5325 while (CONSP (tail
))
5327 if (CONSP (XCAR (tail
))
5328 && MARKERP (XCAR (XCAR (tail
)))
5329 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5332 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5336 XSETCDR (prev
, tail
);
5346 /* Now that we have stripped the elements that need not be in the
5347 undo_list any more, we can finally mark the list. */
5348 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5353 /* Clear the mark bits that we set in certain root slots. */
5356 VECTOR_UNMARK (&buffer_defaults
);
5357 VECTOR_UNMARK (&buffer_local_symbols
);
5359 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5369 consing_since_gc
= 0;
5370 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5371 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5373 gc_relative_threshold
= 0;
5374 if (FLOATP (Vgc_cons_percentage
))
5375 { /* Set gc_cons_combined_threshold. */
5376 double tot
= total_bytes_of_live_objects ();
5378 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5381 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5382 gc_relative_threshold
= tot
;
5384 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5388 if (garbage_collection_messages
)
5390 if (message_p
|| minibuf_level
> 0)
5393 message1_nolog ("Garbage collecting...done");
5396 unbind_to (count
, Qnil
);
5398 Lisp_Object total
[11];
5399 int total_size
= 10;
5401 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5402 bounded_number (total_conses
),
5403 bounded_number (total_free_conses
));
5405 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5406 bounded_number (total_symbols
),
5407 bounded_number (total_free_symbols
));
5409 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5410 bounded_number (total_markers
),
5411 bounded_number (total_free_markers
));
5413 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5414 bounded_number (total_strings
),
5415 bounded_number (total_free_strings
));
5417 total
[4] = list3 (Qstring_bytes
, make_number (1),
5418 bounded_number (total_string_bytes
));
5420 total
[5] = list3 (Qvectors
, make_number (sizeof (struct Lisp_Vector
)),
5421 bounded_number (total_vectors
));
5423 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5424 bounded_number (total_vector_slots
),
5425 bounded_number (total_free_vector_slots
));
5427 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5428 bounded_number (total_floats
),
5429 bounded_number (total_free_floats
));
5431 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5432 bounded_number (total_intervals
),
5433 bounded_number (total_free_intervals
));
5435 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5436 bounded_number (total_buffers
));
5438 #ifdef DOUG_LEA_MALLOC
5440 total
[10] = list4 (Qheap
, make_number (1024),
5441 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5442 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5444 retval
= Flist (total_size
, total
);
5447 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5449 /* Compute average percentage of zombies. */
5451 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5452 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5454 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5455 max_live
= max (nlive
, max_live
);
5456 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5457 max_zombies
= max (nzombies
, max_zombies
);
5462 if (!NILP (Vpost_gc_hook
))
5464 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5465 safe_run_hooks (Qpost_gc_hook
);
5466 unbind_to (gc_count
, Qnil
);
5469 /* Accumulate statistics. */
5470 if (FLOATP (Vgc_elapsed
))
5472 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5473 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5474 + EMACS_TIME_TO_DOUBLE (since_start
));
5479 /* Collect profiling data. */
5480 if (profiler_memory_running
)
5483 size_t tot_after
= total_bytes_of_live_objects ();
5484 if (tot_before
> tot_after
)
5485 swept
= tot_before
- tot_after
;
5486 malloc_probe (swept
);
5489 backtrace_list
= backtrace
.next
;
5494 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5495 only interesting objects referenced from glyphs are strings. */
5498 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5500 struct glyph_row
*row
= matrix
->rows
;
5501 struct glyph_row
*end
= row
+ matrix
->nrows
;
5503 for (; row
< end
; ++row
)
5507 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5509 struct glyph
*glyph
= row
->glyphs
[area
];
5510 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5512 for (; glyph
< end_glyph
; ++glyph
)
5513 if (STRINGP (glyph
->object
)
5514 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5515 mark_object (glyph
->object
);
5521 /* Mark Lisp faces in the face cache C. */
5524 mark_face_cache (struct face_cache
*c
)
5529 for (i
= 0; i
< c
->used
; ++i
)
5531 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5535 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5536 mark_object (face
->lface
[j
]);
5544 /* Mark reference to a Lisp_Object.
5545 If the object referred to has not been seen yet, recursively mark
5546 all the references contained in it. */
5548 #define LAST_MARKED_SIZE 500
5549 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5550 static int last_marked_index
;
5552 /* For debugging--call abort when we cdr down this many
5553 links of a list, in mark_object. In debugging,
5554 the call to abort will hit a breakpoint.
5555 Normally this is zero and the check never goes off. */
5556 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5559 mark_vectorlike (struct Lisp_Vector
*ptr
)
5561 ptrdiff_t size
= ptr
->header
.size
;
5564 eassert (!VECTOR_MARKED_P (ptr
));
5565 VECTOR_MARK (ptr
); /* Else mark it. */
5566 if (size
& PSEUDOVECTOR_FLAG
)
5567 size
&= PSEUDOVECTOR_SIZE_MASK
;
5569 /* Note that this size is not the memory-footprint size, but only
5570 the number of Lisp_Object fields that we should trace.
5571 The distinction is used e.g. by Lisp_Process which places extra
5572 non-Lisp_Object fields at the end of the structure... */
5573 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5574 mark_object (ptr
->contents
[i
]);
5577 /* Like mark_vectorlike but optimized for char-tables (and
5578 sub-char-tables) assuming that the contents are mostly integers or
5582 mark_char_table (struct Lisp_Vector
*ptr
)
5584 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5587 eassert (!VECTOR_MARKED_P (ptr
));
5589 for (i
= 0; i
< size
; i
++)
5591 Lisp_Object val
= ptr
->contents
[i
];
5593 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5595 if (SUB_CHAR_TABLE_P (val
))
5597 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5598 mark_char_table (XVECTOR (val
));
5605 /* Mark the chain of overlays starting at PTR. */
5608 mark_overlay (struct Lisp_Overlay
*ptr
)
5610 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5613 mark_object (ptr
->start
);
5614 mark_object (ptr
->end
);
5615 mark_object (ptr
->plist
);
5619 /* Mark Lisp_Objects and special pointers in BUFFER. */
5622 mark_buffer (struct buffer
*buffer
)
5624 /* This is handled much like other pseudovectors... */
5625 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5627 /* ...but there are some buffer-specific things. */
5629 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5631 /* For now, we just don't mark the undo_list. It's done later in
5632 a special way just before the sweep phase, and after stripping
5633 some of its elements that are not needed any more. */
5635 mark_overlay (buffer
->overlays_before
);
5636 mark_overlay (buffer
->overlays_after
);
5638 /* If this is an indirect buffer, mark its base buffer. */
5639 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5640 mark_buffer (buffer
->base_buffer
);
5643 /* Remove killed buffers or items whose car is a killed buffer from
5644 LIST, and mark other items. Return changed LIST, which is marked. */
5647 mark_discard_killed_buffers (Lisp_Object list
)
5649 Lisp_Object tail
, *prev
= &list
;
5651 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5654 Lisp_Object tem
= XCAR (tail
);
5657 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5658 *prev
= XCDR (tail
);
5661 CONS_MARK (XCONS (tail
));
5662 mark_object (XCAR (tail
));
5663 prev
= &XCDR_AS_LVALUE (tail
);
5670 /* Determine type of generic Lisp_Object and mark it accordingly. */
5673 mark_object (Lisp_Object arg
)
5675 register Lisp_Object obj
= arg
;
5676 #ifdef GC_CHECK_MARKED_OBJECTS
5680 ptrdiff_t cdr_count
= 0;
5684 if (PURE_POINTER_P (XPNTR (obj
)))
5687 last_marked
[last_marked_index
++] = obj
;
5688 if (last_marked_index
== LAST_MARKED_SIZE
)
5689 last_marked_index
= 0;
5691 /* Perform some sanity checks on the objects marked here. Abort if
5692 we encounter an object we know is bogus. This increases GC time
5693 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5694 #ifdef GC_CHECK_MARKED_OBJECTS
5696 po
= (void *) XPNTR (obj
);
5698 /* Check that the object pointed to by PO is known to be a Lisp
5699 structure allocated from the heap. */
5700 #define CHECK_ALLOCATED() \
5702 m = mem_find (po); \
5707 /* Check that the object pointed to by PO is live, using predicate
5709 #define CHECK_LIVE(LIVEP) \
5711 if (!LIVEP (m, po)) \
5715 /* Check both of the above conditions. */
5716 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5718 CHECK_ALLOCATED (); \
5719 CHECK_LIVE (LIVEP); \
5722 #else /* not GC_CHECK_MARKED_OBJECTS */
5724 #define CHECK_LIVE(LIVEP) (void) 0
5725 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5727 #endif /* not GC_CHECK_MARKED_OBJECTS */
5729 switch (XTYPE (obj
))
5733 register struct Lisp_String
*ptr
= XSTRING (obj
);
5734 if (STRING_MARKED_P (ptr
))
5736 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5738 MARK_INTERVAL_TREE (ptr
->intervals
);
5739 #ifdef GC_CHECK_STRING_BYTES
5740 /* Check that the string size recorded in the string is the
5741 same as the one recorded in the sdata structure. */
5743 #endif /* GC_CHECK_STRING_BYTES */
5747 case Lisp_Vectorlike
:
5749 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5750 register ptrdiff_t pvectype
;
5752 if (VECTOR_MARKED_P (ptr
))
5755 #ifdef GC_CHECK_MARKED_OBJECTS
5757 if (m
== MEM_NIL
&& !SUBRP (obj
))
5759 #endif /* GC_CHECK_MARKED_OBJECTS */
5761 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5762 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5763 >> PSEUDOVECTOR_AREA_BITS
);
5765 pvectype
= PVEC_NORMAL_VECTOR
;
5767 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5768 CHECK_LIVE (live_vector_p
);
5773 #ifdef GC_CHECK_MARKED_OBJECTS
5782 #endif /* GC_CHECK_MARKED_OBJECTS */
5783 mark_buffer ((struct buffer
*) ptr
);
5787 { /* We could treat this just like a vector, but it is better
5788 to save the COMPILED_CONSTANTS element for last and avoid
5790 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5794 for (i
= 0; i
< size
; i
++)
5795 if (i
!= COMPILED_CONSTANTS
)
5796 mark_object (ptr
->contents
[i
]);
5797 if (size
> COMPILED_CONSTANTS
)
5799 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5806 mark_vectorlike (ptr
);
5807 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5812 struct window
*w
= (struct window
*) ptr
;
5813 bool leaf
= NILP (w
->hchild
) && NILP (w
->vchild
);
5815 mark_vectorlike (ptr
);
5817 /* Mark glyphs for leaf windows. Marking window
5818 matrices is sufficient because frame matrices
5819 use the same glyph memory. */
5820 if (leaf
&& w
->current_matrix
)
5822 mark_glyph_matrix (w
->current_matrix
);
5823 mark_glyph_matrix (w
->desired_matrix
);
5826 /* Filter out killed buffers from both buffer lists
5827 in attempt to help GC to reclaim killed buffers faster.
5828 We can do it elsewhere for live windows, but this is the
5829 best place to do it for dead windows. */
5831 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5833 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5837 case PVEC_HASH_TABLE
:
5839 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5841 mark_vectorlike (ptr
);
5842 mark_object (h
->test
.name
);
5843 mark_object (h
->test
.user_hash_function
);
5844 mark_object (h
->test
.user_cmp_function
);
5845 /* If hash table is not weak, mark all keys and values.
5846 For weak tables, mark only the vector. */
5848 mark_object (h
->key_and_value
);
5850 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5854 case PVEC_CHAR_TABLE
:
5855 mark_char_table (ptr
);
5858 case PVEC_BOOL_VECTOR
:
5859 /* No Lisp_Objects to mark in a bool vector. */
5870 mark_vectorlike (ptr
);
5877 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5878 struct Lisp_Symbol
*ptrx
;
5882 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5884 mark_object (ptr
->function
);
5885 mark_object (ptr
->plist
);
5886 switch (ptr
->redirect
)
5888 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5889 case SYMBOL_VARALIAS
:
5892 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5896 case SYMBOL_LOCALIZED
:
5898 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5899 Lisp_Object where
= blv
->where
;
5900 /* If the value is set up for a killed buffer or deleted
5901 frame, restore it's global binding. If the value is
5902 forwarded to a C variable, either it's not a Lisp_Object
5903 var, or it's staticpro'd already. */
5904 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5905 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5906 swap_in_global_binding (ptr
);
5907 mark_object (blv
->where
);
5908 mark_object (blv
->valcell
);
5909 mark_object (blv
->defcell
);
5912 case SYMBOL_FORWARDED
:
5913 /* If the value is forwarded to a buffer or keyboard field,
5914 these are marked when we see the corresponding object.
5915 And if it's forwarded to a C variable, either it's not
5916 a Lisp_Object var, or it's staticpro'd already. */
5918 default: emacs_abort ();
5920 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5921 MARK_STRING (XSTRING (ptr
->name
));
5922 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5927 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5928 XSETSYMBOL (obj
, ptrx
);
5935 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5937 if (XMISCANY (obj
)->gcmarkbit
)
5940 switch (XMISCTYPE (obj
))
5942 case Lisp_Misc_Marker
:
5943 /* DO NOT mark thru the marker's chain.
5944 The buffer's markers chain does not preserve markers from gc;
5945 instead, markers are removed from the chain when freed by gc. */
5946 XMISCANY (obj
)->gcmarkbit
= 1;
5949 case Lisp_Misc_Save_Value
:
5950 XMISCANY (obj
)->gcmarkbit
= 1;
5952 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5953 /* If `area' is nonzero, `data[0].pointer' is the address
5954 of a memory area containing `data[1].integer' potential
5959 Lisp_Object
*p
= ptr
->data
[0].pointer
;
5961 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
5962 mark_maybe_object (*p
);
5965 #endif /* GC_MARK_STACK */
5967 /* Find Lisp_Objects in `data[N]' slots and mark them. */
5968 if (ptr
->type0
== SAVE_OBJECT
)
5969 mark_object (ptr
->data
[0].object
);
5970 if (ptr
->type1
== SAVE_OBJECT
)
5971 mark_object (ptr
->data
[1].object
);
5972 if (ptr
->type2
== SAVE_OBJECT
)
5973 mark_object (ptr
->data
[2].object
);
5974 if (ptr
->type3
== SAVE_OBJECT
)
5975 mark_object (ptr
->data
[3].object
);
5980 case Lisp_Misc_Overlay
:
5981 mark_overlay (XOVERLAY (obj
));
5991 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5992 if (CONS_MARKED_P (ptr
))
5994 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5996 /* If the cdr is nil, avoid recursion for the car. */
5997 if (EQ (ptr
->u
.cdr
, Qnil
))
6003 mark_object (ptr
->car
);
6006 if (cdr_count
== mark_object_loop_halt
)
6012 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6013 FLOAT_MARK (XFLOAT (obj
));
6024 #undef CHECK_ALLOCATED
6025 #undef CHECK_ALLOCATED_AND_LIVE
6027 /* Mark the Lisp pointers in the terminal objects.
6028 Called by Fgarbage_collect. */
6031 mark_terminals (void)
6034 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6036 eassert (t
->name
!= NULL
);
6037 #ifdef HAVE_WINDOW_SYSTEM
6038 /* If a terminal object is reachable from a stacpro'ed object,
6039 it might have been marked already. Make sure the image cache
6041 mark_image_cache (t
->image_cache
);
6042 #endif /* HAVE_WINDOW_SYSTEM */
6043 if (!VECTOR_MARKED_P (t
))
6044 mark_vectorlike ((struct Lisp_Vector
*)t
);
6050 /* Value is non-zero if OBJ will survive the current GC because it's
6051 either marked or does not need to be marked to survive. */
6054 survives_gc_p (Lisp_Object obj
)
6058 switch (XTYPE (obj
))
6065 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6069 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6073 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6076 case Lisp_Vectorlike
:
6077 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6081 survives_p
= CONS_MARKED_P (XCONS (obj
));
6085 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6092 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6097 /* Sweep: find all structures not marked, and free them. */
6102 /* Remove or mark entries in weak hash tables.
6103 This must be done before any object is unmarked. */
6104 sweep_weak_hash_tables ();
6107 check_string_bytes (!noninteractive
);
6109 /* Put all unmarked conses on free list */
6111 register struct cons_block
*cblk
;
6112 struct cons_block
**cprev
= &cons_block
;
6113 register int lim
= cons_block_index
;
6114 EMACS_INT num_free
= 0, num_used
= 0;
6118 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6122 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6124 /* Scan the mark bits an int at a time. */
6125 for (i
= 0; i
< ilim
; i
++)
6127 if (cblk
->gcmarkbits
[i
] == -1)
6129 /* Fast path - all cons cells for this int are marked. */
6130 cblk
->gcmarkbits
[i
] = 0;
6131 num_used
+= BITS_PER_INT
;
6135 /* Some cons cells for this int are not marked.
6136 Find which ones, and free them. */
6137 int start
, pos
, stop
;
6139 start
= i
* BITS_PER_INT
;
6141 if (stop
> BITS_PER_INT
)
6142 stop
= BITS_PER_INT
;
6145 for (pos
= start
; pos
< stop
; pos
++)
6147 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6150 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6151 cons_free_list
= &cblk
->conses
[pos
];
6153 cons_free_list
->car
= Vdead
;
6159 CONS_UNMARK (&cblk
->conses
[pos
]);
6165 lim
= CONS_BLOCK_SIZE
;
6166 /* If this block contains only free conses and we have already
6167 seen more than two blocks worth of free conses then deallocate
6169 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6171 *cprev
= cblk
->next
;
6172 /* Unhook from the free list. */
6173 cons_free_list
= cblk
->conses
[0].u
.chain
;
6174 lisp_align_free (cblk
);
6178 num_free
+= this_free
;
6179 cprev
= &cblk
->next
;
6182 total_conses
= num_used
;
6183 total_free_conses
= num_free
;
6186 /* Put all unmarked floats on free list */
6188 register struct float_block
*fblk
;
6189 struct float_block
**fprev
= &float_block
;
6190 register int lim
= float_block_index
;
6191 EMACS_INT num_free
= 0, num_used
= 0;
6193 float_free_list
= 0;
6195 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6199 for (i
= 0; i
< lim
; i
++)
6200 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6203 fblk
->floats
[i
].u
.chain
= float_free_list
;
6204 float_free_list
= &fblk
->floats
[i
];
6209 FLOAT_UNMARK (&fblk
->floats
[i
]);
6211 lim
= FLOAT_BLOCK_SIZE
;
6212 /* If this block contains only free floats and we have already
6213 seen more than two blocks worth of free floats then deallocate
6215 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6217 *fprev
= fblk
->next
;
6218 /* Unhook from the free list. */
6219 float_free_list
= fblk
->floats
[0].u
.chain
;
6220 lisp_align_free (fblk
);
6224 num_free
+= this_free
;
6225 fprev
= &fblk
->next
;
6228 total_floats
= num_used
;
6229 total_free_floats
= num_free
;
6232 /* Put all unmarked intervals on free list */
6234 register struct interval_block
*iblk
;
6235 struct interval_block
**iprev
= &interval_block
;
6236 register int lim
= interval_block_index
;
6237 EMACS_INT num_free
= 0, num_used
= 0;
6239 interval_free_list
= 0;
6241 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6246 for (i
= 0; i
< lim
; i
++)
6248 if (!iblk
->intervals
[i
].gcmarkbit
)
6250 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6251 interval_free_list
= &iblk
->intervals
[i
];
6257 iblk
->intervals
[i
].gcmarkbit
= 0;
6260 lim
= INTERVAL_BLOCK_SIZE
;
6261 /* If this block contains only free intervals and we have already
6262 seen more than two blocks worth of free intervals then
6263 deallocate this block. */
6264 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6266 *iprev
= iblk
->next
;
6267 /* Unhook from the free list. */
6268 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6273 num_free
+= this_free
;
6274 iprev
= &iblk
->next
;
6277 total_intervals
= num_used
;
6278 total_free_intervals
= num_free
;
6281 /* Put all unmarked symbols on free list */
6283 register struct symbol_block
*sblk
;
6284 struct symbol_block
**sprev
= &symbol_block
;
6285 register int lim
= symbol_block_index
;
6286 EMACS_INT num_free
= 0, num_used
= 0;
6288 symbol_free_list
= NULL
;
6290 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6293 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6294 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6296 for (; sym
< end
; ++sym
)
6298 /* Check if the symbol was created during loadup. In such a case
6299 it might be pointed to by pure bytecode which we don't trace,
6300 so we conservatively assume that it is live. */
6301 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6303 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6305 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6306 xfree (SYMBOL_BLV (&sym
->s
));
6307 sym
->s
.next
= symbol_free_list
;
6308 symbol_free_list
= &sym
->s
;
6310 symbol_free_list
->function
= Vdead
;
6318 UNMARK_STRING (XSTRING (sym
->s
.name
));
6319 sym
->s
.gcmarkbit
= 0;
6323 lim
= SYMBOL_BLOCK_SIZE
;
6324 /* If this block contains only free symbols and we have already
6325 seen more than two blocks worth of free symbols then deallocate
6327 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6329 *sprev
= sblk
->next
;
6330 /* Unhook from the free list. */
6331 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6336 num_free
+= this_free
;
6337 sprev
= &sblk
->next
;
6340 total_symbols
= num_used
;
6341 total_free_symbols
= num_free
;
6344 /* Put all unmarked misc's on free list.
6345 For a marker, first unchain it from the buffer it points into. */
6347 register struct marker_block
*mblk
;
6348 struct marker_block
**mprev
= &marker_block
;
6349 register int lim
= marker_block_index
;
6350 EMACS_INT num_free
= 0, num_used
= 0;
6352 marker_free_list
= 0;
6354 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6359 for (i
= 0; i
< lim
; i
++)
6361 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6363 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6364 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6365 /* Set the type of the freed object to Lisp_Misc_Free.
6366 We could leave the type alone, since nobody checks it,
6367 but this might catch bugs faster. */
6368 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6369 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6370 marker_free_list
= &mblk
->markers
[i
].m
;
6376 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6379 lim
= MARKER_BLOCK_SIZE
;
6380 /* If this block contains only free markers and we have already
6381 seen more than two blocks worth of free markers then deallocate
6383 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6385 *mprev
= mblk
->next
;
6386 /* Unhook from the free list. */
6387 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6392 num_free
+= this_free
;
6393 mprev
= &mblk
->next
;
6397 total_markers
= num_used
;
6398 total_free_markers
= num_free
;
6401 /* Free all unmarked buffers */
6403 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6406 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6407 if (!VECTOR_MARKED_P (buffer
))
6409 *bprev
= buffer
->next
;
6414 VECTOR_UNMARK (buffer
);
6415 /* Do not use buffer_(set|get)_intervals here. */
6416 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6418 bprev
= &buffer
->next
;
6423 check_string_bytes (!noninteractive
);
6429 /* Debugging aids. */
6431 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6432 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6433 This may be helpful in debugging Emacs's memory usage.
6434 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6439 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6444 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6445 doc
: /* Return a list of counters that measure how much consing there has been.
6446 Each of these counters increments for a certain kind of object.
6447 The counters wrap around from the largest positive integer to zero.
6448 Garbage collection does not decrease them.
6449 The elements of the value are as follows:
6450 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6451 All are in units of 1 = one object consed
6452 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6454 MISCS include overlays, markers, and some internal types.
6455 Frames, windows, buffers, and subprocesses count as vectors
6456 (but the contents of a buffer's text do not count here). */)
6459 return listn (CONSTYPE_HEAP
, 8,
6460 bounded_number (cons_cells_consed
),
6461 bounded_number (floats_consed
),
6462 bounded_number (vector_cells_consed
),
6463 bounded_number (symbols_consed
),
6464 bounded_number (string_chars_consed
),
6465 bounded_number (misc_objects_consed
),
6466 bounded_number (intervals_consed
),
6467 bounded_number (strings_consed
));
6470 /* Find at most FIND_MAX symbols which have OBJ as their value or
6471 function. This is used in gdbinit's `xwhichsymbols' command. */
6474 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6476 struct symbol_block
*sblk
;
6477 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6478 Lisp_Object found
= Qnil
;
6482 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6484 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6487 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6489 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6493 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6496 XSETSYMBOL (tem
, sym
);
6497 val
= find_symbol_value (tem
);
6499 || EQ (sym
->function
, obj
)
6500 || (!NILP (sym
->function
)
6501 && COMPILEDP (sym
->function
)
6502 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6505 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6507 found
= Fcons (tem
, found
);
6508 if (--find_max
== 0)
6516 unbind_to (gc_count
, Qnil
);
6520 #ifdef ENABLE_CHECKING
6522 bool suppress_checking
;
6525 die (const char *msg
, const char *file
, int line
)
6527 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6529 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6533 /* Initialization. */
6536 init_alloc_once (void)
6538 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6540 pure_size
= PURESIZE
;
6542 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6544 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6547 #ifdef DOUG_LEA_MALLOC
6548 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6549 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6550 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6555 refill_memory_reserve ();
6556 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6563 byte_stack_list
= 0;
6565 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6566 setjmp_tested_p
= longjmps_done
= 0;
6569 Vgc_elapsed
= make_float (0.0);
6574 syms_of_alloc (void)
6576 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6577 doc
: /* Number of bytes of consing between garbage collections.
6578 Garbage collection can happen automatically once this many bytes have been
6579 allocated since the last garbage collection. All data types count.
6581 Garbage collection happens automatically only when `eval' is called.
6583 By binding this temporarily to a large number, you can effectively
6584 prevent garbage collection during a part of the program.
6585 See also `gc-cons-percentage'. */);
6587 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6588 doc
: /* Portion of the heap used for allocation.
6589 Garbage collection can happen automatically once this portion of the heap
6590 has been allocated since the last garbage collection.
6591 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6592 Vgc_cons_percentage
= make_float (0.1);
6594 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6595 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6597 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6598 doc
: /* Number of cons cells that have been consed so far. */);
6600 DEFVAR_INT ("floats-consed", floats_consed
,
6601 doc
: /* Number of floats that have been consed so far. */);
6603 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6604 doc
: /* Number of vector cells that have been consed so far. */);
6606 DEFVAR_INT ("symbols-consed", symbols_consed
,
6607 doc
: /* Number of symbols that have been consed so far. */);
6609 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6610 doc
: /* Number of string characters that have been consed so far. */);
6612 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6613 doc
: /* Number of miscellaneous objects that have been consed so far.
6614 These include markers and overlays, plus certain objects not visible
6617 DEFVAR_INT ("intervals-consed", intervals_consed
,
6618 doc
: /* Number of intervals that have been consed so far. */);
6620 DEFVAR_INT ("strings-consed", strings_consed
,
6621 doc
: /* Number of strings that have been consed so far. */);
6623 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6624 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6625 This means that certain objects should be allocated in shared (pure) space.
6626 It can also be set to a hash-table, in which case this table is used to
6627 do hash-consing of the objects allocated to pure space. */);
6629 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6630 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6631 garbage_collection_messages
= 0;
6633 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6634 doc
: /* Hook run after garbage collection has finished. */);
6635 Vpost_gc_hook
= Qnil
;
6636 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6638 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6639 doc
: /* Precomputed `signal' argument for memory-full error. */);
6640 /* We build this in advance because if we wait until we need it, we might
6641 not be able to allocate the memory to hold it. */
6643 = listn (CONSTYPE_PURE
, 2, Qerror
,
6644 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6646 DEFVAR_LISP ("memory-full", Vmemory_full
,
6647 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6648 Vmemory_full
= Qnil
;
6650 DEFSYM (Qconses
, "conses");
6651 DEFSYM (Qsymbols
, "symbols");
6652 DEFSYM (Qmiscs
, "miscs");
6653 DEFSYM (Qstrings
, "strings");
6654 DEFSYM (Qvectors
, "vectors");
6655 DEFSYM (Qfloats
, "floats");
6656 DEFSYM (Qintervals
, "intervals");
6657 DEFSYM (Qbuffers
, "buffers");
6658 DEFSYM (Qstring_bytes
, "string-bytes");
6659 DEFSYM (Qvector_slots
, "vector-slots");
6660 DEFSYM (Qheap
, "heap");
6661 DEFSYM (Qautomatic_gc
, "Automatic GC");
6663 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6664 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6666 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6667 doc
: /* Accumulated time elapsed in garbage collections.
6668 The time is in seconds as a floating point value. */);
6669 DEFVAR_INT ("gcs-done", gcs_done
,
6670 doc
: /* Accumulated number of garbage collections done. */);
6675 defsubr (&Smake_byte_code
);
6676 defsubr (&Smake_list
);
6677 defsubr (&Smake_vector
);
6678 defsubr (&Smake_string
);
6679 defsubr (&Smake_bool_vector
);
6680 defsubr (&Smake_symbol
);
6681 defsubr (&Smake_marker
);
6682 defsubr (&Spurecopy
);
6683 defsubr (&Sgarbage_collect
);
6684 defsubr (&Smemory_limit
);
6685 defsubr (&Smemory_use_counts
);
6687 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6688 defsubr (&Sgc_status
);
6692 /* When compiled with GCC, GDB might say "No enum type named
6693 pvec_type" if we don't have at least one symbol with that type, and
6694 then xbacktrace could fail. Similarly for the other enums and
6695 their values. Some non-GCC compilers don't like these constructs. */
6699 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6700 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6701 enum char_bits char_bits
;
6702 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6703 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6704 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6705 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6706 enum Lisp_Bits Lisp_Bits
;
6707 enum Lisp_Compiled Lisp_Compiled
;
6708 enum maxargs maxargs
;
6709 enum MAX_ALLOCA MAX_ALLOCA
;
6710 enum More_Lisp_Bits More_Lisp_Bits
;
6711 enum pvec_type pvec_type
;
6713 enum lsb_bits lsb_bits
;
6715 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6716 #endif /* __GNUC__ */