1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
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 mark_terminals (void);
213 static void gc_sweep (void);
214 static Lisp_Object
make_pure_vector (ptrdiff_t);
215 static void mark_buffer (struct buffer
*);
217 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
218 static void refill_memory_reserve (void);
220 static void compact_small_strings (void);
221 static void free_large_strings (void);
222 static void free_misc (Lisp_Object
);
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 /* Base address of stack. Set in main. */
311 Lisp_Object
*stack_base
;
313 /* Root of the tree describing allocated Lisp memory. */
315 static struct mem_node
*mem_root
;
317 /* Lowest and highest known address in the heap. */
319 static void *min_heap_address
, *max_heap_address
;
321 /* Sentinel node of the tree. */
323 static struct mem_node mem_z
;
324 #define MEM_NIL &mem_z
326 static struct Lisp_Vector
*allocate_vectorlike (ptrdiff_t);
327 static void lisp_free (void *);
328 static void mark_stack (void);
329 static bool live_vector_p (struct mem_node
*, void *);
330 static bool live_buffer_p (struct mem_node
*, void *);
331 static bool live_string_p (struct mem_node
*, void *);
332 static bool live_cons_p (struct mem_node
*, void *);
333 static bool live_symbol_p (struct mem_node
*, void *);
334 static bool live_float_p (struct mem_node
*, void *);
335 static bool live_misc_p (struct mem_node
*, void *);
336 static void mark_maybe_object (Lisp_Object
);
337 static void mark_memory (void *, void *);
338 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
339 static void mem_init (void);
340 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
341 static void mem_insert_fixup (struct mem_node
*);
342 static void mem_rotate_left (struct mem_node
*);
343 static void mem_rotate_right (struct mem_node
*);
344 static void mem_delete (struct mem_node
*);
345 static void mem_delete_fixup (struct mem_node
*);
346 static struct mem_node
*mem_find (void *);
350 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
351 static void check_gcpros (void);
354 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
360 /* Recording what needs to be marked for gc. */
362 struct gcpro
*gcprolist
;
364 /* Addresses of staticpro'd variables. Initialize it to a nonzero
365 value; otherwise some compilers put it into BSS. */
367 #define NSTATICS 0x800
368 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
370 /* Index of next unused slot in staticvec. */
372 static int staticidx
;
374 static void *pure_alloc (size_t, int);
377 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
378 ALIGNMENT must be a power of 2. */
380 #define ALIGN(ptr, ALIGNMENT) \
381 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
382 & ~ ((ALIGNMENT) - 1)))
386 /************************************************************************
388 ************************************************************************/
390 /* Function malloc calls this if it finds we are near exhausting storage. */
393 malloc_warning (const char *str
)
395 pending_malloc_warning
= str
;
399 /* Display an already-pending malloc warning. */
402 display_malloc_warning (void)
404 call3 (intern ("display-warning"),
406 build_string (pending_malloc_warning
),
407 intern ("emergency"));
408 pending_malloc_warning
= 0;
411 /* Called if we can't allocate relocatable space for a buffer. */
414 buffer_memory_full (ptrdiff_t nbytes
)
416 /* If buffers use the relocating allocator, no need to free
417 spare_memory, because we may have plenty of malloc space left
418 that we could get, and if we don't, the malloc that fails will
419 itself cause spare_memory to be freed. If buffers don't use the
420 relocating allocator, treat this like any other failing
424 memory_full (nbytes
);
427 /* This used to call error, but if we've run out of memory, we could
428 get infinite recursion trying to build the string. */
429 xsignal (Qnil
, Vmemory_signal_data
);
432 /* A common multiple of the positive integers A and B. Ideally this
433 would be the least common multiple, but there's no way to do that
434 as a constant expression in C, so do the best that we can easily do. */
435 #define COMMON_MULTIPLE(a, b) \
436 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
438 #ifndef XMALLOC_OVERRUN_CHECK
439 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
442 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
445 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
446 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
447 block size in little-endian order. The trailer consists of
448 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
450 The header is used to detect whether this block has been allocated
451 through these functions, as some low-level libc functions may
452 bypass the malloc hooks. */
454 #define XMALLOC_OVERRUN_CHECK_SIZE 16
455 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
456 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
458 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
459 hold a size_t value and (2) the header size is a multiple of the
460 alignment that Emacs needs for C types and for USE_LSB_TAG. */
461 #define XMALLOC_BASE_ALIGNMENT \
462 alignof (union { long double d; intmax_t i; void *p; })
465 # define XMALLOC_HEADER_ALIGNMENT \
466 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
468 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
470 #define XMALLOC_OVERRUN_SIZE_SIZE \
471 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
472 + XMALLOC_HEADER_ALIGNMENT - 1) \
473 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
474 - XMALLOC_OVERRUN_CHECK_SIZE)
476 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
477 { '\x9a', '\x9b', '\xae', '\xaf',
478 '\xbf', '\xbe', '\xce', '\xcf',
479 '\xea', '\xeb', '\xec', '\xed',
480 '\xdf', '\xde', '\x9c', '\x9d' };
482 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
483 { '\xaa', '\xab', '\xac', '\xad',
484 '\xba', '\xbb', '\xbc', '\xbd',
485 '\xca', '\xcb', '\xcc', '\xcd',
486 '\xda', '\xdb', '\xdc', '\xdd' };
488 /* Insert and extract the block size in the header. */
491 xmalloc_put_size (unsigned char *ptr
, size_t size
)
494 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
496 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
502 xmalloc_get_size (unsigned char *ptr
)
506 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
507 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
516 /* Like malloc, but wraps allocated block with header and trailer. */
519 overrun_check_malloc (size_t size
)
521 register unsigned char *val
;
522 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
525 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
528 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
529 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
530 xmalloc_put_size (val
, size
);
531 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
532 XMALLOC_OVERRUN_CHECK_SIZE
);
538 /* Like realloc, but checks old block for overrun, and wraps new block
539 with header and trailer. */
542 overrun_check_realloc (void *block
, size_t size
)
544 register unsigned char *val
= (unsigned char *) block
;
545 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
549 && memcmp (xmalloc_overrun_check_header
,
550 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
551 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
553 size_t osize
= xmalloc_get_size (val
);
554 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
555 XMALLOC_OVERRUN_CHECK_SIZE
))
557 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
558 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
559 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
562 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
566 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
567 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
568 xmalloc_put_size (val
, size
);
569 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
570 XMALLOC_OVERRUN_CHECK_SIZE
);
575 /* Like free, but checks block for overrun. */
578 overrun_check_free (void *block
)
580 unsigned char *val
= (unsigned char *) block
;
583 && memcmp (xmalloc_overrun_check_header
,
584 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
585 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
587 size_t osize
= xmalloc_get_size (val
);
588 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
589 XMALLOC_OVERRUN_CHECK_SIZE
))
591 #ifdef XMALLOC_CLEAR_FREE_MEMORY
592 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
593 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
595 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
596 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
597 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
607 #define malloc overrun_check_malloc
608 #define realloc overrun_check_realloc
609 #define free overrun_check_free
612 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
613 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
614 If that variable is set, block input while in one of Emacs's memory
615 allocation functions. There should be no need for this debugging
616 option, since signal handlers do not allocate memory, but Emacs
617 formerly allocated memory in signal handlers and this compile-time
618 option remains as a way to help debug the issue should it rear its
620 #ifdef XMALLOC_BLOCK_INPUT_CHECK
621 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
623 malloc_block_input (void)
625 if (block_input_in_memory_allocators
)
629 malloc_unblock_input (void)
631 if (block_input_in_memory_allocators
)
634 # define MALLOC_BLOCK_INPUT malloc_block_input ()
635 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
637 # define MALLOC_BLOCK_INPUT ((void) 0)
638 # define MALLOC_UNBLOCK_INPUT ((void) 0)
641 #define MALLOC_PROBE(size) \
643 if (profiler_memory_running) \
644 malloc_probe (size); \
648 /* Like malloc but check for no memory and block interrupt input.. */
651 xmalloc (size_t size
)
657 MALLOC_UNBLOCK_INPUT
;
665 /* Like the above, but zeroes out the memory just allocated. */
668 xzalloc (size_t size
)
674 MALLOC_UNBLOCK_INPUT
;
678 memset (val
, 0, size
);
683 /* Like realloc but check for no memory and block interrupt input.. */
686 xrealloc (void *block
, size_t size
)
691 /* We must call malloc explicitly when BLOCK is 0, since some
692 reallocs don't do this. */
696 val
= realloc (block
, size
);
697 MALLOC_UNBLOCK_INPUT
;
706 /* Like free but block interrupt input. */
715 MALLOC_UNBLOCK_INPUT
;
716 /* We don't call refill_memory_reserve here
717 because in practice the call in r_alloc_free seems to suffice. */
721 /* Other parts of Emacs pass large int values to allocator functions
722 expecting ptrdiff_t. This is portable in practice, but check it to
724 verify (INT_MAX
<= PTRDIFF_MAX
);
727 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
728 Signal an error on memory exhaustion, and block interrupt input. */
731 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
733 eassert (0 <= nitems
&& 0 < item_size
);
734 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
735 memory_full (SIZE_MAX
);
736 return xmalloc (nitems
* item_size
);
740 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
741 Signal an error on memory exhaustion, and block interrupt input. */
744 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
746 eassert (0 <= nitems
&& 0 < item_size
);
747 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
748 memory_full (SIZE_MAX
);
749 return xrealloc (pa
, nitems
* item_size
);
753 /* Grow PA, which points to an array of *NITEMS items, and return the
754 location of the reallocated array, updating *NITEMS to reflect its
755 new size. The new array will contain at least NITEMS_INCR_MIN more
756 items, but will not contain more than NITEMS_MAX items total.
757 ITEM_SIZE is the size of each item, in bytes.
759 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
760 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
763 If PA is null, then allocate a new array instead of reallocating
766 Block interrupt input as needed. If memory exhaustion occurs, set
767 *NITEMS to zero if PA is null, and signal an error (i.e., do not
770 Thus, to grow an array A without saving its old contents, do
771 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
772 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
773 and signals an error, and later this code is reexecuted and
774 attempts to free A. */
777 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
778 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
780 /* The approximate size to use for initial small allocation
781 requests. This is the largest "small" request for the GNU C
783 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
785 /* If the array is tiny, grow it to about (but no greater than)
786 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
787 ptrdiff_t n
= *nitems
;
788 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
789 ptrdiff_t half_again
= n
>> 1;
790 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
792 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
793 NITEMS_MAX, and what the C language can represent safely. */
794 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
795 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
796 ? nitems_max
: C_language_max
);
797 ptrdiff_t nitems_incr_max
= n_max
- n
;
798 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
800 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
803 if (nitems_incr_max
< incr
)
804 memory_full (SIZE_MAX
);
806 pa
= xrealloc (pa
, n
* item_size
);
812 /* Like strdup, but uses xmalloc. */
815 xstrdup (const char *s
)
817 size_t len
= strlen (s
) + 1;
818 char *p
= xmalloc (len
);
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_value (p
, 0));
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 nbytes
= vector_nbytes (vector
);
2839 total_bytes
= nbytes
;
2840 next
= ADVANCE (vector
, nbytes
);
2842 /* While NEXT is not marked, try to coalesce with VECTOR,
2843 thus making VECTOR of the largest possible size. */
2845 while (VECTOR_IN_BLOCK (next
, block
))
2847 if (VECTOR_MARKED_P (next
))
2849 nbytes
= vector_nbytes (next
);
2850 total_bytes
+= nbytes
;
2851 next
= ADVANCE (next
, nbytes
);
2854 eassert (total_bytes
% roundup_size
== 0);
2856 if (vector
== (struct Lisp_Vector
*) block
->data
2857 && !VECTOR_IN_BLOCK (next
, block
))
2858 /* This block should be freed because all of it's
2859 space was coalesced into the only free vector. */
2860 free_this_block
= 1;
2864 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2869 if (free_this_block
)
2871 *bprev
= block
->next
;
2872 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2873 mem_delete (mem_find (block
->data
));
2878 bprev
= &block
->next
;
2881 /* Sweep large vectors. */
2883 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2886 if (VECTOR_MARKED_P (vector
))
2888 VECTOR_UNMARK (vector
);
2890 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2892 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2894 /* All non-bool pseudovectors are small enough to be allocated
2895 from vector blocks. This code should be redesigned if some
2896 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2897 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2900 += (bool_header_size
2901 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2902 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2906 += header_size
/ word_size
+ vector
->header
.size
;
2907 lvprev
= &lv
->next
.vector
;
2911 *lvprev
= lv
->next
.vector
;
2917 /* Value is a pointer to a newly allocated Lisp_Vector structure
2918 with room for LEN Lisp_Objects. */
2920 static struct Lisp_Vector
*
2921 allocate_vectorlike (ptrdiff_t len
)
2923 struct Lisp_Vector
*p
;
2928 p
= XVECTOR (zero_vector
);
2931 size_t nbytes
= header_size
+ len
* word_size
;
2933 #ifdef DOUG_LEA_MALLOC
2934 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2935 because mapped region contents are not preserved in
2937 mallopt (M_MMAP_MAX
, 0);
2940 if (nbytes
<= VBLOCK_BYTES_MAX
)
2941 p
= allocate_vector_from_block (vroundup (nbytes
));
2944 struct large_vector
*lv
2945 = lisp_malloc (sizeof (*lv
) + (len
- 1) * word_size
,
2946 MEM_TYPE_VECTORLIKE
);
2947 lv
->next
.vector
= large_vectors
;
2952 #ifdef DOUG_LEA_MALLOC
2953 /* Back to a reasonable maximum of mmap'ed areas. */
2954 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2957 consing_since_gc
+= nbytes
;
2958 vector_cells_consed
+= len
;
2961 MALLOC_UNBLOCK_INPUT
;
2967 /* Allocate a vector with LEN slots. */
2969 struct Lisp_Vector
*
2970 allocate_vector (EMACS_INT len
)
2972 struct Lisp_Vector
*v
;
2973 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2975 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2976 memory_full (SIZE_MAX
);
2977 v
= allocate_vectorlike (len
);
2978 v
->header
.size
= len
;
2983 /* Allocate other vector-like structures. */
2985 struct Lisp_Vector
*
2986 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2988 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2991 /* Catch bogus values. */
2992 eassert (tag
<= PVEC_FONT
);
2993 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2994 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2996 /* Only the first lisplen slots will be traced normally by the GC. */
2997 for (i
= 0; i
< lisplen
; ++i
)
2998 v
->contents
[i
] = Qnil
;
3000 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3005 allocate_buffer (void)
3007 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3009 BUFFER_PVEC_INIT (b
);
3010 /* Put B on the chain of all buffers including killed ones. */
3011 b
->next
= all_buffers
;
3013 /* Note that the rest fields of B are not initialized. */
3017 struct Lisp_Hash_Table
*
3018 allocate_hash_table (void)
3020 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3024 allocate_window (void)
3028 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3029 /* Users assumes that non-Lisp data is zeroed. */
3030 memset (&w
->current_matrix
, 0,
3031 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3036 allocate_terminal (void)
3040 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3041 /* Users assumes that non-Lisp data is zeroed. */
3042 memset (&t
->next_terminal
, 0,
3043 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3048 allocate_frame (void)
3052 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3053 /* Users assumes that non-Lisp data is zeroed. */
3054 memset (&f
->face_cache
, 0,
3055 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3059 struct Lisp_Process
*
3060 allocate_process (void)
3062 struct Lisp_Process
*p
;
3064 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3065 /* Users assumes that non-Lisp data is zeroed. */
3067 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3071 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3072 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3073 See also the function `vector'. */)
3074 (register Lisp_Object length
, Lisp_Object init
)
3077 register ptrdiff_t sizei
;
3078 register ptrdiff_t i
;
3079 register struct Lisp_Vector
*p
;
3081 CHECK_NATNUM (length
);
3083 p
= allocate_vector (XFASTINT (length
));
3084 sizei
= XFASTINT (length
);
3085 for (i
= 0; i
< sizei
; i
++)
3086 p
->contents
[i
] = init
;
3088 XSETVECTOR (vector
, p
);
3093 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3094 doc
: /* Return a newly created vector with specified arguments as elements.
3095 Any number of arguments, even zero arguments, are allowed.
3096 usage: (vector &rest OBJECTS) */)
3097 (ptrdiff_t nargs
, Lisp_Object
*args
)
3099 register Lisp_Object len
, val
;
3101 register struct Lisp_Vector
*p
;
3103 XSETFASTINT (len
, nargs
);
3104 val
= Fmake_vector (len
, Qnil
);
3106 for (i
= 0; i
< nargs
; i
++)
3107 p
->contents
[i
] = args
[i
];
3112 make_byte_code (struct Lisp_Vector
*v
)
3114 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3115 && STRING_MULTIBYTE (v
->contents
[1]))
3116 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3117 earlier because they produced a raw 8-bit string for byte-code
3118 and now such a byte-code string is loaded as multibyte while
3119 raw 8-bit characters converted to multibyte form. Thus, now we
3120 must convert them back to the original unibyte form. */
3121 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3122 XSETPVECTYPE (v
, PVEC_COMPILED
);
3125 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3126 doc
: /* Create a byte-code object with specified arguments as elements.
3127 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3128 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3129 and (optional) INTERACTIVE-SPEC.
3130 The first four arguments are required; at most six have any
3132 The ARGLIST can be either like the one of `lambda', in which case the arguments
3133 will be dynamically bound before executing the byte code, or it can be an
3134 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3135 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3136 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3137 argument to catch the left-over arguments. If such an integer is used, the
3138 arguments will not be dynamically bound but will be instead pushed on the
3139 stack before executing the byte-code.
3140 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3141 (ptrdiff_t nargs
, Lisp_Object
*args
)
3143 register Lisp_Object len
, val
;
3145 register struct Lisp_Vector
*p
;
3147 /* We used to purecopy everything here, if purify-flag was set. This worked
3148 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3149 dangerous, since make-byte-code is used during execution to build
3150 closures, so any closure built during the preload phase would end up
3151 copied into pure space, including its free variables, which is sometimes
3152 just wasteful and other times plainly wrong (e.g. those free vars may want
3155 XSETFASTINT (len
, nargs
);
3156 val
= Fmake_vector (len
, Qnil
);
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_Misc_Save_Value object containing POINTER and
3346 INTEGER. This is used to package C values to call record_unwind_protect.
3347 The unwind function can get the C values back using XSAVE_VALUE. */
3350 make_save_value (void *pointer
, ptrdiff_t integer
)
3352 register Lisp_Object val
;
3353 register struct Lisp_Save_Value
*p
;
3355 val
= allocate_misc (Lisp_Misc_Save_Value
);
3356 p
= XSAVE_VALUE (val
);
3357 p
->pointer
= pointer
;
3358 p
->integer
= integer
;
3363 /* Free a Lisp_Misc_Save_Value object. */
3366 free_save_value (Lisp_Object save
)
3368 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (save
);
3376 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3379 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3381 register Lisp_Object overlay
;
3383 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3384 OVERLAY_START (overlay
) = start
;
3385 OVERLAY_END (overlay
) = end
;
3386 set_overlay_plist (overlay
, plist
);
3387 XOVERLAY (overlay
)->next
= NULL
;
3391 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3392 doc
: /* Return a newly allocated marker which does not point at any place. */)
3395 register Lisp_Object val
;
3396 register struct Lisp_Marker
*p
;
3398 val
= allocate_misc (Lisp_Misc_Marker
);
3404 p
->insertion_type
= 0;
3408 /* Return a newly allocated marker which points into BUF
3409 at character position CHARPOS and byte position BYTEPOS. */
3412 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3415 struct Lisp_Marker
*m
;
3417 /* No dead buffers here. */
3418 eassert (BUFFER_LIVE_P (buf
));
3420 /* Every character is at least one byte. */
3421 eassert (charpos
<= bytepos
);
3423 obj
= allocate_misc (Lisp_Misc_Marker
);
3426 m
->charpos
= charpos
;
3427 m
->bytepos
= bytepos
;
3428 m
->insertion_type
= 0;
3429 m
->next
= BUF_MARKERS (buf
);
3430 BUF_MARKERS (buf
) = m
;
3434 /* Put MARKER back on the free list after using it temporarily. */
3437 free_marker (Lisp_Object marker
)
3439 unchain_marker (XMARKER (marker
));
3444 /* Return a newly created vector or string with specified arguments as
3445 elements. If all the arguments are characters that can fit
3446 in a string of events, make a string; otherwise, make a vector.
3448 Any number of arguments, even zero arguments, are allowed. */
3451 make_event_array (register int nargs
, Lisp_Object
*args
)
3455 for (i
= 0; i
< nargs
; i
++)
3456 /* The things that fit in a string
3457 are characters that are in 0...127,
3458 after discarding the meta bit and all the bits above it. */
3459 if (!INTEGERP (args
[i
])
3460 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3461 return Fvector (nargs
, args
);
3463 /* Since the loop exited, we know that all the things in it are
3464 characters, so we can make a string. */
3468 result
= Fmake_string (make_number (nargs
), make_number (0));
3469 for (i
= 0; i
< nargs
; i
++)
3471 SSET (result
, i
, XINT (args
[i
]));
3472 /* Move the meta bit to the right place for a string char. */
3473 if (XINT (args
[i
]) & CHAR_META
)
3474 SSET (result
, i
, SREF (result
, i
) | 0x80);
3483 /************************************************************************
3484 Memory Full Handling
3485 ************************************************************************/
3488 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3489 there may have been size_t overflow so that malloc was never
3490 called, or perhaps malloc was invoked successfully but the
3491 resulting pointer had problems fitting into a tagged EMACS_INT. In
3492 either case this counts as memory being full even though malloc did
3496 memory_full (size_t nbytes
)
3498 /* Do not go into hysterics merely because a large request failed. */
3499 bool enough_free_memory
= 0;
3500 if (SPARE_MEMORY
< nbytes
)
3505 p
= malloc (SPARE_MEMORY
);
3509 enough_free_memory
= 1;
3511 MALLOC_UNBLOCK_INPUT
;
3514 if (! enough_free_memory
)
3520 memory_full_cons_threshold
= sizeof (struct cons_block
);
3522 /* The first time we get here, free the spare memory. */
3523 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3524 if (spare_memory
[i
])
3527 free (spare_memory
[i
]);
3528 else if (i
>= 1 && i
<= 4)
3529 lisp_align_free (spare_memory
[i
]);
3531 lisp_free (spare_memory
[i
]);
3532 spare_memory
[i
] = 0;
3536 /* This used to call error, but if we've run out of memory, we could
3537 get infinite recursion trying to build the string. */
3538 xsignal (Qnil
, Vmemory_signal_data
);
3541 /* If we released our reserve (due to running out of memory),
3542 and we have a fair amount free once again,
3543 try to set aside another reserve in case we run out once more.
3545 This is called when a relocatable block is freed in ralloc.c,
3546 and also directly from this file, in case we're not using ralloc.c. */
3549 refill_memory_reserve (void)
3551 #ifndef SYSTEM_MALLOC
3552 if (spare_memory
[0] == 0)
3553 spare_memory
[0] = malloc (SPARE_MEMORY
);
3554 if (spare_memory
[1] == 0)
3555 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3557 if (spare_memory
[2] == 0)
3558 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3560 if (spare_memory
[3] == 0)
3561 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3563 if (spare_memory
[4] == 0)
3564 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3566 if (spare_memory
[5] == 0)
3567 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3569 if (spare_memory
[6] == 0)
3570 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3572 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3573 Vmemory_full
= Qnil
;
3577 /************************************************************************
3579 ************************************************************************/
3581 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3583 /* Conservative C stack marking requires a method to identify possibly
3584 live Lisp objects given a pointer value. We do this by keeping
3585 track of blocks of Lisp data that are allocated in a red-black tree
3586 (see also the comment of mem_node which is the type of nodes in
3587 that tree). Function lisp_malloc adds information for an allocated
3588 block to the red-black tree with calls to mem_insert, and function
3589 lisp_free removes it with mem_delete. Functions live_string_p etc
3590 call mem_find to lookup information about a given pointer in the
3591 tree, and use that to determine if the pointer points to a Lisp
3594 /* Initialize this part of alloc.c. */
3599 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3600 mem_z
.parent
= NULL
;
3601 mem_z
.color
= MEM_BLACK
;
3602 mem_z
.start
= mem_z
.end
= NULL
;
3607 /* Value is a pointer to the mem_node containing START. Value is
3608 MEM_NIL if there is no node in the tree containing START. */
3610 static struct mem_node
*
3611 mem_find (void *start
)
3615 if (start
< min_heap_address
|| start
> max_heap_address
)
3618 /* Make the search always successful to speed up the loop below. */
3619 mem_z
.start
= start
;
3620 mem_z
.end
= (char *) start
+ 1;
3623 while (start
< p
->start
|| start
>= p
->end
)
3624 p
= start
< p
->start
? p
->left
: p
->right
;
3629 /* Insert a new node into the tree for a block of memory with start
3630 address START, end address END, and type TYPE. Value is a
3631 pointer to the node that was inserted. */
3633 static struct mem_node
*
3634 mem_insert (void *start
, void *end
, enum mem_type type
)
3636 struct mem_node
*c
, *parent
, *x
;
3638 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3639 min_heap_address
= start
;
3640 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3641 max_heap_address
= end
;
3643 /* See where in the tree a node for START belongs. In this
3644 particular application, it shouldn't happen that a node is already
3645 present. For debugging purposes, let's check that. */
3649 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3651 while (c
!= MEM_NIL
)
3653 if (start
>= c
->start
&& start
< c
->end
)
3656 c
= start
< c
->start
? c
->left
: c
->right
;
3659 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3661 while (c
!= MEM_NIL
)
3664 c
= start
< c
->start
? c
->left
: c
->right
;
3667 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3669 /* Create a new node. */
3670 #ifdef GC_MALLOC_CHECK
3671 x
= malloc (sizeof *x
);
3675 x
= xmalloc (sizeof *x
);
3681 x
->left
= x
->right
= MEM_NIL
;
3684 /* Insert it as child of PARENT or install it as root. */
3687 if (start
< parent
->start
)
3695 /* Re-establish red-black tree properties. */
3696 mem_insert_fixup (x
);
3702 /* Re-establish the red-black properties of the tree, and thereby
3703 balance the tree, after node X has been inserted; X is always red. */
3706 mem_insert_fixup (struct mem_node
*x
)
3708 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3710 /* X is red and its parent is red. This is a violation of
3711 red-black tree property #3. */
3713 if (x
->parent
== x
->parent
->parent
->left
)
3715 /* We're on the left side of our grandparent, and Y is our
3717 struct mem_node
*y
= x
->parent
->parent
->right
;
3719 if (y
->color
== MEM_RED
)
3721 /* Uncle and parent are red but should be black because
3722 X is red. Change the colors accordingly and proceed
3723 with the grandparent. */
3724 x
->parent
->color
= MEM_BLACK
;
3725 y
->color
= MEM_BLACK
;
3726 x
->parent
->parent
->color
= MEM_RED
;
3727 x
= x
->parent
->parent
;
3731 /* Parent and uncle have different colors; parent is
3732 red, uncle is black. */
3733 if (x
== x
->parent
->right
)
3736 mem_rotate_left (x
);
3739 x
->parent
->color
= MEM_BLACK
;
3740 x
->parent
->parent
->color
= MEM_RED
;
3741 mem_rotate_right (x
->parent
->parent
);
3746 /* This is the symmetrical case of above. */
3747 struct mem_node
*y
= x
->parent
->parent
->left
;
3749 if (y
->color
== MEM_RED
)
3751 x
->parent
->color
= MEM_BLACK
;
3752 y
->color
= MEM_BLACK
;
3753 x
->parent
->parent
->color
= MEM_RED
;
3754 x
= x
->parent
->parent
;
3758 if (x
== x
->parent
->left
)
3761 mem_rotate_right (x
);
3764 x
->parent
->color
= MEM_BLACK
;
3765 x
->parent
->parent
->color
= MEM_RED
;
3766 mem_rotate_left (x
->parent
->parent
);
3771 /* The root may have been changed to red due to the algorithm. Set
3772 it to black so that property #5 is satisfied. */
3773 mem_root
->color
= MEM_BLACK
;
3784 mem_rotate_left (struct mem_node
*x
)
3788 /* Turn y's left sub-tree into x's right sub-tree. */
3791 if (y
->left
!= MEM_NIL
)
3792 y
->left
->parent
= x
;
3794 /* Y's parent was x's parent. */
3796 y
->parent
= x
->parent
;
3798 /* Get the parent to point to y instead of x. */
3801 if (x
== x
->parent
->left
)
3802 x
->parent
->left
= y
;
3804 x
->parent
->right
= y
;
3809 /* Put x on y's left. */
3823 mem_rotate_right (struct mem_node
*x
)
3825 struct mem_node
*y
= x
->left
;
3828 if (y
->right
!= MEM_NIL
)
3829 y
->right
->parent
= x
;
3832 y
->parent
= x
->parent
;
3835 if (x
== x
->parent
->right
)
3836 x
->parent
->right
= y
;
3838 x
->parent
->left
= y
;
3849 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3852 mem_delete (struct mem_node
*z
)
3854 struct mem_node
*x
, *y
;
3856 if (!z
|| z
== MEM_NIL
)
3859 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3864 while (y
->left
!= MEM_NIL
)
3868 if (y
->left
!= MEM_NIL
)
3873 x
->parent
= y
->parent
;
3876 if (y
== y
->parent
->left
)
3877 y
->parent
->left
= x
;
3879 y
->parent
->right
= x
;
3886 z
->start
= y
->start
;
3891 if (y
->color
== MEM_BLACK
)
3892 mem_delete_fixup (x
);
3894 #ifdef GC_MALLOC_CHECK
3902 /* Re-establish the red-black properties of the tree, after a
3906 mem_delete_fixup (struct mem_node
*x
)
3908 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3910 if (x
== x
->parent
->left
)
3912 struct mem_node
*w
= x
->parent
->right
;
3914 if (w
->color
== MEM_RED
)
3916 w
->color
= MEM_BLACK
;
3917 x
->parent
->color
= MEM_RED
;
3918 mem_rotate_left (x
->parent
);
3919 w
= x
->parent
->right
;
3922 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3929 if (w
->right
->color
== MEM_BLACK
)
3931 w
->left
->color
= MEM_BLACK
;
3933 mem_rotate_right (w
);
3934 w
= x
->parent
->right
;
3936 w
->color
= x
->parent
->color
;
3937 x
->parent
->color
= MEM_BLACK
;
3938 w
->right
->color
= MEM_BLACK
;
3939 mem_rotate_left (x
->parent
);
3945 struct mem_node
*w
= x
->parent
->left
;
3947 if (w
->color
== MEM_RED
)
3949 w
->color
= MEM_BLACK
;
3950 x
->parent
->color
= MEM_RED
;
3951 mem_rotate_right (x
->parent
);
3952 w
= x
->parent
->left
;
3955 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3962 if (w
->left
->color
== MEM_BLACK
)
3964 w
->right
->color
= MEM_BLACK
;
3966 mem_rotate_left (w
);
3967 w
= x
->parent
->left
;
3970 w
->color
= x
->parent
->color
;
3971 x
->parent
->color
= MEM_BLACK
;
3972 w
->left
->color
= MEM_BLACK
;
3973 mem_rotate_right (x
->parent
);
3979 x
->color
= MEM_BLACK
;
3983 /* Value is non-zero if P is a pointer to a live Lisp string on
3984 the heap. M is a pointer to the mem_block for P. */
3987 live_string_p (struct mem_node
*m
, void *p
)
3989 if (m
->type
== MEM_TYPE_STRING
)
3991 struct string_block
*b
= (struct string_block
*) m
->start
;
3992 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3994 /* P must point to the start of a Lisp_String structure, and it
3995 must not be on the free-list. */
3997 && offset
% sizeof b
->strings
[0] == 0
3998 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3999 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4006 /* Value is non-zero if P is a pointer to a live Lisp cons on
4007 the heap. M is a pointer to the mem_block for P. */
4010 live_cons_p (struct mem_node
*m
, void *p
)
4012 if (m
->type
== MEM_TYPE_CONS
)
4014 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4015 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4017 /* P must point to the start of a Lisp_Cons, not be
4018 one of the unused cells in the current cons block,
4019 and not be on the free-list. */
4021 && offset
% sizeof b
->conses
[0] == 0
4022 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4024 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4025 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4032 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4033 the heap. M is a pointer to the mem_block for P. */
4036 live_symbol_p (struct mem_node
*m
, void *p
)
4038 if (m
->type
== MEM_TYPE_SYMBOL
)
4040 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4041 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4043 /* P must point to the start of a Lisp_Symbol, not be
4044 one of the unused cells in the current symbol block,
4045 and not be on the free-list. */
4047 && offset
% sizeof b
->symbols
[0] == 0
4048 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4049 && (b
!= symbol_block
4050 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4051 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4058 /* Value is non-zero if P is a pointer to a live Lisp float on
4059 the heap. M is a pointer to the mem_block for P. */
4062 live_float_p (struct mem_node
*m
, void *p
)
4064 if (m
->type
== MEM_TYPE_FLOAT
)
4066 struct float_block
*b
= (struct float_block
*) m
->start
;
4067 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4069 /* P must point to the start of a Lisp_Float and not be
4070 one of the unused cells in the current float block. */
4072 && offset
% sizeof b
->floats
[0] == 0
4073 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4074 && (b
!= float_block
4075 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4082 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4083 the heap. M is a pointer to the mem_block for P. */
4086 live_misc_p (struct mem_node
*m
, void *p
)
4088 if (m
->type
== MEM_TYPE_MISC
)
4090 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4091 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4093 /* P must point to the start of a Lisp_Misc, not be
4094 one of the unused cells in the current misc block,
4095 and not be on the free-list. */
4097 && offset
% sizeof b
->markers
[0] == 0
4098 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4099 && (b
!= marker_block
4100 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4101 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4108 /* Value is non-zero if P is a pointer to a live vector-like object.
4109 M is a pointer to the mem_block for P. */
4112 live_vector_p (struct mem_node
*m
, void *p
)
4114 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4116 /* This memory node corresponds to a vector block. */
4117 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4118 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4120 /* P is in the block's allocation range. Scan the block
4121 up to P and see whether P points to the start of some
4122 vector which is not on a free list. FIXME: check whether
4123 some allocation patterns (probably a lot of short vectors)
4124 may cause a substantial overhead of this loop. */
4125 while (VECTOR_IN_BLOCK (vector
, block
)
4126 && vector
<= (struct Lisp_Vector
*) p
)
4128 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4131 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4134 else if (m
->type
== MEM_TYPE_VECTORLIKE
4135 && (char *) p
== ((char *) m
->start
4136 + offsetof (struct large_vector
, v
)))
4137 /* This memory node corresponds to a large vector. */
4143 /* Value is non-zero if P is a pointer to a live buffer. M is a
4144 pointer to the mem_block for P. */
4147 live_buffer_p (struct mem_node
*m
, void *p
)
4149 /* P must point to the start of the block, and the buffer
4150 must not have been killed. */
4151 return (m
->type
== MEM_TYPE_BUFFER
4153 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4156 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4160 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4162 /* Array of objects that are kept alive because the C stack contains
4163 a pattern that looks like a reference to them . */
4165 #define MAX_ZOMBIES 10
4166 static Lisp_Object zombies
[MAX_ZOMBIES
];
4168 /* Number of zombie objects. */
4170 static EMACS_INT nzombies
;
4172 /* Number of garbage collections. */
4174 static EMACS_INT ngcs
;
4176 /* Average percentage of zombies per collection. */
4178 static double avg_zombies
;
4180 /* Max. number of live and zombie objects. */
4182 static EMACS_INT max_live
, max_zombies
;
4184 /* Average number of live objects per GC. */
4186 static double avg_live
;
4188 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4189 doc
: /* Show information about live and zombie objects. */)
4192 Lisp_Object args
[8], zombie_list
= Qnil
;
4194 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4195 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4196 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4197 args
[1] = make_number (ngcs
);
4198 args
[2] = make_float (avg_live
);
4199 args
[3] = make_float (avg_zombies
);
4200 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4201 args
[5] = make_number (max_live
);
4202 args
[6] = make_number (max_zombies
);
4203 args
[7] = zombie_list
;
4204 return Fmessage (8, args
);
4207 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4210 /* Mark OBJ if we can prove it's a Lisp_Object. */
4213 mark_maybe_object (Lisp_Object obj
)
4221 po
= (void *) XPNTR (obj
);
4228 switch (XTYPE (obj
))
4231 mark_p
= (live_string_p (m
, po
)
4232 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4236 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4240 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4244 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4247 case Lisp_Vectorlike
:
4248 /* Note: can't check BUFFERP before we know it's a
4249 buffer because checking that dereferences the pointer
4250 PO which might point anywhere. */
4251 if (live_vector_p (m
, po
))
4252 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4253 else if (live_buffer_p (m
, po
))
4254 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4258 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4267 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4268 if (nzombies
< MAX_ZOMBIES
)
4269 zombies
[nzombies
] = obj
;
4278 /* If P points to Lisp data, mark that as live if it isn't already
4282 mark_maybe_pointer (void *p
)
4286 /* Quickly rule out some values which can't point to Lisp data.
4287 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4288 Otherwise, assume that Lisp data is aligned on even addresses. */
4289 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4295 Lisp_Object obj
= Qnil
;
4299 case MEM_TYPE_NON_LISP
:
4300 case MEM_TYPE_SPARE
:
4301 /* Nothing to do; not a pointer to Lisp memory. */
4304 case MEM_TYPE_BUFFER
:
4305 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4306 XSETVECTOR (obj
, p
);
4310 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4314 case MEM_TYPE_STRING
:
4315 if (live_string_p (m
, p
)
4316 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4317 XSETSTRING (obj
, p
);
4321 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4325 case MEM_TYPE_SYMBOL
:
4326 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4327 XSETSYMBOL (obj
, p
);
4330 case MEM_TYPE_FLOAT
:
4331 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4335 case MEM_TYPE_VECTORLIKE
:
4336 case MEM_TYPE_VECTOR_BLOCK
:
4337 if (live_vector_p (m
, p
))
4340 XSETVECTOR (tem
, p
);
4341 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4356 /* Alignment of pointer values. Use alignof, as it sometimes returns
4357 a smaller alignment than GCC's __alignof__ and mark_memory might
4358 miss objects if __alignof__ were used. */
4359 #define GC_POINTER_ALIGNMENT alignof (void *)
4361 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4362 not suffice, which is the typical case. A host where a Lisp_Object is
4363 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4364 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4365 suffice to widen it to to a Lisp_Object and check it that way. */
4366 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4367 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4368 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4369 nor mark_maybe_object can follow the pointers. This should not occur on
4370 any practical porting target. */
4371 # error "MSB type bits straddle pointer-word boundaries"
4373 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4374 pointer words that hold pointers ORed with type bits. */
4375 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4377 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4378 words that hold unmodified pointers. */
4379 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4382 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4383 or END+OFFSET..START. */
4386 mark_memory (void *start
, void *end
)
4387 #if defined (__clang__) && defined (__has_feature)
4388 #if __has_feature(address_sanitizer)
4389 /* Do not allow -faddress-sanitizer to check this function, since it
4390 crosses the function stack boundary, and thus would yield many
4392 __attribute__((no_address_safety_analysis
))
4399 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4403 /* Make START the pointer to the start of the memory region,
4404 if it isn't already. */
4412 /* Mark Lisp data pointed to. This is necessary because, in some
4413 situations, the C compiler optimizes Lisp objects away, so that
4414 only a pointer to them remains. Example:
4416 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4419 Lisp_Object obj = build_string ("test");
4420 struct Lisp_String *s = XSTRING (obj);
4421 Fgarbage_collect ();
4422 fprintf (stderr, "test `%s'\n", s->data);
4426 Here, `obj' isn't really used, and the compiler optimizes it
4427 away. The only reference to the life string is through the
4430 for (pp
= start
; (void *) pp
< end
; pp
++)
4431 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4433 void *p
= *(void **) ((char *) pp
+ i
);
4434 mark_maybe_pointer (p
);
4435 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4436 mark_maybe_object (XIL ((intptr_t) p
));
4440 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4441 the GCC system configuration. In gcc 3.2, the only systems for
4442 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4443 by others?) and ns32k-pc532-min. */
4445 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4447 static bool setjmp_tested_p
;
4448 static int longjmps_done
;
4450 #define SETJMP_WILL_LIKELY_WORK "\
4452 Emacs garbage collector has been changed to use conservative stack\n\
4453 marking. Emacs has determined that the method it uses to do the\n\
4454 marking will likely work on your system, but this isn't sure.\n\
4456 If you are a system-programmer, or can get the help of a local wizard\n\
4457 who is, please take a look at the function mark_stack in alloc.c, and\n\
4458 verify that the methods used are appropriate for your system.\n\
4460 Please mail the result to <emacs-devel@gnu.org>.\n\
4463 #define SETJMP_WILL_NOT_WORK "\
4465 Emacs garbage collector has been changed to use conservative stack\n\
4466 marking. Emacs has determined that the default method it uses to do the\n\
4467 marking will not work on your system. We will need a system-dependent\n\
4468 solution for your system.\n\
4470 Please take a look at the function mark_stack in alloc.c, and\n\
4471 try to find a way to make it work on your system.\n\
4473 Note that you may get false negatives, depending on the compiler.\n\
4474 In particular, you need to use -O with GCC for this test.\n\
4476 Please mail the result to <emacs-devel@gnu.org>.\n\
4480 /* Perform a quick check if it looks like setjmp saves registers in a
4481 jmp_buf. Print a message to stderr saying so. When this test
4482 succeeds, this is _not_ a proof that setjmp is sufficient for
4483 conservative stack marking. Only the sources or a disassembly
4493 /* Arrange for X to be put in a register. */
4499 if (longjmps_done
== 1)
4501 /* Came here after the longjmp at the end of the function.
4503 If x == 1, the longjmp has restored the register to its
4504 value before the setjmp, and we can hope that setjmp
4505 saves all such registers in the jmp_buf, although that
4508 For other values of X, either something really strange is
4509 taking place, or the setjmp just didn't save the register. */
4512 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4515 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4522 if (longjmps_done
== 1)
4523 sys_longjmp (jbuf
, 1);
4526 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4529 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4531 /* Abort if anything GCPRO'd doesn't survive the GC. */
4539 for (p
= gcprolist
; p
; p
= p
->next
)
4540 for (i
= 0; i
< p
->nvars
; ++i
)
4541 if (!survives_gc_p (p
->var
[i
]))
4542 /* FIXME: It's not necessarily a bug. It might just be that the
4543 GCPRO is unnecessary or should release the object sooner. */
4547 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4554 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4555 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4557 fprintf (stderr
, " %d = ", i
);
4558 debug_print (zombies
[i
]);
4562 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4565 /* Mark live Lisp objects on the C stack.
4567 There are several system-dependent problems to consider when
4568 porting this to new architectures:
4572 We have to mark Lisp objects in CPU registers that can hold local
4573 variables or are used to pass parameters.
4575 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4576 something that either saves relevant registers on the stack, or
4577 calls mark_maybe_object passing it each register's contents.
4579 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4580 implementation assumes that calling setjmp saves registers we need
4581 to see in a jmp_buf which itself lies on the stack. This doesn't
4582 have to be true! It must be verified for each system, possibly
4583 by taking a look at the source code of setjmp.
4585 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4586 can use it as a machine independent method to store all registers
4587 to the stack. In this case the macros described in the previous
4588 two paragraphs are not used.
4592 Architectures differ in the way their processor stack is organized.
4593 For example, the stack might look like this
4596 | Lisp_Object | size = 4
4598 | something else | size = 2
4600 | Lisp_Object | size = 4
4604 In such a case, not every Lisp_Object will be aligned equally. To
4605 find all Lisp_Object on the stack it won't be sufficient to walk
4606 the stack in steps of 4 bytes. Instead, two passes will be
4607 necessary, one starting at the start of the stack, and a second
4608 pass starting at the start of the stack + 2. Likewise, if the
4609 minimal alignment of Lisp_Objects on the stack is 1, four passes
4610 would be necessary, each one starting with one byte more offset
4611 from the stack start. */
4618 #ifdef HAVE___BUILTIN_UNWIND_INIT
4619 /* Force callee-saved registers and register windows onto the stack.
4620 This is the preferred method if available, obviating the need for
4621 machine dependent methods. */
4622 __builtin_unwind_init ();
4624 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4625 #ifndef GC_SAVE_REGISTERS_ON_STACK
4626 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4627 union aligned_jmpbuf
{
4631 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4633 /* This trick flushes the register windows so that all the state of
4634 the process is contained in the stack. */
4635 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4636 needed on ia64 too. See mach_dep.c, where it also says inline
4637 assembler doesn't work with relevant proprietary compilers. */
4639 #if defined (__sparc64__) && defined (__FreeBSD__)
4640 /* FreeBSD does not have a ta 3 handler. */
4647 /* Save registers that we need to see on the stack. We need to see
4648 registers used to hold register variables and registers used to
4650 #ifdef GC_SAVE_REGISTERS_ON_STACK
4651 GC_SAVE_REGISTERS_ON_STACK (end
);
4652 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4654 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4655 setjmp will definitely work, test it
4656 and print a message with the result
4658 if (!setjmp_tested_p
)
4660 setjmp_tested_p
= 1;
4663 #endif /* GC_SETJMP_WORKS */
4666 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4667 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4668 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4670 /* This assumes that the stack is a contiguous region in memory. If
4671 that's not the case, something has to be done here to iterate
4672 over the stack segments. */
4673 mark_memory (stack_base
, end
);
4675 /* Allow for marking a secondary stack, like the register stack on the
4677 #ifdef GC_MARK_SECONDARY_STACK
4678 GC_MARK_SECONDARY_STACK ();
4681 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4686 #endif /* GC_MARK_STACK != 0 */
4689 /* Determine whether it is safe to access memory at address P. */
4691 valid_pointer_p (void *p
)
4694 return w32_valid_pointer_p (p
, 16);
4698 /* Obviously, we cannot just access it (we would SEGV trying), so we
4699 trick the o/s to tell us whether p is a valid pointer.
4700 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4701 not validate p in that case. */
4705 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4706 emacs_close (fd
[1]);
4707 emacs_close (fd
[0]);
4715 /* Return 2 if OBJ is a killed or special buffer object.
4716 Return 1 if OBJ is a valid lisp object.
4717 Return 0 if OBJ is NOT a valid lisp object.
4718 Return -1 if we cannot validate OBJ.
4719 This function can be quite slow,
4720 so it should only be used in code for manual debugging. */
4723 valid_lisp_object_p (Lisp_Object obj
)
4733 p
= (void *) XPNTR (obj
);
4734 if (PURE_POINTER_P (p
))
4737 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4741 return valid_pointer_p (p
);
4748 int valid
= valid_pointer_p (p
);
4760 case MEM_TYPE_NON_LISP
:
4761 case MEM_TYPE_SPARE
:
4764 case MEM_TYPE_BUFFER
:
4765 return live_buffer_p (m
, p
) ? 1 : 2;
4768 return live_cons_p (m
, p
);
4770 case MEM_TYPE_STRING
:
4771 return live_string_p (m
, p
);
4774 return live_misc_p (m
, p
);
4776 case MEM_TYPE_SYMBOL
:
4777 return live_symbol_p (m
, p
);
4779 case MEM_TYPE_FLOAT
:
4780 return live_float_p (m
, p
);
4782 case MEM_TYPE_VECTORLIKE
:
4783 case MEM_TYPE_VECTOR_BLOCK
:
4784 return live_vector_p (m
, p
);
4797 /***********************************************************************
4798 Pure Storage Management
4799 ***********************************************************************/
4801 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4802 pointer to it. TYPE is the Lisp type for which the memory is
4803 allocated. TYPE < 0 means it's not used for a Lisp object. */
4806 pure_alloc (size_t size
, int type
)
4810 size_t alignment
= GCALIGNMENT
;
4812 size_t alignment
= alignof (EMACS_INT
);
4814 /* Give Lisp_Floats an extra alignment. */
4815 if (type
== Lisp_Float
)
4816 alignment
= alignof (struct Lisp_Float
);
4822 /* Allocate space for a Lisp object from the beginning of the free
4823 space with taking account of alignment. */
4824 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4825 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4829 /* Allocate space for a non-Lisp object from the end of the free
4831 pure_bytes_used_non_lisp
+= size
;
4832 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4834 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4836 if (pure_bytes_used
<= pure_size
)
4839 /* Don't allocate a large amount here,
4840 because it might get mmap'd and then its address
4841 might not be usable. */
4842 purebeg
= xmalloc (10000);
4844 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4845 pure_bytes_used
= 0;
4846 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4851 /* Print a warning if PURESIZE is too small. */
4854 check_pure_size (void)
4856 if (pure_bytes_used_before_overflow
)
4857 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4859 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4863 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4864 the non-Lisp data pool of the pure storage, and return its start
4865 address. Return NULL if not found. */
4868 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4871 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4872 const unsigned char *p
;
4875 if (pure_bytes_used_non_lisp
<= nbytes
)
4878 /* Set up the Boyer-Moore table. */
4880 for (i
= 0; i
< 256; i
++)
4883 p
= (const unsigned char *) data
;
4885 bm_skip
[*p
++] = skip
;
4887 last_char_skip
= bm_skip
['\0'];
4889 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4890 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4892 /* See the comments in the function `boyer_moore' (search.c) for the
4893 use of `infinity'. */
4894 infinity
= pure_bytes_used_non_lisp
+ 1;
4895 bm_skip
['\0'] = infinity
;
4897 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4901 /* Check the last character (== '\0'). */
4904 start
+= bm_skip
[*(p
+ start
)];
4906 while (start
<= start_max
);
4908 if (start
< infinity
)
4909 /* Couldn't find the last character. */
4912 /* No less than `infinity' means we could find the last
4913 character at `p[start - infinity]'. */
4916 /* Check the remaining characters. */
4917 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4919 return non_lisp_beg
+ start
;
4921 start
+= last_char_skip
;
4923 while (start
<= start_max
);
4929 /* Return a string allocated in pure space. DATA is a buffer holding
4930 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4931 means make the result string multibyte.
4933 Must get an error if pure storage is full, since if it cannot hold
4934 a large string it may be able to hold conses that point to that
4935 string; then the string is not protected from gc. */
4938 make_pure_string (const char *data
,
4939 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
4942 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4943 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4944 if (s
->data
== NULL
)
4946 s
->data
= pure_alloc (nbytes
+ 1, -1);
4947 memcpy (s
->data
, data
, nbytes
);
4948 s
->data
[nbytes
] = '\0';
4951 s
->size_byte
= multibyte
? nbytes
: -1;
4952 s
->intervals
= NULL
;
4953 XSETSTRING (string
, s
);
4957 /* Return a string allocated in pure space. Do not
4958 allocate the string data, just point to DATA. */
4961 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
4964 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4967 s
->data
= (unsigned char *) data
;
4968 s
->intervals
= NULL
;
4969 XSETSTRING (string
, s
);
4973 /* Return a cons allocated from pure space. Give it pure copies
4974 of CAR as car and CDR as cdr. */
4977 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4980 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
4982 XSETCAR (new, Fpurecopy (car
));
4983 XSETCDR (new, Fpurecopy (cdr
));
4988 /* Value is a float object with value NUM allocated from pure space. */
4991 make_pure_float (double num
)
4994 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
4996 XFLOAT_INIT (new, num
);
5001 /* Return a vector with room for LEN Lisp_Objects allocated from
5005 make_pure_vector (ptrdiff_t len
)
5008 size_t size
= header_size
+ len
* word_size
;
5009 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5010 XSETVECTOR (new, p
);
5011 XVECTOR (new)->header
.size
= len
;
5016 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5017 doc
: /* Make a copy of object OBJ in pure storage.
5018 Recursively copies contents of vectors and cons cells.
5019 Does not copy symbols. Copies strings without text properties. */)
5020 (register Lisp_Object obj
)
5022 if (NILP (Vpurify_flag
))
5025 if (PURE_POINTER_P (XPNTR (obj
)))
5028 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5030 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5036 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5037 else if (FLOATP (obj
))
5038 obj
= make_pure_float (XFLOAT_DATA (obj
));
5039 else if (STRINGP (obj
))
5040 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5042 STRING_MULTIBYTE (obj
));
5043 else if (COMPILEDP (obj
) || VECTORP (obj
))
5045 register struct Lisp_Vector
*vec
;
5046 register ptrdiff_t i
;
5050 if (size
& PSEUDOVECTOR_FLAG
)
5051 size
&= PSEUDOVECTOR_SIZE_MASK
;
5052 vec
= XVECTOR (make_pure_vector (size
));
5053 for (i
= 0; i
< size
; i
++)
5054 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5055 if (COMPILEDP (obj
))
5057 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5058 XSETCOMPILED (obj
, vec
);
5061 XSETVECTOR (obj
, vec
);
5063 else if (MARKERP (obj
))
5064 error ("Attempt to copy a marker to pure storage");
5066 /* Not purified, don't hash-cons. */
5069 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5070 Fputhash (obj
, obj
, Vpurify_flag
);
5077 /***********************************************************************
5079 ***********************************************************************/
5081 /* Put an entry in staticvec, pointing at the variable with address
5085 staticpro (Lisp_Object
*varaddress
)
5087 staticvec
[staticidx
++] = varaddress
;
5088 if (staticidx
>= NSTATICS
)
5089 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5093 /***********************************************************************
5095 ***********************************************************************/
5097 /* Temporarily prevent garbage collection. */
5100 inhibit_garbage_collection (void)
5102 ptrdiff_t count
= SPECPDL_INDEX ();
5104 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5108 /* Used to avoid possible overflows when
5109 converting from C to Lisp integers. */
5112 bounded_number (EMACS_INT number
)
5114 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5117 /* Calculate total bytes of live objects. */
5120 total_bytes_of_live_objects (void)
5123 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5124 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5125 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5126 tot
+= total_string_bytes
;
5127 tot
+= total_vector_slots
* word_size
;
5128 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5129 tot
+= total_intervals
* sizeof (struct interval
);
5130 tot
+= total_strings
* sizeof (struct Lisp_String
);
5134 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5135 doc
: /* Reclaim storage for Lisp objects no longer needed.
5136 Garbage collection happens automatically if you cons more than
5137 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5138 `garbage-collect' normally returns a list with info on amount of space in use,
5139 where each entry has the form (NAME SIZE USED FREE), where:
5140 - NAME is a symbol describing the kind of objects this entry represents,
5141 - SIZE is the number of bytes used by each one,
5142 - USED is the number of those objects that were found live in the heap,
5143 - FREE is the number of those objects that are not live but that Emacs
5144 keeps around for future allocations (maybe because it does not know how
5145 to return them to the OS).
5146 However, if there was overflow in pure space, `garbage-collect'
5147 returns nil, because real GC can't be done.
5148 See Info node `(elisp)Garbage Collection'. */)
5151 struct specbinding
*bind
;
5152 struct buffer
*nextb
;
5153 char stack_top_variable
;
5156 ptrdiff_t count
= SPECPDL_INDEX ();
5158 Lisp_Object retval
= Qnil
;
5159 size_t tot_before
= 0;
5160 struct backtrace backtrace
;
5165 /* Can't GC if pure storage overflowed because we can't determine
5166 if something is a pure object or not. */
5167 if (pure_bytes_used_before_overflow
)
5170 /* Record this function, so it appears on the profiler's backtraces. */
5171 backtrace
.next
= backtrace_list
;
5172 backtrace
.function
= Qautomatic_gc
;
5173 backtrace
.args
= &Qnil
;
5174 backtrace
.nargs
= 0;
5175 backtrace
.debug_on_exit
= 0;
5176 backtrace_list
= &backtrace
;
5180 /* Don't keep undo information around forever.
5181 Do this early on, so it is no problem if the user quits. */
5182 FOR_EACH_BUFFER (nextb
)
5183 compact_buffer (nextb
);
5185 if (profiler_memory_running
)
5186 tot_before
= total_bytes_of_live_objects ();
5188 start
= current_emacs_time ();
5190 /* In case user calls debug_print during GC,
5191 don't let that cause a recursive GC. */
5192 consing_since_gc
= 0;
5194 /* Save what's currently displayed in the echo area. */
5195 message_p
= push_message ();
5196 record_unwind_protect (pop_message_unwind
, Qnil
);
5198 /* Save a copy of the contents of the stack, for debugging. */
5199 #if MAX_SAVE_STACK > 0
5200 if (NILP (Vpurify_flag
))
5203 ptrdiff_t stack_size
;
5204 if (&stack_top_variable
< stack_bottom
)
5206 stack
= &stack_top_variable
;
5207 stack_size
= stack_bottom
- &stack_top_variable
;
5211 stack
= stack_bottom
;
5212 stack_size
= &stack_top_variable
- stack_bottom
;
5214 if (stack_size
<= MAX_SAVE_STACK
)
5216 if (stack_copy_size
< stack_size
)
5218 stack_copy
= xrealloc (stack_copy
, stack_size
);
5219 stack_copy_size
= stack_size
;
5221 memcpy (stack_copy
, stack
, stack_size
);
5224 #endif /* MAX_SAVE_STACK > 0 */
5226 if (garbage_collection_messages
)
5227 message1_nolog ("Garbage collecting...");
5231 shrink_regexp_cache ();
5235 /* Mark all the special slots that serve as the roots of accessibility. */
5237 mark_buffer (&buffer_defaults
);
5238 mark_buffer (&buffer_local_symbols
);
5240 for (i
= 0; i
< staticidx
; i
++)
5241 mark_object (*staticvec
[i
]);
5243 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5245 mark_object (bind
->symbol
);
5246 mark_object (bind
->old_value
);
5255 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5256 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5260 register struct gcpro
*tail
;
5261 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5262 for (i
= 0; i
< tail
->nvars
; i
++)
5263 mark_object (tail
->var
[i
]);
5267 struct catchtag
*catch;
5268 struct handler
*handler
;
5270 for (catch = catchlist
; catch; catch = catch->next
)
5272 mark_object (catch->tag
);
5273 mark_object (catch->val
);
5275 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5277 mark_object (handler
->handler
);
5278 mark_object (handler
->var
);
5284 #ifdef HAVE_WINDOW_SYSTEM
5285 mark_fringe_data ();
5288 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5292 /* Everything is now marked, except for the things that require special
5293 finalization, i.e. the undo_list.
5294 Look thru every buffer's undo list
5295 for elements that update markers that were not marked,
5297 FOR_EACH_BUFFER (nextb
)
5299 /* If a buffer's undo list is Qt, that means that undo is
5300 turned off in that buffer. Calling truncate_undo_list on
5301 Qt tends to return NULL, which effectively turns undo back on.
5302 So don't call truncate_undo_list if undo_list is Qt. */
5303 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5305 Lisp_Object tail
, prev
;
5306 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5308 while (CONSP (tail
))
5310 if (CONSP (XCAR (tail
))
5311 && MARKERP (XCAR (XCAR (tail
)))
5312 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5315 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5319 XSETCDR (prev
, tail
);
5329 /* Now that we have stripped the elements that need not be in the
5330 undo_list any more, we can finally mark the list. */
5331 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5336 /* Clear the mark bits that we set in certain root slots. */
5338 unmark_byte_stack ();
5339 VECTOR_UNMARK (&buffer_defaults
);
5340 VECTOR_UNMARK (&buffer_local_symbols
);
5342 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5352 consing_since_gc
= 0;
5353 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5354 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5356 gc_relative_threshold
= 0;
5357 if (FLOATP (Vgc_cons_percentage
))
5358 { /* Set gc_cons_combined_threshold. */
5359 double tot
= total_bytes_of_live_objects ();
5361 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5364 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5365 gc_relative_threshold
= tot
;
5367 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5371 if (garbage_collection_messages
)
5373 if (message_p
|| minibuf_level
> 0)
5376 message1_nolog ("Garbage collecting...done");
5379 unbind_to (count
, Qnil
);
5381 Lisp_Object total
[11];
5382 int total_size
= 10;
5384 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5385 bounded_number (total_conses
),
5386 bounded_number (total_free_conses
));
5388 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5389 bounded_number (total_symbols
),
5390 bounded_number (total_free_symbols
));
5392 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5393 bounded_number (total_markers
),
5394 bounded_number (total_free_markers
));
5396 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5397 bounded_number (total_strings
),
5398 bounded_number (total_free_strings
));
5400 total
[4] = list3 (Qstring_bytes
, make_number (1),
5401 bounded_number (total_string_bytes
));
5403 total
[5] = list3 (Qvectors
, make_number (sizeof (struct Lisp_Vector
)),
5404 bounded_number (total_vectors
));
5406 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5407 bounded_number (total_vector_slots
),
5408 bounded_number (total_free_vector_slots
));
5410 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5411 bounded_number (total_floats
),
5412 bounded_number (total_free_floats
));
5414 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5415 bounded_number (total_intervals
),
5416 bounded_number (total_free_intervals
));
5418 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5419 bounded_number (total_buffers
));
5421 #ifdef DOUG_LEA_MALLOC
5423 total
[10] = list4 (Qheap
, make_number (1024),
5424 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5425 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5427 retval
= Flist (total_size
, total
);
5430 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5432 /* Compute average percentage of zombies. */
5434 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5435 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5437 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5438 max_live
= max (nlive
, max_live
);
5439 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5440 max_zombies
= max (nzombies
, max_zombies
);
5445 if (!NILP (Vpost_gc_hook
))
5447 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5448 safe_run_hooks (Qpost_gc_hook
);
5449 unbind_to (gc_count
, Qnil
);
5452 /* Accumulate statistics. */
5453 if (FLOATP (Vgc_elapsed
))
5455 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5456 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5457 + EMACS_TIME_TO_DOUBLE (since_start
));
5462 /* Collect profiling data. */
5463 if (profiler_memory_running
)
5466 size_t tot_after
= total_bytes_of_live_objects ();
5467 if (tot_before
> tot_after
)
5468 swept
= tot_before
- tot_after
;
5469 malloc_probe (swept
);
5472 backtrace_list
= backtrace
.next
;
5477 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5478 only interesting objects referenced from glyphs are strings. */
5481 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5483 struct glyph_row
*row
= matrix
->rows
;
5484 struct glyph_row
*end
= row
+ matrix
->nrows
;
5486 for (; row
< end
; ++row
)
5490 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5492 struct glyph
*glyph
= row
->glyphs
[area
];
5493 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5495 for (; glyph
< end_glyph
; ++glyph
)
5496 if (STRINGP (glyph
->object
)
5497 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5498 mark_object (glyph
->object
);
5504 /* Mark Lisp faces in the face cache C. */
5507 mark_face_cache (struct face_cache
*c
)
5512 for (i
= 0; i
< c
->used
; ++i
)
5514 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5518 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5519 mark_object (face
->lface
[j
]);
5527 /* Mark reference to a Lisp_Object.
5528 If the object referred to has not been seen yet, recursively mark
5529 all the references contained in it. */
5531 #define LAST_MARKED_SIZE 500
5532 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5533 static int last_marked_index
;
5535 /* For debugging--call abort when we cdr down this many
5536 links of a list, in mark_object. In debugging,
5537 the call to abort will hit a breakpoint.
5538 Normally this is zero and the check never goes off. */
5539 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5542 mark_vectorlike (struct Lisp_Vector
*ptr
)
5544 ptrdiff_t size
= ptr
->header
.size
;
5547 eassert (!VECTOR_MARKED_P (ptr
));
5548 VECTOR_MARK (ptr
); /* Else mark it. */
5549 if (size
& PSEUDOVECTOR_FLAG
)
5550 size
&= PSEUDOVECTOR_SIZE_MASK
;
5552 /* Note that this size is not the memory-footprint size, but only
5553 the number of Lisp_Object fields that we should trace.
5554 The distinction is used e.g. by Lisp_Process which places extra
5555 non-Lisp_Object fields at the end of the structure... */
5556 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5557 mark_object (ptr
->contents
[i
]);
5560 /* Like mark_vectorlike but optimized for char-tables (and
5561 sub-char-tables) assuming that the contents are mostly integers or
5565 mark_char_table (struct Lisp_Vector
*ptr
)
5567 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5570 eassert (!VECTOR_MARKED_P (ptr
));
5572 for (i
= 0; i
< size
; i
++)
5574 Lisp_Object val
= ptr
->contents
[i
];
5576 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5578 if (SUB_CHAR_TABLE_P (val
))
5580 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5581 mark_char_table (XVECTOR (val
));
5588 /* Mark the chain of overlays starting at PTR. */
5591 mark_overlay (struct Lisp_Overlay
*ptr
)
5593 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5596 mark_object (ptr
->start
);
5597 mark_object (ptr
->end
);
5598 mark_object (ptr
->plist
);
5602 /* Mark Lisp_Objects and special pointers in BUFFER. */
5605 mark_buffer (struct buffer
*buffer
)
5607 /* This is handled much like other pseudovectors... */
5608 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5610 /* ...but there are some buffer-specific things. */
5612 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5614 /* For now, we just don't mark the undo_list. It's done later in
5615 a special way just before the sweep phase, and after stripping
5616 some of its elements that are not needed any more. */
5618 mark_overlay (buffer
->overlays_before
);
5619 mark_overlay (buffer
->overlays_after
);
5621 /* If this is an indirect buffer, mark its base buffer. */
5622 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5623 mark_buffer (buffer
->base_buffer
);
5626 /* Remove killed buffers or items whose car is a killed buffer from
5627 LIST, and mark other items. Return changed LIST, which is marked. */
5630 mark_discard_killed_buffers (Lisp_Object list
)
5632 Lisp_Object tail
, *prev
= &list
;
5634 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5637 Lisp_Object tem
= XCAR (tail
);
5640 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5641 *prev
= XCDR (tail
);
5644 CONS_MARK (XCONS (tail
));
5645 mark_object (XCAR (tail
));
5646 prev
= &XCDR_AS_LVALUE (tail
);
5653 /* Determine type of generic Lisp_Object and mark it accordingly. */
5656 mark_object (Lisp_Object arg
)
5658 register Lisp_Object obj
= arg
;
5659 #ifdef GC_CHECK_MARKED_OBJECTS
5663 ptrdiff_t cdr_count
= 0;
5667 if (PURE_POINTER_P (XPNTR (obj
)))
5670 last_marked
[last_marked_index
++] = obj
;
5671 if (last_marked_index
== LAST_MARKED_SIZE
)
5672 last_marked_index
= 0;
5674 /* Perform some sanity checks on the objects marked here. Abort if
5675 we encounter an object we know is bogus. This increases GC time
5676 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5677 #ifdef GC_CHECK_MARKED_OBJECTS
5679 po
= (void *) XPNTR (obj
);
5681 /* Check that the object pointed to by PO is known to be a Lisp
5682 structure allocated from the heap. */
5683 #define CHECK_ALLOCATED() \
5685 m = mem_find (po); \
5690 /* Check that the object pointed to by PO is live, using predicate
5692 #define CHECK_LIVE(LIVEP) \
5694 if (!LIVEP (m, po)) \
5698 /* Check both of the above conditions. */
5699 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5701 CHECK_ALLOCATED (); \
5702 CHECK_LIVE (LIVEP); \
5705 #else /* not GC_CHECK_MARKED_OBJECTS */
5707 #define CHECK_LIVE(LIVEP) (void) 0
5708 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5710 #endif /* not GC_CHECK_MARKED_OBJECTS */
5712 switch (XTYPE (obj
))
5716 register struct Lisp_String
*ptr
= XSTRING (obj
);
5717 if (STRING_MARKED_P (ptr
))
5719 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5721 MARK_INTERVAL_TREE (ptr
->intervals
);
5722 #ifdef GC_CHECK_STRING_BYTES
5723 /* Check that the string size recorded in the string is the
5724 same as the one recorded in the sdata structure. */
5726 #endif /* GC_CHECK_STRING_BYTES */
5730 case Lisp_Vectorlike
:
5732 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5733 register ptrdiff_t pvectype
;
5735 if (VECTOR_MARKED_P (ptr
))
5738 #ifdef GC_CHECK_MARKED_OBJECTS
5740 if (m
== MEM_NIL
&& !SUBRP (obj
))
5742 #endif /* GC_CHECK_MARKED_OBJECTS */
5744 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5745 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5746 >> PSEUDOVECTOR_AREA_BITS
);
5748 pvectype
= PVEC_NORMAL_VECTOR
;
5750 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5751 CHECK_LIVE (live_vector_p
);
5756 #ifdef GC_CHECK_MARKED_OBJECTS
5765 #endif /* GC_CHECK_MARKED_OBJECTS */
5766 mark_buffer ((struct buffer
*) ptr
);
5770 { /* We could treat this just like a vector, but it is better
5771 to save the COMPILED_CONSTANTS element for last and avoid
5773 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5777 for (i
= 0; i
< size
; i
++)
5778 if (i
!= COMPILED_CONSTANTS
)
5779 mark_object (ptr
->contents
[i
]);
5780 if (size
> COMPILED_CONSTANTS
)
5782 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5789 mark_vectorlike (ptr
);
5790 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5795 struct window
*w
= (struct window
*) ptr
;
5796 bool leaf
= NILP (w
->hchild
) && NILP (w
->vchild
);
5798 mark_vectorlike (ptr
);
5800 /* Mark glyphs for leaf windows. Marking window
5801 matrices is sufficient because frame matrices
5802 use the same glyph memory. */
5803 if (leaf
&& w
->current_matrix
)
5805 mark_glyph_matrix (w
->current_matrix
);
5806 mark_glyph_matrix (w
->desired_matrix
);
5809 /* Filter out killed buffers from both buffer lists
5810 in attempt to help GC to reclaim killed buffers faster.
5811 We can do it elsewhere for live windows, but this is the
5812 best place to do it for dead windows. */
5814 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5816 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5820 case PVEC_HASH_TABLE
:
5822 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5824 mark_vectorlike (ptr
);
5825 mark_object (h
->test
.name
);
5826 mark_object (h
->test
.user_hash_function
);
5827 mark_object (h
->test
.user_cmp_function
);
5828 /* If hash table is not weak, mark all keys and values.
5829 For weak tables, mark only the vector. */
5831 mark_object (h
->key_and_value
);
5833 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5837 case PVEC_CHAR_TABLE
:
5838 mark_char_table (ptr
);
5841 case PVEC_BOOL_VECTOR
:
5842 /* No Lisp_Objects to mark in a bool vector. */
5853 mark_vectorlike (ptr
);
5860 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5861 struct Lisp_Symbol
*ptrx
;
5865 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5867 mark_object (ptr
->function
);
5868 mark_object (ptr
->plist
);
5869 switch (ptr
->redirect
)
5871 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5872 case SYMBOL_VARALIAS
:
5875 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5879 case SYMBOL_LOCALIZED
:
5881 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5882 Lisp_Object where
= blv
->where
;
5883 /* If the value is set up for a killed buffer or deleted
5884 frame, restore it's global binding. If the value is
5885 forwarded to a C variable, either it's not a Lisp_Object
5886 var, or it's staticpro'd already. */
5887 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5888 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5889 swap_in_global_binding (ptr
);
5890 mark_object (blv
->where
);
5891 mark_object (blv
->valcell
);
5892 mark_object (blv
->defcell
);
5895 case SYMBOL_FORWARDED
:
5896 /* If the value is forwarded to a buffer or keyboard field,
5897 these are marked when we see the corresponding object.
5898 And if it's forwarded to a C variable, either it's not
5899 a Lisp_Object var, or it's staticpro'd already. */
5901 default: emacs_abort ();
5903 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5904 MARK_STRING (XSTRING (ptr
->name
));
5905 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5910 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5911 XSETSYMBOL (obj
, ptrx
);
5918 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5920 if (XMISCANY (obj
)->gcmarkbit
)
5923 switch (XMISCTYPE (obj
))
5925 case Lisp_Misc_Marker
:
5926 /* DO NOT mark thru the marker's chain.
5927 The buffer's markers chain does not preserve markers from gc;
5928 instead, markers are removed from the chain when freed by gc. */
5929 XMISCANY (obj
)->gcmarkbit
= 1;
5932 case Lisp_Misc_Save_Value
:
5933 XMISCANY (obj
)->gcmarkbit
= 1;
5936 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5937 /* If DOGC is set, POINTER is the address of a memory
5938 area containing INTEGER potential Lisp_Objects. */
5941 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5943 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5944 mark_maybe_object (*p
);
5950 case Lisp_Misc_Overlay
:
5951 mark_overlay (XOVERLAY (obj
));
5961 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5962 if (CONS_MARKED_P (ptr
))
5964 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5966 /* If the cdr is nil, avoid recursion for the car. */
5967 if (EQ (ptr
->u
.cdr
, Qnil
))
5973 mark_object (ptr
->car
);
5976 if (cdr_count
== mark_object_loop_halt
)
5982 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5983 FLOAT_MARK (XFLOAT (obj
));
5994 #undef CHECK_ALLOCATED
5995 #undef CHECK_ALLOCATED_AND_LIVE
5997 /* Mark the Lisp pointers in the terminal objects.
5998 Called by Fgarbage_collect. */
6001 mark_terminals (void)
6004 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6006 eassert (t
->name
!= NULL
);
6007 #ifdef HAVE_WINDOW_SYSTEM
6008 /* If a terminal object is reachable from a stacpro'ed object,
6009 it might have been marked already. Make sure the image cache
6011 mark_image_cache (t
->image_cache
);
6012 #endif /* HAVE_WINDOW_SYSTEM */
6013 if (!VECTOR_MARKED_P (t
))
6014 mark_vectorlike ((struct Lisp_Vector
*)t
);
6020 /* Value is non-zero if OBJ will survive the current GC because it's
6021 either marked or does not need to be marked to survive. */
6024 survives_gc_p (Lisp_Object obj
)
6028 switch (XTYPE (obj
))
6035 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6039 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6043 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6046 case Lisp_Vectorlike
:
6047 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6051 survives_p
= CONS_MARKED_P (XCONS (obj
));
6055 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6062 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6067 /* Sweep: find all structures not marked, and free them. */
6072 /* Remove or mark entries in weak hash tables.
6073 This must be done before any object is unmarked. */
6074 sweep_weak_hash_tables ();
6077 check_string_bytes (!noninteractive
);
6079 /* Put all unmarked conses on free list */
6081 register struct cons_block
*cblk
;
6082 struct cons_block
**cprev
= &cons_block
;
6083 register int lim
= cons_block_index
;
6084 EMACS_INT num_free
= 0, num_used
= 0;
6088 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6092 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6094 /* Scan the mark bits an int at a time. */
6095 for (i
= 0; i
< ilim
; i
++)
6097 if (cblk
->gcmarkbits
[i
] == -1)
6099 /* Fast path - all cons cells for this int are marked. */
6100 cblk
->gcmarkbits
[i
] = 0;
6101 num_used
+= BITS_PER_INT
;
6105 /* Some cons cells for this int are not marked.
6106 Find which ones, and free them. */
6107 int start
, pos
, stop
;
6109 start
= i
* BITS_PER_INT
;
6111 if (stop
> BITS_PER_INT
)
6112 stop
= BITS_PER_INT
;
6115 for (pos
= start
; pos
< stop
; pos
++)
6117 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6120 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6121 cons_free_list
= &cblk
->conses
[pos
];
6123 cons_free_list
->car
= Vdead
;
6129 CONS_UNMARK (&cblk
->conses
[pos
]);
6135 lim
= CONS_BLOCK_SIZE
;
6136 /* If this block contains only free conses and we have already
6137 seen more than two blocks worth of free conses then deallocate
6139 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6141 *cprev
= cblk
->next
;
6142 /* Unhook from the free list. */
6143 cons_free_list
= cblk
->conses
[0].u
.chain
;
6144 lisp_align_free (cblk
);
6148 num_free
+= this_free
;
6149 cprev
= &cblk
->next
;
6152 total_conses
= num_used
;
6153 total_free_conses
= num_free
;
6156 /* Put all unmarked floats on free list */
6158 register struct float_block
*fblk
;
6159 struct float_block
**fprev
= &float_block
;
6160 register int lim
= float_block_index
;
6161 EMACS_INT num_free
= 0, num_used
= 0;
6163 float_free_list
= 0;
6165 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6169 for (i
= 0; i
< lim
; i
++)
6170 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6173 fblk
->floats
[i
].u
.chain
= float_free_list
;
6174 float_free_list
= &fblk
->floats
[i
];
6179 FLOAT_UNMARK (&fblk
->floats
[i
]);
6181 lim
= FLOAT_BLOCK_SIZE
;
6182 /* If this block contains only free floats and we have already
6183 seen more than two blocks worth of free floats then deallocate
6185 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6187 *fprev
= fblk
->next
;
6188 /* Unhook from the free list. */
6189 float_free_list
= fblk
->floats
[0].u
.chain
;
6190 lisp_align_free (fblk
);
6194 num_free
+= this_free
;
6195 fprev
= &fblk
->next
;
6198 total_floats
= num_used
;
6199 total_free_floats
= num_free
;
6202 /* Put all unmarked intervals on free list */
6204 register struct interval_block
*iblk
;
6205 struct interval_block
**iprev
= &interval_block
;
6206 register int lim
= interval_block_index
;
6207 EMACS_INT num_free
= 0, num_used
= 0;
6209 interval_free_list
= 0;
6211 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6216 for (i
= 0; i
< lim
; i
++)
6218 if (!iblk
->intervals
[i
].gcmarkbit
)
6220 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6221 interval_free_list
= &iblk
->intervals
[i
];
6227 iblk
->intervals
[i
].gcmarkbit
= 0;
6230 lim
= INTERVAL_BLOCK_SIZE
;
6231 /* If this block contains only free intervals and we have already
6232 seen more than two blocks worth of free intervals then
6233 deallocate this block. */
6234 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6236 *iprev
= iblk
->next
;
6237 /* Unhook from the free list. */
6238 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6243 num_free
+= this_free
;
6244 iprev
= &iblk
->next
;
6247 total_intervals
= num_used
;
6248 total_free_intervals
= num_free
;
6251 /* Put all unmarked symbols on free list */
6253 register struct symbol_block
*sblk
;
6254 struct symbol_block
**sprev
= &symbol_block
;
6255 register int lim
= symbol_block_index
;
6256 EMACS_INT num_free
= 0, num_used
= 0;
6258 symbol_free_list
= NULL
;
6260 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6263 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6264 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6266 for (; sym
< end
; ++sym
)
6268 /* Check if the symbol was created during loadup. In such a case
6269 it might be pointed to by pure bytecode which we don't trace,
6270 so we conservatively assume that it is live. */
6271 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6273 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6275 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6276 xfree (SYMBOL_BLV (&sym
->s
));
6277 sym
->s
.next
= symbol_free_list
;
6278 symbol_free_list
= &sym
->s
;
6280 symbol_free_list
->function
= Vdead
;
6288 UNMARK_STRING (XSTRING (sym
->s
.name
));
6289 sym
->s
.gcmarkbit
= 0;
6293 lim
= SYMBOL_BLOCK_SIZE
;
6294 /* If this block contains only free symbols and we have already
6295 seen more than two blocks worth of free symbols then deallocate
6297 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6299 *sprev
= sblk
->next
;
6300 /* Unhook from the free list. */
6301 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6306 num_free
+= this_free
;
6307 sprev
= &sblk
->next
;
6310 total_symbols
= num_used
;
6311 total_free_symbols
= num_free
;
6314 /* Put all unmarked misc's on free list.
6315 For a marker, first unchain it from the buffer it points into. */
6317 register struct marker_block
*mblk
;
6318 struct marker_block
**mprev
= &marker_block
;
6319 register int lim
= marker_block_index
;
6320 EMACS_INT num_free
= 0, num_used
= 0;
6322 marker_free_list
= 0;
6324 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6329 for (i
= 0; i
< lim
; i
++)
6331 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6333 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6334 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6335 /* Set the type of the freed object to Lisp_Misc_Free.
6336 We could leave the type alone, since nobody checks it,
6337 but this might catch bugs faster. */
6338 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6339 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6340 marker_free_list
= &mblk
->markers
[i
].m
;
6346 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6349 lim
= MARKER_BLOCK_SIZE
;
6350 /* If this block contains only free markers and we have already
6351 seen more than two blocks worth of free markers then deallocate
6353 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6355 *mprev
= mblk
->next
;
6356 /* Unhook from the free list. */
6357 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6362 num_free
+= this_free
;
6363 mprev
= &mblk
->next
;
6367 total_markers
= num_used
;
6368 total_free_markers
= num_free
;
6371 /* Free all unmarked buffers */
6373 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6376 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6377 if (!VECTOR_MARKED_P (buffer
))
6379 *bprev
= buffer
->next
;
6384 VECTOR_UNMARK (buffer
);
6385 /* Do not use buffer_(set|get)_intervals here. */
6386 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6388 bprev
= &buffer
->next
;
6393 check_string_bytes (!noninteractive
);
6399 /* Debugging aids. */
6401 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6402 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6403 This may be helpful in debugging Emacs's memory usage.
6404 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6409 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6414 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6415 doc
: /* Return a list of counters that measure how much consing there has been.
6416 Each of these counters increments for a certain kind of object.
6417 The counters wrap around from the largest positive integer to zero.
6418 Garbage collection does not decrease them.
6419 The elements of the value are as follows:
6420 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6421 All are in units of 1 = one object consed
6422 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6424 MISCS include overlays, markers, and some internal types.
6425 Frames, windows, buffers, and subprocesses count as vectors
6426 (but the contents of a buffer's text do not count here). */)
6429 return listn (CONSTYPE_HEAP
, 8,
6430 bounded_number (cons_cells_consed
),
6431 bounded_number (floats_consed
),
6432 bounded_number (vector_cells_consed
),
6433 bounded_number (symbols_consed
),
6434 bounded_number (string_chars_consed
),
6435 bounded_number (misc_objects_consed
),
6436 bounded_number (intervals_consed
),
6437 bounded_number (strings_consed
));
6440 /* Find at most FIND_MAX symbols which have OBJ as their value or
6441 function. This is used in gdbinit's `xwhichsymbols' command. */
6444 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6446 struct symbol_block
*sblk
;
6447 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6448 Lisp_Object found
= Qnil
;
6452 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6454 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6457 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6459 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6463 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6466 XSETSYMBOL (tem
, sym
);
6467 val
= find_symbol_value (tem
);
6469 || EQ (sym
->function
, obj
)
6470 || (!NILP (sym
->function
)
6471 && COMPILEDP (sym
->function
)
6472 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6475 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6477 found
= Fcons (tem
, found
);
6478 if (--find_max
== 0)
6486 unbind_to (gc_count
, Qnil
);
6490 #ifdef ENABLE_CHECKING
6492 bool suppress_checking
;
6495 die (const char *msg
, const char *file
, int line
)
6497 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6499 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6503 /* Initialization */
6506 init_alloc_once (void)
6508 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6510 pure_size
= PURESIZE
;
6512 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6514 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6517 #ifdef DOUG_LEA_MALLOC
6518 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6519 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6520 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6525 refill_memory_reserve ();
6526 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6533 byte_stack_list
= 0;
6535 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6536 setjmp_tested_p
= longjmps_done
= 0;
6539 Vgc_elapsed
= make_float (0.0);
6544 syms_of_alloc (void)
6546 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6547 doc
: /* Number of bytes of consing between garbage collections.
6548 Garbage collection can happen automatically once this many bytes have been
6549 allocated since the last garbage collection. All data types count.
6551 Garbage collection happens automatically only when `eval' is called.
6553 By binding this temporarily to a large number, you can effectively
6554 prevent garbage collection during a part of the program.
6555 See also `gc-cons-percentage'. */);
6557 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6558 doc
: /* Portion of the heap used for allocation.
6559 Garbage collection can happen automatically once this portion of the heap
6560 has been allocated since the last garbage collection.
6561 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6562 Vgc_cons_percentage
= make_float (0.1);
6564 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6565 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6567 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6568 doc
: /* Number of cons cells that have been consed so far. */);
6570 DEFVAR_INT ("floats-consed", floats_consed
,
6571 doc
: /* Number of floats that have been consed so far. */);
6573 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6574 doc
: /* Number of vector cells that have been consed so far. */);
6576 DEFVAR_INT ("symbols-consed", symbols_consed
,
6577 doc
: /* Number of symbols that have been consed so far. */);
6579 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6580 doc
: /* Number of string characters that have been consed so far. */);
6582 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6583 doc
: /* Number of miscellaneous objects that have been consed so far.
6584 These include markers and overlays, plus certain objects not visible
6587 DEFVAR_INT ("intervals-consed", intervals_consed
,
6588 doc
: /* Number of intervals that have been consed so far. */);
6590 DEFVAR_INT ("strings-consed", strings_consed
,
6591 doc
: /* Number of strings that have been consed so far. */);
6593 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6594 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6595 This means that certain objects should be allocated in shared (pure) space.
6596 It can also be set to a hash-table, in which case this table is used to
6597 do hash-consing of the objects allocated to pure space. */);
6599 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6600 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6601 garbage_collection_messages
= 0;
6603 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6604 doc
: /* Hook run after garbage collection has finished. */);
6605 Vpost_gc_hook
= Qnil
;
6606 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6608 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6609 doc
: /* Precomputed `signal' argument for memory-full error. */);
6610 /* We build this in advance because if we wait until we need it, we might
6611 not be able to allocate the memory to hold it. */
6613 = listn (CONSTYPE_PURE
, 2, Qerror
,
6614 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6616 DEFVAR_LISP ("memory-full", Vmemory_full
,
6617 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6618 Vmemory_full
= Qnil
;
6620 DEFSYM (Qconses
, "conses");
6621 DEFSYM (Qsymbols
, "symbols");
6622 DEFSYM (Qmiscs
, "miscs");
6623 DEFSYM (Qstrings
, "strings");
6624 DEFSYM (Qvectors
, "vectors");
6625 DEFSYM (Qfloats
, "floats");
6626 DEFSYM (Qintervals
, "intervals");
6627 DEFSYM (Qbuffers
, "buffers");
6628 DEFSYM (Qstring_bytes
, "string-bytes");
6629 DEFSYM (Qvector_slots
, "vector-slots");
6630 DEFSYM (Qheap
, "heap");
6631 DEFSYM (Qautomatic_gc
, "Automatic GC");
6633 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6634 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6636 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6637 doc
: /* Accumulated time elapsed in garbage collections.
6638 The time is in seconds as a floating point value. */);
6639 DEFVAR_INT ("gcs-done", gcs_done
,
6640 doc
: /* Accumulated number of garbage collections done. */);
6645 defsubr (&Smake_byte_code
);
6646 defsubr (&Smake_list
);
6647 defsubr (&Smake_vector
);
6648 defsubr (&Smake_string
);
6649 defsubr (&Smake_bool_vector
);
6650 defsubr (&Smake_symbol
);
6651 defsubr (&Smake_marker
);
6652 defsubr (&Spurecopy
);
6653 defsubr (&Sgarbage_collect
);
6654 defsubr (&Smemory_limit
);
6655 defsubr (&Smemory_use_counts
);
6657 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6658 defsubr (&Sgc_status
);
6662 /* When compiled with GCC, GDB might say "No enum type named
6663 pvec_type" if we don't have at least one symbol with that type, and
6664 then xbacktrace could fail. Similarly for the other enums and
6665 their values. Some non-GCC compilers don't like these constructs. */
6669 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6670 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6671 enum char_bits char_bits
;
6672 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6673 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6674 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6675 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6676 enum Lisp_Bits Lisp_Bits
;
6677 enum Lisp_Compiled Lisp_Compiled
;
6678 enum maxargs maxargs
;
6679 enum MAX_ALLOCA MAX_ALLOCA
;
6680 enum More_Lisp_Bits More_Lisp_Bits
;
6681 enum pvec_type pvec_type
;
6683 enum lsb_bits lsb_bits
;
6685 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6686 #endif /* __GNUC__ */