1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #define LISP_INLINE EXTERN_INLINE
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
38 #include "intervals.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
53 # undef GC_CHECK_MARKED_OBJECTS
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
73 #include "w32heap.h" /* for sbrk */
76 #ifdef DOUG_LEA_MALLOC
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #endif /* not DOUG_LEA_MALLOC */
87 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
88 to a struct Lisp_String. */
90 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
91 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
92 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
94 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
95 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
96 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
98 /* Default value of gc_cons_threshold (see below). */
100 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
102 /* Global variables. */
103 struct emacs_globals globals
;
105 /* Number of bytes of consing done since the last gc. */
107 EMACS_INT consing_since_gc
;
109 /* Similar minimum, computed from Vgc_cons_percentage. */
111 EMACS_INT gc_relative_threshold
;
113 /* Minimum number of bytes of consing since GC before next GC,
114 when memory is full. */
116 EMACS_INT memory_full_cons_threshold
;
118 /* True during GC. */
122 /* True means abort if try to GC.
123 This is for code which is written on the assumption that
124 no GC will happen, so as to verify that assumption. */
128 /* Number of live and free conses etc. */
130 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
131 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
132 static EMACS_INT total_free_floats
, total_floats
;
134 /* Points to memory space allocated as "spare", to be freed if we run
135 out of memory. We keep one large block, four cons-blocks, and
136 two string blocks. */
138 static char *spare_memory
[7];
140 /* Amount of spare memory to keep in large reserve block, or to see
141 whether this much is available when malloc fails on a larger request. */
143 #define SPARE_MEMORY (1 << 14)
145 /* Initialize it to a nonzero value to force it into data space
146 (rather than bss space). That way unexec will remap it into text
147 space (pure), on some systems. We have not implemented the
148 remapping on more recent systems because this is less important
149 nowadays than in the days of small memories and timesharing. */
151 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
152 #define PUREBEG (char *) pure
154 /* Pointer to the pure area, and its size. */
156 static char *purebeg
;
157 static ptrdiff_t pure_size
;
159 /* Number of bytes of pure storage used before pure storage overflowed.
160 If this is non-zero, this implies that an overflow occurred. */
162 static ptrdiff_t pure_bytes_used_before_overflow
;
164 /* True if P points into pure space. */
166 #define PURE_POINTER_P(P) \
167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
169 /* Index in pure at which next pure Lisp object will be allocated.. */
171 static ptrdiff_t pure_bytes_used_lisp
;
173 /* Number of bytes allocated for non-Lisp objects in pure storage. */
175 static ptrdiff_t pure_bytes_used_non_lisp
;
177 /* If nonzero, this is a warning delivered by malloc and not yet
180 const char *pending_malloc_warning
;
182 /* Maximum amount of C stack to save when a GC happens. */
184 #ifndef MAX_SAVE_STACK
185 #define MAX_SAVE_STACK 16000
188 /* Buffer in which we save a copy of the C stack at each GC. */
190 #if MAX_SAVE_STACK > 0
191 static char *stack_copy
;
192 static ptrdiff_t stack_copy_size
;
195 static Lisp_Object Qconses
;
196 static Lisp_Object Qsymbols
;
197 static Lisp_Object Qmiscs
;
198 static Lisp_Object Qstrings
;
199 static Lisp_Object Qvectors
;
200 static Lisp_Object Qfloats
;
201 static Lisp_Object Qintervals
;
202 static Lisp_Object Qbuffers
;
203 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
204 static Lisp_Object Qgc_cons_threshold
;
205 Lisp_Object Qautomatic_gc
;
206 Lisp_Object Qchar_table_extra_slots
;
208 /* Hook run after GC has finished. */
210 static Lisp_Object Qpost_gc_hook
;
212 static void free_save_value (Lisp_Object
);
213 static void mark_terminals (void);
214 static void gc_sweep (void);
215 static Lisp_Object
make_pure_vector (ptrdiff_t);
216 static void mark_buffer (struct buffer
*);
218 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
219 static void refill_memory_reserve (void);
221 static void compact_small_strings (void);
222 static void free_large_strings (void);
223 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
225 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
226 what memory allocated via lisp_malloc and lisp_align_malloc is intended
227 for what purpose. This enumeration specifies the type of memory. */
238 /* Since all non-bool pseudovectors are small enough to be
239 allocated from vector blocks, this memory type denotes
240 large regular vectors and large bool pseudovectors. */
242 /* Special type to denote vector blocks. */
243 MEM_TYPE_VECTOR_BLOCK
,
244 /* Special type to denote reserved memory. */
248 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
250 /* A unique object in pure space used to make some Lisp objects
251 on free lists recognizable in O(1). */
253 static Lisp_Object Vdead
;
254 #define DEADP(x) EQ (x, Vdead)
256 #ifdef GC_MALLOC_CHECK
258 enum mem_type allocated_mem_type
;
260 #endif /* GC_MALLOC_CHECK */
262 /* A node in the red-black tree describing allocated memory containing
263 Lisp data. Each such block is recorded with its start and end
264 address when it is allocated, and removed from the tree when it
267 A red-black tree is a balanced binary tree with the following
270 1. Every node is either red or black.
271 2. Every leaf is black.
272 3. If a node is red, then both of its children are black.
273 4. Every simple path from a node to a descendant leaf contains
274 the same number of black nodes.
275 5. The root is always black.
277 When nodes are inserted into the tree, or deleted from the tree,
278 the tree is "fixed" so that these properties are always true.
280 A red-black tree with N internal nodes has height at most 2
281 log(N+1). Searches, insertions and deletions are done in O(log N).
282 Please see a text book about data structures for a detailed
283 description of red-black trees. Any book worth its salt should
288 /* Children of this node. These pointers are never NULL. When there
289 is no child, the value is MEM_NIL, which points to a dummy node. */
290 struct mem_node
*left
, *right
;
292 /* The parent of this node. In the root node, this is NULL. */
293 struct mem_node
*parent
;
295 /* Start and end of allocated region. */
299 enum {MEM_BLACK
, MEM_RED
} color
;
305 /* Base address of stack. Set in main. */
307 Lisp_Object
*stack_base
;
309 /* Root of the tree describing allocated Lisp memory. */
311 static struct mem_node
*mem_root
;
313 /* Lowest and highest known address in the heap. */
315 static void *min_heap_address
, *max_heap_address
;
317 /* Sentinel node of the tree. */
319 static struct mem_node mem_z
;
320 #define MEM_NIL &mem_z
322 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
323 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
324 static void mem_insert_fixup (struct mem_node
*);
325 static void mem_rotate_left (struct mem_node
*);
326 static void mem_rotate_right (struct mem_node
*);
327 static void mem_delete (struct mem_node
*);
328 static void mem_delete_fixup (struct mem_node
*);
329 static struct mem_node
*mem_find (void *);
332 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
338 /* Recording what needs to be marked for gc. */
340 struct gcpro
*gcprolist
;
342 /* Addresses of staticpro'd variables. Initialize it to a nonzero
343 value; otherwise some compilers put it into BSS. */
345 #define NSTATICS 0x800
346 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
348 /* Index of next unused slot in staticvec. */
350 static int staticidx
;
352 static void *pure_alloc (size_t, int);
355 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
356 ALIGNMENT must be a power of 2. */
358 #define ALIGN(ptr, ALIGNMENT) \
359 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
360 & ~ ((ALIGNMENT) - 1)))
363 XFLOAT_INIT (Lisp_Object f
, double n
)
365 XFLOAT (f
)->u
.data
= n
;
369 /************************************************************************
371 ************************************************************************/
373 /* Function malloc calls this if it finds we are near exhausting storage. */
376 malloc_warning (const char *str
)
378 pending_malloc_warning
= str
;
382 /* Display an already-pending malloc warning. */
385 display_malloc_warning (void)
387 call3 (intern ("display-warning"),
389 build_string (pending_malloc_warning
),
390 intern ("emergency"));
391 pending_malloc_warning
= 0;
394 /* Called if we can't allocate relocatable space for a buffer. */
397 buffer_memory_full (ptrdiff_t nbytes
)
399 /* If buffers use the relocating allocator, no need to free
400 spare_memory, because we may have plenty of malloc space left
401 that we could get, and if we don't, the malloc that fails will
402 itself cause spare_memory to be freed. If buffers don't use the
403 relocating allocator, treat this like any other failing
407 memory_full (nbytes
);
409 /* This used to call error, but if we've run out of memory, we could
410 get infinite recursion trying to build the string. */
411 xsignal (Qnil
, Vmemory_signal_data
);
415 /* A common multiple of the positive integers A and B. Ideally this
416 would be the least common multiple, but there's no way to do that
417 as a constant expression in C, so do the best that we can easily do. */
418 #define COMMON_MULTIPLE(a, b) \
419 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
421 #ifndef XMALLOC_OVERRUN_CHECK
422 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
425 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
428 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
429 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
430 block size in little-endian order. The trailer consists of
431 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
433 The header is used to detect whether this block has been allocated
434 through these functions, as some low-level libc functions may
435 bypass the malloc hooks. */
437 #define XMALLOC_OVERRUN_CHECK_SIZE 16
438 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
439 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
441 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
442 hold a size_t value and (2) the header size is a multiple of the
443 alignment that Emacs needs for C types and for USE_LSB_TAG. */
444 #define XMALLOC_BASE_ALIGNMENT \
445 alignof (union { long double d; intmax_t i; void *p; })
448 # define XMALLOC_HEADER_ALIGNMENT \
449 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
451 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
453 #define XMALLOC_OVERRUN_SIZE_SIZE \
454 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
455 + XMALLOC_HEADER_ALIGNMENT - 1) \
456 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
457 - XMALLOC_OVERRUN_CHECK_SIZE)
459 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
460 { '\x9a', '\x9b', '\xae', '\xaf',
461 '\xbf', '\xbe', '\xce', '\xcf',
462 '\xea', '\xeb', '\xec', '\xed',
463 '\xdf', '\xde', '\x9c', '\x9d' };
465 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
466 { '\xaa', '\xab', '\xac', '\xad',
467 '\xba', '\xbb', '\xbc', '\xbd',
468 '\xca', '\xcb', '\xcc', '\xcd',
469 '\xda', '\xdb', '\xdc', '\xdd' };
471 /* Insert and extract the block size in the header. */
474 xmalloc_put_size (unsigned char *ptr
, size_t size
)
477 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
479 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
485 xmalloc_get_size (unsigned char *ptr
)
489 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
490 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
499 /* Like malloc, but wraps allocated block with header and trailer. */
502 overrun_check_malloc (size_t size
)
504 register unsigned char *val
;
505 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
508 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
511 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
512 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
513 xmalloc_put_size (val
, size
);
514 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
515 XMALLOC_OVERRUN_CHECK_SIZE
);
521 /* Like realloc, but checks old block for overrun, and wraps new block
522 with header and trailer. */
525 overrun_check_realloc (void *block
, size_t size
)
527 register unsigned char *val
= (unsigned char *) block
;
528 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
532 && memcmp (xmalloc_overrun_check_header
,
533 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
534 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
536 size_t osize
= xmalloc_get_size (val
);
537 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
538 XMALLOC_OVERRUN_CHECK_SIZE
))
540 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
541 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
542 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
545 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
549 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
550 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
551 xmalloc_put_size (val
, size
);
552 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
553 XMALLOC_OVERRUN_CHECK_SIZE
);
558 /* Like free, but checks block for overrun. */
561 overrun_check_free (void *block
)
563 unsigned char *val
= (unsigned char *) block
;
566 && memcmp (xmalloc_overrun_check_header
,
567 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
568 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
570 size_t osize
= xmalloc_get_size (val
);
571 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
572 XMALLOC_OVERRUN_CHECK_SIZE
))
574 #ifdef XMALLOC_CLEAR_FREE_MEMORY
575 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
576 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
578 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
579 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
580 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
590 #define malloc overrun_check_malloc
591 #define realloc overrun_check_realloc
592 #define free overrun_check_free
595 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
596 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
597 If that variable is set, block input while in one of Emacs's memory
598 allocation functions. There should be no need for this debugging
599 option, since signal handlers do not allocate memory, but Emacs
600 formerly allocated memory in signal handlers and this compile-time
601 option remains as a way to help debug the issue should it rear its
603 #ifdef XMALLOC_BLOCK_INPUT_CHECK
604 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
606 malloc_block_input (void)
608 if (block_input_in_memory_allocators
)
612 malloc_unblock_input (void)
614 if (block_input_in_memory_allocators
)
617 # define MALLOC_BLOCK_INPUT malloc_block_input ()
618 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
620 # define MALLOC_BLOCK_INPUT ((void) 0)
621 # define MALLOC_UNBLOCK_INPUT ((void) 0)
624 #define MALLOC_PROBE(size) \
626 if (profiler_memory_running) \
627 malloc_probe (size); \
631 /* Like malloc but check for no memory and block interrupt input.. */
634 xmalloc (size_t size
)
640 MALLOC_UNBLOCK_INPUT
;
648 /* Like the above, but zeroes out the memory just allocated. */
651 xzalloc (size_t size
)
657 MALLOC_UNBLOCK_INPUT
;
661 memset (val
, 0, size
);
666 /* Like realloc but check for no memory and block interrupt input.. */
669 xrealloc (void *block
, size_t size
)
674 /* We must call malloc explicitly when BLOCK is 0, since some
675 reallocs don't do this. */
679 val
= realloc (block
, size
);
680 MALLOC_UNBLOCK_INPUT
;
689 /* Like free but block interrupt input. */
698 MALLOC_UNBLOCK_INPUT
;
699 /* We don't call refill_memory_reserve here
700 because in practice the call in r_alloc_free seems to suffice. */
704 /* Other parts of Emacs pass large int values to allocator functions
705 expecting ptrdiff_t. This is portable in practice, but check it to
707 verify (INT_MAX
<= PTRDIFF_MAX
);
710 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
711 Signal an error on memory exhaustion, and block interrupt input. */
714 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
716 eassert (0 <= nitems
&& 0 < item_size
);
717 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
718 memory_full (SIZE_MAX
);
719 return xmalloc (nitems
* item_size
);
723 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
724 Signal an error on memory exhaustion, and block interrupt input. */
727 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
729 eassert (0 <= nitems
&& 0 < item_size
);
730 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
731 memory_full (SIZE_MAX
);
732 return xrealloc (pa
, nitems
* item_size
);
736 /* Grow PA, which points to an array of *NITEMS items, and return the
737 location of the reallocated array, updating *NITEMS to reflect its
738 new size. The new array will contain at least NITEMS_INCR_MIN more
739 items, but will not contain more than NITEMS_MAX items total.
740 ITEM_SIZE is the size of each item, in bytes.
742 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
743 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
746 If PA is null, then allocate a new array instead of reallocating
749 Block interrupt input as needed. If memory exhaustion occurs, set
750 *NITEMS to zero if PA is null, and signal an error (i.e., do not
753 Thus, to grow an array A without saving its old contents, do
754 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
755 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
756 and signals an error, and later this code is reexecuted and
757 attempts to free A. */
760 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
761 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
763 /* The approximate size to use for initial small allocation
764 requests. This is the largest "small" request for the GNU C
766 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
768 /* If the array is tiny, grow it to about (but no greater than)
769 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
770 ptrdiff_t n
= *nitems
;
771 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
772 ptrdiff_t half_again
= n
>> 1;
773 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
775 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
776 NITEMS_MAX, and what the C language can represent safely. */
777 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
778 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
779 ? nitems_max
: C_language_max
);
780 ptrdiff_t nitems_incr_max
= n_max
- n
;
781 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
783 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
786 if (nitems_incr_max
< incr
)
787 memory_full (SIZE_MAX
);
789 pa
= xrealloc (pa
, n
* item_size
);
795 /* Like strdup, but uses xmalloc. */
798 xstrdup (const char *s
)
800 size_t len
= strlen (s
) + 1;
801 char *p
= xmalloc (len
);
806 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
807 argument is a const pointer. */
810 xputenv (char const *string
)
812 if (putenv ((char *) string
) != 0)
816 /* Unwind for SAFE_ALLOCA */
819 safe_alloca_unwind (Lisp_Object arg
)
821 free_save_value (arg
);
825 /* Return a newly allocated memory block of SIZE bytes, remembering
826 to free it when unwinding. */
828 record_xmalloc (size_t size
)
830 void *p
= xmalloc (size
);
831 record_unwind_protect (safe_alloca_unwind
, make_save_pointer (p
));
836 /* Like malloc but used for allocating Lisp data. NBYTES is the
837 number of bytes to allocate, TYPE describes the intended use of the
838 allocated memory block (for strings, for conses, ...). */
841 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
845 lisp_malloc (size_t nbytes
, enum mem_type type
)
851 #ifdef GC_MALLOC_CHECK
852 allocated_mem_type
= type
;
855 val
= malloc (nbytes
);
858 /* If the memory just allocated cannot be addressed thru a Lisp
859 object's pointer, and it needs to be,
860 that's equivalent to running out of memory. */
861 if (val
&& type
!= MEM_TYPE_NON_LISP
)
864 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
865 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
867 lisp_malloc_loser
= val
;
874 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
875 if (val
&& type
!= MEM_TYPE_NON_LISP
)
876 mem_insert (val
, (char *) val
+ nbytes
, type
);
879 MALLOC_UNBLOCK_INPUT
;
881 memory_full (nbytes
);
882 MALLOC_PROBE (nbytes
);
886 /* Free BLOCK. This must be called to free memory allocated with a
887 call to lisp_malloc. */
890 lisp_free (void *block
)
894 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
895 mem_delete (mem_find (block
));
897 MALLOC_UNBLOCK_INPUT
;
900 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
902 /* The entry point is lisp_align_malloc which returns blocks of at most
903 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
905 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
906 #define USE_POSIX_MEMALIGN 1
909 /* BLOCK_ALIGN has to be a power of 2. */
910 #define BLOCK_ALIGN (1 << 10)
912 /* Padding to leave at the end of a malloc'd block. This is to give
913 malloc a chance to minimize the amount of memory wasted to alignment.
914 It should be tuned to the particular malloc library used.
915 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
916 posix_memalign on the other hand would ideally prefer a value of 4
917 because otherwise, there's 1020 bytes wasted between each ablocks.
918 In Emacs, testing shows that those 1020 can most of the time be
919 efficiently used by malloc to place other objects, so a value of 0 can
920 still preferable unless you have a lot of aligned blocks and virtually
922 #define BLOCK_PADDING 0
923 #define BLOCK_BYTES \
924 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
926 /* Internal data structures and constants. */
928 #define ABLOCKS_SIZE 16
930 /* An aligned block of memory. */
935 char payload
[BLOCK_BYTES
];
936 struct ablock
*next_free
;
938 /* `abase' is the aligned base of the ablocks. */
939 /* It is overloaded to hold the virtual `busy' field that counts
940 the number of used ablock in the parent ablocks.
941 The first ablock has the `busy' field, the others have the `abase'
942 field. To tell the difference, we assume that pointers will have
943 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
944 is used to tell whether the real base of the parent ablocks is `abase'
945 (if not, the word before the first ablock holds a pointer to the
947 struct ablocks
*abase
;
948 /* The padding of all but the last ablock is unused. The padding of
949 the last ablock in an ablocks is not allocated. */
951 char padding
[BLOCK_PADDING
];
955 /* A bunch of consecutive aligned blocks. */
958 struct ablock blocks
[ABLOCKS_SIZE
];
961 /* Size of the block requested from malloc or posix_memalign. */
962 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
964 #define ABLOCK_ABASE(block) \
965 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
966 ? (struct ablocks *)(block) \
969 /* Virtual `busy' field. */
970 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
972 /* Pointer to the (not necessarily aligned) malloc block. */
973 #ifdef USE_POSIX_MEMALIGN
974 #define ABLOCKS_BASE(abase) (abase)
976 #define ABLOCKS_BASE(abase) \
977 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
980 /* The list of free ablock. */
981 static struct ablock
*free_ablock
;
983 /* Allocate an aligned block of nbytes.
984 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
985 smaller or equal to BLOCK_BYTES. */
987 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
990 struct ablocks
*abase
;
992 eassert (nbytes
<= BLOCK_BYTES
);
996 #ifdef GC_MALLOC_CHECK
997 allocated_mem_type
= type
;
1003 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1005 #ifdef DOUG_LEA_MALLOC
1006 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1007 because mapped region contents are not preserved in
1009 mallopt (M_MMAP_MAX
, 0);
1012 #ifdef USE_POSIX_MEMALIGN
1014 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1020 base
= malloc (ABLOCKS_BYTES
);
1021 abase
= ALIGN (base
, BLOCK_ALIGN
);
1026 MALLOC_UNBLOCK_INPUT
;
1027 memory_full (ABLOCKS_BYTES
);
1030 aligned
= (base
== abase
);
1032 ((void**)abase
)[-1] = base
;
1034 #ifdef DOUG_LEA_MALLOC
1035 /* Back to a reasonable maximum of mmap'ed areas. */
1036 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1040 /* If the memory just allocated cannot be addressed thru a Lisp
1041 object's pointer, and it needs to be, that's equivalent to
1042 running out of memory. */
1043 if (type
!= MEM_TYPE_NON_LISP
)
1046 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1047 XSETCONS (tem
, end
);
1048 if ((char *) XCONS (tem
) != end
)
1050 lisp_malloc_loser
= base
;
1052 MALLOC_UNBLOCK_INPUT
;
1053 memory_full (SIZE_MAX
);
1058 /* Initialize the blocks and put them on the free list.
1059 If `base' was not properly aligned, we can't use the last block. */
1060 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1062 abase
->blocks
[i
].abase
= abase
;
1063 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1064 free_ablock
= &abase
->blocks
[i
];
1066 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1068 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1069 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1070 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1071 eassert (ABLOCKS_BASE (abase
) == base
);
1072 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1075 abase
= ABLOCK_ABASE (free_ablock
);
1076 ABLOCKS_BUSY (abase
) =
1077 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1079 free_ablock
= free_ablock
->x
.next_free
;
1081 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1082 if (type
!= MEM_TYPE_NON_LISP
)
1083 mem_insert (val
, (char *) val
+ nbytes
, type
);
1086 MALLOC_UNBLOCK_INPUT
;
1088 MALLOC_PROBE (nbytes
);
1090 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1095 lisp_align_free (void *block
)
1097 struct ablock
*ablock
= block
;
1098 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1101 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1102 mem_delete (mem_find (block
));
1104 /* Put on free list. */
1105 ablock
->x
.next_free
= free_ablock
;
1106 free_ablock
= ablock
;
1107 /* Update busy count. */
1108 ABLOCKS_BUSY (abase
)
1109 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1111 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1112 { /* All the blocks are free. */
1113 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1114 struct ablock
**tem
= &free_ablock
;
1115 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1119 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1122 *tem
= (*tem
)->x
.next_free
;
1125 tem
= &(*tem
)->x
.next_free
;
1127 eassert ((aligned
& 1) == aligned
);
1128 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1129 #ifdef USE_POSIX_MEMALIGN
1130 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1132 free (ABLOCKS_BASE (abase
));
1134 MALLOC_UNBLOCK_INPUT
;
1138 /***********************************************************************
1140 ***********************************************************************/
1142 /* Number of intervals allocated in an interval_block structure.
1143 The 1020 is 1024 minus malloc overhead. */
1145 #define INTERVAL_BLOCK_SIZE \
1146 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1148 /* Intervals are allocated in chunks in the form of an interval_block
1151 struct interval_block
1153 /* Place `intervals' first, to preserve alignment. */
1154 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1155 struct interval_block
*next
;
1158 /* Current interval block. Its `next' pointer points to older
1161 static struct interval_block
*interval_block
;
1163 /* Index in interval_block above of the next unused interval
1166 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1168 /* Number of free and live intervals. */
1170 static EMACS_INT total_free_intervals
, total_intervals
;
1172 /* List of free intervals. */
1174 static INTERVAL interval_free_list
;
1176 /* Return a new interval. */
1179 make_interval (void)
1185 if (interval_free_list
)
1187 val
= interval_free_list
;
1188 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1192 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1194 struct interval_block
*newi
1195 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1197 newi
->next
= interval_block
;
1198 interval_block
= newi
;
1199 interval_block_index
= 0;
1200 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1202 val
= &interval_block
->intervals
[interval_block_index
++];
1205 MALLOC_UNBLOCK_INPUT
;
1207 consing_since_gc
+= sizeof (struct interval
);
1209 total_free_intervals
--;
1210 RESET_INTERVAL (val
);
1216 /* Mark Lisp objects in interval I. */
1219 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1221 /* Intervals should never be shared. So, if extra internal checking is
1222 enabled, GC aborts if it seems to have visited an interval twice. */
1223 eassert (!i
->gcmarkbit
);
1225 mark_object (i
->plist
);
1228 /* Mark the interval tree rooted in I. */
1230 #define MARK_INTERVAL_TREE(i) \
1232 if (i && !i->gcmarkbit) \
1233 traverse_intervals_noorder (i, mark_interval, Qnil); \
1236 /***********************************************************************
1238 ***********************************************************************/
1240 /* Lisp_Strings are allocated in string_block structures. When a new
1241 string_block is allocated, all the Lisp_Strings it contains are
1242 added to a free-list string_free_list. When a new Lisp_String is
1243 needed, it is taken from that list. During the sweep phase of GC,
1244 string_blocks that are entirely free are freed, except two which
1247 String data is allocated from sblock structures. Strings larger
1248 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1249 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1251 Sblocks consist internally of sdata structures, one for each
1252 Lisp_String. The sdata structure points to the Lisp_String it
1253 belongs to. The Lisp_String points back to the `u.data' member of
1254 its sdata structure.
1256 When a Lisp_String is freed during GC, it is put back on
1257 string_free_list, and its `data' member and its sdata's `string'
1258 pointer is set to null. The size of the string is recorded in the
1259 `n.nbytes' member of the sdata. So, sdata structures that are no
1260 longer used, can be easily recognized, and it's easy to compact the
1261 sblocks of small strings which we do in compact_small_strings. */
1263 /* Size in bytes of an sblock structure used for small strings. This
1264 is 8192 minus malloc overhead. */
1266 #define SBLOCK_SIZE 8188
1268 /* Strings larger than this are considered large strings. String data
1269 for large strings is allocated from individual sblocks. */
1271 #define LARGE_STRING_BYTES 1024
1273 /* Struct or union describing string memory sub-allocated from an sblock.
1274 This is where the contents of Lisp strings are stored. */
1276 #ifdef GC_CHECK_STRING_BYTES
1280 /* Back-pointer to the string this sdata belongs to. If null, this
1281 structure is free, and the NBYTES member of the union below
1282 contains the string's byte size (the same value that STRING_BYTES
1283 would return if STRING were non-null). If non-null, STRING_BYTES
1284 (STRING) is the size of the data, and DATA contains the string's
1286 struct Lisp_String
*string
;
1289 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1292 #define SDATA_NBYTES(S) (S)->nbytes
1293 #define SDATA_DATA(S) (S)->data
1294 #define SDATA_SELECTOR(member) member
1300 struct Lisp_String
*string
;
1302 /* When STRING is non-null. */
1305 struct Lisp_String
*string
;
1306 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1309 /* When STRING is null. */
1312 struct Lisp_String
*string
;
1317 #define SDATA_NBYTES(S) (S)->n.nbytes
1318 #define SDATA_DATA(S) (S)->u.data
1319 #define SDATA_SELECTOR(member) u.member
1321 #endif /* not GC_CHECK_STRING_BYTES */
1323 #define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1326 /* Structure describing a block of memory which is sub-allocated to
1327 obtain string data memory for strings. Blocks for small strings
1328 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1329 as large as needed. */
1334 struct sblock
*next
;
1336 /* Pointer to the next free sdata block. This points past the end
1337 of the sblock if there isn't any space left in this block. */
1340 /* Start of data. */
1344 /* Number of Lisp strings in a string_block structure. The 1020 is
1345 1024 minus malloc overhead. */
1347 #define STRING_BLOCK_SIZE \
1348 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1350 /* Structure describing a block from which Lisp_String structures
1355 /* Place `strings' first, to preserve alignment. */
1356 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1357 struct string_block
*next
;
1360 /* Head and tail of the list of sblock structures holding Lisp string
1361 data. We always allocate from current_sblock. The NEXT pointers
1362 in the sblock structures go from oldest_sblock to current_sblock. */
1364 static struct sblock
*oldest_sblock
, *current_sblock
;
1366 /* List of sblocks for large strings. */
1368 static struct sblock
*large_sblocks
;
1370 /* List of string_block structures. */
1372 static struct string_block
*string_blocks
;
1374 /* Free-list of Lisp_Strings. */
1376 static struct Lisp_String
*string_free_list
;
1378 /* Number of live and free Lisp_Strings. */
1380 static EMACS_INT total_strings
, total_free_strings
;
1382 /* Number of bytes used by live strings. */
1384 static EMACS_INT total_string_bytes
;
1386 /* Given a pointer to a Lisp_String S which is on the free-list
1387 string_free_list, return a pointer to its successor in the
1390 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1392 /* Return a pointer to the sdata structure belonging to Lisp string S.
1393 S must be live, i.e. S->data must not be null. S->data is actually
1394 a pointer to the `u.data' member of its sdata structure; the
1395 structure starts at a constant offset in front of that. */
1397 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1400 #ifdef GC_CHECK_STRING_OVERRUN
1402 /* We check for overrun in string data blocks by appending a small
1403 "cookie" after each allocated string data block, and check for the
1404 presence of this cookie during GC. */
1406 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1407 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1408 { '\xde', '\xad', '\xbe', '\xef' };
1411 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1414 /* Value is the size of an sdata structure large enough to hold NBYTES
1415 bytes of string data. The value returned includes a terminating
1416 NUL byte, the size of the sdata structure, and padding. */
1418 #ifdef GC_CHECK_STRING_BYTES
1420 #define SDATA_SIZE(NBYTES) \
1421 ((SDATA_DATA_OFFSET \
1423 + sizeof (ptrdiff_t) - 1) \
1424 & ~(sizeof (ptrdiff_t) - 1))
1426 #else /* not GC_CHECK_STRING_BYTES */
1428 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1429 less than the size of that member. The 'max' is not needed when
1430 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1431 alignment code reserves enough space. */
1433 #define SDATA_SIZE(NBYTES) \
1434 ((SDATA_DATA_OFFSET \
1435 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1437 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1439 + sizeof (ptrdiff_t) - 1) \
1440 & ~(sizeof (ptrdiff_t) - 1))
1442 #endif /* not GC_CHECK_STRING_BYTES */
1444 /* Extra bytes to allocate for each string. */
1446 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1448 /* Exact bound on the number of bytes in a string, not counting the
1449 terminating null. A string cannot contain more bytes than
1450 STRING_BYTES_BOUND, nor can it be so long that the size_t
1451 arithmetic in allocate_string_data would overflow while it is
1452 calculating a value to be passed to malloc. */
1453 static ptrdiff_t const STRING_BYTES_MAX
=
1454 min (STRING_BYTES_BOUND
,
1455 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1457 - offsetof (struct sblock
, first_data
)
1458 - SDATA_DATA_OFFSET
)
1459 & ~(sizeof (EMACS_INT
) - 1)));
1461 /* Initialize string allocation. Called from init_alloc_once. */
1466 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1467 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1471 #ifdef GC_CHECK_STRING_BYTES
1473 static int check_string_bytes_count
;
1475 /* Like STRING_BYTES, but with debugging check. Can be
1476 called during GC, so pay attention to the mark bit. */
1479 string_bytes (struct Lisp_String
*s
)
1482 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1484 if (!PURE_POINTER_P (s
)
1486 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1491 /* Check validity of Lisp strings' string_bytes member in B. */
1494 check_sblock (struct sblock
*b
)
1496 sdata
*from
, *end
, *from_end
;
1500 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1502 /* Compute the next FROM here because copying below may
1503 overwrite data we need to compute it. */
1506 /* Check that the string size recorded in the string is the
1507 same as the one recorded in the sdata structure. */
1508 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1509 : SDATA_NBYTES (from
));
1510 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1515 /* Check validity of Lisp strings' string_bytes member. ALL_P
1516 means check all strings, otherwise check only most
1517 recently allocated strings. Used for hunting a bug. */
1520 check_string_bytes (bool all_p
)
1526 for (b
= large_sblocks
; b
; b
= b
->next
)
1528 struct Lisp_String
*s
= b
->first_data
.string
;
1533 for (b
= oldest_sblock
; b
; b
= b
->next
)
1536 else if (current_sblock
)
1537 check_sblock (current_sblock
);
1540 #else /* not GC_CHECK_STRING_BYTES */
1542 #define check_string_bytes(all) ((void) 0)
1544 #endif /* GC_CHECK_STRING_BYTES */
1546 #ifdef GC_CHECK_STRING_FREE_LIST
1548 /* Walk through the string free list looking for bogus next pointers.
1549 This may catch buffer overrun from a previous string. */
1552 check_string_free_list (void)
1554 struct Lisp_String
*s
;
1556 /* Pop a Lisp_String off the free-list. */
1557 s
= string_free_list
;
1560 if ((uintptr_t) s
< 1024)
1562 s
= NEXT_FREE_LISP_STRING (s
);
1566 #define check_string_free_list()
1569 /* Return a new Lisp_String. */
1571 static struct Lisp_String
*
1572 allocate_string (void)
1574 struct Lisp_String
*s
;
1578 /* If the free-list is empty, allocate a new string_block, and
1579 add all the Lisp_Strings in it to the free-list. */
1580 if (string_free_list
== NULL
)
1582 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1585 b
->next
= string_blocks
;
1588 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1591 /* Every string on a free list should have NULL data pointer. */
1593 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1594 string_free_list
= s
;
1597 total_free_strings
+= STRING_BLOCK_SIZE
;
1600 check_string_free_list ();
1602 /* Pop a Lisp_String off the free-list. */
1603 s
= string_free_list
;
1604 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1606 MALLOC_UNBLOCK_INPUT
;
1608 --total_free_strings
;
1611 consing_since_gc
+= sizeof *s
;
1613 #ifdef GC_CHECK_STRING_BYTES
1614 if (!noninteractive
)
1616 if (++check_string_bytes_count
== 200)
1618 check_string_bytes_count
= 0;
1619 check_string_bytes (1);
1622 check_string_bytes (0);
1624 #endif /* GC_CHECK_STRING_BYTES */
1630 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1631 plus a NUL byte at the end. Allocate an sdata structure for S, and
1632 set S->data to its `u.data' member. Store a NUL byte at the end of
1633 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1634 S->data if it was initially non-null. */
1637 allocate_string_data (struct Lisp_String
*s
,
1638 EMACS_INT nchars
, EMACS_INT nbytes
)
1640 sdata
*data
, *old_data
;
1642 ptrdiff_t needed
, old_nbytes
;
1644 if (STRING_BYTES_MAX
< nbytes
)
1647 /* Determine the number of bytes needed to store NBYTES bytes
1649 needed
= SDATA_SIZE (nbytes
);
1652 old_data
= SDATA_OF_STRING (s
);
1653 old_nbytes
= STRING_BYTES (s
);
1660 if (nbytes
> LARGE_STRING_BYTES
)
1662 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1664 #ifdef DOUG_LEA_MALLOC
1665 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1666 because mapped region contents are not preserved in
1669 In case you think of allowing it in a dumped Emacs at the
1670 cost of not being able to re-dump, there's another reason:
1671 mmap'ed data typically have an address towards the top of the
1672 address space, which won't fit into an EMACS_INT (at least on
1673 32-bit systems with the current tagging scheme). --fx */
1674 mallopt (M_MMAP_MAX
, 0);
1677 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1679 #ifdef DOUG_LEA_MALLOC
1680 /* Back to a reasonable maximum of mmap'ed areas. */
1681 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1684 b
->next_free
= &b
->first_data
;
1685 b
->first_data
.string
= NULL
;
1686 b
->next
= large_sblocks
;
1689 else if (current_sblock
== NULL
1690 || (((char *) current_sblock
+ SBLOCK_SIZE
1691 - (char *) current_sblock
->next_free
)
1692 < (needed
+ GC_STRING_EXTRA
)))
1694 /* Not enough room in the current sblock. */
1695 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1696 b
->next_free
= &b
->first_data
;
1697 b
->first_data
.string
= NULL
;
1701 current_sblock
->next
= b
;
1709 data
= b
->next_free
;
1710 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1712 MALLOC_UNBLOCK_INPUT
;
1715 s
->data
= SDATA_DATA (data
);
1716 #ifdef GC_CHECK_STRING_BYTES
1717 SDATA_NBYTES (data
) = nbytes
;
1720 s
->size_byte
= nbytes
;
1721 s
->data
[nbytes
] = '\0';
1722 #ifdef GC_CHECK_STRING_OVERRUN
1723 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1724 GC_STRING_OVERRUN_COOKIE_SIZE
);
1727 /* Note that Faset may call to this function when S has already data
1728 assigned. In this case, mark data as free by setting it's string
1729 back-pointer to null, and record the size of the data in it. */
1732 SDATA_NBYTES (old_data
) = old_nbytes
;
1733 old_data
->string
= NULL
;
1736 consing_since_gc
+= needed
;
1740 /* Sweep and compact strings. */
1743 sweep_strings (void)
1745 struct string_block
*b
, *next
;
1746 struct string_block
*live_blocks
= NULL
;
1748 string_free_list
= NULL
;
1749 total_strings
= total_free_strings
= 0;
1750 total_string_bytes
= 0;
1752 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1753 for (b
= string_blocks
; b
; b
= next
)
1756 struct Lisp_String
*free_list_before
= string_free_list
;
1760 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1762 struct Lisp_String
*s
= b
->strings
+ i
;
1766 /* String was not on free-list before. */
1767 if (STRING_MARKED_P (s
))
1769 /* String is live; unmark it and its intervals. */
1772 /* Do not use string_(set|get)_intervals here. */
1773 s
->intervals
= balance_intervals (s
->intervals
);
1776 total_string_bytes
+= STRING_BYTES (s
);
1780 /* String is dead. Put it on the free-list. */
1781 sdata
*data
= SDATA_OF_STRING (s
);
1783 /* Save the size of S in its sdata so that we know
1784 how large that is. Reset the sdata's string
1785 back-pointer so that we know it's free. */
1786 #ifdef GC_CHECK_STRING_BYTES
1787 if (string_bytes (s
) != SDATA_NBYTES (data
))
1790 data
->n
.nbytes
= STRING_BYTES (s
);
1792 data
->string
= NULL
;
1794 /* Reset the strings's `data' member so that we
1798 /* Put the string on the free-list. */
1799 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1800 string_free_list
= s
;
1806 /* S was on the free-list before. Put it there again. */
1807 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1808 string_free_list
= s
;
1813 /* Free blocks that contain free Lisp_Strings only, except
1814 the first two of them. */
1815 if (nfree
== STRING_BLOCK_SIZE
1816 && total_free_strings
> STRING_BLOCK_SIZE
)
1819 string_free_list
= free_list_before
;
1823 total_free_strings
+= nfree
;
1824 b
->next
= live_blocks
;
1829 check_string_free_list ();
1831 string_blocks
= live_blocks
;
1832 free_large_strings ();
1833 compact_small_strings ();
1835 check_string_free_list ();
1839 /* Free dead large strings. */
1842 free_large_strings (void)
1844 struct sblock
*b
, *next
;
1845 struct sblock
*live_blocks
= NULL
;
1847 for (b
= large_sblocks
; b
; b
= next
)
1851 if (b
->first_data
.string
== NULL
)
1855 b
->next
= live_blocks
;
1860 large_sblocks
= live_blocks
;
1864 /* Compact data of small strings. Free sblocks that don't contain
1865 data of live strings after compaction. */
1868 compact_small_strings (void)
1870 struct sblock
*b
, *tb
, *next
;
1871 sdata
*from
, *to
, *end
, *tb_end
;
1872 sdata
*to_end
, *from_end
;
1874 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1875 to, and TB_END is the end of TB. */
1877 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1878 to
= &tb
->first_data
;
1880 /* Step through the blocks from the oldest to the youngest. We
1881 expect that old blocks will stabilize over time, so that less
1882 copying will happen this way. */
1883 for (b
= oldest_sblock
; b
; b
= b
->next
)
1886 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1888 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1890 /* Compute the next FROM here because copying below may
1891 overwrite data we need to compute it. */
1893 struct Lisp_String
*s
= from
->string
;
1895 #ifdef GC_CHECK_STRING_BYTES
1896 /* Check that the string size recorded in the string is the
1897 same as the one recorded in the sdata structure. */
1898 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1900 #endif /* GC_CHECK_STRING_BYTES */
1902 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1903 eassert (nbytes
<= LARGE_STRING_BYTES
);
1905 nbytes
= SDATA_SIZE (nbytes
);
1906 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1908 #ifdef GC_CHECK_STRING_OVERRUN
1909 if (memcmp (string_overrun_cookie
,
1910 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1911 GC_STRING_OVERRUN_COOKIE_SIZE
))
1915 /* Non-NULL S means it's alive. Copy its data. */
1918 /* If TB is full, proceed with the next sblock. */
1919 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1920 if (to_end
> tb_end
)
1924 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1925 to
= &tb
->first_data
;
1926 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1929 /* Copy, and update the string's `data' pointer. */
1932 eassert (tb
!= b
|| to
< from
);
1933 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1934 to
->string
->data
= SDATA_DATA (to
);
1937 /* Advance past the sdata we copied to. */
1943 /* The rest of the sblocks following TB don't contain live data, so
1944 we can free them. */
1945 for (b
= tb
->next
; b
; b
= next
)
1953 current_sblock
= tb
;
1957 string_overflow (void)
1959 error ("Maximum string size exceeded");
1962 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1963 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1964 LENGTH must be an integer.
1965 INIT must be an integer that represents a character. */)
1966 (Lisp_Object length
, Lisp_Object init
)
1968 register Lisp_Object val
;
1969 register unsigned char *p
, *end
;
1973 CHECK_NATNUM (length
);
1974 CHECK_CHARACTER (init
);
1976 c
= XFASTINT (init
);
1977 if (ASCII_CHAR_P (c
))
1979 nbytes
= XINT (length
);
1980 val
= make_uninit_string (nbytes
);
1982 end
= p
+ SCHARS (val
);
1988 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1989 int len
= CHAR_STRING (c
, str
);
1990 EMACS_INT string_len
= XINT (length
);
1992 if (string_len
> STRING_BYTES_MAX
/ len
)
1994 nbytes
= len
* string_len
;
1995 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2000 memcpy (p
, str
, len
);
2010 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2011 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2012 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2013 (Lisp_Object length
, Lisp_Object init
)
2015 register Lisp_Object val
;
2016 struct Lisp_Bool_Vector
*p
;
2017 ptrdiff_t length_in_chars
;
2018 EMACS_INT length_in_elts
;
2020 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2023 CHECK_NATNUM (length
);
2025 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2027 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2029 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2031 /* No Lisp_Object to trace in there. */
2032 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2034 p
= XBOOL_VECTOR (val
);
2035 p
->size
= XFASTINT (length
);
2037 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2038 / BOOL_VECTOR_BITS_PER_CHAR
);
2039 if (length_in_chars
)
2041 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2043 /* Clear any extraneous bits in the last byte. */
2044 p
->data
[length_in_chars
- 1]
2045 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2052 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2053 of characters from the contents. This string may be unibyte or
2054 multibyte, depending on the contents. */
2057 make_string (const char *contents
, ptrdiff_t nbytes
)
2059 register Lisp_Object val
;
2060 ptrdiff_t nchars
, multibyte_nbytes
;
2062 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2063 &nchars
, &multibyte_nbytes
);
2064 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2065 /* CONTENTS contains no multibyte sequences or contains an invalid
2066 multibyte sequence. We must make unibyte string. */
2067 val
= make_unibyte_string (contents
, nbytes
);
2069 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2074 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2077 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2079 register Lisp_Object val
;
2080 val
= make_uninit_string (length
);
2081 memcpy (SDATA (val
), contents
, length
);
2086 /* Make a multibyte string from NCHARS characters occupying NBYTES
2087 bytes at CONTENTS. */
2090 make_multibyte_string (const char *contents
,
2091 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2093 register Lisp_Object val
;
2094 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2095 memcpy (SDATA (val
), contents
, nbytes
);
2100 /* Make a string from NCHARS characters occupying NBYTES bytes at
2101 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2104 make_string_from_bytes (const char *contents
,
2105 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2107 register Lisp_Object val
;
2108 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2109 memcpy (SDATA (val
), contents
, nbytes
);
2110 if (SBYTES (val
) == SCHARS (val
))
2111 STRING_SET_UNIBYTE (val
);
2116 /* Make a string from NCHARS characters occupying NBYTES bytes at
2117 CONTENTS. The argument MULTIBYTE controls whether to label the
2118 string as multibyte. If NCHARS is negative, it counts the number of
2119 characters by itself. */
2122 make_specified_string (const char *contents
,
2123 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2130 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2135 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2136 memcpy (SDATA (val
), contents
, nbytes
);
2138 STRING_SET_UNIBYTE (val
);
2143 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2144 occupying LENGTH bytes. */
2147 make_uninit_string (EMACS_INT length
)
2152 return empty_unibyte_string
;
2153 val
= make_uninit_multibyte_string (length
, length
);
2154 STRING_SET_UNIBYTE (val
);
2159 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2160 which occupy NBYTES bytes. */
2163 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2166 struct Lisp_String
*s
;
2171 return empty_multibyte_string
;
2173 s
= allocate_string ();
2174 s
->intervals
= NULL
;
2175 allocate_string_data (s
, nchars
, nbytes
);
2176 XSETSTRING (string
, s
);
2177 string_chars_consed
+= nbytes
;
2181 /* Print arguments to BUF according to a FORMAT, then return
2182 a Lisp_String initialized with the data from BUF. */
2185 make_formatted_string (char *buf
, const char *format
, ...)
2190 va_start (ap
, format
);
2191 length
= vsprintf (buf
, format
, ap
);
2193 return make_string (buf
, length
);
2197 /***********************************************************************
2199 ***********************************************************************/
2201 /* We store float cells inside of float_blocks, allocating a new
2202 float_block with malloc whenever necessary. Float cells reclaimed
2203 by GC are put on a free list to be reallocated before allocating
2204 any new float cells from the latest float_block. */
2206 #define FLOAT_BLOCK_SIZE \
2207 (((BLOCK_BYTES - sizeof (struct float_block *) \
2208 /* The compiler might add padding at the end. */ \
2209 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2210 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2212 #define GETMARKBIT(block,n) \
2213 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2214 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2217 #define SETMARKBIT(block,n) \
2218 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2219 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2221 #define UNSETMARKBIT(block,n) \
2222 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2223 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2225 #define FLOAT_BLOCK(fptr) \
2226 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2228 #define FLOAT_INDEX(fptr) \
2229 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2233 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2234 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2235 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2236 struct float_block
*next
;
2239 #define FLOAT_MARKED_P(fptr) \
2240 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2242 #define FLOAT_MARK(fptr) \
2243 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2245 #define FLOAT_UNMARK(fptr) \
2246 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2248 /* Current float_block. */
2250 static struct float_block
*float_block
;
2252 /* Index of first unused Lisp_Float in the current float_block. */
2254 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2256 /* Free-list of Lisp_Floats. */
2258 static struct Lisp_Float
*float_free_list
;
2260 /* Return a new float object with value FLOAT_VALUE. */
2263 make_float (double float_value
)
2265 register Lisp_Object val
;
2269 if (float_free_list
)
2271 /* We use the data field for chaining the free list
2272 so that we won't use the same field that has the mark bit. */
2273 XSETFLOAT (val
, float_free_list
);
2274 float_free_list
= float_free_list
->u
.chain
;
2278 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2280 struct float_block
*new
2281 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2282 new->next
= float_block
;
2283 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2285 float_block_index
= 0;
2286 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2288 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2289 float_block_index
++;
2292 MALLOC_UNBLOCK_INPUT
;
2294 XFLOAT_INIT (val
, float_value
);
2295 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2296 consing_since_gc
+= sizeof (struct Lisp_Float
);
2298 total_free_floats
--;
2304 /***********************************************************************
2306 ***********************************************************************/
2308 /* We store cons cells inside of cons_blocks, allocating a new
2309 cons_block with malloc whenever necessary. Cons cells reclaimed by
2310 GC are put on a free list to be reallocated before allocating
2311 any new cons cells from the latest cons_block. */
2313 #define CONS_BLOCK_SIZE \
2314 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2315 /* The compiler might add padding at the end. */ \
2316 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2317 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2319 #define CONS_BLOCK(fptr) \
2320 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2322 #define CONS_INDEX(fptr) \
2323 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2327 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2328 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2329 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2330 struct cons_block
*next
;
2333 #define CONS_MARKED_P(fptr) \
2334 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2336 #define CONS_MARK(fptr) \
2337 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2339 #define CONS_UNMARK(fptr) \
2340 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2342 /* Current cons_block. */
2344 static struct cons_block
*cons_block
;
2346 /* Index of first unused Lisp_Cons in the current block. */
2348 static int cons_block_index
= CONS_BLOCK_SIZE
;
2350 /* Free-list of Lisp_Cons structures. */
2352 static struct Lisp_Cons
*cons_free_list
;
2354 /* Explicitly free a cons cell by putting it on the free-list. */
2357 free_cons (struct Lisp_Cons
*ptr
)
2359 ptr
->u
.chain
= cons_free_list
;
2363 cons_free_list
= ptr
;
2364 consing_since_gc
-= sizeof *ptr
;
2365 total_free_conses
++;
2368 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2369 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2370 (Lisp_Object car
, Lisp_Object cdr
)
2372 register Lisp_Object val
;
2378 /* We use the cdr for chaining the free list
2379 so that we won't use the same field that has the mark bit. */
2380 XSETCONS (val
, cons_free_list
);
2381 cons_free_list
= cons_free_list
->u
.chain
;
2385 if (cons_block_index
== CONS_BLOCK_SIZE
)
2387 struct cons_block
*new
2388 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2389 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2390 new->next
= cons_block
;
2392 cons_block_index
= 0;
2393 total_free_conses
+= CONS_BLOCK_SIZE
;
2395 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2399 MALLOC_UNBLOCK_INPUT
;
2403 eassert (!CONS_MARKED_P (XCONS (val
)));
2404 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2405 total_free_conses
--;
2406 cons_cells_consed
++;
2410 #ifdef GC_CHECK_CONS_LIST
2411 /* Get an error now if there's any junk in the cons free list. */
2413 check_cons_list (void)
2415 struct Lisp_Cons
*tail
= cons_free_list
;
2418 tail
= tail
->u
.chain
;
2422 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2425 list1 (Lisp_Object arg1
)
2427 return Fcons (arg1
, Qnil
);
2431 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2433 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2438 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2440 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2445 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2447 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2452 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2454 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2455 Fcons (arg5
, Qnil
)))));
2458 /* Make a list of COUNT Lisp_Objects, where ARG is the
2459 first one. Allocate conses from pure space if TYPE
2460 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2463 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2467 Lisp_Object val
, *objp
;
2469 /* Change to SAFE_ALLOCA if you hit this eassert. */
2470 eassert (count
<= MAX_ALLOCA
/ word_size
);
2472 objp
= alloca (count
* word_size
);
2475 for (i
= 1; i
< count
; i
++)
2476 objp
[i
] = va_arg (ap
, Lisp_Object
);
2479 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2481 if (type
== CONSTYPE_PURE
)
2482 val
= pure_cons (objp
[i
], val
);
2483 else if (type
== CONSTYPE_HEAP
)
2484 val
= Fcons (objp
[i
], val
);
2491 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2492 doc
: /* Return a newly created list with specified arguments as elements.
2493 Any number of arguments, even zero arguments, are allowed.
2494 usage: (list &rest OBJECTS) */)
2495 (ptrdiff_t nargs
, Lisp_Object
*args
)
2497 register Lisp_Object val
;
2503 val
= Fcons (args
[nargs
], val
);
2509 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2510 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2511 (register Lisp_Object length
, Lisp_Object init
)
2513 register Lisp_Object val
;
2514 register EMACS_INT size
;
2516 CHECK_NATNUM (length
);
2517 size
= XFASTINT (length
);
2522 val
= Fcons (init
, val
);
2527 val
= Fcons (init
, val
);
2532 val
= Fcons (init
, val
);
2537 val
= Fcons (init
, val
);
2542 val
= Fcons (init
, val
);
2557 /***********************************************************************
2559 ***********************************************************************/
2561 /* This value is balanced well enough to avoid too much internal overhead
2562 for the most common cases; it's not required to be a power of two, but
2563 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2565 #define VECTOR_BLOCK_SIZE 4096
2567 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2570 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2573 /* ROUNDUP_SIZE must be a power of 2. */
2574 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2576 /* Verify assumptions described above. */
2577 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2578 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2580 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2582 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2584 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2586 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2588 /* Size of the minimal vector allocated from block. */
2590 #define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
2592 /* Size of the largest vector allocated from block. */
2594 #define VBLOCK_BYTES_MAX \
2595 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2597 /* We maintain one free list for each possible block-allocated
2598 vector size, and this is the number of free lists we have. */
2600 #define VECTOR_MAX_FREE_LIST_INDEX \
2601 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2603 /* Common shortcut to advance vector pointer over a block data. */
2605 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2607 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2609 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2611 /* Get and set the next field in block-allocated vectorlike objects on
2612 the free list. Doing it this way respects C's aliasing rules.
2613 We could instead make 'contents' a union, but that would mean
2614 changes everywhere that the code uses 'contents'. */
2615 static struct Lisp_Vector
*
2616 next_in_free_list (struct Lisp_Vector
*v
)
2618 intptr_t i
= XLI (v
->contents
[0]);
2619 return (struct Lisp_Vector
*) i
;
2622 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2624 v
->contents
[0] = XIL ((intptr_t) next
);
2627 /* Common shortcut to setup vector on a free list. */
2629 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2631 (tmp) = ((nbytes - header_size) / word_size); \
2632 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2633 eassert ((nbytes) % roundup_size == 0); \
2634 (tmp) = VINDEX (nbytes); \
2635 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2636 set_next_in_free_list (v, vector_free_lists[tmp]); \
2637 vector_free_lists[tmp] = (v); \
2638 total_free_vector_slots += (nbytes) / word_size; \
2641 /* This internal type is used to maintain the list of large vectors
2642 which are allocated at their own, e.g. outside of vector blocks. */
2647 struct large_vector
*vector
;
2649 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2650 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2653 struct Lisp_Vector v
;
2656 /* This internal type is used to maintain an underlying storage
2657 for small vectors. */
2661 char data
[VECTOR_BLOCK_BYTES
];
2662 struct vector_block
*next
;
2665 /* Chain of vector blocks. */
2667 static struct vector_block
*vector_blocks
;
2669 /* Vector free lists, where NTH item points to a chain of free
2670 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2672 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2674 /* Singly-linked list of large vectors. */
2676 static struct large_vector
*large_vectors
;
2678 /* The only vector with 0 slots, allocated from pure space. */
2680 Lisp_Object zero_vector
;
2682 /* Number of live vectors. */
2684 static EMACS_INT total_vectors
;
2686 /* Total size of live and free vectors, in Lisp_Object units. */
2688 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2690 /* Get a new vector block. */
2692 static struct vector_block
*
2693 allocate_vector_block (void)
2695 struct vector_block
*block
= xmalloc (sizeof *block
);
2697 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2698 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2699 MEM_TYPE_VECTOR_BLOCK
);
2702 block
->next
= vector_blocks
;
2703 vector_blocks
= block
;
2707 /* Called once to initialize vector allocation. */
2712 zero_vector
= make_pure_vector (0);
2715 /* Allocate vector from a vector block. */
2717 static struct Lisp_Vector
*
2718 allocate_vector_from_block (size_t nbytes
)
2720 struct Lisp_Vector
*vector
;
2721 struct vector_block
*block
;
2722 size_t index
, restbytes
;
2724 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2725 eassert (nbytes
% roundup_size
== 0);
2727 /* First, try to allocate from a free list
2728 containing vectors of the requested size. */
2729 index
= VINDEX (nbytes
);
2730 if (vector_free_lists
[index
])
2732 vector
= vector_free_lists
[index
];
2733 vector_free_lists
[index
] = next_in_free_list (vector
);
2734 total_free_vector_slots
-= nbytes
/ word_size
;
2738 /* Next, check free lists containing larger vectors. Since
2739 we will split the result, we should have remaining space
2740 large enough to use for one-slot vector at least. */
2741 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2742 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2743 if (vector_free_lists
[index
])
2745 /* This vector is larger than requested. */
2746 vector
= vector_free_lists
[index
];
2747 vector_free_lists
[index
] = next_in_free_list (vector
);
2748 total_free_vector_slots
-= nbytes
/ word_size
;
2750 /* Excess bytes are used for the smaller vector,
2751 which should be set on an appropriate free list. */
2752 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2753 eassert (restbytes
% roundup_size
== 0);
2754 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2758 /* Finally, need a new vector block. */
2759 block
= allocate_vector_block ();
2761 /* New vector will be at the beginning of this block. */
2762 vector
= (struct Lisp_Vector
*) block
->data
;
2764 /* If the rest of space from this block is large enough
2765 for one-slot vector at least, set up it on a free list. */
2766 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2767 if (restbytes
>= VBLOCK_BYTES_MIN
)
2769 eassert (restbytes
% roundup_size
== 0);
2770 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2775 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2777 #define VECTOR_IN_BLOCK(vector, block) \
2778 ((char *) (vector) <= (block)->data \
2779 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2781 /* Return the memory footprint of V in bytes. */
2784 vector_nbytes (struct Lisp_Vector
*v
)
2786 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2788 if (size
& PSEUDOVECTOR_FLAG
)
2790 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2791 size
= (bool_header_size
2792 + (((struct Lisp_Bool_Vector
*) v
)->size
2793 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2794 / BOOL_VECTOR_BITS_PER_CHAR
);
2797 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2798 + ((size
& PSEUDOVECTOR_REST_MASK
)
2799 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2802 size
= header_size
+ size
* word_size
;
2803 return vroundup (size
);
2806 /* Reclaim space used by unmarked vectors. */
2809 sweep_vectors (void)
2811 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2812 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2813 struct Lisp_Vector
*vector
, *next
;
2815 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2816 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2818 /* Looking through vector blocks. */
2820 for (block
= vector_blocks
; block
; block
= *bprev
)
2822 bool free_this_block
= 0;
2825 for (vector
= (struct Lisp_Vector
*) block
->data
;
2826 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2828 if (VECTOR_MARKED_P (vector
))
2830 VECTOR_UNMARK (vector
);
2832 nbytes
= vector_nbytes (vector
);
2833 total_vector_slots
+= nbytes
/ word_size
;
2834 next
= ADVANCE (vector
, nbytes
);
2838 ptrdiff_t total_bytes
;
2840 nbytes
= vector_nbytes (vector
);
2841 total_bytes
= nbytes
;
2842 next
= ADVANCE (vector
, nbytes
);
2844 /* While NEXT is not marked, try to coalesce with VECTOR,
2845 thus making VECTOR of the largest possible size. */
2847 while (VECTOR_IN_BLOCK (next
, block
))
2849 if (VECTOR_MARKED_P (next
))
2851 nbytes
= vector_nbytes (next
);
2852 total_bytes
+= nbytes
;
2853 next
= ADVANCE (next
, nbytes
);
2856 eassert (total_bytes
% roundup_size
== 0);
2858 if (vector
== (struct Lisp_Vector
*) block
->data
2859 && !VECTOR_IN_BLOCK (next
, block
))
2860 /* This block should be freed because all of it's
2861 space was coalesced into the only free vector. */
2862 free_this_block
= 1;
2866 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2871 if (free_this_block
)
2873 *bprev
= block
->next
;
2874 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2875 mem_delete (mem_find (block
->data
));
2880 bprev
= &block
->next
;
2883 /* Sweep large vectors. */
2885 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2888 if (VECTOR_MARKED_P (vector
))
2890 VECTOR_UNMARK (vector
);
2892 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2894 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2896 /* All non-bool pseudovectors are small enough to be allocated
2897 from vector blocks. This code should be redesigned if some
2898 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2899 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2902 += (bool_header_size
2903 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2904 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2908 += header_size
/ word_size
+ vector
->header
.size
;
2909 lvprev
= &lv
->next
.vector
;
2913 *lvprev
= lv
->next
.vector
;
2919 /* Value is a pointer to a newly allocated Lisp_Vector structure
2920 with room for LEN Lisp_Objects. */
2922 static struct Lisp_Vector
*
2923 allocate_vectorlike (ptrdiff_t len
)
2925 struct Lisp_Vector
*p
;
2930 p
= XVECTOR (zero_vector
);
2933 size_t nbytes
= header_size
+ len
* word_size
;
2935 #ifdef DOUG_LEA_MALLOC
2936 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2937 because mapped region contents are not preserved in
2939 mallopt (M_MMAP_MAX
, 0);
2942 if (nbytes
<= VBLOCK_BYTES_MAX
)
2943 p
= allocate_vector_from_block (vroundup (nbytes
));
2946 struct large_vector
*lv
2947 = lisp_malloc ((offsetof (struct large_vector
, v
.contents
)
2949 MEM_TYPE_VECTORLIKE
);
2950 lv
->next
.vector
= large_vectors
;
2955 #ifdef DOUG_LEA_MALLOC
2956 /* Back to a reasonable maximum of mmap'ed areas. */
2957 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2960 consing_since_gc
+= nbytes
;
2961 vector_cells_consed
+= len
;
2964 MALLOC_UNBLOCK_INPUT
;
2970 /* Allocate a vector with LEN slots. */
2972 struct Lisp_Vector
*
2973 allocate_vector (EMACS_INT len
)
2975 struct Lisp_Vector
*v
;
2976 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2978 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2979 memory_full (SIZE_MAX
);
2980 v
= allocate_vectorlike (len
);
2981 v
->header
.size
= len
;
2986 /* Allocate other vector-like structures. */
2988 struct Lisp_Vector
*
2989 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2991 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2994 /* Catch bogus values. */
2995 eassert (tag
<= PVEC_FONT
);
2996 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2997 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2999 /* Only the first lisplen slots will be traced normally by the GC. */
3000 for (i
= 0; i
< lisplen
; ++i
)
3001 v
->contents
[i
] = Qnil
;
3003 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3008 allocate_buffer (void)
3010 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3012 BUFFER_PVEC_INIT (b
);
3013 /* Put B on the chain of all buffers including killed ones. */
3014 b
->next
= all_buffers
;
3016 /* Note that the rest fields of B are not initialized. */
3020 struct Lisp_Hash_Table
*
3021 allocate_hash_table (void)
3023 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3027 allocate_window (void)
3031 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3032 /* Users assumes that non-Lisp data is zeroed. */
3033 memset (&w
->current_matrix
, 0,
3034 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3039 allocate_terminal (void)
3043 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3044 /* Users assumes that non-Lisp data is zeroed. */
3045 memset (&t
->next_terminal
, 0,
3046 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3051 allocate_frame (void)
3055 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3056 /* Users assumes that non-Lisp data is zeroed. */
3057 memset (&f
->face_cache
, 0,
3058 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3062 struct Lisp_Process
*
3063 allocate_process (void)
3065 struct Lisp_Process
*p
;
3067 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3068 /* Users assumes that non-Lisp data is zeroed. */
3070 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3074 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3075 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3076 See also the function `vector'. */)
3077 (register Lisp_Object length
, Lisp_Object init
)
3080 register ptrdiff_t sizei
;
3081 register ptrdiff_t i
;
3082 register struct Lisp_Vector
*p
;
3084 CHECK_NATNUM (length
);
3086 p
= allocate_vector (XFASTINT (length
));
3087 sizei
= XFASTINT (length
);
3088 for (i
= 0; i
< sizei
; i
++)
3089 p
->contents
[i
] = init
;
3091 XSETVECTOR (vector
, p
);
3096 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3097 doc
: /* Return a newly created vector with specified arguments as elements.
3098 Any number of arguments, even zero arguments, are allowed.
3099 usage: (vector &rest OBJECTS) */)
3100 (ptrdiff_t nargs
, Lisp_Object
*args
)
3103 register Lisp_Object val
= make_uninit_vector (nargs
);
3104 register struct Lisp_Vector
*p
= XVECTOR (val
);
3106 for (i
= 0; i
< nargs
; i
++)
3107 p
->contents
[i
] = args
[i
];
3112 make_byte_code (struct Lisp_Vector
*v
)
3114 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3115 && STRING_MULTIBYTE (v
->contents
[1]))
3116 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3117 earlier because they produced a raw 8-bit string for byte-code
3118 and now such a byte-code string is loaded as multibyte while
3119 raw 8-bit characters converted to multibyte form. Thus, now we
3120 must convert them back to the original unibyte form. */
3121 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3122 XSETPVECTYPE (v
, PVEC_COMPILED
);
3125 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3126 doc
: /* Create a byte-code object with specified arguments as elements.
3127 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3128 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3129 and (optional) INTERACTIVE-SPEC.
3130 The first four arguments are required; at most six have any
3132 The ARGLIST can be either like the one of `lambda', in which case the arguments
3133 will be dynamically bound before executing the byte code, or it can be an
3134 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3135 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3136 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3137 argument to catch the left-over arguments. If such an integer is used, the
3138 arguments will not be dynamically bound but will be instead pushed on the
3139 stack before executing the byte-code.
3140 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3141 (ptrdiff_t nargs
, Lisp_Object
*args
)
3144 register Lisp_Object val
= make_uninit_vector (nargs
);
3145 register struct Lisp_Vector
*p
= XVECTOR (val
);
3147 /* We used to purecopy everything here, if purify-flag was set. This worked
3148 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3149 dangerous, since make-byte-code is used during execution to build
3150 closures, so any closure built during the preload phase would end up
3151 copied into pure space, including its free variables, which is sometimes
3152 just wasteful and other times plainly wrong (e.g. those free vars may want
3155 for (i
= 0; i
< nargs
; i
++)
3156 p
->contents
[i
] = args
[i
];
3158 XSETCOMPILED (val
, p
);
3164 /***********************************************************************
3166 ***********************************************************************/
3168 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3169 of the required alignment if LSB tags are used. */
3171 union aligned_Lisp_Symbol
3173 struct Lisp_Symbol s
;
3175 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3180 /* Each symbol_block is just under 1020 bytes long, since malloc
3181 really allocates in units of powers of two and uses 4 bytes for its
3184 #define SYMBOL_BLOCK_SIZE \
3185 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3189 /* Place `symbols' first, to preserve alignment. */
3190 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3191 struct symbol_block
*next
;
3194 /* Current symbol block and index of first unused Lisp_Symbol
3197 static struct symbol_block
*symbol_block
;
3198 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3200 /* List of free symbols. */
3202 static struct Lisp_Symbol
*symbol_free_list
;
3205 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3207 XSYMBOL (sym
)->name
= name
;
3210 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3211 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3212 Its value is void, and its function definition and property list are nil. */)
3215 register Lisp_Object val
;
3216 register struct Lisp_Symbol
*p
;
3218 CHECK_STRING (name
);
3222 if (symbol_free_list
)
3224 XSETSYMBOL (val
, symbol_free_list
);
3225 symbol_free_list
= symbol_free_list
->next
;
3229 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3231 struct symbol_block
*new
3232 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3233 new->next
= symbol_block
;
3235 symbol_block_index
= 0;
3236 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3238 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3239 symbol_block_index
++;
3242 MALLOC_UNBLOCK_INPUT
;
3245 set_symbol_name (val
, name
);
3246 set_symbol_plist (val
, Qnil
);
3247 p
->redirect
= SYMBOL_PLAINVAL
;
3248 SET_SYMBOL_VAL (p
, Qunbound
);
3249 set_symbol_function (val
, Qnil
);
3250 set_symbol_next (val
, NULL
);
3252 p
->interned
= SYMBOL_UNINTERNED
;
3254 p
->declared_special
= 0;
3255 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3257 total_free_symbols
--;
3263 /***********************************************************************
3264 Marker (Misc) Allocation
3265 ***********************************************************************/
3267 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3268 the required alignment when LSB tags are used. */
3270 union aligned_Lisp_Misc
3274 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3279 /* Allocation of markers and other objects that share that structure.
3280 Works like allocation of conses. */
3282 #define MARKER_BLOCK_SIZE \
3283 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3287 /* Place `markers' first, to preserve alignment. */
3288 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3289 struct marker_block
*next
;
3292 static struct marker_block
*marker_block
;
3293 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3295 static union Lisp_Misc
*marker_free_list
;
3297 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3300 allocate_misc (enum Lisp_Misc_Type type
)
3306 if (marker_free_list
)
3308 XSETMISC (val
, marker_free_list
);
3309 marker_free_list
= marker_free_list
->u_free
.chain
;
3313 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3315 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3316 new->next
= marker_block
;
3318 marker_block_index
= 0;
3319 total_free_markers
+= MARKER_BLOCK_SIZE
;
3321 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3322 marker_block_index
++;
3325 MALLOC_UNBLOCK_INPUT
;
3327 --total_free_markers
;
3328 consing_since_gc
+= sizeof (union Lisp_Misc
);
3329 misc_objects_consed
++;
3330 XMISCANY (val
)->type
= type
;
3331 XMISCANY (val
)->gcmarkbit
= 0;
3335 /* Free a Lisp_Misc object. */
3338 free_misc (Lisp_Object misc
)
3340 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3341 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3342 marker_free_list
= XMISC (misc
);
3343 consing_since_gc
-= sizeof (union Lisp_Misc
);
3344 total_free_markers
++;
3347 /* Verify properties of Lisp_Save_Value's representation
3348 that are assumed here and elsewhere. */
3350 verify (SAVE_UNUSED
== 0);
3351 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3355 /* Return a Lisp_Save_Value object with the data saved according to
3356 DATA_TYPE. DATA_TYPE should be one of SAVE_TYPE_INT_INT, etc. */
3359 make_save_value (enum Lisp_Save_Type save_type
, ...)
3363 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3364 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3366 eassert (0 < save_type
3367 && (save_type
< 1 << (SAVE_TYPE_BITS
- 1)
3368 || save_type
== SAVE_TYPE_MEMORY
));
3369 p
->save_type
= save_type
;
3370 va_start (ap
, save_type
);
3371 save_type
&= ~ (1 << (SAVE_TYPE_BITS
- 1));
3373 for (i
= 0; save_type
; i
++, save_type
>>= SAVE_SLOT_BITS
)
3374 switch (save_type
& ((1 << SAVE_SLOT_BITS
) - 1))
3377 p
->data
[i
].pointer
= va_arg (ap
, void *);
3380 case SAVE_FUNCPOINTER
:
3381 p
->data
[i
].funcpointer
= va_arg (ap
, voidfuncptr
);
3385 p
->data
[i
].integer
= va_arg (ap
, ptrdiff_t);
3389 p
->data
[i
].object
= va_arg (ap
, Lisp_Object
);
3400 /* The most common task it to save just one C pointer. */
3403 make_save_pointer (void *pointer
)
3405 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3406 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3407 p
->save_type
= SAVE_POINTER
;
3408 p
->data
[0].pointer
= pointer
;
3412 /* Free a Lisp_Save_Value object. Do not use this function
3413 if SAVE contains pointer other than returned by xmalloc. */
3416 free_save_value (Lisp_Object save
)
3418 xfree (XSAVE_POINTER (save
, 0));
3422 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3425 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3427 register Lisp_Object overlay
;
3429 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3430 OVERLAY_START (overlay
) = start
;
3431 OVERLAY_END (overlay
) = end
;
3432 set_overlay_plist (overlay
, plist
);
3433 XOVERLAY (overlay
)->next
= NULL
;
3437 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3438 doc
: /* Return a newly allocated marker which does not point at any place. */)
3441 register Lisp_Object val
;
3442 register struct Lisp_Marker
*p
;
3444 val
= allocate_misc (Lisp_Misc_Marker
);
3450 p
->insertion_type
= 0;
3454 /* Return a newly allocated marker which points into BUF
3455 at character position CHARPOS and byte position BYTEPOS. */
3458 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3461 struct Lisp_Marker
*m
;
3463 /* No dead buffers here. */
3464 eassert (BUFFER_LIVE_P (buf
));
3466 /* Every character is at least one byte. */
3467 eassert (charpos
<= bytepos
);
3469 obj
= allocate_misc (Lisp_Misc_Marker
);
3472 m
->charpos
= charpos
;
3473 m
->bytepos
= bytepos
;
3474 m
->insertion_type
= 0;
3475 m
->next
= BUF_MARKERS (buf
);
3476 BUF_MARKERS (buf
) = m
;
3480 /* Put MARKER back on the free list after using it temporarily. */
3483 free_marker (Lisp_Object marker
)
3485 unchain_marker (XMARKER (marker
));
3490 /* Return a newly created vector or string with specified arguments as
3491 elements. If all the arguments are characters that can fit
3492 in a string of events, make a string; otherwise, make a vector.
3494 Any number of arguments, even zero arguments, are allowed. */
3497 make_event_array (register int nargs
, Lisp_Object
*args
)
3501 for (i
= 0; i
< nargs
; i
++)
3502 /* The things that fit in a string
3503 are characters that are in 0...127,
3504 after discarding the meta bit and all the bits above it. */
3505 if (!INTEGERP (args
[i
])
3506 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3507 return Fvector (nargs
, args
);
3509 /* Since the loop exited, we know that all the things in it are
3510 characters, so we can make a string. */
3514 result
= Fmake_string (make_number (nargs
), make_number (0));
3515 for (i
= 0; i
< nargs
; i
++)
3517 SSET (result
, i
, XINT (args
[i
]));
3518 /* Move the meta bit to the right place for a string char. */
3519 if (XINT (args
[i
]) & CHAR_META
)
3520 SSET (result
, i
, SREF (result
, i
) | 0x80);
3529 /************************************************************************
3530 Memory Full Handling
3531 ************************************************************************/
3534 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3535 there may have been size_t overflow so that malloc was never
3536 called, or perhaps malloc was invoked successfully but the
3537 resulting pointer had problems fitting into a tagged EMACS_INT. In
3538 either case this counts as memory being full even though malloc did
3542 memory_full (size_t nbytes
)
3544 /* Do not go into hysterics merely because a large request failed. */
3545 bool enough_free_memory
= 0;
3546 if (SPARE_MEMORY
< nbytes
)
3551 p
= malloc (SPARE_MEMORY
);
3555 enough_free_memory
= 1;
3557 MALLOC_UNBLOCK_INPUT
;
3560 if (! enough_free_memory
)
3566 memory_full_cons_threshold
= sizeof (struct cons_block
);
3568 /* The first time we get here, free the spare memory. */
3569 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3570 if (spare_memory
[i
])
3573 free (spare_memory
[i
]);
3574 else if (i
>= 1 && i
<= 4)
3575 lisp_align_free (spare_memory
[i
]);
3577 lisp_free (spare_memory
[i
]);
3578 spare_memory
[i
] = 0;
3582 /* This used to call error, but if we've run out of memory, we could
3583 get infinite recursion trying to build the string. */
3584 xsignal (Qnil
, Vmemory_signal_data
);
3587 /* If we released our reserve (due to running out of memory),
3588 and we have a fair amount free once again,
3589 try to set aside another reserve in case we run out once more.
3591 This is called when a relocatable block is freed in ralloc.c,
3592 and also directly from this file, in case we're not using ralloc.c. */
3595 refill_memory_reserve (void)
3597 #ifndef SYSTEM_MALLOC
3598 if (spare_memory
[0] == 0)
3599 spare_memory
[0] = malloc (SPARE_MEMORY
);
3600 if (spare_memory
[1] == 0)
3601 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3603 if (spare_memory
[2] == 0)
3604 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3606 if (spare_memory
[3] == 0)
3607 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3609 if (spare_memory
[4] == 0)
3610 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3612 if (spare_memory
[5] == 0)
3613 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3615 if (spare_memory
[6] == 0)
3616 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3618 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3619 Vmemory_full
= Qnil
;
3623 /************************************************************************
3625 ************************************************************************/
3627 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3629 /* Conservative C stack marking requires a method to identify possibly
3630 live Lisp objects given a pointer value. We do this by keeping
3631 track of blocks of Lisp data that are allocated in a red-black tree
3632 (see also the comment of mem_node which is the type of nodes in
3633 that tree). Function lisp_malloc adds information for an allocated
3634 block to the red-black tree with calls to mem_insert, and function
3635 lisp_free removes it with mem_delete. Functions live_string_p etc
3636 call mem_find to lookup information about a given pointer in the
3637 tree, and use that to determine if the pointer points to a Lisp
3640 /* Initialize this part of alloc.c. */
3645 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3646 mem_z
.parent
= NULL
;
3647 mem_z
.color
= MEM_BLACK
;
3648 mem_z
.start
= mem_z
.end
= NULL
;
3653 /* Value is a pointer to the mem_node containing START. Value is
3654 MEM_NIL if there is no node in the tree containing START. */
3656 static struct mem_node
*
3657 mem_find (void *start
)
3661 if (start
< min_heap_address
|| start
> max_heap_address
)
3664 /* Make the search always successful to speed up the loop below. */
3665 mem_z
.start
= start
;
3666 mem_z
.end
= (char *) start
+ 1;
3669 while (start
< p
->start
|| start
>= p
->end
)
3670 p
= start
< p
->start
? p
->left
: p
->right
;
3675 /* Insert a new node into the tree for a block of memory with start
3676 address START, end address END, and type TYPE. Value is a
3677 pointer to the node that was inserted. */
3679 static struct mem_node
*
3680 mem_insert (void *start
, void *end
, enum mem_type type
)
3682 struct mem_node
*c
, *parent
, *x
;
3684 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3685 min_heap_address
= start
;
3686 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3687 max_heap_address
= end
;
3689 /* See where in the tree a node for START belongs. In this
3690 particular application, it shouldn't happen that a node is already
3691 present. For debugging purposes, let's check that. */
3695 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3697 while (c
!= MEM_NIL
)
3699 if (start
>= c
->start
&& start
< c
->end
)
3702 c
= start
< c
->start
? c
->left
: c
->right
;
3705 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3707 while (c
!= MEM_NIL
)
3710 c
= start
< c
->start
? c
->left
: c
->right
;
3713 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3715 /* Create a new node. */
3716 #ifdef GC_MALLOC_CHECK
3717 x
= malloc (sizeof *x
);
3721 x
= xmalloc (sizeof *x
);
3727 x
->left
= x
->right
= MEM_NIL
;
3730 /* Insert it as child of PARENT or install it as root. */
3733 if (start
< parent
->start
)
3741 /* Re-establish red-black tree properties. */
3742 mem_insert_fixup (x
);
3748 /* Re-establish the red-black properties of the tree, and thereby
3749 balance the tree, after node X has been inserted; X is always red. */
3752 mem_insert_fixup (struct mem_node
*x
)
3754 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3756 /* X is red and its parent is red. This is a violation of
3757 red-black tree property #3. */
3759 if (x
->parent
== x
->parent
->parent
->left
)
3761 /* We're on the left side of our grandparent, and Y is our
3763 struct mem_node
*y
= x
->parent
->parent
->right
;
3765 if (y
->color
== MEM_RED
)
3767 /* Uncle and parent are red but should be black because
3768 X is red. Change the colors accordingly and proceed
3769 with the grandparent. */
3770 x
->parent
->color
= MEM_BLACK
;
3771 y
->color
= MEM_BLACK
;
3772 x
->parent
->parent
->color
= MEM_RED
;
3773 x
= x
->parent
->parent
;
3777 /* Parent and uncle have different colors; parent is
3778 red, uncle is black. */
3779 if (x
== x
->parent
->right
)
3782 mem_rotate_left (x
);
3785 x
->parent
->color
= MEM_BLACK
;
3786 x
->parent
->parent
->color
= MEM_RED
;
3787 mem_rotate_right (x
->parent
->parent
);
3792 /* This is the symmetrical case of above. */
3793 struct mem_node
*y
= x
->parent
->parent
->left
;
3795 if (y
->color
== MEM_RED
)
3797 x
->parent
->color
= MEM_BLACK
;
3798 y
->color
= MEM_BLACK
;
3799 x
->parent
->parent
->color
= MEM_RED
;
3800 x
= x
->parent
->parent
;
3804 if (x
== x
->parent
->left
)
3807 mem_rotate_right (x
);
3810 x
->parent
->color
= MEM_BLACK
;
3811 x
->parent
->parent
->color
= MEM_RED
;
3812 mem_rotate_left (x
->parent
->parent
);
3817 /* The root may have been changed to red due to the algorithm. Set
3818 it to black so that property #5 is satisfied. */
3819 mem_root
->color
= MEM_BLACK
;
3830 mem_rotate_left (struct mem_node
*x
)
3834 /* Turn y's left sub-tree into x's right sub-tree. */
3837 if (y
->left
!= MEM_NIL
)
3838 y
->left
->parent
= x
;
3840 /* Y's parent was x's parent. */
3842 y
->parent
= x
->parent
;
3844 /* Get the parent to point to y instead of x. */
3847 if (x
== x
->parent
->left
)
3848 x
->parent
->left
= y
;
3850 x
->parent
->right
= y
;
3855 /* Put x on y's left. */
3869 mem_rotate_right (struct mem_node
*x
)
3871 struct mem_node
*y
= x
->left
;
3874 if (y
->right
!= MEM_NIL
)
3875 y
->right
->parent
= x
;
3878 y
->parent
= x
->parent
;
3881 if (x
== x
->parent
->right
)
3882 x
->parent
->right
= y
;
3884 x
->parent
->left
= y
;
3895 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3898 mem_delete (struct mem_node
*z
)
3900 struct mem_node
*x
, *y
;
3902 if (!z
|| z
== MEM_NIL
)
3905 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3910 while (y
->left
!= MEM_NIL
)
3914 if (y
->left
!= MEM_NIL
)
3919 x
->parent
= y
->parent
;
3922 if (y
== y
->parent
->left
)
3923 y
->parent
->left
= x
;
3925 y
->parent
->right
= x
;
3932 z
->start
= y
->start
;
3937 if (y
->color
== MEM_BLACK
)
3938 mem_delete_fixup (x
);
3940 #ifdef GC_MALLOC_CHECK
3948 /* Re-establish the red-black properties of the tree, after a
3952 mem_delete_fixup (struct mem_node
*x
)
3954 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3956 if (x
== x
->parent
->left
)
3958 struct mem_node
*w
= x
->parent
->right
;
3960 if (w
->color
== MEM_RED
)
3962 w
->color
= MEM_BLACK
;
3963 x
->parent
->color
= MEM_RED
;
3964 mem_rotate_left (x
->parent
);
3965 w
= x
->parent
->right
;
3968 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3975 if (w
->right
->color
== MEM_BLACK
)
3977 w
->left
->color
= MEM_BLACK
;
3979 mem_rotate_right (w
);
3980 w
= x
->parent
->right
;
3982 w
->color
= x
->parent
->color
;
3983 x
->parent
->color
= MEM_BLACK
;
3984 w
->right
->color
= MEM_BLACK
;
3985 mem_rotate_left (x
->parent
);
3991 struct mem_node
*w
= x
->parent
->left
;
3993 if (w
->color
== MEM_RED
)
3995 w
->color
= MEM_BLACK
;
3996 x
->parent
->color
= MEM_RED
;
3997 mem_rotate_right (x
->parent
);
3998 w
= x
->parent
->left
;
4001 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4008 if (w
->left
->color
== MEM_BLACK
)
4010 w
->right
->color
= MEM_BLACK
;
4012 mem_rotate_left (w
);
4013 w
= x
->parent
->left
;
4016 w
->color
= x
->parent
->color
;
4017 x
->parent
->color
= MEM_BLACK
;
4018 w
->left
->color
= MEM_BLACK
;
4019 mem_rotate_right (x
->parent
);
4025 x
->color
= MEM_BLACK
;
4029 /* Value is non-zero if P is a pointer to a live Lisp string on
4030 the heap. M is a pointer to the mem_block for P. */
4033 live_string_p (struct mem_node
*m
, void *p
)
4035 if (m
->type
== MEM_TYPE_STRING
)
4037 struct string_block
*b
= (struct string_block
*) m
->start
;
4038 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4040 /* P must point to the start of a Lisp_String structure, and it
4041 must not be on the free-list. */
4043 && offset
% sizeof b
->strings
[0] == 0
4044 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4045 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4052 /* Value is non-zero if P is a pointer to a live Lisp cons on
4053 the heap. M is a pointer to the mem_block for P. */
4056 live_cons_p (struct mem_node
*m
, void *p
)
4058 if (m
->type
== MEM_TYPE_CONS
)
4060 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4061 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4063 /* P must point to the start of a Lisp_Cons, not be
4064 one of the unused cells in the current cons block,
4065 and not be on the free-list. */
4067 && offset
% sizeof b
->conses
[0] == 0
4068 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4070 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4071 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4078 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4079 the heap. M is a pointer to the mem_block for P. */
4082 live_symbol_p (struct mem_node
*m
, void *p
)
4084 if (m
->type
== MEM_TYPE_SYMBOL
)
4086 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4087 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4089 /* P must point to the start of a Lisp_Symbol, not be
4090 one of the unused cells in the current symbol block,
4091 and not be on the free-list. */
4093 && offset
% sizeof b
->symbols
[0] == 0
4094 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4095 && (b
!= symbol_block
4096 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4097 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4104 /* Value is non-zero if P is a pointer to a live Lisp float on
4105 the heap. M is a pointer to the mem_block for P. */
4108 live_float_p (struct mem_node
*m
, void *p
)
4110 if (m
->type
== MEM_TYPE_FLOAT
)
4112 struct float_block
*b
= (struct float_block
*) m
->start
;
4113 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4115 /* P must point to the start of a Lisp_Float and not be
4116 one of the unused cells in the current float block. */
4118 && offset
% sizeof b
->floats
[0] == 0
4119 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4120 && (b
!= float_block
4121 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4128 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4129 the heap. M is a pointer to the mem_block for P. */
4132 live_misc_p (struct mem_node
*m
, void *p
)
4134 if (m
->type
== MEM_TYPE_MISC
)
4136 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4137 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4139 /* P must point to the start of a Lisp_Misc, not be
4140 one of the unused cells in the current misc block,
4141 and not be on the free-list. */
4143 && offset
% sizeof b
->markers
[0] == 0
4144 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4145 && (b
!= marker_block
4146 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4147 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4154 /* Value is non-zero if P is a pointer to a live vector-like object.
4155 M is a pointer to the mem_block for P. */
4158 live_vector_p (struct mem_node
*m
, void *p
)
4160 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4162 /* This memory node corresponds to a vector block. */
4163 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4164 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4166 /* P is in the block's allocation range. Scan the block
4167 up to P and see whether P points to the start of some
4168 vector which is not on a free list. FIXME: check whether
4169 some allocation patterns (probably a lot of short vectors)
4170 may cause a substantial overhead of this loop. */
4171 while (VECTOR_IN_BLOCK (vector
, block
)
4172 && vector
<= (struct Lisp_Vector
*) p
)
4174 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4177 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4180 else if (m
->type
== MEM_TYPE_VECTORLIKE
4181 && (char *) p
== ((char *) m
->start
4182 + offsetof (struct large_vector
, v
)))
4183 /* This memory node corresponds to a large vector. */
4189 /* Value is non-zero if P is a pointer to a live buffer. M is a
4190 pointer to the mem_block for P. */
4193 live_buffer_p (struct mem_node
*m
, void *p
)
4195 /* P must point to the start of the block, and the buffer
4196 must not have been killed. */
4197 return (m
->type
== MEM_TYPE_BUFFER
4199 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4202 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4206 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4208 /* Array of objects that are kept alive because the C stack contains
4209 a pattern that looks like a reference to them . */
4211 #define MAX_ZOMBIES 10
4212 static Lisp_Object zombies
[MAX_ZOMBIES
];
4214 /* Number of zombie objects. */
4216 static EMACS_INT nzombies
;
4218 /* Number of garbage collections. */
4220 static EMACS_INT ngcs
;
4222 /* Average percentage of zombies per collection. */
4224 static double avg_zombies
;
4226 /* Max. number of live and zombie objects. */
4228 static EMACS_INT max_live
, max_zombies
;
4230 /* Average number of live objects per GC. */
4232 static double avg_live
;
4234 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4235 doc
: /* Show information about live and zombie objects. */)
4238 Lisp_Object args
[8], zombie_list
= Qnil
;
4240 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4241 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4242 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4243 args
[1] = make_number (ngcs
);
4244 args
[2] = make_float (avg_live
);
4245 args
[3] = make_float (avg_zombies
);
4246 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4247 args
[5] = make_number (max_live
);
4248 args
[6] = make_number (max_zombies
);
4249 args
[7] = zombie_list
;
4250 return Fmessage (8, args
);
4253 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4256 /* Mark OBJ if we can prove it's a Lisp_Object. */
4259 mark_maybe_object (Lisp_Object obj
)
4267 po
= (void *) XPNTR (obj
);
4274 switch (XTYPE (obj
))
4277 mark_p
= (live_string_p (m
, po
)
4278 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4282 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4286 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4290 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4293 case Lisp_Vectorlike
:
4294 /* Note: can't check BUFFERP before we know it's a
4295 buffer because checking that dereferences the pointer
4296 PO which might point anywhere. */
4297 if (live_vector_p (m
, po
))
4298 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4299 else if (live_buffer_p (m
, po
))
4300 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4304 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4313 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4314 if (nzombies
< MAX_ZOMBIES
)
4315 zombies
[nzombies
] = obj
;
4324 /* If P points to Lisp data, mark that as live if it isn't already
4328 mark_maybe_pointer (void *p
)
4332 /* Quickly rule out some values which can't point to Lisp data.
4333 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4334 Otherwise, assume that Lisp data is aligned on even addresses. */
4335 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4341 Lisp_Object obj
= Qnil
;
4345 case MEM_TYPE_NON_LISP
:
4346 case MEM_TYPE_SPARE
:
4347 /* Nothing to do; not a pointer to Lisp memory. */
4350 case MEM_TYPE_BUFFER
:
4351 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4352 XSETVECTOR (obj
, p
);
4356 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4360 case MEM_TYPE_STRING
:
4361 if (live_string_p (m
, p
)
4362 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4363 XSETSTRING (obj
, p
);
4367 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4371 case MEM_TYPE_SYMBOL
:
4372 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4373 XSETSYMBOL (obj
, p
);
4376 case MEM_TYPE_FLOAT
:
4377 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4381 case MEM_TYPE_VECTORLIKE
:
4382 case MEM_TYPE_VECTOR_BLOCK
:
4383 if (live_vector_p (m
, p
))
4386 XSETVECTOR (tem
, p
);
4387 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4402 /* Alignment of pointer values. Use alignof, as it sometimes returns
4403 a smaller alignment than GCC's __alignof__ and mark_memory might
4404 miss objects if __alignof__ were used. */
4405 #define GC_POINTER_ALIGNMENT alignof (void *)
4407 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4408 not suffice, which is the typical case. A host where a Lisp_Object is
4409 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4410 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4411 suffice to widen it to to a Lisp_Object and check it that way. */
4412 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4413 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4414 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4415 nor mark_maybe_object can follow the pointers. This should not occur on
4416 any practical porting target. */
4417 # error "MSB type bits straddle pointer-word boundaries"
4419 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4420 pointer words that hold pointers ORed with type bits. */
4421 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4423 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4424 words that hold unmodified pointers. */
4425 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4428 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4429 or END+OFFSET..START. */
4432 mark_memory (void *start
, void *end
)
4433 #if defined (__clang__) && defined (__has_feature)
4434 #if __has_feature(address_sanitizer)
4435 /* Do not allow -faddress-sanitizer to check this function, since it
4436 crosses the function stack boundary, and thus would yield many
4438 __attribute__((no_address_safety_analysis
))
4445 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4449 /* Make START the pointer to the start of the memory region,
4450 if it isn't already. */
4458 /* Mark Lisp data pointed to. This is necessary because, in some
4459 situations, the C compiler optimizes Lisp objects away, so that
4460 only a pointer to them remains. Example:
4462 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4465 Lisp_Object obj = build_string ("test");
4466 struct Lisp_String *s = XSTRING (obj);
4467 Fgarbage_collect ();
4468 fprintf (stderr, "test `%s'\n", s->data);
4472 Here, `obj' isn't really used, and the compiler optimizes it
4473 away. The only reference to the life string is through the
4476 for (pp
= start
; (void *) pp
< end
; pp
++)
4477 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4479 void *p
= *(void **) ((char *) pp
+ i
);
4480 mark_maybe_pointer (p
);
4481 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4482 mark_maybe_object (XIL ((intptr_t) p
));
4486 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4488 static bool setjmp_tested_p
;
4489 static int longjmps_done
;
4491 #define SETJMP_WILL_LIKELY_WORK "\
4493 Emacs garbage collector has been changed to use conservative stack\n\
4494 marking. Emacs has determined that the method it uses to do the\n\
4495 marking will likely work on your system, but this isn't sure.\n\
4497 If you are a system-programmer, or can get the help of a local wizard\n\
4498 who is, please take a look at the function mark_stack in alloc.c, and\n\
4499 verify that the methods used are appropriate for your system.\n\
4501 Please mail the result to <emacs-devel@gnu.org>.\n\
4504 #define SETJMP_WILL_NOT_WORK "\
4506 Emacs garbage collector has been changed to use conservative stack\n\
4507 marking. Emacs has determined that the default method it uses to do the\n\
4508 marking will not work on your system. We will need a system-dependent\n\
4509 solution for your system.\n\
4511 Please take a look at the function mark_stack in alloc.c, and\n\
4512 try to find a way to make it work on your system.\n\
4514 Note that you may get false negatives, depending on the compiler.\n\
4515 In particular, you need to use -O with GCC for this test.\n\
4517 Please mail the result to <emacs-devel@gnu.org>.\n\
4521 /* Perform a quick check if it looks like setjmp saves registers in a
4522 jmp_buf. Print a message to stderr saying so. When this test
4523 succeeds, this is _not_ a proof that setjmp is sufficient for
4524 conservative stack marking. Only the sources or a disassembly
4534 /* Arrange for X to be put in a register. */
4540 if (longjmps_done
== 1)
4542 /* Came here after the longjmp at the end of the function.
4544 If x == 1, the longjmp has restored the register to its
4545 value before the setjmp, and we can hope that setjmp
4546 saves all such registers in the jmp_buf, although that
4549 For other values of X, either something really strange is
4550 taking place, or the setjmp just didn't save the register. */
4553 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4556 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4563 if (longjmps_done
== 1)
4564 sys_longjmp (jbuf
, 1);
4567 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4570 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4572 /* Abort if anything GCPRO'd doesn't survive the GC. */
4580 for (p
= gcprolist
; p
; p
= p
->next
)
4581 for (i
= 0; i
< p
->nvars
; ++i
)
4582 if (!survives_gc_p (p
->var
[i
]))
4583 /* FIXME: It's not necessarily a bug. It might just be that the
4584 GCPRO is unnecessary or should release the object sooner. */
4588 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4595 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4596 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4598 fprintf (stderr
, " %d = ", i
);
4599 debug_print (zombies
[i
]);
4603 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4606 /* Mark live Lisp objects on the C stack.
4608 There are several system-dependent problems to consider when
4609 porting this to new architectures:
4613 We have to mark Lisp objects in CPU registers that can hold local
4614 variables or are used to pass parameters.
4616 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4617 something that either saves relevant registers on the stack, or
4618 calls mark_maybe_object passing it each register's contents.
4620 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4621 implementation assumes that calling setjmp saves registers we need
4622 to see in a jmp_buf which itself lies on the stack. This doesn't
4623 have to be true! It must be verified for each system, possibly
4624 by taking a look at the source code of setjmp.
4626 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4627 can use it as a machine independent method to store all registers
4628 to the stack. In this case the macros described in the previous
4629 two paragraphs are not used.
4633 Architectures differ in the way their processor stack is organized.
4634 For example, the stack might look like this
4637 | Lisp_Object | size = 4
4639 | something else | size = 2
4641 | Lisp_Object | size = 4
4645 In such a case, not every Lisp_Object will be aligned equally. To
4646 find all Lisp_Object on the stack it won't be sufficient to walk
4647 the stack in steps of 4 bytes. Instead, two passes will be
4648 necessary, one starting at the start of the stack, and a second
4649 pass starting at the start of the stack + 2. Likewise, if the
4650 minimal alignment of Lisp_Objects on the stack is 1, four passes
4651 would be necessary, each one starting with one byte more offset
4652 from the stack start. */
4659 #ifdef HAVE___BUILTIN_UNWIND_INIT
4660 /* Force callee-saved registers and register windows onto the stack.
4661 This is the preferred method if available, obviating the need for
4662 machine dependent methods. */
4663 __builtin_unwind_init ();
4665 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4666 #ifndef GC_SAVE_REGISTERS_ON_STACK
4667 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4668 union aligned_jmpbuf
{
4672 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4674 /* This trick flushes the register windows so that all the state of
4675 the process is contained in the stack. */
4676 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4677 needed on ia64 too. See mach_dep.c, where it also says inline
4678 assembler doesn't work with relevant proprietary compilers. */
4680 #if defined (__sparc64__) && defined (__FreeBSD__)
4681 /* FreeBSD does not have a ta 3 handler. */
4688 /* Save registers that we need to see on the stack. We need to see
4689 registers used to hold register variables and registers used to
4691 #ifdef GC_SAVE_REGISTERS_ON_STACK
4692 GC_SAVE_REGISTERS_ON_STACK (end
);
4693 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4695 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4696 setjmp will definitely work, test it
4697 and print a message with the result
4699 if (!setjmp_tested_p
)
4701 setjmp_tested_p
= 1;
4704 #endif /* GC_SETJMP_WORKS */
4707 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4708 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4709 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4711 /* This assumes that the stack is a contiguous region in memory. If
4712 that's not the case, something has to be done here to iterate
4713 over the stack segments. */
4714 mark_memory (stack_base
, end
);
4716 /* Allow for marking a secondary stack, like the register stack on the
4718 #ifdef GC_MARK_SECONDARY_STACK
4719 GC_MARK_SECONDARY_STACK ();
4722 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4727 #endif /* GC_MARK_STACK != 0 */
4730 /* Determine whether it is safe to access memory at address P. */
4732 valid_pointer_p (void *p
)
4735 return w32_valid_pointer_p (p
, 16);
4739 /* Obviously, we cannot just access it (we would SEGV trying), so we
4740 trick the o/s to tell us whether p is a valid pointer.
4741 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4742 not validate p in that case. */
4744 if (pipe2 (fd
, O_CLOEXEC
) == 0)
4746 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4747 emacs_close (fd
[1]);
4748 emacs_close (fd
[0]);
4756 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4757 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4758 cannot validate OBJ. This function can be quite slow, so its primary
4759 use is the manual debugging. The only exception is print_object, where
4760 we use it to check whether the memory referenced by the pointer of
4761 Lisp_Save_Value object contains valid objects. */
4764 valid_lisp_object_p (Lisp_Object obj
)
4774 p
= (void *) XPNTR (obj
);
4775 if (PURE_POINTER_P (p
))
4778 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4782 return valid_pointer_p (p
);
4789 int valid
= valid_pointer_p (p
);
4801 case MEM_TYPE_NON_LISP
:
4802 case MEM_TYPE_SPARE
:
4805 case MEM_TYPE_BUFFER
:
4806 return live_buffer_p (m
, p
) ? 1 : 2;
4809 return live_cons_p (m
, p
);
4811 case MEM_TYPE_STRING
:
4812 return live_string_p (m
, p
);
4815 return live_misc_p (m
, p
);
4817 case MEM_TYPE_SYMBOL
:
4818 return live_symbol_p (m
, p
);
4820 case MEM_TYPE_FLOAT
:
4821 return live_float_p (m
, p
);
4823 case MEM_TYPE_VECTORLIKE
:
4824 case MEM_TYPE_VECTOR_BLOCK
:
4825 return live_vector_p (m
, p
);
4838 /***********************************************************************
4839 Pure Storage Management
4840 ***********************************************************************/
4842 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4843 pointer to it. TYPE is the Lisp type for which the memory is
4844 allocated. TYPE < 0 means it's not used for a Lisp object. */
4847 pure_alloc (size_t size
, int type
)
4851 size_t alignment
= GCALIGNMENT
;
4853 size_t alignment
= alignof (EMACS_INT
);
4855 /* Give Lisp_Floats an extra alignment. */
4856 if (type
== Lisp_Float
)
4857 alignment
= alignof (struct Lisp_Float
);
4863 /* Allocate space for a Lisp object from the beginning of the free
4864 space with taking account of alignment. */
4865 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4866 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4870 /* Allocate space for a non-Lisp object from the end of the free
4872 pure_bytes_used_non_lisp
+= size
;
4873 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4875 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4877 if (pure_bytes_used
<= pure_size
)
4880 /* Don't allocate a large amount here,
4881 because it might get mmap'd and then its address
4882 might not be usable. */
4883 purebeg
= xmalloc (10000);
4885 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4886 pure_bytes_used
= 0;
4887 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4892 /* Print a warning if PURESIZE is too small. */
4895 check_pure_size (void)
4897 if (pure_bytes_used_before_overflow
)
4898 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4900 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4904 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4905 the non-Lisp data pool of the pure storage, and return its start
4906 address. Return NULL if not found. */
4909 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4912 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4913 const unsigned char *p
;
4916 if (pure_bytes_used_non_lisp
<= nbytes
)
4919 /* Set up the Boyer-Moore table. */
4921 for (i
= 0; i
< 256; i
++)
4924 p
= (const unsigned char *) data
;
4926 bm_skip
[*p
++] = skip
;
4928 last_char_skip
= bm_skip
['\0'];
4930 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4931 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4933 /* See the comments in the function `boyer_moore' (search.c) for the
4934 use of `infinity'. */
4935 infinity
= pure_bytes_used_non_lisp
+ 1;
4936 bm_skip
['\0'] = infinity
;
4938 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4942 /* Check the last character (== '\0'). */
4945 start
+= bm_skip
[*(p
+ start
)];
4947 while (start
<= start_max
);
4949 if (start
< infinity
)
4950 /* Couldn't find the last character. */
4953 /* No less than `infinity' means we could find the last
4954 character at `p[start - infinity]'. */
4957 /* Check the remaining characters. */
4958 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4960 return non_lisp_beg
+ start
;
4962 start
+= last_char_skip
;
4964 while (start
<= start_max
);
4970 /* Return a string allocated in pure space. DATA is a buffer holding
4971 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4972 means make the result string multibyte.
4974 Must get an error if pure storage is full, since if it cannot hold
4975 a large string it may be able to hold conses that point to that
4976 string; then the string is not protected from gc. */
4979 make_pure_string (const char *data
,
4980 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
4983 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4984 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4985 if (s
->data
== NULL
)
4987 s
->data
= pure_alloc (nbytes
+ 1, -1);
4988 memcpy (s
->data
, data
, nbytes
);
4989 s
->data
[nbytes
] = '\0';
4992 s
->size_byte
= multibyte
? nbytes
: -1;
4993 s
->intervals
= NULL
;
4994 XSETSTRING (string
, s
);
4998 /* Return a string allocated in pure space. Do not
4999 allocate the string data, just point to DATA. */
5002 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5005 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5008 s
->data
= (unsigned char *) data
;
5009 s
->intervals
= NULL
;
5010 XSETSTRING (string
, s
);
5014 /* Return a cons allocated from pure space. Give it pure copies
5015 of CAR as car and CDR as cdr. */
5018 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5021 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5023 XSETCAR (new, Fpurecopy (car
));
5024 XSETCDR (new, Fpurecopy (cdr
));
5029 /* Value is a float object with value NUM allocated from pure space. */
5032 make_pure_float (double num
)
5035 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5037 XFLOAT_INIT (new, num
);
5042 /* Return a vector with room for LEN Lisp_Objects allocated from
5046 make_pure_vector (ptrdiff_t len
)
5049 size_t size
= header_size
+ len
* word_size
;
5050 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5051 XSETVECTOR (new, p
);
5052 XVECTOR (new)->header
.size
= len
;
5057 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5058 doc
: /* Make a copy of object OBJ in pure storage.
5059 Recursively copies contents of vectors and cons cells.
5060 Does not copy symbols. Copies strings without text properties. */)
5061 (register Lisp_Object obj
)
5063 if (NILP (Vpurify_flag
))
5066 if (PURE_POINTER_P (XPNTR (obj
)))
5069 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5071 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5077 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5078 else if (FLOATP (obj
))
5079 obj
= make_pure_float (XFLOAT_DATA (obj
));
5080 else if (STRINGP (obj
))
5081 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5083 STRING_MULTIBYTE (obj
));
5084 else if (COMPILEDP (obj
) || VECTORP (obj
))
5086 register struct Lisp_Vector
*vec
;
5087 register ptrdiff_t i
;
5091 if (size
& PSEUDOVECTOR_FLAG
)
5092 size
&= PSEUDOVECTOR_SIZE_MASK
;
5093 vec
= XVECTOR (make_pure_vector (size
));
5094 for (i
= 0; i
< size
; i
++)
5095 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5096 if (COMPILEDP (obj
))
5098 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5099 XSETCOMPILED (obj
, vec
);
5102 XSETVECTOR (obj
, vec
);
5104 else if (MARKERP (obj
))
5105 error ("Attempt to copy a marker to pure storage");
5107 /* Not purified, don't hash-cons. */
5110 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5111 Fputhash (obj
, obj
, Vpurify_flag
);
5118 /***********************************************************************
5120 ***********************************************************************/
5122 /* Put an entry in staticvec, pointing at the variable with address
5126 staticpro (Lisp_Object
*varaddress
)
5128 staticvec
[staticidx
++] = varaddress
;
5129 if (staticidx
>= NSTATICS
)
5130 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5134 /***********************************************************************
5136 ***********************************************************************/
5138 /* Temporarily prevent garbage collection. */
5141 inhibit_garbage_collection (void)
5143 ptrdiff_t count
= SPECPDL_INDEX ();
5145 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5149 /* Used to avoid possible overflows when
5150 converting from C to Lisp integers. */
5153 bounded_number (EMACS_INT number
)
5155 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5158 /* Calculate total bytes of live objects. */
5161 total_bytes_of_live_objects (void)
5164 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5165 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5166 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5167 tot
+= total_string_bytes
;
5168 tot
+= total_vector_slots
* word_size
;
5169 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5170 tot
+= total_intervals
* sizeof (struct interval
);
5171 tot
+= total_strings
* sizeof (struct Lisp_String
);
5175 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5176 doc
: /* Reclaim storage for Lisp objects no longer needed.
5177 Garbage collection happens automatically if you cons more than
5178 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5179 `garbage-collect' normally returns a list with info on amount of space in use,
5180 where each entry has the form (NAME SIZE USED FREE), where:
5181 - NAME is a symbol describing the kind of objects this entry represents,
5182 - SIZE is the number of bytes used by each one,
5183 - USED is the number of those objects that were found live in the heap,
5184 - FREE is the number of those objects that are not live but that Emacs
5185 keeps around for future allocations (maybe because it does not know how
5186 to return them to the OS).
5187 However, if there was overflow in pure space, `garbage-collect'
5188 returns nil, because real GC can't be done.
5189 See Info node `(elisp)Garbage Collection'. */)
5192 struct buffer
*nextb
;
5193 char stack_top_variable
;
5196 ptrdiff_t count
= SPECPDL_INDEX ();
5198 Lisp_Object retval
= Qnil
;
5199 size_t tot_before
= 0;
5204 /* Can't GC if pure storage overflowed because we can't determine
5205 if something is a pure object or not. */
5206 if (pure_bytes_used_before_overflow
)
5209 /* Record this function, so it appears on the profiler's backtraces. */
5210 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5214 /* Don't keep undo information around forever.
5215 Do this early on, so it is no problem if the user quits. */
5216 FOR_EACH_BUFFER (nextb
)
5217 compact_buffer (nextb
);
5219 if (profiler_memory_running
)
5220 tot_before
= total_bytes_of_live_objects ();
5222 start
= current_emacs_time ();
5224 /* In case user calls debug_print during GC,
5225 don't let that cause a recursive GC. */
5226 consing_since_gc
= 0;
5228 /* Save what's currently displayed in the echo area. */
5229 message_p
= push_message ();
5230 record_unwind_protect (pop_message_unwind
, Qnil
);
5232 /* Save a copy of the contents of the stack, for debugging. */
5233 #if MAX_SAVE_STACK > 0
5234 if (NILP (Vpurify_flag
))
5237 ptrdiff_t stack_size
;
5238 if (&stack_top_variable
< stack_bottom
)
5240 stack
= &stack_top_variable
;
5241 stack_size
= stack_bottom
- &stack_top_variable
;
5245 stack
= stack_bottom
;
5246 stack_size
= &stack_top_variable
- stack_bottom
;
5248 if (stack_size
<= MAX_SAVE_STACK
)
5250 if (stack_copy_size
< stack_size
)
5252 stack_copy
= xrealloc (stack_copy
, stack_size
);
5253 stack_copy_size
= stack_size
;
5255 memcpy (stack_copy
, stack
, stack_size
);
5258 #endif /* MAX_SAVE_STACK > 0 */
5260 if (garbage_collection_messages
)
5261 message1_nolog ("Garbage collecting...");
5265 shrink_regexp_cache ();
5269 /* Mark all the special slots that serve as the roots of accessibility. */
5271 mark_buffer (&buffer_defaults
);
5272 mark_buffer (&buffer_local_symbols
);
5274 for (i
= 0; i
< staticidx
; i
++)
5275 mark_object (*staticvec
[i
]);
5285 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5286 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5290 register struct gcpro
*tail
;
5291 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5292 for (i
= 0; i
< tail
->nvars
; i
++)
5293 mark_object (tail
->var
[i
]);
5297 struct catchtag
*catch;
5298 struct handler
*handler
;
5300 for (catch = catchlist
; catch; catch = catch->next
)
5302 mark_object (catch->tag
);
5303 mark_object (catch->val
);
5305 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5307 mark_object (handler
->handler
);
5308 mark_object (handler
->var
);
5313 #ifdef HAVE_WINDOW_SYSTEM
5314 mark_fringe_data ();
5317 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5321 /* Everything is now marked, except for the things that require special
5322 finalization, i.e. the undo_list.
5323 Look thru every buffer's undo list
5324 for elements that update markers that were not marked,
5326 FOR_EACH_BUFFER (nextb
)
5328 /* If a buffer's undo list is Qt, that means that undo is
5329 turned off in that buffer. Calling truncate_undo_list on
5330 Qt tends to return NULL, which effectively turns undo back on.
5331 So don't call truncate_undo_list if undo_list is Qt. */
5332 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5334 Lisp_Object tail
, prev
;
5335 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5337 while (CONSP (tail
))
5339 if (CONSP (XCAR (tail
))
5340 && MARKERP (XCAR (XCAR (tail
)))
5341 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5344 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5348 XSETCDR (prev
, tail
);
5358 /* Now that we have stripped the elements that need not be in the
5359 undo_list any more, we can finally mark the list. */
5360 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5365 /* Clear the mark bits that we set in certain root slots. */
5367 unmark_byte_stack ();
5368 VECTOR_UNMARK (&buffer_defaults
);
5369 VECTOR_UNMARK (&buffer_local_symbols
);
5371 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5381 consing_since_gc
= 0;
5382 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5383 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5385 gc_relative_threshold
= 0;
5386 if (FLOATP (Vgc_cons_percentage
))
5387 { /* Set gc_cons_combined_threshold. */
5388 double tot
= total_bytes_of_live_objects ();
5390 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5393 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5394 gc_relative_threshold
= tot
;
5396 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5400 if (garbage_collection_messages
)
5402 if (message_p
|| minibuf_level
> 0)
5405 message1_nolog ("Garbage collecting...done");
5408 unbind_to (count
, Qnil
);
5410 Lisp_Object total
[11];
5411 int total_size
= 10;
5413 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5414 bounded_number (total_conses
),
5415 bounded_number (total_free_conses
));
5417 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5418 bounded_number (total_symbols
),
5419 bounded_number (total_free_symbols
));
5421 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5422 bounded_number (total_markers
),
5423 bounded_number (total_free_markers
));
5425 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5426 bounded_number (total_strings
),
5427 bounded_number (total_free_strings
));
5429 total
[4] = list3 (Qstring_bytes
, make_number (1),
5430 bounded_number (total_string_bytes
));
5432 total
[5] = list3 (Qvectors
,
5433 make_number (header_size
+ sizeof (Lisp_Object
)),
5434 bounded_number (total_vectors
));
5436 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5437 bounded_number (total_vector_slots
),
5438 bounded_number (total_free_vector_slots
));
5440 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5441 bounded_number (total_floats
),
5442 bounded_number (total_free_floats
));
5444 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5445 bounded_number (total_intervals
),
5446 bounded_number (total_free_intervals
));
5448 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5449 bounded_number (total_buffers
));
5451 #ifdef DOUG_LEA_MALLOC
5453 total
[10] = list4 (Qheap
, make_number (1024),
5454 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5455 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5457 retval
= Flist (total_size
, total
);
5460 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5462 /* Compute average percentage of zombies. */
5464 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5465 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5467 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5468 max_live
= max (nlive
, max_live
);
5469 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5470 max_zombies
= max (nzombies
, max_zombies
);
5475 if (!NILP (Vpost_gc_hook
))
5477 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5478 safe_run_hooks (Qpost_gc_hook
);
5479 unbind_to (gc_count
, Qnil
);
5482 /* Accumulate statistics. */
5483 if (FLOATP (Vgc_elapsed
))
5485 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5486 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5487 + EMACS_TIME_TO_DOUBLE (since_start
));
5492 /* Collect profiling data. */
5493 if (profiler_memory_running
)
5496 size_t tot_after
= total_bytes_of_live_objects ();
5497 if (tot_before
> tot_after
)
5498 swept
= tot_before
- tot_after
;
5499 malloc_probe (swept
);
5506 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5507 only interesting objects referenced from glyphs are strings. */
5510 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5512 struct glyph_row
*row
= matrix
->rows
;
5513 struct glyph_row
*end
= row
+ matrix
->nrows
;
5515 for (; row
< end
; ++row
)
5519 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5521 struct glyph
*glyph
= row
->glyphs
[area
];
5522 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5524 for (; glyph
< end_glyph
; ++glyph
)
5525 if (STRINGP (glyph
->object
)
5526 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5527 mark_object (glyph
->object
);
5533 /* Mark Lisp faces in the face cache C. */
5536 mark_face_cache (struct face_cache
*c
)
5541 for (i
= 0; i
< c
->used
; ++i
)
5543 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5547 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5548 mark_object (face
->lface
[j
]);
5556 /* Mark reference to a Lisp_Object.
5557 If the object referred to has not been seen yet, recursively mark
5558 all the references contained in it. */
5560 #define LAST_MARKED_SIZE 500
5561 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5562 static int last_marked_index
;
5564 /* For debugging--call abort when we cdr down this many
5565 links of a list, in mark_object. In debugging,
5566 the call to abort will hit a breakpoint.
5567 Normally this is zero and the check never goes off. */
5568 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5571 mark_vectorlike (struct Lisp_Vector
*ptr
)
5573 ptrdiff_t size
= ptr
->header
.size
;
5576 eassert (!VECTOR_MARKED_P (ptr
));
5577 VECTOR_MARK (ptr
); /* Else mark it. */
5578 if (size
& PSEUDOVECTOR_FLAG
)
5579 size
&= PSEUDOVECTOR_SIZE_MASK
;
5581 /* Note that this size is not the memory-footprint size, but only
5582 the number of Lisp_Object fields that we should trace.
5583 The distinction is used e.g. by Lisp_Process which places extra
5584 non-Lisp_Object fields at the end of the structure... */
5585 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5586 mark_object (ptr
->contents
[i
]);
5589 /* Like mark_vectorlike but optimized for char-tables (and
5590 sub-char-tables) assuming that the contents are mostly integers or
5594 mark_char_table (struct Lisp_Vector
*ptr
)
5596 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5599 eassert (!VECTOR_MARKED_P (ptr
));
5601 for (i
= 0; i
< size
; i
++)
5603 Lisp_Object val
= ptr
->contents
[i
];
5605 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5607 if (SUB_CHAR_TABLE_P (val
))
5609 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5610 mark_char_table (XVECTOR (val
));
5617 /* Mark the chain of overlays starting at PTR. */
5620 mark_overlay (struct Lisp_Overlay
*ptr
)
5622 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5625 mark_object (ptr
->start
);
5626 mark_object (ptr
->end
);
5627 mark_object (ptr
->plist
);
5631 /* Mark Lisp_Objects and special pointers in BUFFER. */
5634 mark_buffer (struct buffer
*buffer
)
5636 /* This is handled much like other pseudovectors... */
5637 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5639 /* ...but there are some buffer-specific things. */
5641 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5643 /* For now, we just don't mark the undo_list. It's done later in
5644 a special way just before the sweep phase, and after stripping
5645 some of its elements that are not needed any more. */
5647 mark_overlay (buffer
->overlays_before
);
5648 mark_overlay (buffer
->overlays_after
);
5650 /* If this is an indirect buffer, mark its base buffer. */
5651 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5652 mark_buffer (buffer
->base_buffer
);
5655 /* Remove killed buffers or items whose car is a killed buffer from
5656 LIST, and mark other items. Return changed LIST, which is marked. */
5659 mark_discard_killed_buffers (Lisp_Object list
)
5661 Lisp_Object tail
, *prev
= &list
;
5663 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5666 Lisp_Object tem
= XCAR (tail
);
5669 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5670 *prev
= XCDR (tail
);
5673 CONS_MARK (XCONS (tail
));
5674 mark_object (XCAR (tail
));
5675 prev
= xcdr_addr (tail
);
5682 /* Determine type of generic Lisp_Object and mark it accordingly. */
5685 mark_object (Lisp_Object arg
)
5687 register Lisp_Object obj
= arg
;
5688 #ifdef GC_CHECK_MARKED_OBJECTS
5692 ptrdiff_t cdr_count
= 0;
5696 if (PURE_POINTER_P (XPNTR (obj
)))
5699 last_marked
[last_marked_index
++] = obj
;
5700 if (last_marked_index
== LAST_MARKED_SIZE
)
5701 last_marked_index
= 0;
5703 /* Perform some sanity checks on the objects marked here. Abort if
5704 we encounter an object we know is bogus. This increases GC time
5705 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5706 #ifdef GC_CHECK_MARKED_OBJECTS
5708 po
= (void *) XPNTR (obj
);
5710 /* Check that the object pointed to by PO is known to be a Lisp
5711 structure allocated from the heap. */
5712 #define CHECK_ALLOCATED() \
5714 m = mem_find (po); \
5719 /* Check that the object pointed to by PO is live, using predicate
5721 #define CHECK_LIVE(LIVEP) \
5723 if (!LIVEP (m, po)) \
5727 /* Check both of the above conditions. */
5728 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5730 CHECK_ALLOCATED (); \
5731 CHECK_LIVE (LIVEP); \
5734 #else /* not GC_CHECK_MARKED_OBJECTS */
5736 #define CHECK_LIVE(LIVEP) (void) 0
5737 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5739 #endif /* not GC_CHECK_MARKED_OBJECTS */
5741 switch (XTYPE (obj
))
5745 register struct Lisp_String
*ptr
= XSTRING (obj
);
5746 if (STRING_MARKED_P (ptr
))
5748 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5750 MARK_INTERVAL_TREE (ptr
->intervals
);
5751 #ifdef GC_CHECK_STRING_BYTES
5752 /* Check that the string size recorded in the string is the
5753 same as the one recorded in the sdata structure. */
5755 #endif /* GC_CHECK_STRING_BYTES */
5759 case Lisp_Vectorlike
:
5761 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5762 register ptrdiff_t pvectype
;
5764 if (VECTOR_MARKED_P (ptr
))
5767 #ifdef GC_CHECK_MARKED_OBJECTS
5769 if (m
== MEM_NIL
&& !SUBRP (obj
))
5771 #endif /* GC_CHECK_MARKED_OBJECTS */
5773 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5774 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5775 >> PSEUDOVECTOR_AREA_BITS
);
5777 pvectype
= PVEC_NORMAL_VECTOR
;
5779 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5780 CHECK_LIVE (live_vector_p
);
5785 #ifdef GC_CHECK_MARKED_OBJECTS
5794 #endif /* GC_CHECK_MARKED_OBJECTS */
5795 mark_buffer ((struct buffer
*) ptr
);
5799 { /* We could treat this just like a vector, but it is better
5800 to save the COMPILED_CONSTANTS element for last and avoid
5802 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5806 for (i
= 0; i
< size
; i
++)
5807 if (i
!= COMPILED_CONSTANTS
)
5808 mark_object (ptr
->contents
[i
]);
5809 if (size
> COMPILED_CONSTANTS
)
5811 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5818 mark_vectorlike (ptr
);
5819 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5824 struct window
*w
= (struct window
*) ptr
;
5826 mark_vectorlike (ptr
);
5828 /* Mark glyph matrices, if any. Marking window
5829 matrices is sufficient because frame matrices
5830 use the same glyph memory. */
5831 if (w
->current_matrix
)
5833 mark_glyph_matrix (w
->current_matrix
);
5834 mark_glyph_matrix (w
->desired_matrix
);
5837 /* Filter out killed buffers from both buffer lists
5838 in attempt to help GC to reclaim killed buffers faster.
5839 We can do it elsewhere for live windows, but this is the
5840 best place to do it for dead windows. */
5842 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5844 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5848 case PVEC_HASH_TABLE
:
5850 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5852 mark_vectorlike (ptr
);
5853 mark_object (h
->test
.name
);
5854 mark_object (h
->test
.user_hash_function
);
5855 mark_object (h
->test
.user_cmp_function
);
5856 /* If hash table is not weak, mark all keys and values.
5857 For weak tables, mark only the vector. */
5859 mark_object (h
->key_and_value
);
5861 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5865 case PVEC_CHAR_TABLE
:
5866 mark_char_table (ptr
);
5869 case PVEC_BOOL_VECTOR
:
5870 /* No Lisp_Objects to mark in a bool vector. */
5881 mark_vectorlike (ptr
);
5888 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5889 struct Lisp_Symbol
*ptrx
;
5893 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5895 mark_object (ptr
->function
);
5896 mark_object (ptr
->plist
);
5897 switch (ptr
->redirect
)
5899 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5900 case SYMBOL_VARALIAS
:
5903 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5907 case SYMBOL_LOCALIZED
:
5909 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5910 Lisp_Object where
= blv
->where
;
5911 /* If the value is set up for a killed buffer or deleted
5912 frame, restore it's global binding. If the value is
5913 forwarded to a C variable, either it's not a Lisp_Object
5914 var, or it's staticpro'd already. */
5915 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5916 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5917 swap_in_global_binding (ptr
);
5918 mark_object (blv
->where
);
5919 mark_object (blv
->valcell
);
5920 mark_object (blv
->defcell
);
5923 case SYMBOL_FORWARDED
:
5924 /* If the value is forwarded to a buffer or keyboard field,
5925 these are marked when we see the corresponding object.
5926 And if it's forwarded to a C variable, either it's not
5927 a Lisp_Object var, or it's staticpro'd already. */
5929 default: emacs_abort ();
5931 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5932 MARK_STRING (XSTRING (ptr
->name
));
5933 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5938 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5939 XSETSYMBOL (obj
, ptrx
);
5946 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5948 if (XMISCANY (obj
)->gcmarkbit
)
5951 switch (XMISCTYPE (obj
))
5953 case Lisp_Misc_Marker
:
5954 /* DO NOT mark thru the marker's chain.
5955 The buffer's markers chain does not preserve markers from gc;
5956 instead, markers are removed from the chain when freed by gc. */
5957 XMISCANY (obj
)->gcmarkbit
= 1;
5960 case Lisp_Misc_Save_Value
:
5961 XMISCANY (obj
)->gcmarkbit
= 1;
5963 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5964 /* If `save_type' is zero, `data[0].pointer' is the address
5965 of a memory area containing `data[1].integer' potential
5967 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
5969 Lisp_Object
*p
= ptr
->data
[0].pointer
;
5971 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
5972 mark_maybe_object (*p
);
5976 /* Find Lisp_Objects in `data[N]' slots and mark them. */
5978 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
5979 if (save_type (ptr
, i
) == SAVE_OBJECT
)
5980 mark_object (ptr
->data
[i
].object
);
5985 case Lisp_Misc_Overlay
:
5986 mark_overlay (XOVERLAY (obj
));
5996 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5997 if (CONS_MARKED_P (ptr
))
5999 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6001 /* If the cdr is nil, avoid recursion for the car. */
6002 if (EQ (ptr
->u
.cdr
, Qnil
))
6008 mark_object (ptr
->car
);
6011 if (cdr_count
== mark_object_loop_halt
)
6017 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6018 FLOAT_MARK (XFLOAT (obj
));
6029 #undef CHECK_ALLOCATED
6030 #undef CHECK_ALLOCATED_AND_LIVE
6032 /* Mark the Lisp pointers in the terminal objects.
6033 Called by Fgarbage_collect. */
6036 mark_terminals (void)
6039 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6041 eassert (t
->name
!= NULL
);
6042 #ifdef HAVE_WINDOW_SYSTEM
6043 /* If a terminal object is reachable from a stacpro'ed object,
6044 it might have been marked already. Make sure the image cache
6046 mark_image_cache (t
->image_cache
);
6047 #endif /* HAVE_WINDOW_SYSTEM */
6048 if (!VECTOR_MARKED_P (t
))
6049 mark_vectorlike ((struct Lisp_Vector
*)t
);
6055 /* Value is non-zero if OBJ will survive the current GC because it's
6056 either marked or does not need to be marked to survive. */
6059 survives_gc_p (Lisp_Object obj
)
6063 switch (XTYPE (obj
))
6070 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6074 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6078 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6081 case Lisp_Vectorlike
:
6082 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6086 survives_p
= CONS_MARKED_P (XCONS (obj
));
6090 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6097 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6102 /* Sweep: find all structures not marked, and free them. */
6107 /* Remove or mark entries in weak hash tables.
6108 This must be done before any object is unmarked. */
6109 sweep_weak_hash_tables ();
6112 check_string_bytes (!noninteractive
);
6114 /* Put all unmarked conses on free list */
6116 register struct cons_block
*cblk
;
6117 struct cons_block
**cprev
= &cons_block
;
6118 register int lim
= cons_block_index
;
6119 EMACS_INT num_free
= 0, num_used
= 0;
6123 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6127 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6129 /* Scan the mark bits an int at a time. */
6130 for (i
= 0; i
< ilim
; i
++)
6132 if (cblk
->gcmarkbits
[i
] == -1)
6134 /* Fast path - all cons cells for this int are marked. */
6135 cblk
->gcmarkbits
[i
] = 0;
6136 num_used
+= BITS_PER_INT
;
6140 /* Some cons cells for this int are not marked.
6141 Find which ones, and free them. */
6142 int start
, pos
, stop
;
6144 start
= i
* BITS_PER_INT
;
6146 if (stop
> BITS_PER_INT
)
6147 stop
= BITS_PER_INT
;
6150 for (pos
= start
; pos
< stop
; pos
++)
6152 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6155 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6156 cons_free_list
= &cblk
->conses
[pos
];
6158 cons_free_list
->car
= Vdead
;
6164 CONS_UNMARK (&cblk
->conses
[pos
]);
6170 lim
= CONS_BLOCK_SIZE
;
6171 /* If this block contains only free conses and we have already
6172 seen more than two blocks worth of free conses then deallocate
6174 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6176 *cprev
= cblk
->next
;
6177 /* Unhook from the free list. */
6178 cons_free_list
= cblk
->conses
[0].u
.chain
;
6179 lisp_align_free (cblk
);
6183 num_free
+= this_free
;
6184 cprev
= &cblk
->next
;
6187 total_conses
= num_used
;
6188 total_free_conses
= num_free
;
6191 /* Put all unmarked floats on free list */
6193 register struct float_block
*fblk
;
6194 struct float_block
**fprev
= &float_block
;
6195 register int lim
= float_block_index
;
6196 EMACS_INT num_free
= 0, num_used
= 0;
6198 float_free_list
= 0;
6200 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6204 for (i
= 0; i
< lim
; i
++)
6205 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6208 fblk
->floats
[i
].u
.chain
= float_free_list
;
6209 float_free_list
= &fblk
->floats
[i
];
6214 FLOAT_UNMARK (&fblk
->floats
[i
]);
6216 lim
= FLOAT_BLOCK_SIZE
;
6217 /* If this block contains only free floats and we have already
6218 seen more than two blocks worth of free floats then deallocate
6220 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6222 *fprev
= fblk
->next
;
6223 /* Unhook from the free list. */
6224 float_free_list
= fblk
->floats
[0].u
.chain
;
6225 lisp_align_free (fblk
);
6229 num_free
+= this_free
;
6230 fprev
= &fblk
->next
;
6233 total_floats
= num_used
;
6234 total_free_floats
= num_free
;
6237 /* Put all unmarked intervals on free list */
6239 register struct interval_block
*iblk
;
6240 struct interval_block
**iprev
= &interval_block
;
6241 register int lim
= interval_block_index
;
6242 EMACS_INT num_free
= 0, num_used
= 0;
6244 interval_free_list
= 0;
6246 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6251 for (i
= 0; i
< lim
; i
++)
6253 if (!iblk
->intervals
[i
].gcmarkbit
)
6255 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6256 interval_free_list
= &iblk
->intervals
[i
];
6262 iblk
->intervals
[i
].gcmarkbit
= 0;
6265 lim
= INTERVAL_BLOCK_SIZE
;
6266 /* If this block contains only free intervals and we have already
6267 seen more than two blocks worth of free intervals then
6268 deallocate this block. */
6269 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6271 *iprev
= iblk
->next
;
6272 /* Unhook from the free list. */
6273 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6278 num_free
+= this_free
;
6279 iprev
= &iblk
->next
;
6282 total_intervals
= num_used
;
6283 total_free_intervals
= num_free
;
6286 /* Put all unmarked symbols on free list */
6288 register struct symbol_block
*sblk
;
6289 struct symbol_block
**sprev
= &symbol_block
;
6290 register int lim
= symbol_block_index
;
6291 EMACS_INT num_free
= 0, num_used
= 0;
6293 symbol_free_list
= NULL
;
6295 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6298 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6299 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6301 for (; sym
< end
; ++sym
)
6303 /* Check if the symbol was created during loadup. In such a case
6304 it might be pointed to by pure bytecode which we don't trace,
6305 so we conservatively assume that it is live. */
6306 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6308 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6310 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6311 xfree (SYMBOL_BLV (&sym
->s
));
6312 sym
->s
.next
= symbol_free_list
;
6313 symbol_free_list
= &sym
->s
;
6315 symbol_free_list
->function
= Vdead
;
6323 UNMARK_STRING (XSTRING (sym
->s
.name
));
6324 sym
->s
.gcmarkbit
= 0;
6328 lim
= SYMBOL_BLOCK_SIZE
;
6329 /* If this block contains only free symbols and we have already
6330 seen more than two blocks worth of free symbols then deallocate
6332 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6334 *sprev
= sblk
->next
;
6335 /* Unhook from the free list. */
6336 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6341 num_free
+= this_free
;
6342 sprev
= &sblk
->next
;
6345 total_symbols
= num_used
;
6346 total_free_symbols
= num_free
;
6349 /* Put all unmarked misc's on free list.
6350 For a marker, first unchain it from the buffer it points into. */
6352 register struct marker_block
*mblk
;
6353 struct marker_block
**mprev
= &marker_block
;
6354 register int lim
= marker_block_index
;
6355 EMACS_INT num_free
= 0, num_used
= 0;
6357 marker_free_list
= 0;
6359 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6364 for (i
= 0; i
< lim
; i
++)
6366 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6368 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6369 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6370 /* Set the type of the freed object to Lisp_Misc_Free.
6371 We could leave the type alone, since nobody checks it,
6372 but this might catch bugs faster. */
6373 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6374 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6375 marker_free_list
= &mblk
->markers
[i
].m
;
6381 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6384 lim
= MARKER_BLOCK_SIZE
;
6385 /* If this block contains only free markers and we have already
6386 seen more than two blocks worth of free markers then deallocate
6388 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6390 *mprev
= mblk
->next
;
6391 /* Unhook from the free list. */
6392 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6397 num_free
+= this_free
;
6398 mprev
= &mblk
->next
;
6402 total_markers
= num_used
;
6403 total_free_markers
= num_free
;
6406 /* Free all unmarked buffers */
6408 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6411 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6412 if (!VECTOR_MARKED_P (buffer
))
6414 *bprev
= buffer
->next
;
6419 VECTOR_UNMARK (buffer
);
6420 /* Do not use buffer_(set|get)_intervals here. */
6421 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6423 bprev
= &buffer
->next
;
6428 check_string_bytes (!noninteractive
);
6434 /* Debugging aids. */
6436 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6437 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6438 This may be helpful in debugging Emacs's memory usage.
6439 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6444 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6449 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6450 doc
: /* Return a list of counters that measure how much consing there has been.
6451 Each of these counters increments for a certain kind of object.
6452 The counters wrap around from the largest positive integer to zero.
6453 Garbage collection does not decrease them.
6454 The elements of the value are as follows:
6455 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6456 All are in units of 1 = one object consed
6457 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6459 MISCS include overlays, markers, and some internal types.
6460 Frames, windows, buffers, and subprocesses count as vectors
6461 (but the contents of a buffer's text do not count here). */)
6464 return listn (CONSTYPE_HEAP
, 8,
6465 bounded_number (cons_cells_consed
),
6466 bounded_number (floats_consed
),
6467 bounded_number (vector_cells_consed
),
6468 bounded_number (symbols_consed
),
6469 bounded_number (string_chars_consed
),
6470 bounded_number (misc_objects_consed
),
6471 bounded_number (intervals_consed
),
6472 bounded_number (strings_consed
));
6475 /* Find at most FIND_MAX symbols which have OBJ as their value or
6476 function. This is used in gdbinit's `xwhichsymbols' command. */
6479 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6481 struct symbol_block
*sblk
;
6482 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6483 Lisp_Object found
= Qnil
;
6487 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6489 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6492 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6494 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6498 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6501 XSETSYMBOL (tem
, sym
);
6502 val
= find_symbol_value (tem
);
6504 || EQ (sym
->function
, obj
)
6505 || (!NILP (sym
->function
)
6506 && COMPILEDP (sym
->function
)
6507 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6510 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6512 found
= Fcons (tem
, found
);
6513 if (--find_max
== 0)
6521 unbind_to (gc_count
, Qnil
);
6525 #ifdef ENABLE_CHECKING
6527 bool suppress_checking
;
6530 die (const char *msg
, const char *file
, int line
)
6532 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6534 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6538 /* Initialization. */
6541 init_alloc_once (void)
6543 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6545 pure_size
= PURESIZE
;
6547 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6549 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6552 #ifdef DOUG_LEA_MALLOC
6553 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6554 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6555 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6560 refill_memory_reserve ();
6561 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6568 byte_stack_list
= 0;
6570 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6571 setjmp_tested_p
= longjmps_done
= 0;
6574 Vgc_elapsed
= make_float (0.0);
6579 syms_of_alloc (void)
6581 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6582 doc
: /* Number of bytes of consing between garbage collections.
6583 Garbage collection can happen automatically once this many bytes have been
6584 allocated since the last garbage collection. All data types count.
6586 Garbage collection happens automatically only when `eval' is called.
6588 By binding this temporarily to a large number, you can effectively
6589 prevent garbage collection during a part of the program.
6590 See also `gc-cons-percentage'. */);
6592 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6593 doc
: /* Portion of the heap used for allocation.
6594 Garbage collection can happen automatically once this portion of the heap
6595 has been allocated since the last garbage collection.
6596 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6597 Vgc_cons_percentage
= make_float (0.1);
6599 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6600 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6602 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6603 doc
: /* Number of cons cells that have been consed so far. */);
6605 DEFVAR_INT ("floats-consed", floats_consed
,
6606 doc
: /* Number of floats that have been consed so far. */);
6608 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6609 doc
: /* Number of vector cells that have been consed so far. */);
6611 DEFVAR_INT ("symbols-consed", symbols_consed
,
6612 doc
: /* Number of symbols that have been consed so far. */);
6614 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6615 doc
: /* Number of string characters that have been consed so far. */);
6617 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6618 doc
: /* Number of miscellaneous objects that have been consed so far.
6619 These include markers and overlays, plus certain objects not visible
6622 DEFVAR_INT ("intervals-consed", intervals_consed
,
6623 doc
: /* Number of intervals that have been consed so far. */);
6625 DEFVAR_INT ("strings-consed", strings_consed
,
6626 doc
: /* Number of strings that have been consed so far. */);
6628 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6629 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6630 This means that certain objects should be allocated in shared (pure) space.
6631 It can also be set to a hash-table, in which case this table is used to
6632 do hash-consing of the objects allocated to pure space. */);
6634 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6635 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6636 garbage_collection_messages
= 0;
6638 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6639 doc
: /* Hook run after garbage collection has finished. */);
6640 Vpost_gc_hook
= Qnil
;
6641 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6643 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6644 doc
: /* Precomputed `signal' argument for memory-full error. */);
6645 /* We build this in advance because if we wait until we need it, we might
6646 not be able to allocate the memory to hold it. */
6648 = listn (CONSTYPE_PURE
, 2, Qerror
,
6649 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6651 DEFVAR_LISP ("memory-full", Vmemory_full
,
6652 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6653 Vmemory_full
= Qnil
;
6655 DEFSYM (Qconses
, "conses");
6656 DEFSYM (Qsymbols
, "symbols");
6657 DEFSYM (Qmiscs
, "miscs");
6658 DEFSYM (Qstrings
, "strings");
6659 DEFSYM (Qvectors
, "vectors");
6660 DEFSYM (Qfloats
, "floats");
6661 DEFSYM (Qintervals
, "intervals");
6662 DEFSYM (Qbuffers
, "buffers");
6663 DEFSYM (Qstring_bytes
, "string-bytes");
6664 DEFSYM (Qvector_slots
, "vector-slots");
6665 DEFSYM (Qheap
, "heap");
6666 DEFSYM (Qautomatic_gc
, "Automatic GC");
6668 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6669 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6671 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6672 doc
: /* Accumulated time elapsed in garbage collections.
6673 The time is in seconds as a floating point value. */);
6674 DEFVAR_INT ("gcs-done", gcs_done
,
6675 doc
: /* Accumulated number of garbage collections done. */);
6680 defsubr (&Smake_byte_code
);
6681 defsubr (&Smake_list
);
6682 defsubr (&Smake_vector
);
6683 defsubr (&Smake_string
);
6684 defsubr (&Smake_bool_vector
);
6685 defsubr (&Smake_symbol
);
6686 defsubr (&Smake_marker
);
6687 defsubr (&Spurecopy
);
6688 defsubr (&Sgarbage_collect
);
6689 defsubr (&Smemory_limit
);
6690 defsubr (&Smemory_use_counts
);
6692 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6693 defsubr (&Sgc_status
);
6697 /* When compiled with GCC, GDB might say "No enum type named
6698 pvec_type" if we don't have at least one symbol with that type, and
6699 then xbacktrace could fail. Similarly for the other enums and
6700 their values. Some non-GCC compilers don't like these constructs. */
6704 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6705 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6706 enum char_bits char_bits
;
6707 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6708 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6709 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6710 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6711 enum Lisp_Bits Lisp_Bits
;
6712 enum Lisp_Compiled Lisp_Compiled
;
6713 enum maxargs maxargs
;
6714 enum MAX_ALLOCA MAX_ALLOCA
;
6715 enum More_Lisp_Bits More_Lisp_Bits
;
6716 enum pvec_type pvec_type
;
6717 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6718 #endif /* __GNUC__ */