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
764 the old one. Thus, to grow an array A without saving its old
765 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
768 Block interrupt input as needed. If memory exhaustion occurs, set
769 *NITEMS to zero if PA is null, and signal an error (i.e., do not
773 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
774 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
776 /* The approximate size to use for initial small allocation
777 requests. This is the largest "small" request for the GNU C
779 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
781 /* If the array is tiny, grow it to about (but no greater than)
782 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
783 ptrdiff_t n
= *nitems
;
784 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
785 ptrdiff_t half_again
= n
>> 1;
786 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
788 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
789 NITEMS_MAX, and what the C language can represent safely. */
790 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
791 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
792 ? nitems_max
: C_language_max
);
793 ptrdiff_t nitems_incr_max
= n_max
- n
;
794 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
796 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
799 if (nitems_incr_max
< incr
)
800 memory_full (SIZE_MAX
);
802 pa
= xrealloc (pa
, n
* item_size
);
808 /* Like strdup, but uses xmalloc. */
811 xstrdup (const char *s
)
813 size_t len
= strlen (s
) + 1;
814 char *p
= xmalloc (len
);
820 /* Unwind for SAFE_ALLOCA */
823 safe_alloca_unwind (Lisp_Object arg
)
825 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
834 /* Return a newly allocated memory block of SIZE bytes, remembering
835 to free it when unwinding. */
837 record_xmalloc (size_t size
)
839 void *p
= xmalloc (size
);
840 record_unwind_protect (safe_alloca_unwind
, make_save_value (p
, 0));
845 /* Like malloc but used for allocating Lisp data. NBYTES is the
846 number of bytes to allocate, TYPE describes the intended use of the
847 allocated memory block (for strings, for conses, ...). */
850 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
854 lisp_malloc (size_t nbytes
, enum mem_type type
)
860 #ifdef GC_MALLOC_CHECK
861 allocated_mem_type
= type
;
864 val
= malloc (nbytes
);
867 /* If the memory just allocated cannot be addressed thru a Lisp
868 object's pointer, and it needs to be,
869 that's equivalent to running out of memory. */
870 if (val
&& type
!= MEM_TYPE_NON_LISP
)
873 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
874 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
876 lisp_malloc_loser
= val
;
883 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
884 if (val
&& type
!= MEM_TYPE_NON_LISP
)
885 mem_insert (val
, (char *) val
+ nbytes
, type
);
888 MALLOC_UNBLOCK_INPUT
;
890 memory_full (nbytes
);
891 MALLOC_PROBE (nbytes
);
895 /* Free BLOCK. This must be called to free memory allocated with a
896 call to lisp_malloc. */
899 lisp_free (void *block
)
903 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
904 mem_delete (mem_find (block
));
906 MALLOC_UNBLOCK_INPUT
;
909 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
911 /* The entry point is lisp_align_malloc which returns blocks of at most
912 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
914 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
915 #define USE_POSIX_MEMALIGN 1
918 /* BLOCK_ALIGN has to be a power of 2. */
919 #define BLOCK_ALIGN (1 << 10)
921 /* Padding to leave at the end of a malloc'd block. This is to give
922 malloc a chance to minimize the amount of memory wasted to alignment.
923 It should be tuned to the particular malloc library used.
924 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
925 posix_memalign on the other hand would ideally prefer a value of 4
926 because otherwise, there's 1020 bytes wasted between each ablocks.
927 In Emacs, testing shows that those 1020 can most of the time be
928 efficiently used by malloc to place other objects, so a value of 0 can
929 still preferable unless you have a lot of aligned blocks and virtually
931 #define BLOCK_PADDING 0
932 #define BLOCK_BYTES \
933 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
935 /* Internal data structures and constants. */
937 #define ABLOCKS_SIZE 16
939 /* An aligned block of memory. */
944 char payload
[BLOCK_BYTES
];
945 struct ablock
*next_free
;
947 /* `abase' is the aligned base of the ablocks. */
948 /* It is overloaded to hold the virtual `busy' field that counts
949 the number of used ablock in the parent ablocks.
950 The first ablock has the `busy' field, the others have the `abase'
951 field. To tell the difference, we assume that pointers will have
952 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
953 is used to tell whether the real base of the parent ablocks is `abase'
954 (if not, the word before the first ablock holds a pointer to the
956 struct ablocks
*abase
;
957 /* The padding of all but the last ablock is unused. The padding of
958 the last ablock in an ablocks is not allocated. */
960 char padding
[BLOCK_PADDING
];
964 /* A bunch of consecutive aligned blocks. */
967 struct ablock blocks
[ABLOCKS_SIZE
];
970 /* Size of the block requested from malloc or posix_memalign. */
971 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
973 #define ABLOCK_ABASE(block) \
974 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
975 ? (struct ablocks *)(block) \
978 /* Virtual `busy' field. */
979 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
981 /* Pointer to the (not necessarily aligned) malloc block. */
982 #ifdef USE_POSIX_MEMALIGN
983 #define ABLOCKS_BASE(abase) (abase)
985 #define ABLOCKS_BASE(abase) \
986 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
989 /* The list of free ablock. */
990 static struct ablock
*free_ablock
;
992 /* Allocate an aligned block of nbytes.
993 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
994 smaller or equal to BLOCK_BYTES. */
996 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
999 struct ablocks
*abase
;
1001 eassert (nbytes
<= BLOCK_BYTES
);
1005 #ifdef GC_MALLOC_CHECK
1006 allocated_mem_type
= type
;
1012 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1014 #ifdef DOUG_LEA_MALLOC
1015 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1016 because mapped region contents are not preserved in
1018 mallopt (M_MMAP_MAX
, 0);
1021 #ifdef USE_POSIX_MEMALIGN
1023 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1029 base
= malloc (ABLOCKS_BYTES
);
1030 abase
= ALIGN (base
, BLOCK_ALIGN
);
1035 MALLOC_UNBLOCK_INPUT
;
1036 memory_full (ABLOCKS_BYTES
);
1039 aligned
= (base
== abase
);
1041 ((void**)abase
)[-1] = base
;
1043 #ifdef DOUG_LEA_MALLOC
1044 /* Back to a reasonable maximum of mmap'ed areas. */
1045 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1049 /* If the memory just allocated cannot be addressed thru a Lisp
1050 object's pointer, and it needs to be, that's equivalent to
1051 running out of memory. */
1052 if (type
!= MEM_TYPE_NON_LISP
)
1055 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1056 XSETCONS (tem
, end
);
1057 if ((char *) XCONS (tem
) != end
)
1059 lisp_malloc_loser
= base
;
1061 MALLOC_UNBLOCK_INPUT
;
1062 memory_full (SIZE_MAX
);
1067 /* Initialize the blocks and put them on the free list.
1068 If `base' was not properly aligned, we can't use the last block. */
1069 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1071 abase
->blocks
[i
].abase
= abase
;
1072 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1073 free_ablock
= &abase
->blocks
[i
];
1075 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1077 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1078 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1079 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1080 eassert (ABLOCKS_BASE (abase
) == base
);
1081 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1084 abase
= ABLOCK_ABASE (free_ablock
);
1085 ABLOCKS_BUSY (abase
) =
1086 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1088 free_ablock
= free_ablock
->x
.next_free
;
1090 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1091 if (type
!= MEM_TYPE_NON_LISP
)
1092 mem_insert (val
, (char *) val
+ nbytes
, type
);
1095 MALLOC_UNBLOCK_INPUT
;
1097 MALLOC_PROBE (nbytes
);
1099 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1104 lisp_align_free (void *block
)
1106 struct ablock
*ablock
= block
;
1107 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1110 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1111 mem_delete (mem_find (block
));
1113 /* Put on free list. */
1114 ablock
->x
.next_free
= free_ablock
;
1115 free_ablock
= ablock
;
1116 /* Update busy count. */
1117 ABLOCKS_BUSY (abase
)
1118 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1120 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1121 { /* All the blocks are free. */
1122 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1123 struct ablock
**tem
= &free_ablock
;
1124 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1128 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1131 *tem
= (*tem
)->x
.next_free
;
1134 tem
= &(*tem
)->x
.next_free
;
1136 eassert ((aligned
& 1) == aligned
);
1137 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1138 #ifdef USE_POSIX_MEMALIGN
1139 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1141 free (ABLOCKS_BASE (abase
));
1143 MALLOC_UNBLOCK_INPUT
;
1147 /***********************************************************************
1149 ***********************************************************************/
1151 /* Number of intervals allocated in an interval_block structure.
1152 The 1020 is 1024 minus malloc overhead. */
1154 #define INTERVAL_BLOCK_SIZE \
1155 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1157 /* Intervals are allocated in chunks in form of an interval_block
1160 struct interval_block
1162 /* Place `intervals' first, to preserve alignment. */
1163 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1164 struct interval_block
*next
;
1167 /* Current interval block. Its `next' pointer points to older
1170 static struct interval_block
*interval_block
;
1172 /* Index in interval_block above of the next unused interval
1175 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1177 /* Number of free and live intervals. */
1179 static EMACS_INT total_free_intervals
, total_intervals
;
1181 /* List of free intervals. */
1183 static INTERVAL interval_free_list
;
1185 /* Return a new interval. */
1188 make_interval (void)
1194 if (interval_free_list
)
1196 val
= interval_free_list
;
1197 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1201 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1203 struct interval_block
*newi
1204 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1206 newi
->next
= interval_block
;
1207 interval_block
= newi
;
1208 interval_block_index
= 0;
1209 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1211 val
= &interval_block
->intervals
[interval_block_index
++];
1214 MALLOC_UNBLOCK_INPUT
;
1216 consing_since_gc
+= sizeof (struct interval
);
1218 total_free_intervals
--;
1219 RESET_INTERVAL (val
);
1225 /* Mark Lisp objects in interval I. */
1228 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1230 /* Intervals should never be shared. So, if extra internal checking is
1231 enabled, GC aborts if it seems to have visited an interval twice. */
1232 eassert (!i
->gcmarkbit
);
1234 mark_object (i
->plist
);
1237 /* Mark the interval tree rooted in I. */
1239 #define MARK_INTERVAL_TREE(i) \
1241 if (i && !i->gcmarkbit) \
1242 traverse_intervals_noorder (i, mark_interval, Qnil); \
1245 /***********************************************************************
1247 ***********************************************************************/
1249 /* Lisp_Strings are allocated in string_block structures. When a new
1250 string_block is allocated, all the Lisp_Strings it contains are
1251 added to a free-list string_free_list. When a new Lisp_String is
1252 needed, it is taken from that list. During the sweep phase of GC,
1253 string_blocks that are entirely free are freed, except two which
1256 String data is allocated from sblock structures. Strings larger
1257 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1258 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1260 Sblocks consist internally of sdata structures, one for each
1261 Lisp_String. The sdata structure points to the Lisp_String it
1262 belongs to. The Lisp_String points back to the `u.data' member of
1263 its sdata structure.
1265 When a Lisp_String is freed during GC, it is put back on
1266 string_free_list, and its `data' member and its sdata's `string'
1267 pointer is set to null. The size of the string is recorded in the
1268 `u.nbytes' member of the sdata. So, sdata structures that are no
1269 longer used, can be easily recognized, and it's easy to compact the
1270 sblocks of small strings which we do in compact_small_strings. */
1272 /* Size in bytes of an sblock structure used for small strings. This
1273 is 8192 minus malloc overhead. */
1275 #define SBLOCK_SIZE 8188
1277 /* Strings larger than this are considered large strings. String data
1278 for large strings is allocated from individual sblocks. */
1280 #define LARGE_STRING_BYTES 1024
1282 /* Structure describing string memory sub-allocated from an sblock.
1283 This is where the contents of Lisp strings are stored. */
1287 /* Back-pointer to the string this sdata belongs to. If null, this
1288 structure is free, and the NBYTES member of the union below
1289 contains the string's byte size (the same value that STRING_BYTES
1290 would return if STRING were non-null). If non-null, STRING_BYTES
1291 (STRING) is the size of the data, and DATA contains the string's
1293 struct Lisp_String
*string
;
1295 #ifdef GC_CHECK_STRING_BYTES
1298 unsigned char data
[1];
1300 #define SDATA_NBYTES(S) (S)->nbytes
1301 #define SDATA_DATA(S) (S)->data
1302 #define SDATA_SELECTOR(member) member
1304 #else /* not GC_CHECK_STRING_BYTES */
1308 /* When STRING is non-null. */
1309 unsigned char data
[1];
1311 /* When STRING is null. */
1315 #define SDATA_NBYTES(S) (S)->u.nbytes
1316 #define SDATA_DATA(S) (S)->u.data
1317 #define SDATA_SELECTOR(member) u.member
1319 #endif /* not GC_CHECK_STRING_BYTES */
1321 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1325 /* Structure describing a block of memory which is sub-allocated to
1326 obtain string data memory for strings. Blocks for small strings
1327 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1328 as large as needed. */
1333 struct sblock
*next
;
1335 /* Pointer to the next free sdata block. This points past the end
1336 of the sblock if there isn't any space left in this block. */
1337 struct sdata
*next_free
;
1339 /* Start of data. */
1340 struct sdata first_data
;
1343 /* Number of Lisp strings in a string_block structure. The 1020 is
1344 1024 minus malloc overhead. */
1346 #define STRING_BLOCK_SIZE \
1347 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1349 /* Structure describing a block from which Lisp_String structures
1354 /* Place `strings' first, to preserve alignment. */
1355 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1356 struct string_block
*next
;
1359 /* Head and tail of the list of sblock structures holding Lisp string
1360 data. We always allocate from current_sblock. The NEXT pointers
1361 in the sblock structures go from oldest_sblock to current_sblock. */
1363 static struct sblock
*oldest_sblock
, *current_sblock
;
1365 /* List of sblocks for large strings. */
1367 static struct sblock
*large_sblocks
;
1369 /* List of string_block structures. */
1371 static struct string_block
*string_blocks
;
1373 /* Free-list of Lisp_Strings. */
1375 static struct Lisp_String
*string_free_list
;
1377 /* Number of live and free Lisp_Strings. */
1379 static EMACS_INT total_strings
, total_free_strings
;
1381 /* Number of bytes used by live strings. */
1383 static EMACS_INT total_string_bytes
;
1385 /* Given a pointer to a Lisp_String S which is on the free-list
1386 string_free_list, return a pointer to its successor in the
1389 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1391 /* Return a pointer to the sdata structure belonging to Lisp string S.
1392 S must be live, i.e. S->data must not be null. S->data is actually
1393 a pointer to the `u.data' member of its sdata structure; the
1394 structure starts at a constant offset in front of that. */
1396 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1399 #ifdef GC_CHECK_STRING_OVERRUN
1401 /* We check for overrun in string data blocks by appending a small
1402 "cookie" after each allocated string data block, and check for the
1403 presence of this cookie during GC. */
1405 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1406 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1407 { '\xde', '\xad', '\xbe', '\xef' };
1410 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1413 /* Value is the size of an sdata structure large enough to hold NBYTES
1414 bytes of string data. The value returned includes a terminating
1415 NUL byte, the size of the sdata structure, and padding. */
1417 #ifdef GC_CHECK_STRING_BYTES
1419 #define SDATA_SIZE(NBYTES) \
1420 ((SDATA_DATA_OFFSET \
1422 + sizeof (ptrdiff_t) - 1) \
1423 & ~(sizeof (ptrdiff_t) - 1))
1425 #else /* not GC_CHECK_STRING_BYTES */
1427 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1428 less than the size of that member. The 'max' is not needed when
1429 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1430 alignment code reserves enough space. */
1432 #define SDATA_SIZE(NBYTES) \
1433 ((SDATA_DATA_OFFSET \
1434 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1436 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1438 + sizeof (ptrdiff_t) - 1) \
1439 & ~(sizeof (ptrdiff_t) - 1))
1441 #endif /* not GC_CHECK_STRING_BYTES */
1443 /* Extra bytes to allocate for each string. */
1445 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1447 /* Exact bound on the number of bytes in a string, not counting the
1448 terminating null. A string cannot contain more bytes than
1449 STRING_BYTES_BOUND, nor can it be so long that the size_t
1450 arithmetic in allocate_string_data would overflow while it is
1451 calculating a value to be passed to malloc. */
1452 static ptrdiff_t const STRING_BYTES_MAX
=
1453 min (STRING_BYTES_BOUND
,
1454 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1456 - offsetof (struct sblock
, first_data
)
1457 - SDATA_DATA_OFFSET
)
1458 & ~(sizeof (EMACS_INT
) - 1)));
1460 /* Initialize string allocation. Called from init_alloc_once. */
1465 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1466 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1470 #ifdef GC_CHECK_STRING_BYTES
1472 static int check_string_bytes_count
;
1474 /* Like STRING_BYTES, but with debugging check. Can be
1475 called during GC, so pay attention to the mark bit. */
1478 string_bytes (struct Lisp_String
*s
)
1481 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1483 if (!PURE_POINTER_P (s
)
1485 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1490 /* Check validity of Lisp strings' string_bytes member in B. */
1493 check_sblock (struct sblock
*b
)
1495 struct sdata
*from
, *end
, *from_end
;
1499 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1501 /* Compute the next FROM here because copying below may
1502 overwrite data we need to compute it. */
1505 /* Check that the string size recorded in the string is the
1506 same as the one recorded in the sdata structure. */
1507 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1508 : SDATA_NBYTES (from
));
1509 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1514 /* Check validity of Lisp strings' string_bytes member. ALL_P
1515 means check all strings, otherwise check only most
1516 recently allocated strings. Used for hunting a bug. */
1519 check_string_bytes (bool all_p
)
1525 for (b
= large_sblocks
; b
; b
= b
->next
)
1527 struct Lisp_String
*s
= b
->first_data
.string
;
1532 for (b
= oldest_sblock
; b
; b
= b
->next
)
1535 else if (current_sblock
)
1536 check_sblock (current_sblock
);
1539 #else /* not GC_CHECK_STRING_BYTES */
1541 #define check_string_bytes(all) ((void) 0)
1543 #endif /* GC_CHECK_STRING_BYTES */
1545 #ifdef GC_CHECK_STRING_FREE_LIST
1547 /* Walk through the string free list looking for bogus next pointers.
1548 This may catch buffer overrun from a previous string. */
1551 check_string_free_list (void)
1553 struct Lisp_String
*s
;
1555 /* Pop a Lisp_String off the free-list. */
1556 s
= string_free_list
;
1559 if ((uintptr_t) s
< 1024)
1561 s
= NEXT_FREE_LISP_STRING (s
);
1565 #define check_string_free_list()
1568 /* Return a new Lisp_String. */
1570 static struct Lisp_String
*
1571 allocate_string (void)
1573 struct Lisp_String
*s
;
1577 /* If the free-list is empty, allocate a new string_block, and
1578 add all the Lisp_Strings in it to the free-list. */
1579 if (string_free_list
== NULL
)
1581 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1584 b
->next
= string_blocks
;
1587 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1590 /* Every string on a free list should have NULL data pointer. */
1592 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1593 string_free_list
= s
;
1596 total_free_strings
+= STRING_BLOCK_SIZE
;
1599 check_string_free_list ();
1601 /* Pop a Lisp_String off the free-list. */
1602 s
= string_free_list
;
1603 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1605 MALLOC_UNBLOCK_INPUT
;
1607 --total_free_strings
;
1610 consing_since_gc
+= sizeof *s
;
1612 #ifdef GC_CHECK_STRING_BYTES
1613 if (!noninteractive
)
1615 if (++check_string_bytes_count
== 200)
1617 check_string_bytes_count
= 0;
1618 check_string_bytes (1);
1621 check_string_bytes (0);
1623 #endif /* GC_CHECK_STRING_BYTES */
1629 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1630 plus a NUL byte at the end. Allocate an sdata structure for S, and
1631 set S->data to its `u.data' member. Store a NUL byte at the end of
1632 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1633 S->data if it was initially non-null. */
1636 allocate_string_data (struct Lisp_String
*s
,
1637 EMACS_INT nchars
, EMACS_INT nbytes
)
1639 struct sdata
*data
, *old_data
;
1641 ptrdiff_t needed
, old_nbytes
;
1643 if (STRING_BYTES_MAX
< nbytes
)
1646 /* Determine the number of bytes needed to store NBYTES bytes
1648 needed
= SDATA_SIZE (nbytes
);
1651 old_data
= SDATA_OF_STRING (s
);
1652 old_nbytes
= STRING_BYTES (s
);
1659 if (nbytes
> LARGE_STRING_BYTES
)
1661 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1663 #ifdef DOUG_LEA_MALLOC
1664 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1665 because mapped region contents are not preserved in
1668 In case you think of allowing it in a dumped Emacs at the
1669 cost of not being able to re-dump, there's another reason:
1670 mmap'ed data typically have an address towards the top of the
1671 address space, which won't fit into an EMACS_INT (at least on
1672 32-bit systems with the current tagging scheme). --fx */
1673 mallopt (M_MMAP_MAX
, 0);
1676 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1678 #ifdef DOUG_LEA_MALLOC
1679 /* Back to a reasonable maximum of mmap'ed areas. */
1680 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1683 b
->next_free
= &b
->first_data
;
1684 b
->first_data
.string
= NULL
;
1685 b
->next
= large_sblocks
;
1688 else if (current_sblock
== NULL
1689 || (((char *) current_sblock
+ SBLOCK_SIZE
1690 - (char *) current_sblock
->next_free
)
1691 < (needed
+ GC_STRING_EXTRA
)))
1693 /* Not enough room in the current sblock. */
1694 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1695 b
->next_free
= &b
->first_data
;
1696 b
->first_data
.string
= NULL
;
1700 current_sblock
->next
= b
;
1708 data
= b
->next_free
;
1709 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1711 MALLOC_UNBLOCK_INPUT
;
1714 s
->data
= SDATA_DATA (data
);
1715 #ifdef GC_CHECK_STRING_BYTES
1716 SDATA_NBYTES (data
) = nbytes
;
1719 s
->size_byte
= nbytes
;
1720 s
->data
[nbytes
] = '\0';
1721 #ifdef GC_CHECK_STRING_OVERRUN
1722 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1723 GC_STRING_OVERRUN_COOKIE_SIZE
);
1726 /* Note that Faset may call to this function when S has already data
1727 assigned. In this case, mark data as free by setting it's string
1728 back-pointer to null, and record the size of the data in it. */
1731 SDATA_NBYTES (old_data
) = old_nbytes
;
1732 old_data
->string
= NULL
;
1735 consing_since_gc
+= needed
;
1739 /* Sweep and compact strings. */
1742 sweep_strings (void)
1744 struct string_block
*b
, *next
;
1745 struct string_block
*live_blocks
= NULL
;
1747 string_free_list
= NULL
;
1748 total_strings
= total_free_strings
= 0;
1749 total_string_bytes
= 0;
1751 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1752 for (b
= string_blocks
; b
; b
= next
)
1755 struct Lisp_String
*free_list_before
= string_free_list
;
1759 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1761 struct Lisp_String
*s
= b
->strings
+ i
;
1765 /* String was not on free-list before. */
1766 if (STRING_MARKED_P (s
))
1768 /* String is live; unmark it and its intervals. */
1771 /* Do not use string_(set|get)_intervals here. */
1772 s
->intervals
= balance_intervals (s
->intervals
);
1775 total_string_bytes
+= STRING_BYTES (s
);
1779 /* String is dead. Put it on the free-list. */
1780 struct sdata
*data
= SDATA_OF_STRING (s
);
1782 /* Save the size of S in its sdata so that we know
1783 how large that is. Reset the sdata's string
1784 back-pointer so that we know it's free. */
1785 #ifdef GC_CHECK_STRING_BYTES
1786 if (string_bytes (s
) != SDATA_NBYTES (data
))
1789 data
->u
.nbytes
= STRING_BYTES (s
);
1791 data
->string
= NULL
;
1793 /* Reset the strings's `data' member so that we
1797 /* Put the string on the free-list. */
1798 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1799 string_free_list
= s
;
1805 /* S was on the free-list before. Put it there again. */
1806 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1807 string_free_list
= s
;
1812 /* Free blocks that contain free Lisp_Strings only, except
1813 the first two of them. */
1814 if (nfree
== STRING_BLOCK_SIZE
1815 && total_free_strings
> STRING_BLOCK_SIZE
)
1818 string_free_list
= free_list_before
;
1822 total_free_strings
+= nfree
;
1823 b
->next
= live_blocks
;
1828 check_string_free_list ();
1830 string_blocks
= live_blocks
;
1831 free_large_strings ();
1832 compact_small_strings ();
1834 check_string_free_list ();
1838 /* Free dead large strings. */
1841 free_large_strings (void)
1843 struct sblock
*b
, *next
;
1844 struct sblock
*live_blocks
= NULL
;
1846 for (b
= large_sblocks
; b
; b
= next
)
1850 if (b
->first_data
.string
== NULL
)
1854 b
->next
= live_blocks
;
1859 large_sblocks
= live_blocks
;
1863 /* Compact data of small strings. Free sblocks that don't contain
1864 data of live strings after compaction. */
1867 compact_small_strings (void)
1869 struct sblock
*b
, *tb
, *next
;
1870 struct sdata
*from
, *to
, *end
, *tb_end
;
1871 struct sdata
*to_end
, *from_end
;
1873 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1874 to, and TB_END is the end of TB. */
1876 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1877 to
= &tb
->first_data
;
1879 /* Step through the blocks from the oldest to the youngest. We
1880 expect that old blocks will stabilize over time, so that less
1881 copying will happen this way. */
1882 for (b
= oldest_sblock
; b
; b
= b
->next
)
1885 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1887 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1889 /* Compute the next FROM here because copying below may
1890 overwrite data we need to compute it. */
1892 struct Lisp_String
*s
= from
->string
;
1894 #ifdef GC_CHECK_STRING_BYTES
1895 /* Check that the string size recorded in the string is the
1896 same as the one recorded in the sdata structure. */
1897 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1899 #endif /* GC_CHECK_STRING_BYTES */
1901 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1902 eassert (nbytes
<= LARGE_STRING_BYTES
);
1904 nbytes
= SDATA_SIZE (nbytes
);
1905 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1907 #ifdef GC_CHECK_STRING_OVERRUN
1908 if (memcmp (string_overrun_cookie
,
1909 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1910 GC_STRING_OVERRUN_COOKIE_SIZE
))
1914 /* Non-NULL S means it's alive. Copy its data. */
1917 /* If TB is full, proceed with the next sblock. */
1918 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1919 if (to_end
> tb_end
)
1923 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1924 to
= &tb
->first_data
;
1925 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1928 /* Copy, and update the string's `data' pointer. */
1931 eassert (tb
!= b
|| to
< from
);
1932 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1933 to
->string
->data
= SDATA_DATA (to
);
1936 /* Advance past the sdata we copied to. */
1942 /* The rest of the sblocks following TB don't contain live data, so
1943 we can free them. */
1944 for (b
= tb
->next
; b
; b
= next
)
1952 current_sblock
= tb
;
1956 string_overflow (void)
1958 error ("Maximum string size exceeded");
1961 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1962 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1963 LENGTH must be an integer.
1964 INIT must be an integer that represents a character. */)
1965 (Lisp_Object length
, Lisp_Object init
)
1967 register Lisp_Object val
;
1968 register unsigned char *p
, *end
;
1972 CHECK_NATNUM (length
);
1973 CHECK_CHARACTER (init
);
1975 c
= XFASTINT (init
);
1976 if (ASCII_CHAR_P (c
))
1978 nbytes
= XINT (length
);
1979 val
= make_uninit_string (nbytes
);
1981 end
= p
+ SCHARS (val
);
1987 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1988 int len
= CHAR_STRING (c
, str
);
1989 EMACS_INT string_len
= XINT (length
);
1991 if (string_len
> STRING_BYTES_MAX
/ len
)
1993 nbytes
= len
* string_len
;
1994 val
= make_uninit_multibyte_string (string_len
, nbytes
);
1999 memcpy (p
, str
, len
);
2009 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2010 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2011 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2012 (Lisp_Object length
, Lisp_Object init
)
2014 register Lisp_Object val
;
2015 struct Lisp_Bool_Vector
*p
;
2016 ptrdiff_t length_in_chars
;
2017 EMACS_INT length_in_elts
;
2019 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2022 CHECK_NATNUM (length
);
2024 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2026 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2028 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2030 /* No Lisp_Object to trace in there. */
2031 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2033 p
= XBOOL_VECTOR (val
);
2034 p
->size
= XFASTINT (length
);
2036 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2037 / BOOL_VECTOR_BITS_PER_CHAR
);
2038 if (length_in_chars
)
2040 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2042 /* Clear any extraneous bits in the last byte. */
2043 p
->data
[length_in_chars
- 1]
2044 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2051 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2052 of characters from the contents. This string may be unibyte or
2053 multibyte, depending on the contents. */
2056 make_string (const char *contents
, ptrdiff_t nbytes
)
2058 register Lisp_Object val
;
2059 ptrdiff_t nchars
, multibyte_nbytes
;
2061 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2062 &nchars
, &multibyte_nbytes
);
2063 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2064 /* CONTENTS contains no multibyte sequences or contains an invalid
2065 multibyte sequence. We must make unibyte string. */
2066 val
= make_unibyte_string (contents
, nbytes
);
2068 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2073 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2076 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2078 register Lisp_Object val
;
2079 val
= make_uninit_string (length
);
2080 memcpy (SDATA (val
), contents
, length
);
2085 /* Make a multibyte string from NCHARS characters occupying NBYTES
2086 bytes at CONTENTS. */
2089 make_multibyte_string (const char *contents
,
2090 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2092 register Lisp_Object val
;
2093 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2094 memcpy (SDATA (val
), contents
, nbytes
);
2099 /* Make a string from NCHARS characters occupying NBYTES bytes at
2100 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2103 make_string_from_bytes (const char *contents
,
2104 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2106 register Lisp_Object val
;
2107 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2108 memcpy (SDATA (val
), contents
, nbytes
);
2109 if (SBYTES (val
) == SCHARS (val
))
2110 STRING_SET_UNIBYTE (val
);
2115 /* Make a string from NCHARS characters occupying NBYTES bytes at
2116 CONTENTS. The argument MULTIBYTE controls whether to label the
2117 string as multibyte. If NCHARS is negative, it counts the number of
2118 characters by itself. */
2121 make_specified_string (const char *contents
,
2122 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2129 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2134 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2135 memcpy (SDATA (val
), contents
, nbytes
);
2137 STRING_SET_UNIBYTE (val
);
2142 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2143 occupying LENGTH bytes. */
2146 make_uninit_string (EMACS_INT length
)
2151 return empty_unibyte_string
;
2152 val
= make_uninit_multibyte_string (length
, length
);
2153 STRING_SET_UNIBYTE (val
);
2158 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2159 which occupy NBYTES bytes. */
2162 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2165 struct Lisp_String
*s
;
2170 return empty_multibyte_string
;
2172 s
= allocate_string ();
2173 s
->intervals
= NULL
;
2174 allocate_string_data (s
, nchars
, nbytes
);
2175 XSETSTRING (string
, s
);
2176 string_chars_consed
+= nbytes
;
2180 /* Print arguments to BUF according to a FORMAT, then return
2181 a Lisp_String initialized with the data from BUF. */
2184 make_formatted_string (char *buf
, const char *format
, ...)
2189 va_start (ap
, format
);
2190 length
= vsprintf (buf
, format
, ap
);
2192 return make_string (buf
, length
);
2196 /***********************************************************************
2198 ***********************************************************************/
2200 /* We store float cells inside of float_blocks, allocating a new
2201 float_block with malloc whenever necessary. Float cells reclaimed
2202 by GC are put on a free list to be reallocated before allocating
2203 any new float cells from the latest float_block. */
2205 #define FLOAT_BLOCK_SIZE \
2206 (((BLOCK_BYTES - sizeof (struct float_block *) \
2207 /* The compiler might add padding at the end. */ \
2208 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2209 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2211 #define GETMARKBIT(block,n) \
2212 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2213 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2216 #define SETMARKBIT(block,n) \
2217 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2218 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2220 #define UNSETMARKBIT(block,n) \
2221 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2222 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2224 #define FLOAT_BLOCK(fptr) \
2225 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2227 #define FLOAT_INDEX(fptr) \
2228 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2232 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2233 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2234 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2235 struct float_block
*next
;
2238 #define FLOAT_MARKED_P(fptr) \
2239 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2241 #define FLOAT_MARK(fptr) \
2242 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2244 #define FLOAT_UNMARK(fptr) \
2245 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2247 /* Current float_block. */
2249 static struct float_block
*float_block
;
2251 /* Index of first unused Lisp_Float in the current float_block. */
2253 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2255 /* Free-list of Lisp_Floats. */
2257 static struct Lisp_Float
*float_free_list
;
2259 /* Return a new float object with value FLOAT_VALUE. */
2262 make_float (double float_value
)
2264 register Lisp_Object val
;
2268 if (float_free_list
)
2270 /* We use the data field for chaining the free list
2271 so that we won't use the same field that has the mark bit. */
2272 XSETFLOAT (val
, float_free_list
);
2273 float_free_list
= float_free_list
->u
.chain
;
2277 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2279 struct float_block
*new
2280 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2281 new->next
= float_block
;
2282 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2284 float_block_index
= 0;
2285 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2287 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2288 float_block_index
++;
2291 MALLOC_UNBLOCK_INPUT
;
2293 XFLOAT_INIT (val
, float_value
);
2294 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2295 consing_since_gc
+= sizeof (struct Lisp_Float
);
2297 total_free_floats
--;
2303 /***********************************************************************
2305 ***********************************************************************/
2307 /* We store cons cells inside of cons_blocks, allocating a new
2308 cons_block with malloc whenever necessary. Cons cells reclaimed by
2309 GC are put on a free list to be reallocated before allocating
2310 any new cons cells from the latest cons_block. */
2312 #define CONS_BLOCK_SIZE \
2313 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2314 /* The compiler might add padding at the end. */ \
2315 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2316 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2318 #define CONS_BLOCK(fptr) \
2319 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2321 #define CONS_INDEX(fptr) \
2322 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2326 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2327 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2328 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2329 struct cons_block
*next
;
2332 #define CONS_MARKED_P(fptr) \
2333 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2335 #define CONS_MARK(fptr) \
2336 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2338 #define CONS_UNMARK(fptr) \
2339 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2341 /* Current cons_block. */
2343 static struct cons_block
*cons_block
;
2345 /* Index of first unused Lisp_Cons in the current block. */
2347 static int cons_block_index
= CONS_BLOCK_SIZE
;
2349 /* Free-list of Lisp_Cons structures. */
2351 static struct Lisp_Cons
*cons_free_list
;
2353 /* Explicitly free a cons cell by putting it on the free-list. */
2356 free_cons (struct Lisp_Cons
*ptr
)
2358 ptr
->u
.chain
= cons_free_list
;
2362 cons_free_list
= ptr
;
2363 consing_since_gc
-= sizeof *ptr
;
2364 total_free_conses
++;
2367 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2368 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2369 (Lisp_Object car
, Lisp_Object cdr
)
2371 register Lisp_Object val
;
2377 /* We use the cdr for chaining the free list
2378 so that we won't use the same field that has the mark bit. */
2379 XSETCONS (val
, cons_free_list
);
2380 cons_free_list
= cons_free_list
->u
.chain
;
2384 if (cons_block_index
== CONS_BLOCK_SIZE
)
2386 struct cons_block
*new
2387 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2388 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2389 new->next
= cons_block
;
2391 cons_block_index
= 0;
2392 total_free_conses
+= CONS_BLOCK_SIZE
;
2394 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2398 MALLOC_UNBLOCK_INPUT
;
2402 eassert (!CONS_MARKED_P (XCONS (val
)));
2403 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2404 total_free_conses
--;
2405 cons_cells_consed
++;
2409 #ifdef GC_CHECK_CONS_LIST
2410 /* Get an error now if there's any junk in the cons free list. */
2412 check_cons_list (void)
2414 struct Lisp_Cons
*tail
= cons_free_list
;
2417 tail
= tail
->u
.chain
;
2421 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2424 list1 (Lisp_Object arg1
)
2426 return Fcons (arg1
, Qnil
);
2430 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2432 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2437 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2439 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2444 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2446 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2451 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2453 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2454 Fcons (arg5
, Qnil
)))));
2457 /* Make a list of COUNT Lisp_Objects, where ARG is the
2458 first one. Allocate conses from pure space if TYPE
2459 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2462 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2466 Lisp_Object val
, *objp
;
2468 /* Change to SAFE_ALLOCA if you hit this eassert. */
2469 eassert (count
<= MAX_ALLOCA
/ word_size
);
2471 objp
= alloca (count
* word_size
);
2474 for (i
= 1; i
< count
; i
++)
2475 objp
[i
] = va_arg (ap
, Lisp_Object
);
2478 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2480 if (type
== CONSTYPE_PURE
)
2481 val
= pure_cons (objp
[i
], val
);
2482 else if (type
== CONSTYPE_HEAP
)
2483 val
= Fcons (objp
[i
], val
);
2490 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2491 doc
: /* Return a newly created list with specified arguments as elements.
2492 Any number of arguments, even zero arguments, are allowed.
2493 usage: (list &rest OBJECTS) */)
2494 (ptrdiff_t nargs
, Lisp_Object
*args
)
2496 register Lisp_Object val
;
2502 val
= Fcons (args
[nargs
], val
);
2508 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2509 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2510 (register Lisp_Object length
, Lisp_Object init
)
2512 register Lisp_Object val
;
2513 register EMACS_INT size
;
2515 CHECK_NATNUM (length
);
2516 size
= XFASTINT (length
);
2521 val
= Fcons (init
, val
);
2526 val
= Fcons (init
, val
);
2531 val
= Fcons (init
, val
);
2536 val
= Fcons (init
, val
);
2541 val
= Fcons (init
, val
);
2556 /***********************************************************************
2558 ***********************************************************************/
2560 /* This value is balanced well enough to avoid too much internal overhead
2561 for the most common cases; it's not required to be a power of two, but
2562 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2564 #define VECTOR_BLOCK_SIZE 4096
2566 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2569 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2572 /* ROUNDUP_SIZE must be a power of 2. */
2573 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2575 /* Verify assumptions described above. */
2576 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2577 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2579 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2581 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2583 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2585 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2587 /* Size of the minimal vector allocated from block. */
2589 #define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2591 /* Size of the largest vector allocated from block. */
2593 #define VBLOCK_BYTES_MAX \
2594 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2596 /* We maintain one free list for each possible block-allocated
2597 vector size, and this is the number of free lists we have. */
2599 #define VECTOR_MAX_FREE_LIST_INDEX \
2600 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2602 /* Common shortcut to advance vector pointer over a block data. */
2604 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2606 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2608 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2610 /* Get and set the next field in block-allocated vectorlike objects on
2611 the free list. Doing it this way respects C's aliasing rules.
2612 We could instead make 'contents' a union, but that would mean
2613 changes everywhere that the code uses 'contents'. */
2614 static struct Lisp_Vector
*
2615 next_in_free_list (struct Lisp_Vector
*v
)
2617 intptr_t i
= XLI (v
->contents
[0]);
2618 return (struct Lisp_Vector
*) i
;
2621 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2623 v
->contents
[0] = XIL ((intptr_t) next
);
2626 /* Common shortcut to setup vector on a free list. */
2628 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2630 (tmp) = ((nbytes - header_size) / word_size); \
2631 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2632 eassert ((nbytes) % roundup_size == 0); \
2633 (tmp) = VINDEX (nbytes); \
2634 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2635 set_next_in_free_list (v, vector_free_lists[tmp]); \
2636 vector_free_lists[tmp] = (v); \
2637 total_free_vector_slots += (nbytes) / word_size; \
2640 /* This internal type is used to maintain the list of large vectors
2641 which are allocated at their own, e.g. outside of vector blocks. */
2646 struct large_vector
*vector
;
2648 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2649 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2652 struct Lisp_Vector v
;
2655 /* This internal type is used to maintain an underlying storage
2656 for small vectors. */
2660 char data
[VECTOR_BLOCK_BYTES
];
2661 struct vector_block
*next
;
2664 /* Chain of vector blocks. */
2666 static struct vector_block
*vector_blocks
;
2668 /* Vector free lists, where NTH item points to a chain of free
2669 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2671 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2673 /* Singly-linked list of large vectors. */
2675 static struct large_vector
*large_vectors
;
2677 /* The only vector with 0 slots, allocated from pure space. */
2679 Lisp_Object zero_vector
;
2681 /* Number of live vectors. */
2683 static EMACS_INT total_vectors
;
2685 /* Total size of live and free vectors, in Lisp_Object units. */
2687 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2689 /* Get a new vector block. */
2691 static struct vector_block
*
2692 allocate_vector_block (void)
2694 struct vector_block
*block
= xmalloc (sizeof *block
);
2696 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2697 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2698 MEM_TYPE_VECTOR_BLOCK
);
2701 block
->next
= vector_blocks
;
2702 vector_blocks
= block
;
2706 /* Called once to initialize vector allocation. */
2711 zero_vector
= make_pure_vector (0);
2714 /* Allocate vector from a vector block. */
2716 static struct Lisp_Vector
*
2717 allocate_vector_from_block (size_t nbytes
)
2719 struct Lisp_Vector
*vector
;
2720 struct vector_block
*block
;
2721 size_t index
, restbytes
;
2723 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2724 eassert (nbytes
% roundup_size
== 0);
2726 /* First, try to allocate from a free list
2727 containing vectors of the requested size. */
2728 index
= VINDEX (nbytes
);
2729 if (vector_free_lists
[index
])
2731 vector
= vector_free_lists
[index
];
2732 vector_free_lists
[index
] = next_in_free_list (vector
);
2733 total_free_vector_slots
-= nbytes
/ word_size
;
2737 /* Next, check free lists containing larger vectors. Since
2738 we will split the result, we should have remaining space
2739 large enough to use for one-slot vector at least. */
2740 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2741 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2742 if (vector_free_lists
[index
])
2744 /* This vector is larger than requested. */
2745 vector
= vector_free_lists
[index
];
2746 vector_free_lists
[index
] = next_in_free_list (vector
);
2747 total_free_vector_slots
-= nbytes
/ word_size
;
2749 /* Excess bytes are used for the smaller vector,
2750 which should be set on an appropriate free list. */
2751 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2752 eassert (restbytes
% roundup_size
== 0);
2753 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2757 /* Finally, need a new vector block. */
2758 block
= allocate_vector_block ();
2760 /* New vector will be at the beginning of this block. */
2761 vector
= (struct Lisp_Vector
*) block
->data
;
2763 /* If the rest of space from this block is large enough
2764 for one-slot vector at least, set up it on a free list. */
2765 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2766 if (restbytes
>= VBLOCK_BYTES_MIN
)
2768 eassert (restbytes
% roundup_size
== 0);
2769 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2774 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2776 #define VECTOR_IN_BLOCK(vector, block) \
2777 ((char *) (vector) <= (block)->data \
2778 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2780 /* Return the memory footprint of V in bytes. */
2783 vector_nbytes (struct Lisp_Vector
*v
)
2785 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2787 if (size
& PSEUDOVECTOR_FLAG
)
2789 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2790 size
= (bool_header_size
2791 + (((struct Lisp_Bool_Vector
*) v
)->size
2792 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2793 / BOOL_VECTOR_BITS_PER_CHAR
);
2796 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2797 + ((size
& PSEUDOVECTOR_REST_MASK
)
2798 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2801 size
= header_size
+ size
* word_size
;
2802 return vroundup (size
);
2805 /* Reclaim space used by unmarked vectors. */
2808 sweep_vectors (void)
2810 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2811 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2812 struct Lisp_Vector
*vector
, *next
;
2814 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2815 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2817 /* Looking through vector blocks. */
2819 for (block
= vector_blocks
; block
; block
= *bprev
)
2821 bool free_this_block
= 0;
2824 for (vector
= (struct Lisp_Vector
*) block
->data
;
2825 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2827 if (VECTOR_MARKED_P (vector
))
2829 VECTOR_UNMARK (vector
);
2831 nbytes
= vector_nbytes (vector
);
2832 total_vector_slots
+= nbytes
/ word_size
;
2833 next
= ADVANCE (vector
, nbytes
);
2837 ptrdiff_t total_bytes
;
2839 nbytes
= vector_nbytes (vector
);
2840 total_bytes
= nbytes
;
2841 next
= ADVANCE (vector
, nbytes
);
2843 /* While NEXT is not marked, try to coalesce with VECTOR,
2844 thus making VECTOR of the largest possible size. */
2846 while (VECTOR_IN_BLOCK (next
, block
))
2848 if (VECTOR_MARKED_P (next
))
2850 nbytes
= vector_nbytes (next
);
2851 total_bytes
+= nbytes
;
2852 next
= ADVANCE (next
, nbytes
);
2855 eassert (total_bytes
% roundup_size
== 0);
2857 if (vector
== (struct Lisp_Vector
*) block
->data
2858 && !VECTOR_IN_BLOCK (next
, block
))
2859 /* This block should be freed because all of it's
2860 space was coalesced into the only free vector. */
2861 free_this_block
= 1;
2865 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2870 if (free_this_block
)
2872 *bprev
= block
->next
;
2873 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2874 mem_delete (mem_find (block
->data
));
2879 bprev
= &block
->next
;
2882 /* Sweep large vectors. */
2884 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2887 if (VECTOR_MARKED_P (vector
))
2889 VECTOR_UNMARK (vector
);
2891 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2893 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2895 /* All non-bool pseudovectors are small enough to be allocated
2896 from vector blocks. This code should be redesigned if some
2897 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2898 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2901 += (bool_header_size
2902 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2903 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2907 += header_size
/ word_size
+ vector
->header
.size
;
2908 lvprev
= &lv
->next
.vector
;
2912 *lvprev
= lv
->next
.vector
;
2918 /* Value is a pointer to a newly allocated Lisp_Vector structure
2919 with room for LEN Lisp_Objects. */
2921 static struct Lisp_Vector
*
2922 allocate_vectorlike (ptrdiff_t len
)
2924 struct Lisp_Vector
*p
;
2929 p
= XVECTOR (zero_vector
);
2932 size_t nbytes
= header_size
+ len
* word_size
;
2934 #ifdef DOUG_LEA_MALLOC
2935 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2936 because mapped region contents are not preserved in
2938 mallopt (M_MMAP_MAX
, 0);
2941 if (nbytes
<= VBLOCK_BYTES_MAX
)
2942 p
= allocate_vector_from_block (vroundup (nbytes
));
2945 struct large_vector
*lv
2946 = lisp_malloc (sizeof (*lv
) + (len
- 1) * word_size
,
2947 MEM_TYPE_VECTORLIKE
);
2948 lv
->next
.vector
= large_vectors
;
2953 #ifdef DOUG_LEA_MALLOC
2954 /* Back to a reasonable maximum of mmap'ed areas. */
2955 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2958 consing_since_gc
+= nbytes
;
2959 vector_cells_consed
+= len
;
2962 MALLOC_UNBLOCK_INPUT
;
2968 /* Allocate a vector with LEN slots. */
2970 struct Lisp_Vector
*
2971 allocate_vector (EMACS_INT len
)
2973 struct Lisp_Vector
*v
;
2974 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2976 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2977 memory_full (SIZE_MAX
);
2978 v
= allocate_vectorlike (len
);
2979 v
->header
.size
= len
;
2984 /* Allocate other vector-like structures. */
2986 struct Lisp_Vector
*
2987 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2989 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2992 /* Catch bogus values. */
2993 eassert (tag
<= PVEC_FONT
);
2994 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2995 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2997 /* Only the first lisplen slots will be traced normally by the GC. */
2998 for (i
= 0; i
< lisplen
; ++i
)
2999 v
->contents
[i
] = Qnil
;
3001 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3006 allocate_buffer (void)
3008 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3010 BUFFER_PVEC_INIT (b
);
3011 /* Put B on the chain of all buffers including killed ones. */
3012 b
->next
= all_buffers
;
3014 /* Note that the rest fields of B are not initialized. */
3018 struct Lisp_Hash_Table
*
3019 allocate_hash_table (void)
3021 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3025 allocate_window (void)
3029 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3030 /* Users assumes that non-Lisp data is zeroed. */
3031 memset (&w
->current_matrix
, 0,
3032 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3037 allocate_terminal (void)
3041 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3042 /* Users assumes that non-Lisp data is zeroed. */
3043 memset (&t
->next_terminal
, 0,
3044 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3049 allocate_frame (void)
3053 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3054 /* Users assumes that non-Lisp data is zeroed. */
3055 memset (&f
->face_cache
, 0,
3056 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3060 struct Lisp_Process
*
3061 allocate_process (void)
3063 struct Lisp_Process
*p
;
3065 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3066 /* Users assumes that non-Lisp data is zeroed. */
3068 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3072 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3073 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3074 See also the function `vector'. */)
3075 (register Lisp_Object length
, Lisp_Object init
)
3078 register ptrdiff_t sizei
;
3079 register ptrdiff_t i
;
3080 register struct Lisp_Vector
*p
;
3082 CHECK_NATNUM (length
);
3084 p
= allocate_vector (XFASTINT (length
));
3085 sizei
= XFASTINT (length
);
3086 for (i
= 0; i
< sizei
; i
++)
3087 p
->contents
[i
] = init
;
3089 XSETVECTOR (vector
, p
);
3094 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3095 doc
: /* Return a newly created vector with specified arguments as elements.
3096 Any number of arguments, even zero arguments, are allowed.
3097 usage: (vector &rest OBJECTS) */)
3098 (ptrdiff_t nargs
, Lisp_Object
*args
)
3100 register Lisp_Object len
, val
;
3102 register struct Lisp_Vector
*p
;
3104 XSETFASTINT (len
, nargs
);
3105 val
= Fmake_vector (len
, Qnil
);
3107 for (i
= 0; i
< nargs
; i
++)
3108 p
->contents
[i
] = args
[i
];
3113 make_byte_code (struct Lisp_Vector
*v
)
3115 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3116 && STRING_MULTIBYTE (v
->contents
[1]))
3117 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3118 earlier because they produced a raw 8-bit string for byte-code
3119 and now such a byte-code string is loaded as multibyte while
3120 raw 8-bit characters converted to multibyte form. Thus, now we
3121 must convert them back to the original unibyte form. */
3122 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3123 XSETPVECTYPE (v
, PVEC_COMPILED
);
3126 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3127 doc
: /* Create a byte-code object with specified arguments as elements.
3128 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3129 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3130 and (optional) INTERACTIVE-SPEC.
3131 The first four arguments are required; at most six have any
3133 The ARGLIST can be either like the one of `lambda', in which case the arguments
3134 will be dynamically bound before executing the byte code, or it can be an
3135 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3136 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3137 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3138 argument to catch the left-over arguments. If such an integer is used, the
3139 arguments will not be dynamically bound but will be instead pushed on the
3140 stack before executing the byte-code.
3141 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3142 (ptrdiff_t nargs
, Lisp_Object
*args
)
3144 register Lisp_Object len
, val
;
3146 register struct Lisp_Vector
*p
;
3148 /* We used to purecopy everything here, if purify-flag was set. This worked
3149 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3150 dangerous, since make-byte-code is used during execution to build
3151 closures, so any closure built during the preload phase would end up
3152 copied into pure space, including its free variables, which is sometimes
3153 just wasteful and other times plainly wrong (e.g. those free vars may want
3156 XSETFASTINT (len
, nargs
);
3157 val
= Fmake_vector (len
, Qnil
);
3160 for (i
= 0; i
< nargs
; i
++)
3161 p
->contents
[i
] = args
[i
];
3163 XSETCOMPILED (val
, p
);
3169 /***********************************************************************
3171 ***********************************************************************/
3173 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3174 of the required alignment if LSB tags are used. */
3176 union aligned_Lisp_Symbol
3178 struct Lisp_Symbol s
;
3180 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3185 /* Each symbol_block is just under 1020 bytes long, since malloc
3186 really allocates in units of powers of two and uses 4 bytes for its
3189 #define SYMBOL_BLOCK_SIZE \
3190 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3194 /* Place `symbols' first, to preserve alignment. */
3195 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3196 struct symbol_block
*next
;
3199 /* Current symbol block and index of first unused Lisp_Symbol
3202 static struct symbol_block
*symbol_block
;
3203 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3205 /* List of free symbols. */
3207 static struct Lisp_Symbol
*symbol_free_list
;
3209 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3210 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3211 Its value is void, and its function definition and property list are nil. */)
3214 register Lisp_Object val
;
3215 register struct Lisp_Symbol
*p
;
3217 CHECK_STRING (name
);
3221 if (symbol_free_list
)
3223 XSETSYMBOL (val
, symbol_free_list
);
3224 symbol_free_list
= symbol_free_list
->next
;
3228 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3230 struct symbol_block
*new
3231 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3232 new->next
= symbol_block
;
3234 symbol_block_index
= 0;
3235 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3237 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3238 symbol_block_index
++;
3241 MALLOC_UNBLOCK_INPUT
;
3244 set_symbol_name (val
, name
);
3245 set_symbol_plist (val
, Qnil
);
3246 p
->redirect
= SYMBOL_PLAINVAL
;
3247 SET_SYMBOL_VAL (p
, Qunbound
);
3248 set_symbol_function (val
, Qnil
);
3249 set_symbol_next (val
, NULL
);
3251 p
->interned
= SYMBOL_UNINTERNED
;
3253 p
->declared_special
= 0;
3254 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3256 total_free_symbols
--;
3262 /***********************************************************************
3263 Marker (Misc) Allocation
3264 ***********************************************************************/
3266 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3267 the required alignment when LSB tags are used. */
3269 union aligned_Lisp_Misc
3273 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3278 /* Allocation of markers and other objects that share that structure.
3279 Works like allocation of conses. */
3281 #define MARKER_BLOCK_SIZE \
3282 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3286 /* Place `markers' first, to preserve alignment. */
3287 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3288 struct marker_block
*next
;
3291 static struct marker_block
*marker_block
;
3292 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3294 static union Lisp_Misc
*marker_free_list
;
3296 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3299 allocate_misc (enum Lisp_Misc_Type type
)
3305 if (marker_free_list
)
3307 XSETMISC (val
, marker_free_list
);
3308 marker_free_list
= marker_free_list
->u_free
.chain
;
3312 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3314 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3315 new->next
= marker_block
;
3317 marker_block_index
= 0;
3318 total_free_markers
+= MARKER_BLOCK_SIZE
;
3320 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3321 marker_block_index
++;
3324 MALLOC_UNBLOCK_INPUT
;
3326 --total_free_markers
;
3327 consing_since_gc
+= sizeof (union Lisp_Misc
);
3328 misc_objects_consed
++;
3329 XMISCTYPE (val
) = type
;
3330 XMISCANY (val
)->gcmarkbit
= 0;
3334 /* Free a Lisp_Misc object */
3337 free_misc (Lisp_Object misc
)
3339 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3340 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3341 marker_free_list
= XMISC (misc
);
3342 consing_since_gc
-= sizeof (union Lisp_Misc
);
3343 total_free_markers
++;
3346 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3347 INTEGER. This is used to package C values to call record_unwind_protect.
3348 The unwind function can get the C values back using XSAVE_VALUE. */
3351 make_save_value (void *pointer
, ptrdiff_t integer
)
3353 register Lisp_Object val
;
3354 register struct Lisp_Save_Value
*p
;
3356 val
= allocate_misc (Lisp_Misc_Save_Value
);
3357 p
= XSAVE_VALUE (val
);
3358 p
->pointer
= pointer
;
3359 p
->integer
= integer
;
3364 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3367 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3369 register Lisp_Object overlay
;
3371 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3372 OVERLAY_START (overlay
) = start
;
3373 OVERLAY_END (overlay
) = end
;
3374 set_overlay_plist (overlay
, plist
);
3375 XOVERLAY (overlay
)->next
= NULL
;
3379 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3380 doc
: /* Return a newly allocated marker which does not point at any place. */)
3383 register Lisp_Object val
;
3384 register struct Lisp_Marker
*p
;
3386 val
= allocate_misc (Lisp_Misc_Marker
);
3392 p
->insertion_type
= 0;
3396 /* Return a newly allocated marker which points into BUF
3397 at character position CHARPOS and byte position BYTEPOS. */
3400 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3403 struct Lisp_Marker
*m
;
3405 /* No dead buffers here. */
3406 eassert (BUFFER_LIVE_P (buf
));
3408 /* Every character is at least one byte. */
3409 eassert (charpos
<= bytepos
);
3411 obj
= allocate_misc (Lisp_Misc_Marker
);
3414 m
->charpos
= charpos
;
3415 m
->bytepos
= bytepos
;
3416 m
->insertion_type
= 0;
3417 m
->next
= BUF_MARKERS (buf
);
3418 BUF_MARKERS (buf
) = m
;
3422 /* Put MARKER back on the free list after using it temporarily. */
3425 free_marker (Lisp_Object marker
)
3427 unchain_marker (XMARKER (marker
));
3432 /* Return a newly created vector or string with specified arguments as
3433 elements. If all the arguments are characters that can fit
3434 in a string of events, make a string; otherwise, make a vector.
3436 Any number of arguments, even zero arguments, are allowed. */
3439 make_event_array (register int nargs
, Lisp_Object
*args
)
3443 for (i
= 0; i
< nargs
; i
++)
3444 /* The things that fit in a string
3445 are characters that are in 0...127,
3446 after discarding the meta bit and all the bits above it. */
3447 if (!INTEGERP (args
[i
])
3448 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3449 return Fvector (nargs
, args
);
3451 /* Since the loop exited, we know that all the things in it are
3452 characters, so we can make a string. */
3456 result
= Fmake_string (make_number (nargs
), make_number (0));
3457 for (i
= 0; i
< nargs
; i
++)
3459 SSET (result
, i
, XINT (args
[i
]));
3460 /* Move the meta bit to the right place for a string char. */
3461 if (XINT (args
[i
]) & CHAR_META
)
3462 SSET (result
, i
, SREF (result
, i
) | 0x80);
3471 /************************************************************************
3472 Memory Full Handling
3473 ************************************************************************/
3476 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3477 there may have been size_t overflow so that malloc was never
3478 called, or perhaps malloc was invoked successfully but the
3479 resulting pointer had problems fitting into a tagged EMACS_INT. In
3480 either case this counts as memory being full even though malloc did
3484 memory_full (size_t nbytes
)
3486 /* Do not go into hysterics merely because a large request failed. */
3487 bool enough_free_memory
= 0;
3488 if (SPARE_MEMORY
< nbytes
)
3493 p
= malloc (SPARE_MEMORY
);
3497 enough_free_memory
= 1;
3499 MALLOC_UNBLOCK_INPUT
;
3502 if (! enough_free_memory
)
3508 memory_full_cons_threshold
= sizeof (struct cons_block
);
3510 /* The first time we get here, free the spare memory. */
3511 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3512 if (spare_memory
[i
])
3515 free (spare_memory
[i
]);
3516 else if (i
>= 1 && i
<= 4)
3517 lisp_align_free (spare_memory
[i
]);
3519 lisp_free (spare_memory
[i
]);
3520 spare_memory
[i
] = 0;
3524 /* This used to call error, but if we've run out of memory, we could
3525 get infinite recursion trying to build the string. */
3526 xsignal (Qnil
, Vmemory_signal_data
);
3529 /* If we released our reserve (due to running out of memory),
3530 and we have a fair amount free once again,
3531 try to set aside another reserve in case we run out once more.
3533 This is called when a relocatable block is freed in ralloc.c,
3534 and also directly from this file, in case we're not using ralloc.c. */
3537 refill_memory_reserve (void)
3539 #ifndef SYSTEM_MALLOC
3540 if (spare_memory
[0] == 0)
3541 spare_memory
[0] = malloc (SPARE_MEMORY
);
3542 if (spare_memory
[1] == 0)
3543 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3545 if (spare_memory
[2] == 0)
3546 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3548 if (spare_memory
[3] == 0)
3549 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3551 if (spare_memory
[4] == 0)
3552 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3554 if (spare_memory
[5] == 0)
3555 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3557 if (spare_memory
[6] == 0)
3558 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3560 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3561 Vmemory_full
= Qnil
;
3565 /************************************************************************
3567 ************************************************************************/
3569 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3571 /* Conservative C stack marking requires a method to identify possibly
3572 live Lisp objects given a pointer value. We do this by keeping
3573 track of blocks of Lisp data that are allocated in a red-black tree
3574 (see also the comment of mem_node which is the type of nodes in
3575 that tree). Function lisp_malloc adds information for an allocated
3576 block to the red-black tree with calls to mem_insert, and function
3577 lisp_free removes it with mem_delete. Functions live_string_p etc
3578 call mem_find to lookup information about a given pointer in the
3579 tree, and use that to determine if the pointer points to a Lisp
3582 /* Initialize this part of alloc.c. */
3587 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3588 mem_z
.parent
= NULL
;
3589 mem_z
.color
= MEM_BLACK
;
3590 mem_z
.start
= mem_z
.end
= NULL
;
3595 /* Value is a pointer to the mem_node containing START. Value is
3596 MEM_NIL if there is no node in the tree containing START. */
3598 static struct mem_node
*
3599 mem_find (void *start
)
3603 if (start
< min_heap_address
|| start
> max_heap_address
)
3606 /* Make the search always successful to speed up the loop below. */
3607 mem_z
.start
= start
;
3608 mem_z
.end
= (char *) start
+ 1;
3611 while (start
< p
->start
|| start
>= p
->end
)
3612 p
= start
< p
->start
? p
->left
: p
->right
;
3617 /* Insert a new node into the tree for a block of memory with start
3618 address START, end address END, and type TYPE. Value is a
3619 pointer to the node that was inserted. */
3621 static struct mem_node
*
3622 mem_insert (void *start
, void *end
, enum mem_type type
)
3624 struct mem_node
*c
, *parent
, *x
;
3626 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3627 min_heap_address
= start
;
3628 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3629 max_heap_address
= end
;
3631 /* See where in the tree a node for START belongs. In this
3632 particular application, it shouldn't happen that a node is already
3633 present. For debugging purposes, let's check that. */
3637 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3639 while (c
!= MEM_NIL
)
3641 if (start
>= c
->start
&& start
< c
->end
)
3644 c
= start
< c
->start
? c
->left
: c
->right
;
3647 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3649 while (c
!= MEM_NIL
)
3652 c
= start
< c
->start
? c
->left
: c
->right
;
3655 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3657 /* Create a new node. */
3658 #ifdef GC_MALLOC_CHECK
3659 x
= malloc (sizeof *x
);
3663 x
= xmalloc (sizeof *x
);
3669 x
->left
= x
->right
= MEM_NIL
;
3672 /* Insert it as child of PARENT or install it as root. */
3675 if (start
< parent
->start
)
3683 /* Re-establish red-black tree properties. */
3684 mem_insert_fixup (x
);
3690 /* Re-establish the red-black properties of the tree, and thereby
3691 balance the tree, after node X has been inserted; X is always red. */
3694 mem_insert_fixup (struct mem_node
*x
)
3696 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3698 /* X is red and its parent is red. This is a violation of
3699 red-black tree property #3. */
3701 if (x
->parent
== x
->parent
->parent
->left
)
3703 /* We're on the left side of our grandparent, and Y is our
3705 struct mem_node
*y
= x
->parent
->parent
->right
;
3707 if (y
->color
== MEM_RED
)
3709 /* Uncle and parent are red but should be black because
3710 X is red. Change the colors accordingly and proceed
3711 with the grandparent. */
3712 x
->parent
->color
= MEM_BLACK
;
3713 y
->color
= MEM_BLACK
;
3714 x
->parent
->parent
->color
= MEM_RED
;
3715 x
= x
->parent
->parent
;
3719 /* Parent and uncle have different colors; parent is
3720 red, uncle is black. */
3721 if (x
== x
->parent
->right
)
3724 mem_rotate_left (x
);
3727 x
->parent
->color
= MEM_BLACK
;
3728 x
->parent
->parent
->color
= MEM_RED
;
3729 mem_rotate_right (x
->parent
->parent
);
3734 /* This is the symmetrical case of above. */
3735 struct mem_node
*y
= x
->parent
->parent
->left
;
3737 if (y
->color
== MEM_RED
)
3739 x
->parent
->color
= MEM_BLACK
;
3740 y
->color
= MEM_BLACK
;
3741 x
->parent
->parent
->color
= MEM_RED
;
3742 x
= x
->parent
->parent
;
3746 if (x
== x
->parent
->left
)
3749 mem_rotate_right (x
);
3752 x
->parent
->color
= MEM_BLACK
;
3753 x
->parent
->parent
->color
= MEM_RED
;
3754 mem_rotate_left (x
->parent
->parent
);
3759 /* The root may have been changed to red due to the algorithm. Set
3760 it to black so that property #5 is satisfied. */
3761 mem_root
->color
= MEM_BLACK
;
3772 mem_rotate_left (struct mem_node
*x
)
3776 /* Turn y's left sub-tree into x's right sub-tree. */
3779 if (y
->left
!= MEM_NIL
)
3780 y
->left
->parent
= x
;
3782 /* Y's parent was x's parent. */
3784 y
->parent
= x
->parent
;
3786 /* Get the parent to point to y instead of x. */
3789 if (x
== x
->parent
->left
)
3790 x
->parent
->left
= y
;
3792 x
->parent
->right
= y
;
3797 /* Put x on y's left. */
3811 mem_rotate_right (struct mem_node
*x
)
3813 struct mem_node
*y
= x
->left
;
3816 if (y
->right
!= MEM_NIL
)
3817 y
->right
->parent
= x
;
3820 y
->parent
= x
->parent
;
3823 if (x
== x
->parent
->right
)
3824 x
->parent
->right
= y
;
3826 x
->parent
->left
= y
;
3837 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3840 mem_delete (struct mem_node
*z
)
3842 struct mem_node
*x
, *y
;
3844 if (!z
|| z
== MEM_NIL
)
3847 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3852 while (y
->left
!= MEM_NIL
)
3856 if (y
->left
!= MEM_NIL
)
3861 x
->parent
= y
->parent
;
3864 if (y
== y
->parent
->left
)
3865 y
->parent
->left
= x
;
3867 y
->parent
->right
= x
;
3874 z
->start
= y
->start
;
3879 if (y
->color
== MEM_BLACK
)
3880 mem_delete_fixup (x
);
3882 #ifdef GC_MALLOC_CHECK
3890 /* Re-establish the red-black properties of the tree, after a
3894 mem_delete_fixup (struct mem_node
*x
)
3896 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3898 if (x
== x
->parent
->left
)
3900 struct mem_node
*w
= x
->parent
->right
;
3902 if (w
->color
== MEM_RED
)
3904 w
->color
= MEM_BLACK
;
3905 x
->parent
->color
= MEM_RED
;
3906 mem_rotate_left (x
->parent
);
3907 w
= x
->parent
->right
;
3910 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3917 if (w
->right
->color
== MEM_BLACK
)
3919 w
->left
->color
= MEM_BLACK
;
3921 mem_rotate_right (w
);
3922 w
= x
->parent
->right
;
3924 w
->color
= x
->parent
->color
;
3925 x
->parent
->color
= MEM_BLACK
;
3926 w
->right
->color
= MEM_BLACK
;
3927 mem_rotate_left (x
->parent
);
3933 struct mem_node
*w
= x
->parent
->left
;
3935 if (w
->color
== MEM_RED
)
3937 w
->color
= MEM_BLACK
;
3938 x
->parent
->color
= MEM_RED
;
3939 mem_rotate_right (x
->parent
);
3940 w
= x
->parent
->left
;
3943 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3950 if (w
->left
->color
== MEM_BLACK
)
3952 w
->right
->color
= MEM_BLACK
;
3954 mem_rotate_left (w
);
3955 w
= x
->parent
->left
;
3958 w
->color
= x
->parent
->color
;
3959 x
->parent
->color
= MEM_BLACK
;
3960 w
->left
->color
= MEM_BLACK
;
3961 mem_rotate_right (x
->parent
);
3967 x
->color
= MEM_BLACK
;
3971 /* Value is non-zero if P is a pointer to a live Lisp string on
3972 the heap. M is a pointer to the mem_block for P. */
3975 live_string_p (struct mem_node
*m
, void *p
)
3977 if (m
->type
== MEM_TYPE_STRING
)
3979 struct string_block
*b
= (struct string_block
*) m
->start
;
3980 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3982 /* P must point to the start of a Lisp_String structure, and it
3983 must not be on the free-list. */
3985 && offset
% sizeof b
->strings
[0] == 0
3986 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3987 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3994 /* Value is non-zero if P is a pointer to a live Lisp cons on
3995 the heap. M is a pointer to the mem_block for P. */
3998 live_cons_p (struct mem_node
*m
, void *p
)
4000 if (m
->type
== MEM_TYPE_CONS
)
4002 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4003 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4005 /* P must point to the start of a Lisp_Cons, not be
4006 one of the unused cells in the current cons block,
4007 and not be on the free-list. */
4009 && offset
% sizeof b
->conses
[0] == 0
4010 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4012 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4013 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4020 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4021 the heap. M is a pointer to the mem_block for P. */
4024 live_symbol_p (struct mem_node
*m
, void *p
)
4026 if (m
->type
== MEM_TYPE_SYMBOL
)
4028 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4029 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4031 /* P must point to the start of a Lisp_Symbol, not be
4032 one of the unused cells in the current symbol block,
4033 and not be on the free-list. */
4035 && offset
% sizeof b
->symbols
[0] == 0
4036 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4037 && (b
!= symbol_block
4038 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4039 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4046 /* Value is non-zero if P is a pointer to a live Lisp float on
4047 the heap. M is a pointer to the mem_block for P. */
4050 live_float_p (struct mem_node
*m
, void *p
)
4052 if (m
->type
== MEM_TYPE_FLOAT
)
4054 struct float_block
*b
= (struct float_block
*) m
->start
;
4055 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4057 /* P must point to the start of a Lisp_Float and not be
4058 one of the unused cells in the current float block. */
4060 && offset
% sizeof b
->floats
[0] == 0
4061 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4062 && (b
!= float_block
4063 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4070 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4071 the heap. M is a pointer to the mem_block for P. */
4074 live_misc_p (struct mem_node
*m
, void *p
)
4076 if (m
->type
== MEM_TYPE_MISC
)
4078 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4079 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4081 /* P must point to the start of a Lisp_Misc, not be
4082 one of the unused cells in the current misc block,
4083 and not be on the free-list. */
4085 && offset
% sizeof b
->markers
[0] == 0
4086 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4087 && (b
!= marker_block
4088 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4089 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4096 /* Value is non-zero if P is a pointer to a live vector-like object.
4097 M is a pointer to the mem_block for P. */
4100 live_vector_p (struct mem_node
*m
, void *p
)
4102 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4104 /* This memory node corresponds to a vector block. */
4105 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4106 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4108 /* P is in the block's allocation range. Scan the block
4109 up to P and see whether P points to the start of some
4110 vector which is not on a free list. FIXME: check whether
4111 some allocation patterns (probably a lot of short vectors)
4112 may cause a substantial overhead of this loop. */
4113 while (VECTOR_IN_BLOCK (vector
, block
)
4114 && vector
<= (struct Lisp_Vector
*) p
)
4116 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4119 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4122 else if (m
->type
== MEM_TYPE_VECTORLIKE
4123 && (char *) p
== ((char *) m
->start
4124 + offsetof (struct large_vector
, v
)))
4125 /* This memory node corresponds to a large vector. */
4131 /* Value is non-zero if P is a pointer to a live buffer. M is a
4132 pointer to the mem_block for P. */
4135 live_buffer_p (struct mem_node
*m
, void *p
)
4137 /* P must point to the start of the block, and the buffer
4138 must not have been killed. */
4139 return (m
->type
== MEM_TYPE_BUFFER
4141 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4144 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4148 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4150 /* Array of objects that are kept alive because the C stack contains
4151 a pattern that looks like a reference to them . */
4153 #define MAX_ZOMBIES 10
4154 static Lisp_Object zombies
[MAX_ZOMBIES
];
4156 /* Number of zombie objects. */
4158 static EMACS_INT nzombies
;
4160 /* Number of garbage collections. */
4162 static EMACS_INT ngcs
;
4164 /* Average percentage of zombies per collection. */
4166 static double avg_zombies
;
4168 /* Max. number of live and zombie objects. */
4170 static EMACS_INT max_live
, max_zombies
;
4172 /* Average number of live objects per GC. */
4174 static double avg_live
;
4176 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4177 doc
: /* Show information about live and zombie objects. */)
4180 Lisp_Object args
[8], zombie_list
= Qnil
;
4182 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4183 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4184 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4185 args
[1] = make_number (ngcs
);
4186 args
[2] = make_float (avg_live
);
4187 args
[3] = make_float (avg_zombies
);
4188 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4189 args
[5] = make_number (max_live
);
4190 args
[6] = make_number (max_zombies
);
4191 args
[7] = zombie_list
;
4192 return Fmessage (8, args
);
4195 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4198 /* Mark OBJ if we can prove it's a Lisp_Object. */
4201 mark_maybe_object (Lisp_Object obj
)
4209 po
= (void *) XPNTR (obj
);
4216 switch (XTYPE (obj
))
4219 mark_p
= (live_string_p (m
, po
)
4220 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4224 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4228 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4232 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4235 case Lisp_Vectorlike
:
4236 /* Note: can't check BUFFERP before we know it's a
4237 buffer because checking that dereferences the pointer
4238 PO which might point anywhere. */
4239 if (live_vector_p (m
, po
))
4240 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4241 else if (live_buffer_p (m
, po
))
4242 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4246 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4255 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4256 if (nzombies
< MAX_ZOMBIES
)
4257 zombies
[nzombies
] = obj
;
4266 /* If P points to Lisp data, mark that as live if it isn't already
4270 mark_maybe_pointer (void *p
)
4274 /* Quickly rule out some values which can't point to Lisp data.
4275 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4276 Otherwise, assume that Lisp data is aligned on even addresses. */
4277 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4283 Lisp_Object obj
= Qnil
;
4287 case MEM_TYPE_NON_LISP
:
4288 case MEM_TYPE_SPARE
:
4289 /* Nothing to do; not a pointer to Lisp memory. */
4292 case MEM_TYPE_BUFFER
:
4293 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4294 XSETVECTOR (obj
, p
);
4298 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4302 case MEM_TYPE_STRING
:
4303 if (live_string_p (m
, p
)
4304 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4305 XSETSTRING (obj
, p
);
4309 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4313 case MEM_TYPE_SYMBOL
:
4314 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4315 XSETSYMBOL (obj
, p
);
4318 case MEM_TYPE_FLOAT
:
4319 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4323 case MEM_TYPE_VECTORLIKE
:
4324 case MEM_TYPE_VECTOR_BLOCK
:
4325 if (live_vector_p (m
, p
))
4328 XSETVECTOR (tem
, p
);
4329 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4344 /* Alignment of pointer values. Use alignof, as it sometimes returns
4345 a smaller alignment than GCC's __alignof__ and mark_memory might
4346 miss objects if __alignof__ were used. */
4347 #define GC_POINTER_ALIGNMENT alignof (void *)
4349 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4350 not suffice, which is the typical case. A host where a Lisp_Object is
4351 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4352 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4353 suffice to widen it to to a Lisp_Object and check it that way. */
4354 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4355 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4356 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4357 nor mark_maybe_object can follow the pointers. This should not occur on
4358 any practical porting target. */
4359 # error "MSB type bits straddle pointer-word boundaries"
4361 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4362 pointer words that hold pointers ORed with type bits. */
4363 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4365 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4366 words that hold unmodified pointers. */
4367 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4370 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4371 or END+OFFSET..START. */
4374 mark_memory (void *start
, void *end
)
4375 #if defined (__clang__) && defined (__has_feature)
4376 #if __has_feature(address_sanitizer)
4377 /* Do not allow -faddress-sanitizer to check this function, since it
4378 crosses the function stack boundary, and thus would yield many
4380 __attribute__((no_address_safety_analysis
))
4387 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4391 /* Make START the pointer to the start of the memory region,
4392 if it isn't already. */
4400 /* Mark Lisp data pointed to. This is necessary because, in some
4401 situations, the C compiler optimizes Lisp objects away, so that
4402 only a pointer to them remains. Example:
4404 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4407 Lisp_Object obj = build_string ("test");
4408 struct Lisp_String *s = XSTRING (obj);
4409 Fgarbage_collect ();
4410 fprintf (stderr, "test `%s'\n", s->data);
4414 Here, `obj' isn't really used, and the compiler optimizes it
4415 away. The only reference to the life string is through the
4418 for (pp
= start
; (void *) pp
< end
; pp
++)
4419 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4421 void *p
= *(void **) ((char *) pp
+ i
);
4422 mark_maybe_pointer (p
);
4423 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4424 mark_maybe_object (XIL ((intptr_t) p
));
4428 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4429 the GCC system configuration. In gcc 3.2, the only systems for
4430 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4431 by others?) and ns32k-pc532-min. */
4433 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4435 static bool setjmp_tested_p
;
4436 static int longjmps_done
;
4438 #define SETJMP_WILL_LIKELY_WORK "\
4440 Emacs garbage collector has been changed to use conservative stack\n\
4441 marking. Emacs has determined that the method it uses to do the\n\
4442 marking will likely work on your system, but this isn't sure.\n\
4444 If you are a system-programmer, or can get the help of a local wizard\n\
4445 who is, please take a look at the function mark_stack in alloc.c, and\n\
4446 verify that the methods used are appropriate for your system.\n\
4448 Please mail the result to <emacs-devel@gnu.org>.\n\
4451 #define SETJMP_WILL_NOT_WORK "\
4453 Emacs garbage collector has been changed to use conservative stack\n\
4454 marking. Emacs has determined that the default method it uses to do the\n\
4455 marking will not work on your system. We will need a system-dependent\n\
4456 solution for your system.\n\
4458 Please take a look at the function mark_stack in alloc.c, and\n\
4459 try to find a way to make it work on your system.\n\
4461 Note that you may get false negatives, depending on the compiler.\n\
4462 In particular, you need to use -O with GCC for this test.\n\
4464 Please mail the result to <emacs-devel@gnu.org>.\n\
4468 /* Perform a quick check if it looks like setjmp saves registers in a
4469 jmp_buf. Print a message to stderr saying so. When this test
4470 succeeds, this is _not_ a proof that setjmp is sufficient for
4471 conservative stack marking. Only the sources or a disassembly
4481 /* Arrange for X to be put in a register. */
4487 if (longjmps_done
== 1)
4489 /* Came here after the longjmp at the end of the function.
4491 If x == 1, the longjmp has restored the register to its
4492 value before the setjmp, and we can hope that setjmp
4493 saves all such registers in the jmp_buf, although that
4496 For other values of X, either something really strange is
4497 taking place, or the setjmp just didn't save the register. */
4500 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4503 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4510 if (longjmps_done
== 1)
4511 sys_longjmp (jbuf
, 1);
4514 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4517 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4519 /* Abort if anything GCPRO'd doesn't survive the GC. */
4527 for (p
= gcprolist
; p
; p
= p
->next
)
4528 for (i
= 0; i
< p
->nvars
; ++i
)
4529 if (!survives_gc_p (p
->var
[i
]))
4530 /* FIXME: It's not necessarily a bug. It might just be that the
4531 GCPRO is unnecessary or should release the object sooner. */
4535 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4542 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4543 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4545 fprintf (stderr
, " %d = ", i
);
4546 debug_print (zombies
[i
]);
4550 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4553 /* Mark live Lisp objects on the C stack.
4555 There are several system-dependent problems to consider when
4556 porting this to new architectures:
4560 We have to mark Lisp objects in CPU registers that can hold local
4561 variables or are used to pass parameters.
4563 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4564 something that either saves relevant registers on the stack, or
4565 calls mark_maybe_object passing it each register's contents.
4567 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4568 implementation assumes that calling setjmp saves registers we need
4569 to see in a jmp_buf which itself lies on the stack. This doesn't
4570 have to be true! It must be verified for each system, possibly
4571 by taking a look at the source code of setjmp.
4573 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4574 can use it as a machine independent method to store all registers
4575 to the stack. In this case the macros described in the previous
4576 two paragraphs are not used.
4580 Architectures differ in the way their processor stack is organized.
4581 For example, the stack might look like this
4584 | Lisp_Object | size = 4
4586 | something else | size = 2
4588 | Lisp_Object | size = 4
4592 In such a case, not every Lisp_Object will be aligned equally. To
4593 find all Lisp_Object on the stack it won't be sufficient to walk
4594 the stack in steps of 4 bytes. Instead, two passes will be
4595 necessary, one starting at the start of the stack, and a second
4596 pass starting at the start of the stack + 2. Likewise, if the
4597 minimal alignment of Lisp_Objects on the stack is 1, four passes
4598 would be necessary, each one starting with one byte more offset
4599 from the stack start. */
4606 #ifdef HAVE___BUILTIN_UNWIND_INIT
4607 /* Force callee-saved registers and register windows onto the stack.
4608 This is the preferred method if available, obviating the need for
4609 machine dependent methods. */
4610 __builtin_unwind_init ();
4612 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4613 #ifndef GC_SAVE_REGISTERS_ON_STACK
4614 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4615 union aligned_jmpbuf
{
4619 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4621 /* This trick flushes the register windows so that all the state of
4622 the process is contained in the stack. */
4623 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4624 needed on ia64 too. See mach_dep.c, where it also says inline
4625 assembler doesn't work with relevant proprietary compilers. */
4627 #if defined (__sparc64__) && defined (__FreeBSD__)
4628 /* FreeBSD does not have a ta 3 handler. */
4635 /* Save registers that we need to see on the stack. We need to see
4636 registers used to hold register variables and registers used to
4638 #ifdef GC_SAVE_REGISTERS_ON_STACK
4639 GC_SAVE_REGISTERS_ON_STACK (end
);
4640 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4642 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4643 setjmp will definitely work, test it
4644 and print a message with the result
4646 if (!setjmp_tested_p
)
4648 setjmp_tested_p
= 1;
4651 #endif /* GC_SETJMP_WORKS */
4654 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4655 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4656 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4658 /* This assumes that the stack is a contiguous region in memory. If
4659 that's not the case, something has to be done here to iterate
4660 over the stack segments. */
4661 mark_memory (stack_base
, end
);
4663 /* Allow for marking a secondary stack, like the register stack on the
4665 #ifdef GC_MARK_SECONDARY_STACK
4666 GC_MARK_SECONDARY_STACK ();
4669 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4674 #endif /* GC_MARK_STACK != 0 */
4677 /* Determine whether it is safe to access memory at address P. */
4679 valid_pointer_p (void *p
)
4682 return w32_valid_pointer_p (p
, 16);
4686 /* Obviously, we cannot just access it (we would SEGV trying), so we
4687 trick the o/s to tell us whether p is a valid pointer.
4688 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4689 not validate p in that case. */
4693 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4694 emacs_close (fd
[1]);
4695 emacs_close (fd
[0]);
4703 /* Return 2 if OBJ is a killed or special buffer object.
4704 Return 1 if OBJ is a valid lisp object.
4705 Return 0 if OBJ is NOT a valid lisp object.
4706 Return -1 if we cannot validate OBJ.
4707 This function can be quite slow,
4708 so it should only be used in code for manual debugging. */
4711 valid_lisp_object_p (Lisp_Object obj
)
4721 p
= (void *) XPNTR (obj
);
4722 if (PURE_POINTER_P (p
))
4725 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4729 return valid_pointer_p (p
);
4736 int valid
= valid_pointer_p (p
);
4748 case MEM_TYPE_NON_LISP
:
4749 case MEM_TYPE_SPARE
:
4752 case MEM_TYPE_BUFFER
:
4753 return live_buffer_p (m
, p
) ? 1 : 2;
4756 return live_cons_p (m
, p
);
4758 case MEM_TYPE_STRING
:
4759 return live_string_p (m
, p
);
4762 return live_misc_p (m
, p
);
4764 case MEM_TYPE_SYMBOL
:
4765 return live_symbol_p (m
, p
);
4767 case MEM_TYPE_FLOAT
:
4768 return live_float_p (m
, p
);
4770 case MEM_TYPE_VECTORLIKE
:
4771 case MEM_TYPE_VECTOR_BLOCK
:
4772 return live_vector_p (m
, p
);
4785 /***********************************************************************
4786 Pure Storage Management
4787 ***********************************************************************/
4789 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4790 pointer to it. TYPE is the Lisp type for which the memory is
4791 allocated. TYPE < 0 means it's not used for a Lisp object. */
4794 pure_alloc (size_t size
, int type
)
4798 size_t alignment
= GCALIGNMENT
;
4800 size_t alignment
= alignof (EMACS_INT
);
4802 /* Give Lisp_Floats an extra alignment. */
4803 if (type
== Lisp_Float
)
4804 alignment
= alignof (struct Lisp_Float
);
4810 /* Allocate space for a Lisp object from the beginning of the free
4811 space with taking account of alignment. */
4812 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4813 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4817 /* Allocate space for a non-Lisp object from the end of the free
4819 pure_bytes_used_non_lisp
+= size
;
4820 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4822 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4824 if (pure_bytes_used
<= pure_size
)
4827 /* Don't allocate a large amount here,
4828 because it might get mmap'd and then its address
4829 might not be usable. */
4830 purebeg
= xmalloc (10000);
4832 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4833 pure_bytes_used
= 0;
4834 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4839 /* Print a warning if PURESIZE is too small. */
4842 check_pure_size (void)
4844 if (pure_bytes_used_before_overflow
)
4845 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4847 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4851 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4852 the non-Lisp data pool of the pure storage, and return its start
4853 address. Return NULL if not found. */
4856 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4859 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4860 const unsigned char *p
;
4863 if (pure_bytes_used_non_lisp
<= nbytes
)
4866 /* Set up the Boyer-Moore table. */
4868 for (i
= 0; i
< 256; i
++)
4871 p
= (const unsigned char *) data
;
4873 bm_skip
[*p
++] = skip
;
4875 last_char_skip
= bm_skip
['\0'];
4877 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4878 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4880 /* See the comments in the function `boyer_moore' (search.c) for the
4881 use of `infinity'. */
4882 infinity
= pure_bytes_used_non_lisp
+ 1;
4883 bm_skip
['\0'] = infinity
;
4885 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4889 /* Check the last character (== '\0'). */
4892 start
+= bm_skip
[*(p
+ start
)];
4894 while (start
<= start_max
);
4896 if (start
< infinity
)
4897 /* Couldn't find the last character. */
4900 /* No less than `infinity' means we could find the last
4901 character at `p[start - infinity]'. */
4904 /* Check the remaining characters. */
4905 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4907 return non_lisp_beg
+ start
;
4909 start
+= last_char_skip
;
4911 while (start
<= start_max
);
4917 /* Return a string allocated in pure space. DATA is a buffer holding
4918 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4919 means make the result string multibyte.
4921 Must get an error if pure storage is full, since if it cannot hold
4922 a large string it may be able to hold conses that point to that
4923 string; then the string is not protected from gc. */
4926 make_pure_string (const char *data
,
4927 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
4930 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4931 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4932 if (s
->data
== NULL
)
4934 s
->data
= pure_alloc (nbytes
+ 1, -1);
4935 memcpy (s
->data
, data
, nbytes
);
4936 s
->data
[nbytes
] = '\0';
4939 s
->size_byte
= multibyte
? nbytes
: -1;
4940 s
->intervals
= NULL
;
4941 XSETSTRING (string
, s
);
4945 /* Return a string allocated in pure space. Do not
4946 allocate the string data, just point to DATA. */
4949 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
4952 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4955 s
->data
= (unsigned char *) data
;
4956 s
->intervals
= NULL
;
4957 XSETSTRING (string
, s
);
4961 /* Return a cons allocated from pure space. Give it pure copies
4962 of CAR as car and CDR as cdr. */
4965 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4968 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
4970 XSETCAR (new, Fpurecopy (car
));
4971 XSETCDR (new, Fpurecopy (cdr
));
4976 /* Value is a float object with value NUM allocated from pure space. */
4979 make_pure_float (double num
)
4982 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
4984 XFLOAT_INIT (new, num
);
4989 /* Return a vector with room for LEN Lisp_Objects allocated from
4993 make_pure_vector (ptrdiff_t len
)
4996 size_t size
= header_size
+ len
* word_size
;
4997 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
4998 XSETVECTOR (new, p
);
4999 XVECTOR (new)->header
.size
= len
;
5004 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5005 doc
: /* Make a copy of object OBJ in pure storage.
5006 Recursively copies contents of vectors and cons cells.
5007 Does not copy symbols. Copies strings without text properties. */)
5008 (register Lisp_Object obj
)
5010 if (NILP (Vpurify_flag
))
5013 if (PURE_POINTER_P (XPNTR (obj
)))
5016 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5018 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5024 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5025 else if (FLOATP (obj
))
5026 obj
= make_pure_float (XFLOAT_DATA (obj
));
5027 else if (STRINGP (obj
))
5028 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5030 STRING_MULTIBYTE (obj
));
5031 else if (COMPILEDP (obj
) || VECTORP (obj
))
5033 register struct Lisp_Vector
*vec
;
5034 register ptrdiff_t i
;
5038 if (size
& PSEUDOVECTOR_FLAG
)
5039 size
&= PSEUDOVECTOR_SIZE_MASK
;
5040 vec
= XVECTOR (make_pure_vector (size
));
5041 for (i
= 0; i
< size
; i
++)
5042 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5043 if (COMPILEDP (obj
))
5045 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5046 XSETCOMPILED (obj
, vec
);
5049 XSETVECTOR (obj
, vec
);
5051 else if (MARKERP (obj
))
5052 error ("Attempt to copy a marker to pure storage");
5054 /* Not purified, don't hash-cons. */
5057 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5058 Fputhash (obj
, obj
, Vpurify_flag
);
5065 /***********************************************************************
5067 ***********************************************************************/
5069 /* Put an entry in staticvec, pointing at the variable with address
5073 staticpro (Lisp_Object
*varaddress
)
5075 staticvec
[staticidx
++] = varaddress
;
5076 if (staticidx
>= NSTATICS
)
5077 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5081 /***********************************************************************
5083 ***********************************************************************/
5085 /* Temporarily prevent garbage collection. */
5088 inhibit_garbage_collection (void)
5090 ptrdiff_t count
= SPECPDL_INDEX ();
5092 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5096 /* Used to avoid possible overflows when
5097 converting from C to Lisp integers. */
5100 bounded_number (EMACS_INT number
)
5102 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5105 /* Calculate total bytes of live objects. */
5108 total_bytes_of_live_objects (void)
5111 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5112 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5113 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5114 tot
+= total_string_bytes
;
5115 tot
+= total_vector_slots
* word_size
;
5116 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5117 tot
+= total_intervals
* sizeof (struct interval
);
5118 tot
+= total_strings
* sizeof (struct Lisp_String
);
5122 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5123 doc
: /* Reclaim storage for Lisp objects no longer needed.
5124 Garbage collection happens automatically if you cons more than
5125 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5126 `garbage-collect' normally returns a list with info on amount of space in use,
5127 where each entry has the form (NAME SIZE USED FREE), where:
5128 - NAME is a symbol describing the kind of objects this entry represents,
5129 - SIZE is the number of bytes used by each one,
5130 - USED is the number of those objects that were found live in the heap,
5131 - FREE is the number of those objects that are not live but that Emacs
5132 keeps around for future allocations (maybe because it does not know how
5133 to return them to the OS).
5134 However, if there was overflow in pure space, `garbage-collect'
5135 returns nil, because real GC can't be done.
5136 See Info node `(elisp)Garbage Collection'. */)
5139 struct specbinding
*bind
;
5140 struct buffer
*nextb
;
5141 char stack_top_variable
;
5144 ptrdiff_t count
= SPECPDL_INDEX ();
5146 Lisp_Object retval
= Qnil
;
5147 size_t tot_before
= 0;
5148 struct backtrace backtrace
;
5153 /* Can't GC if pure storage overflowed because we can't determine
5154 if something is a pure object or not. */
5155 if (pure_bytes_used_before_overflow
)
5158 /* Record this function, so it appears on the profiler's backtraces. */
5159 backtrace
.next
= backtrace_list
;
5160 backtrace
.function
= Qautomatic_gc
;
5161 backtrace
.args
= &Qnil
;
5162 backtrace
.nargs
= 0;
5163 backtrace
.debug_on_exit
= 0;
5164 backtrace_list
= &backtrace
;
5168 /* Don't keep undo information around forever.
5169 Do this early on, so it is no problem if the user quits. */
5170 FOR_EACH_BUFFER (nextb
)
5171 compact_buffer (nextb
);
5173 if (profiler_memory_running
)
5174 tot_before
= total_bytes_of_live_objects ();
5176 start
= current_emacs_time ();
5178 /* In case user calls debug_print during GC,
5179 don't let that cause a recursive GC. */
5180 consing_since_gc
= 0;
5182 /* Save what's currently displayed in the echo area. */
5183 message_p
= push_message ();
5184 record_unwind_protect (pop_message_unwind
, Qnil
);
5186 /* Save a copy of the contents of the stack, for debugging. */
5187 #if MAX_SAVE_STACK > 0
5188 if (NILP (Vpurify_flag
))
5191 ptrdiff_t stack_size
;
5192 if (&stack_top_variable
< stack_bottom
)
5194 stack
= &stack_top_variable
;
5195 stack_size
= stack_bottom
- &stack_top_variable
;
5199 stack
= stack_bottom
;
5200 stack_size
= &stack_top_variable
- stack_bottom
;
5202 if (stack_size
<= MAX_SAVE_STACK
)
5204 if (stack_copy_size
< stack_size
)
5206 stack_copy
= xrealloc (stack_copy
, stack_size
);
5207 stack_copy_size
= stack_size
;
5209 memcpy (stack_copy
, stack
, stack_size
);
5212 #endif /* MAX_SAVE_STACK > 0 */
5214 if (garbage_collection_messages
)
5215 message1_nolog ("Garbage collecting...");
5219 shrink_regexp_cache ();
5223 /* Mark all the special slots that serve as the roots of accessibility. */
5225 mark_buffer (&buffer_defaults
);
5226 mark_buffer (&buffer_local_symbols
);
5228 for (i
= 0; i
< staticidx
; i
++)
5229 mark_object (*staticvec
[i
]);
5231 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5233 mark_object (bind
->symbol
);
5234 mark_object (bind
->old_value
);
5243 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5244 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5248 register struct gcpro
*tail
;
5249 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5250 for (i
= 0; i
< tail
->nvars
; i
++)
5251 mark_object (tail
->var
[i
]);
5255 struct catchtag
*catch;
5256 struct handler
*handler
;
5258 for (catch = catchlist
; catch; catch = catch->next
)
5260 mark_object (catch->tag
);
5261 mark_object (catch->val
);
5263 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5265 mark_object (handler
->handler
);
5266 mark_object (handler
->var
);
5272 #ifdef HAVE_WINDOW_SYSTEM
5273 mark_fringe_data ();
5276 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5280 /* Everything is now marked, except for the things that require special
5281 finalization, i.e. the undo_list.
5282 Look thru every buffer's undo list
5283 for elements that update markers that were not marked,
5285 FOR_EACH_BUFFER (nextb
)
5287 /* If a buffer's undo list is Qt, that means that undo is
5288 turned off in that buffer. Calling truncate_undo_list on
5289 Qt tends to return NULL, which effectively turns undo back on.
5290 So don't call truncate_undo_list if undo_list is Qt. */
5291 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5293 Lisp_Object tail
, prev
;
5294 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5296 while (CONSP (tail
))
5298 if (CONSP (XCAR (tail
))
5299 && MARKERP (XCAR (XCAR (tail
)))
5300 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5303 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5307 XSETCDR (prev
, tail
);
5317 /* Now that we have stripped the elements that need not be in the
5318 undo_list any more, we can finally mark the list. */
5319 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5324 /* Clear the mark bits that we set in certain root slots. */
5326 unmark_byte_stack ();
5327 VECTOR_UNMARK (&buffer_defaults
);
5328 VECTOR_UNMARK (&buffer_local_symbols
);
5330 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5340 consing_since_gc
= 0;
5341 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5342 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5344 gc_relative_threshold
= 0;
5345 if (FLOATP (Vgc_cons_percentage
))
5346 { /* Set gc_cons_combined_threshold. */
5347 double tot
= total_bytes_of_live_objects ();
5349 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5352 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5353 gc_relative_threshold
= tot
;
5355 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5359 if (garbage_collection_messages
)
5361 if (message_p
|| minibuf_level
> 0)
5364 message1_nolog ("Garbage collecting...done");
5367 unbind_to (count
, Qnil
);
5369 Lisp_Object total
[11];
5370 int total_size
= 10;
5372 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5373 bounded_number (total_conses
),
5374 bounded_number (total_free_conses
));
5376 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5377 bounded_number (total_symbols
),
5378 bounded_number (total_free_symbols
));
5380 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5381 bounded_number (total_markers
),
5382 bounded_number (total_free_markers
));
5384 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5385 bounded_number (total_strings
),
5386 bounded_number (total_free_strings
));
5388 total
[4] = list3 (Qstring_bytes
, make_number (1),
5389 bounded_number (total_string_bytes
));
5391 total
[5] = list3 (Qvectors
, make_number (sizeof (struct Lisp_Vector
)),
5392 bounded_number (total_vectors
));
5394 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5395 bounded_number (total_vector_slots
),
5396 bounded_number (total_free_vector_slots
));
5398 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5399 bounded_number (total_floats
),
5400 bounded_number (total_free_floats
));
5402 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5403 bounded_number (total_intervals
),
5404 bounded_number (total_free_intervals
));
5406 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5407 bounded_number (total_buffers
));
5409 #ifdef DOUG_LEA_MALLOC
5411 total
[10] = list4 (Qheap
, make_number (1024),
5412 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5413 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5415 retval
= Flist (total_size
, total
);
5418 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5420 /* Compute average percentage of zombies. */
5422 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5423 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5425 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5426 max_live
= max (nlive
, max_live
);
5427 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5428 max_zombies
= max (nzombies
, max_zombies
);
5433 if (!NILP (Vpost_gc_hook
))
5435 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5436 safe_run_hooks (Qpost_gc_hook
);
5437 unbind_to (gc_count
, Qnil
);
5440 /* Accumulate statistics. */
5441 if (FLOATP (Vgc_elapsed
))
5443 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5444 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5445 + EMACS_TIME_TO_DOUBLE (since_start
));
5450 /* Collect profiling data. */
5451 if (profiler_memory_running
)
5454 size_t tot_after
= total_bytes_of_live_objects ();
5455 if (tot_before
> tot_after
)
5456 swept
= tot_before
- tot_after
;
5457 malloc_probe (swept
);
5460 backtrace_list
= backtrace
.next
;
5465 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5466 only interesting objects referenced from glyphs are strings. */
5469 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5471 struct glyph_row
*row
= matrix
->rows
;
5472 struct glyph_row
*end
= row
+ matrix
->nrows
;
5474 for (; row
< end
; ++row
)
5478 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5480 struct glyph
*glyph
= row
->glyphs
[area
];
5481 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5483 for (; glyph
< end_glyph
; ++glyph
)
5484 if (STRINGP (glyph
->object
)
5485 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5486 mark_object (glyph
->object
);
5492 /* Mark Lisp faces in the face cache C. */
5495 mark_face_cache (struct face_cache
*c
)
5500 for (i
= 0; i
< c
->used
; ++i
)
5502 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5506 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5507 mark_object (face
->lface
[j
]);
5515 /* Mark reference to a Lisp_Object.
5516 If the object referred to has not been seen yet, recursively mark
5517 all the references contained in it. */
5519 #define LAST_MARKED_SIZE 500
5520 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5521 static int last_marked_index
;
5523 /* For debugging--call abort when we cdr down this many
5524 links of a list, in mark_object. In debugging,
5525 the call to abort will hit a breakpoint.
5526 Normally this is zero and the check never goes off. */
5527 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5530 mark_vectorlike (struct Lisp_Vector
*ptr
)
5532 ptrdiff_t size
= ptr
->header
.size
;
5535 eassert (!VECTOR_MARKED_P (ptr
));
5536 VECTOR_MARK (ptr
); /* Else mark it. */
5537 if (size
& PSEUDOVECTOR_FLAG
)
5538 size
&= PSEUDOVECTOR_SIZE_MASK
;
5540 /* Note that this size is not the memory-footprint size, but only
5541 the number of Lisp_Object fields that we should trace.
5542 The distinction is used e.g. by Lisp_Process which places extra
5543 non-Lisp_Object fields at the end of the structure... */
5544 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5545 mark_object (ptr
->contents
[i
]);
5548 /* Like mark_vectorlike but optimized for char-tables (and
5549 sub-char-tables) assuming that the contents are mostly integers or
5553 mark_char_table (struct Lisp_Vector
*ptr
)
5555 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5558 eassert (!VECTOR_MARKED_P (ptr
));
5560 for (i
= 0; i
< size
; i
++)
5562 Lisp_Object val
= ptr
->contents
[i
];
5564 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5566 if (SUB_CHAR_TABLE_P (val
))
5568 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5569 mark_char_table (XVECTOR (val
));
5576 /* Mark the chain of overlays starting at PTR. */
5579 mark_overlay (struct Lisp_Overlay
*ptr
)
5581 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5584 mark_object (ptr
->start
);
5585 mark_object (ptr
->end
);
5586 mark_object (ptr
->plist
);
5590 /* Mark Lisp_Objects and special pointers in BUFFER. */
5593 mark_buffer (struct buffer
*buffer
)
5595 /* This is handled much like other pseudovectors... */
5596 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5598 /* ...but there are some buffer-specific things. */
5600 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5602 /* For now, we just don't mark the undo_list. It's done later in
5603 a special way just before the sweep phase, and after stripping
5604 some of its elements that are not needed any more. */
5606 mark_overlay (buffer
->overlays_before
);
5607 mark_overlay (buffer
->overlays_after
);
5609 /* If this is an indirect buffer, mark its base buffer. */
5610 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5611 mark_buffer (buffer
->base_buffer
);
5614 /* Remove killed buffers or items whose car is a killed buffer from
5615 LIST, and mark other items. Return changed LIST, which is marked. */
5618 mark_discard_killed_buffers (Lisp_Object list
)
5620 Lisp_Object tail
, *prev
= &list
;
5622 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5625 Lisp_Object tem
= XCAR (tail
);
5628 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5629 *prev
= XCDR (tail
);
5632 CONS_MARK (XCONS (tail
));
5633 mark_object (XCAR (tail
));
5634 prev
= &XCDR_AS_LVALUE (tail
);
5641 /* Determine type of generic Lisp_Object and mark it accordingly. */
5644 mark_object (Lisp_Object arg
)
5646 register Lisp_Object obj
= arg
;
5647 #ifdef GC_CHECK_MARKED_OBJECTS
5651 ptrdiff_t cdr_count
= 0;
5655 if (PURE_POINTER_P (XPNTR (obj
)))
5658 last_marked
[last_marked_index
++] = obj
;
5659 if (last_marked_index
== LAST_MARKED_SIZE
)
5660 last_marked_index
= 0;
5662 /* Perform some sanity checks on the objects marked here. Abort if
5663 we encounter an object we know is bogus. This increases GC time
5664 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5665 #ifdef GC_CHECK_MARKED_OBJECTS
5667 po
= (void *) XPNTR (obj
);
5669 /* Check that the object pointed to by PO is known to be a Lisp
5670 structure allocated from the heap. */
5671 #define CHECK_ALLOCATED() \
5673 m = mem_find (po); \
5678 /* Check that the object pointed to by PO is live, using predicate
5680 #define CHECK_LIVE(LIVEP) \
5682 if (!LIVEP (m, po)) \
5686 /* Check both of the above conditions. */
5687 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5689 CHECK_ALLOCATED (); \
5690 CHECK_LIVE (LIVEP); \
5693 #else /* not GC_CHECK_MARKED_OBJECTS */
5695 #define CHECK_LIVE(LIVEP) (void) 0
5696 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5698 #endif /* not GC_CHECK_MARKED_OBJECTS */
5700 switch (XTYPE (obj
))
5704 register struct Lisp_String
*ptr
= XSTRING (obj
);
5705 if (STRING_MARKED_P (ptr
))
5707 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5709 MARK_INTERVAL_TREE (ptr
->intervals
);
5710 #ifdef GC_CHECK_STRING_BYTES
5711 /* Check that the string size recorded in the string is the
5712 same as the one recorded in the sdata structure. */
5714 #endif /* GC_CHECK_STRING_BYTES */
5718 case Lisp_Vectorlike
:
5720 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5721 register ptrdiff_t pvectype
;
5723 if (VECTOR_MARKED_P (ptr
))
5726 #ifdef GC_CHECK_MARKED_OBJECTS
5728 if (m
== MEM_NIL
&& !SUBRP (obj
))
5730 #endif /* GC_CHECK_MARKED_OBJECTS */
5732 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5733 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5734 >> PSEUDOVECTOR_AREA_BITS
);
5736 pvectype
= PVEC_NORMAL_VECTOR
;
5738 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5739 CHECK_LIVE (live_vector_p
);
5744 #ifdef GC_CHECK_MARKED_OBJECTS
5753 #endif /* GC_CHECK_MARKED_OBJECTS */
5754 mark_buffer ((struct buffer
*) ptr
);
5758 { /* We could treat this just like a vector, but it is better
5759 to save the COMPILED_CONSTANTS element for last and avoid
5761 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5765 for (i
= 0; i
< size
; i
++)
5766 if (i
!= COMPILED_CONSTANTS
)
5767 mark_object (ptr
->contents
[i
]);
5768 if (size
> COMPILED_CONSTANTS
)
5770 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5777 mark_vectorlike (ptr
);
5778 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5783 struct window
*w
= (struct window
*) ptr
;
5784 bool leaf
= NILP (w
->hchild
) && NILP (w
->vchild
);
5786 mark_vectorlike (ptr
);
5788 /* Mark glyphs for leaf windows. Marking window
5789 matrices is sufficient because frame matrices
5790 use the same glyph memory. */
5791 if (leaf
&& w
->current_matrix
)
5793 mark_glyph_matrix (w
->current_matrix
);
5794 mark_glyph_matrix (w
->desired_matrix
);
5797 /* Filter out killed buffers from both buffer lists
5798 in attempt to help GC to reclaim killed buffers faster.
5799 We can do it elsewhere for live windows, but this is the
5800 best place to do it for dead windows. */
5802 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5804 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5808 case PVEC_HASH_TABLE
:
5810 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5812 mark_vectorlike (ptr
);
5813 mark_object (h
->test
.name
);
5814 mark_object (h
->test
.user_hash_function
);
5815 mark_object (h
->test
.user_cmp_function
);
5816 /* If hash table is not weak, mark all keys and values.
5817 For weak tables, mark only the vector. */
5819 mark_object (h
->key_and_value
);
5821 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5825 case PVEC_CHAR_TABLE
:
5826 mark_char_table (ptr
);
5829 case PVEC_BOOL_VECTOR
:
5830 /* No Lisp_Objects to mark in a bool vector. */
5841 mark_vectorlike (ptr
);
5848 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5849 struct Lisp_Symbol
*ptrx
;
5853 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5855 mark_object (ptr
->function
);
5856 mark_object (ptr
->plist
);
5857 switch (ptr
->redirect
)
5859 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5860 case SYMBOL_VARALIAS
:
5863 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5867 case SYMBOL_LOCALIZED
:
5869 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5870 Lisp_Object where
= blv
->where
;
5871 /* If the value is set up for a killed buffer or deleted
5872 frame, restore it's global binding. If the value is
5873 forwarded to a C variable, either it's not a Lisp_Object
5874 var, or it's staticpro'd already. */
5875 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5876 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5877 swap_in_global_binding (ptr
);
5878 mark_object (blv
->where
);
5879 mark_object (blv
->valcell
);
5880 mark_object (blv
->defcell
);
5883 case SYMBOL_FORWARDED
:
5884 /* If the value is forwarded to a buffer or keyboard field,
5885 these are marked when we see the corresponding object.
5886 And if it's forwarded to a C variable, either it's not
5887 a Lisp_Object var, or it's staticpro'd already. */
5889 default: emacs_abort ();
5891 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5892 MARK_STRING (XSTRING (ptr
->name
));
5893 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5898 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5899 XSETSYMBOL (obj
, ptrx
);
5906 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5908 if (XMISCANY (obj
)->gcmarkbit
)
5911 switch (XMISCTYPE (obj
))
5913 case Lisp_Misc_Marker
:
5914 /* DO NOT mark thru the marker's chain.
5915 The buffer's markers chain does not preserve markers from gc;
5916 instead, markers are removed from the chain when freed by gc. */
5917 XMISCANY (obj
)->gcmarkbit
= 1;
5920 case Lisp_Misc_Save_Value
:
5921 XMISCANY (obj
)->gcmarkbit
= 1;
5924 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5925 /* If DOGC is set, POINTER is the address of a memory
5926 area containing INTEGER potential Lisp_Objects. */
5929 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5931 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5932 mark_maybe_object (*p
);
5938 case Lisp_Misc_Overlay
:
5939 mark_overlay (XOVERLAY (obj
));
5949 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5950 if (CONS_MARKED_P (ptr
))
5952 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5954 /* If the cdr is nil, avoid recursion for the car. */
5955 if (EQ (ptr
->u
.cdr
, Qnil
))
5961 mark_object (ptr
->car
);
5964 if (cdr_count
== mark_object_loop_halt
)
5970 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5971 FLOAT_MARK (XFLOAT (obj
));
5982 #undef CHECK_ALLOCATED
5983 #undef CHECK_ALLOCATED_AND_LIVE
5985 /* Mark the Lisp pointers in the terminal objects.
5986 Called by Fgarbage_collect. */
5989 mark_terminals (void)
5992 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5994 eassert (t
->name
!= NULL
);
5995 #ifdef HAVE_WINDOW_SYSTEM
5996 /* If a terminal object is reachable from a stacpro'ed object,
5997 it might have been marked already. Make sure the image cache
5999 mark_image_cache (t
->image_cache
);
6000 #endif /* HAVE_WINDOW_SYSTEM */
6001 if (!VECTOR_MARKED_P (t
))
6002 mark_vectorlike ((struct Lisp_Vector
*)t
);
6008 /* Value is non-zero if OBJ will survive the current GC because it's
6009 either marked or does not need to be marked to survive. */
6012 survives_gc_p (Lisp_Object obj
)
6016 switch (XTYPE (obj
))
6023 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6027 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6031 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6034 case Lisp_Vectorlike
:
6035 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6039 survives_p
= CONS_MARKED_P (XCONS (obj
));
6043 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6050 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6055 /* Sweep: find all structures not marked, and free them. */
6060 /* Remove or mark entries in weak hash tables.
6061 This must be done before any object is unmarked. */
6062 sweep_weak_hash_tables ();
6065 check_string_bytes (!noninteractive
);
6067 /* Put all unmarked conses on free list */
6069 register struct cons_block
*cblk
;
6070 struct cons_block
**cprev
= &cons_block
;
6071 register int lim
= cons_block_index
;
6072 EMACS_INT num_free
= 0, num_used
= 0;
6076 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6080 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6082 /* Scan the mark bits an int at a time. */
6083 for (i
= 0; i
< ilim
; i
++)
6085 if (cblk
->gcmarkbits
[i
] == -1)
6087 /* Fast path - all cons cells for this int are marked. */
6088 cblk
->gcmarkbits
[i
] = 0;
6089 num_used
+= BITS_PER_INT
;
6093 /* Some cons cells for this int are not marked.
6094 Find which ones, and free them. */
6095 int start
, pos
, stop
;
6097 start
= i
* BITS_PER_INT
;
6099 if (stop
> BITS_PER_INT
)
6100 stop
= BITS_PER_INT
;
6103 for (pos
= start
; pos
< stop
; pos
++)
6105 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6108 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6109 cons_free_list
= &cblk
->conses
[pos
];
6111 cons_free_list
->car
= Vdead
;
6117 CONS_UNMARK (&cblk
->conses
[pos
]);
6123 lim
= CONS_BLOCK_SIZE
;
6124 /* If this block contains only free conses and we have already
6125 seen more than two blocks worth of free conses then deallocate
6127 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6129 *cprev
= cblk
->next
;
6130 /* Unhook from the free list. */
6131 cons_free_list
= cblk
->conses
[0].u
.chain
;
6132 lisp_align_free (cblk
);
6136 num_free
+= this_free
;
6137 cprev
= &cblk
->next
;
6140 total_conses
= num_used
;
6141 total_free_conses
= num_free
;
6144 /* Put all unmarked floats on free list */
6146 register struct float_block
*fblk
;
6147 struct float_block
**fprev
= &float_block
;
6148 register int lim
= float_block_index
;
6149 EMACS_INT num_free
= 0, num_used
= 0;
6151 float_free_list
= 0;
6153 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6157 for (i
= 0; i
< lim
; i
++)
6158 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6161 fblk
->floats
[i
].u
.chain
= float_free_list
;
6162 float_free_list
= &fblk
->floats
[i
];
6167 FLOAT_UNMARK (&fblk
->floats
[i
]);
6169 lim
= FLOAT_BLOCK_SIZE
;
6170 /* If this block contains only free floats and we have already
6171 seen more than two blocks worth of free floats then deallocate
6173 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6175 *fprev
= fblk
->next
;
6176 /* Unhook from the free list. */
6177 float_free_list
= fblk
->floats
[0].u
.chain
;
6178 lisp_align_free (fblk
);
6182 num_free
+= this_free
;
6183 fprev
= &fblk
->next
;
6186 total_floats
= num_used
;
6187 total_free_floats
= num_free
;
6190 /* Put all unmarked intervals on free list */
6192 register struct interval_block
*iblk
;
6193 struct interval_block
**iprev
= &interval_block
;
6194 register int lim
= interval_block_index
;
6195 EMACS_INT num_free
= 0, num_used
= 0;
6197 interval_free_list
= 0;
6199 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6204 for (i
= 0; i
< lim
; i
++)
6206 if (!iblk
->intervals
[i
].gcmarkbit
)
6208 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6209 interval_free_list
= &iblk
->intervals
[i
];
6215 iblk
->intervals
[i
].gcmarkbit
= 0;
6218 lim
= INTERVAL_BLOCK_SIZE
;
6219 /* If this block contains only free intervals and we have already
6220 seen more than two blocks worth of free intervals then
6221 deallocate this block. */
6222 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6224 *iprev
= iblk
->next
;
6225 /* Unhook from the free list. */
6226 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6231 num_free
+= this_free
;
6232 iprev
= &iblk
->next
;
6235 total_intervals
= num_used
;
6236 total_free_intervals
= num_free
;
6239 /* Put all unmarked symbols on free list */
6241 register struct symbol_block
*sblk
;
6242 struct symbol_block
**sprev
= &symbol_block
;
6243 register int lim
= symbol_block_index
;
6244 EMACS_INT num_free
= 0, num_used
= 0;
6246 symbol_free_list
= NULL
;
6248 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6251 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6252 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6254 for (; sym
< end
; ++sym
)
6256 /* Check if the symbol was created during loadup. In such a case
6257 it might be pointed to by pure bytecode which we don't trace,
6258 so we conservatively assume that it is live. */
6259 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6261 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6263 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6264 xfree (SYMBOL_BLV (&sym
->s
));
6265 sym
->s
.next
= symbol_free_list
;
6266 symbol_free_list
= &sym
->s
;
6268 symbol_free_list
->function
= Vdead
;
6276 UNMARK_STRING (XSTRING (sym
->s
.name
));
6277 sym
->s
.gcmarkbit
= 0;
6281 lim
= SYMBOL_BLOCK_SIZE
;
6282 /* If this block contains only free symbols and we have already
6283 seen more than two blocks worth of free symbols then deallocate
6285 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6287 *sprev
= sblk
->next
;
6288 /* Unhook from the free list. */
6289 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6294 num_free
+= this_free
;
6295 sprev
= &sblk
->next
;
6298 total_symbols
= num_used
;
6299 total_free_symbols
= num_free
;
6302 /* Put all unmarked misc's on free list.
6303 For a marker, first unchain it from the buffer it points into. */
6305 register struct marker_block
*mblk
;
6306 struct marker_block
**mprev
= &marker_block
;
6307 register int lim
= marker_block_index
;
6308 EMACS_INT num_free
= 0, num_used
= 0;
6310 marker_free_list
= 0;
6312 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6317 for (i
= 0; i
< lim
; i
++)
6319 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6321 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6322 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6323 /* Set the type of the freed object to Lisp_Misc_Free.
6324 We could leave the type alone, since nobody checks it,
6325 but this might catch bugs faster. */
6326 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6327 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6328 marker_free_list
= &mblk
->markers
[i
].m
;
6334 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6337 lim
= MARKER_BLOCK_SIZE
;
6338 /* If this block contains only free markers and we have already
6339 seen more than two blocks worth of free markers then deallocate
6341 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6343 *mprev
= mblk
->next
;
6344 /* Unhook from the free list. */
6345 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6350 num_free
+= this_free
;
6351 mprev
= &mblk
->next
;
6355 total_markers
= num_used
;
6356 total_free_markers
= num_free
;
6359 /* Free all unmarked buffers */
6361 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6364 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6365 if (!VECTOR_MARKED_P (buffer
))
6367 *bprev
= buffer
->next
;
6372 VECTOR_UNMARK (buffer
);
6373 /* Do not use buffer_(set|get)_intervals here. */
6374 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6376 bprev
= &buffer
->next
;
6381 check_string_bytes (!noninteractive
);
6387 /* Debugging aids. */
6389 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6390 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6391 This may be helpful in debugging Emacs's memory usage.
6392 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6397 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6402 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6403 doc
: /* Return a list of counters that measure how much consing there has been.
6404 Each of these counters increments for a certain kind of object.
6405 The counters wrap around from the largest positive integer to zero.
6406 Garbage collection does not decrease them.
6407 The elements of the value are as follows:
6408 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6409 All are in units of 1 = one object consed
6410 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6412 MISCS include overlays, markers, and some internal types.
6413 Frames, windows, buffers, and subprocesses count as vectors
6414 (but the contents of a buffer's text do not count here). */)
6417 return listn (CONSTYPE_HEAP
, 8,
6418 bounded_number (cons_cells_consed
),
6419 bounded_number (floats_consed
),
6420 bounded_number (vector_cells_consed
),
6421 bounded_number (symbols_consed
),
6422 bounded_number (string_chars_consed
),
6423 bounded_number (misc_objects_consed
),
6424 bounded_number (intervals_consed
),
6425 bounded_number (strings_consed
));
6428 /* Find at most FIND_MAX symbols which have OBJ as their value or
6429 function. This is used in gdbinit's `xwhichsymbols' command. */
6432 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6434 struct symbol_block
*sblk
;
6435 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6436 Lisp_Object found
= Qnil
;
6440 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6442 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6445 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6447 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6451 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6454 XSETSYMBOL (tem
, sym
);
6455 val
= find_symbol_value (tem
);
6457 || EQ (sym
->function
, obj
)
6458 || (!NILP (sym
->function
)
6459 && COMPILEDP (sym
->function
)
6460 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6463 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6465 found
= Fcons (tem
, found
);
6466 if (--find_max
== 0)
6474 unbind_to (gc_count
, Qnil
);
6478 #ifdef ENABLE_CHECKING
6480 bool suppress_checking
;
6483 die (const char *msg
, const char *file
, int line
)
6485 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6487 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6491 /* Initialization */
6494 init_alloc_once (void)
6496 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6498 pure_size
= PURESIZE
;
6500 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6502 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6505 #ifdef DOUG_LEA_MALLOC
6506 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6507 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6508 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6513 refill_memory_reserve ();
6514 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6521 byte_stack_list
= 0;
6523 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6524 setjmp_tested_p
= longjmps_done
= 0;
6527 Vgc_elapsed
= make_float (0.0);
6532 syms_of_alloc (void)
6534 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6535 doc
: /* Number of bytes of consing between garbage collections.
6536 Garbage collection can happen automatically once this many bytes have been
6537 allocated since the last garbage collection. All data types count.
6539 Garbage collection happens automatically only when `eval' is called.
6541 By binding this temporarily to a large number, you can effectively
6542 prevent garbage collection during a part of the program.
6543 See also `gc-cons-percentage'. */);
6545 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6546 doc
: /* Portion of the heap used for allocation.
6547 Garbage collection can happen automatically once this portion of the heap
6548 has been allocated since the last garbage collection.
6549 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6550 Vgc_cons_percentage
= make_float (0.1);
6552 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6553 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6555 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6556 doc
: /* Number of cons cells that have been consed so far. */);
6558 DEFVAR_INT ("floats-consed", floats_consed
,
6559 doc
: /* Number of floats that have been consed so far. */);
6561 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6562 doc
: /* Number of vector cells that have been consed so far. */);
6564 DEFVAR_INT ("symbols-consed", symbols_consed
,
6565 doc
: /* Number of symbols that have been consed so far. */);
6567 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6568 doc
: /* Number of string characters that have been consed so far. */);
6570 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6571 doc
: /* Number of miscellaneous objects that have been consed so far.
6572 These include markers and overlays, plus certain objects not visible
6575 DEFVAR_INT ("intervals-consed", intervals_consed
,
6576 doc
: /* Number of intervals that have been consed so far. */);
6578 DEFVAR_INT ("strings-consed", strings_consed
,
6579 doc
: /* Number of strings that have been consed so far. */);
6581 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6582 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6583 This means that certain objects should be allocated in shared (pure) space.
6584 It can also be set to a hash-table, in which case this table is used to
6585 do hash-consing of the objects allocated to pure space. */);
6587 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6588 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6589 garbage_collection_messages
= 0;
6591 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6592 doc
: /* Hook run after garbage collection has finished. */);
6593 Vpost_gc_hook
= Qnil
;
6594 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6596 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6597 doc
: /* Precomputed `signal' argument for memory-full error. */);
6598 /* We build this in advance because if we wait until we need it, we might
6599 not be able to allocate the memory to hold it. */
6601 = listn (CONSTYPE_PURE
, 2, Qerror
,
6602 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6604 DEFVAR_LISP ("memory-full", Vmemory_full
,
6605 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6606 Vmemory_full
= Qnil
;
6608 DEFSYM (Qconses
, "conses");
6609 DEFSYM (Qsymbols
, "symbols");
6610 DEFSYM (Qmiscs
, "miscs");
6611 DEFSYM (Qstrings
, "strings");
6612 DEFSYM (Qvectors
, "vectors");
6613 DEFSYM (Qfloats
, "floats");
6614 DEFSYM (Qintervals
, "intervals");
6615 DEFSYM (Qbuffers
, "buffers");
6616 DEFSYM (Qstring_bytes
, "string-bytes");
6617 DEFSYM (Qvector_slots
, "vector-slots");
6618 DEFSYM (Qheap
, "heap");
6619 DEFSYM (Qautomatic_gc
, "Automatic GC");
6621 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6622 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6624 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6625 doc
: /* Accumulated time elapsed in garbage collections.
6626 The time is in seconds as a floating point value. */);
6627 DEFVAR_INT ("gcs-done", gcs_done
,
6628 doc
: /* Accumulated number of garbage collections done. */);
6633 defsubr (&Smake_byte_code
);
6634 defsubr (&Smake_list
);
6635 defsubr (&Smake_vector
);
6636 defsubr (&Smake_string
);
6637 defsubr (&Smake_bool_vector
);
6638 defsubr (&Smake_symbol
);
6639 defsubr (&Smake_marker
);
6640 defsubr (&Spurecopy
);
6641 defsubr (&Sgarbage_collect
);
6642 defsubr (&Smemory_limit
);
6643 defsubr (&Smemory_use_counts
);
6645 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6646 defsubr (&Sgc_status
);
6650 /* When compiled with GCC, GDB might say "No enum type named
6651 pvec_type" if we don't have at least one symbol with that type, and
6652 then xbacktrace could fail. Similarly for the other enums and
6653 their values. Some non-GCC compilers don't like these constructs. */
6657 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6658 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6659 enum char_bits char_bits
;
6660 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6661 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6662 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6663 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6664 enum Lisp_Bits Lisp_Bits
;
6665 enum Lisp_Compiled Lisp_Compiled
;
6666 enum maxargs maxargs
;
6667 enum MAX_ALLOCA MAX_ALLOCA
;
6668 enum More_Lisp_Bits More_Lisp_Bits
;
6669 enum pvec_type pvec_type
;
6671 enum lsb_bits lsb_bits
;
6673 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6674 #endif /* __GNUC__ */