1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #define LISP_INLINE EXTERN_INLINE
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
38 #include "intervals.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
53 # undef GC_CHECK_MARKED_OBJECTS
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
73 #include "w32heap.h" /* for sbrk */
76 #ifdef DOUG_LEA_MALLOC
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #endif /* not DOUG_LEA_MALLOC */
87 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
88 to a struct Lisp_String. */
90 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
91 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
92 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
94 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
95 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
96 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
98 /* Default value of gc_cons_threshold (see below). */
100 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
102 /* Global variables. */
103 struct emacs_globals globals
;
105 /* Number of bytes of consing done since the last gc. */
107 EMACS_INT consing_since_gc
;
109 /* Similar minimum, computed from Vgc_cons_percentage. */
111 EMACS_INT gc_relative_threshold
;
113 /* Minimum number of bytes of consing since GC before next GC,
114 when memory is full. */
116 EMACS_INT memory_full_cons_threshold
;
118 /* True during GC. */
122 /* True means abort if try to GC.
123 This is for code which is written on the assumption that
124 no GC will happen, so as to verify that assumption. */
128 /* Number of live and free conses etc. */
130 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
131 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
132 static EMACS_INT total_free_floats
, total_floats
;
134 /* Points to memory space allocated as "spare", to be freed if we run
135 out of memory. We keep one large block, four cons-blocks, and
136 two string blocks. */
138 static char *spare_memory
[7];
140 /* Amount of spare memory to keep in large reserve block, or to see
141 whether this much is available when malloc fails on a larger request. */
143 #define SPARE_MEMORY (1 << 14)
145 /* Initialize it to a nonzero value to force it into data space
146 (rather than bss space). That way unexec will remap it into text
147 space (pure), on some systems. We have not implemented the
148 remapping on more recent systems because this is less important
149 nowadays than in the days of small memories and timesharing. */
151 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
152 #define PUREBEG (char *) pure
154 /* Pointer to the pure area, and its size. */
156 static char *purebeg
;
157 static ptrdiff_t pure_size
;
159 /* Number of bytes of pure storage used before pure storage overflowed.
160 If this is non-zero, this implies that an overflow occurred. */
162 static ptrdiff_t pure_bytes_used_before_overflow
;
164 /* True if P points into pure space. */
166 #define PURE_POINTER_P(P) \
167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
169 /* Index in pure at which next pure Lisp object will be allocated.. */
171 static ptrdiff_t pure_bytes_used_lisp
;
173 /* Number of bytes allocated for non-Lisp objects in pure storage. */
175 static ptrdiff_t pure_bytes_used_non_lisp
;
177 /* If nonzero, this is a warning delivered by malloc and not yet
180 const char *pending_malloc_warning
;
182 /* Maximum amount of C stack to save when a GC happens. */
184 #ifndef MAX_SAVE_STACK
185 #define MAX_SAVE_STACK 16000
188 /* Buffer in which we save a copy of the C stack at each GC. */
190 #if MAX_SAVE_STACK > 0
191 static char *stack_copy
;
192 static ptrdiff_t stack_copy_size
;
195 static Lisp_Object Qconses
;
196 static Lisp_Object Qsymbols
;
197 static Lisp_Object Qmiscs
;
198 static Lisp_Object Qstrings
;
199 static Lisp_Object Qvectors
;
200 static Lisp_Object Qfloats
;
201 static Lisp_Object Qintervals
;
202 static Lisp_Object Qbuffers
;
203 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
204 static Lisp_Object Qgc_cons_threshold
;
205 Lisp_Object Qautomatic_gc
;
206 Lisp_Object Qchar_table_extra_slots
;
208 /* Hook run after GC has finished. */
210 static Lisp_Object Qpost_gc_hook
;
212 static void free_save_value (Lisp_Object
);
213 static void mark_terminals (void);
214 static void gc_sweep (void);
215 static Lisp_Object
make_pure_vector (ptrdiff_t);
216 static void mark_buffer (struct buffer
*);
218 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
219 static void refill_memory_reserve (void);
221 static void compact_small_strings (void);
222 static void free_large_strings (void);
223 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
225 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
226 what memory allocated via lisp_malloc and lisp_align_malloc is intended
227 for what purpose. This enumeration specifies the type of memory. */
238 /* Since all non-bool pseudovectors are small enough to be
239 allocated from vector blocks, this memory type denotes
240 large regular vectors and large bool pseudovectors. */
242 /* Special type to denote vector blocks. */
243 MEM_TYPE_VECTOR_BLOCK
,
244 /* Special type to denote reserved memory. */
248 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
250 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
251 #include <stdio.h> /* For fprintf. */
254 /* A unique object in pure space used to make some Lisp objects
255 on free lists recognizable in O(1). */
257 static Lisp_Object Vdead
;
258 #define DEADP(x) EQ (x, Vdead)
260 #ifdef GC_MALLOC_CHECK
262 enum mem_type allocated_mem_type
;
264 #endif /* GC_MALLOC_CHECK */
266 /* A node in the red-black tree describing allocated memory containing
267 Lisp data. Each such block is recorded with its start and end
268 address when it is allocated, and removed from the tree when it
271 A red-black tree is a balanced binary tree with the following
274 1. Every node is either red or black.
275 2. Every leaf is black.
276 3. If a node is red, then both of its children are black.
277 4. Every simple path from a node to a descendant leaf contains
278 the same number of black nodes.
279 5. The root is always black.
281 When nodes are inserted into the tree, or deleted from the tree,
282 the tree is "fixed" so that these properties are always true.
284 A red-black tree with N internal nodes has height at most 2
285 log(N+1). Searches, insertions and deletions are done in O(log N).
286 Please see a text book about data structures for a detailed
287 description of red-black trees. Any book worth its salt should
292 /* Children of this node. These pointers are never NULL. When there
293 is no child, the value is MEM_NIL, which points to a dummy node. */
294 struct mem_node
*left
, *right
;
296 /* The parent of this node. In the root node, this is NULL. */
297 struct mem_node
*parent
;
299 /* Start and end of allocated region. */
303 enum {MEM_BLACK
, MEM_RED
} color
;
309 /* Base address of stack. Set in main. */
311 Lisp_Object
*stack_base
;
313 /* Root of the tree describing allocated Lisp memory. */
315 static struct mem_node
*mem_root
;
317 /* Lowest and highest known address in the heap. */
319 static void *min_heap_address
, *max_heap_address
;
321 /* Sentinel node of the tree. */
323 static struct mem_node mem_z
;
324 #define MEM_NIL &mem_z
326 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
327 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
328 static void mem_insert_fixup (struct mem_node
*);
329 static void mem_rotate_left (struct mem_node
*);
330 static void mem_rotate_right (struct mem_node
*);
331 static void mem_delete (struct mem_node
*);
332 static void mem_delete_fixup (struct mem_node
*);
333 static struct mem_node
*mem_find (void *);
336 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
342 /* Recording what needs to be marked for gc. */
344 struct gcpro
*gcprolist
;
346 /* Addresses of staticpro'd variables. Initialize it to a nonzero
347 value; otherwise some compilers put it into BSS. */
349 #define NSTATICS 0x800
350 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
352 /* Index of next unused slot in staticvec. */
354 static int staticidx
;
356 static void *pure_alloc (size_t, int);
359 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
360 ALIGNMENT must be a power of 2. */
362 #define ALIGN(ptr, ALIGNMENT) \
363 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
364 & ~ ((ALIGNMENT) - 1)))
368 /************************************************************************
370 ************************************************************************/
372 /* Function malloc calls this if it finds we are near exhausting storage. */
375 malloc_warning (const char *str
)
377 pending_malloc_warning
= str
;
381 /* Display an already-pending malloc warning. */
384 display_malloc_warning (void)
386 call3 (intern ("display-warning"),
388 build_string (pending_malloc_warning
),
389 intern ("emergency"));
390 pending_malloc_warning
= 0;
393 /* Called if we can't allocate relocatable space for a buffer. */
396 buffer_memory_full (ptrdiff_t nbytes
)
398 /* If buffers use the relocating allocator, no need to free
399 spare_memory, because we may have plenty of malloc space left
400 that we could get, and if we don't, the malloc that fails will
401 itself cause spare_memory to be freed. If buffers don't use the
402 relocating allocator, treat this like any other failing
406 memory_full (nbytes
);
408 /* This used to call error, but if we've run out of memory, we could
409 get infinite recursion trying to build the string. */
410 xsignal (Qnil
, Vmemory_signal_data
);
414 /* A common multiple of the positive integers A and B. Ideally this
415 would be the least common multiple, but there's no way to do that
416 as a constant expression in C, so do the best that we can easily do. */
417 #define COMMON_MULTIPLE(a, b) \
418 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
420 #ifndef XMALLOC_OVERRUN_CHECK
421 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
424 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
427 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
428 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
429 block size in little-endian order. The trailer consists of
430 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
432 The header is used to detect whether this block has been allocated
433 through these functions, as some low-level libc functions may
434 bypass the malloc hooks. */
436 #define XMALLOC_OVERRUN_CHECK_SIZE 16
437 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
438 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
440 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
441 hold a size_t value and (2) the header size is a multiple of the
442 alignment that Emacs needs for C types and for USE_LSB_TAG. */
443 #define XMALLOC_BASE_ALIGNMENT \
444 alignof (union { long double d; intmax_t i; void *p; })
447 # define XMALLOC_HEADER_ALIGNMENT \
448 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
450 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
452 #define XMALLOC_OVERRUN_SIZE_SIZE \
453 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
454 + XMALLOC_HEADER_ALIGNMENT - 1) \
455 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
456 - XMALLOC_OVERRUN_CHECK_SIZE)
458 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
459 { '\x9a', '\x9b', '\xae', '\xaf',
460 '\xbf', '\xbe', '\xce', '\xcf',
461 '\xea', '\xeb', '\xec', '\xed',
462 '\xdf', '\xde', '\x9c', '\x9d' };
464 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
465 { '\xaa', '\xab', '\xac', '\xad',
466 '\xba', '\xbb', '\xbc', '\xbd',
467 '\xca', '\xcb', '\xcc', '\xcd',
468 '\xda', '\xdb', '\xdc', '\xdd' };
470 /* Insert and extract the block size in the header. */
473 xmalloc_put_size (unsigned char *ptr
, size_t size
)
476 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
478 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
484 xmalloc_get_size (unsigned char *ptr
)
488 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
489 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
498 /* Like malloc, but wraps allocated block with header and trailer. */
501 overrun_check_malloc (size_t size
)
503 register unsigned char *val
;
504 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
507 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
510 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
511 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
512 xmalloc_put_size (val
, size
);
513 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
514 XMALLOC_OVERRUN_CHECK_SIZE
);
520 /* Like realloc, but checks old block for overrun, and wraps new block
521 with header and trailer. */
524 overrun_check_realloc (void *block
, size_t size
)
526 register unsigned char *val
= (unsigned char *) block
;
527 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
531 && memcmp (xmalloc_overrun_check_header
,
532 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
533 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
535 size_t osize
= xmalloc_get_size (val
);
536 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
537 XMALLOC_OVERRUN_CHECK_SIZE
))
539 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
540 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
541 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
544 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
548 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
549 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
550 xmalloc_put_size (val
, size
);
551 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
552 XMALLOC_OVERRUN_CHECK_SIZE
);
557 /* Like free, but checks block for overrun. */
560 overrun_check_free (void *block
)
562 unsigned char *val
= (unsigned char *) block
;
565 && memcmp (xmalloc_overrun_check_header
,
566 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
567 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
569 size_t osize
= xmalloc_get_size (val
);
570 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
571 XMALLOC_OVERRUN_CHECK_SIZE
))
573 #ifdef XMALLOC_CLEAR_FREE_MEMORY
574 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
575 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
577 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
578 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
579 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
589 #define malloc overrun_check_malloc
590 #define realloc overrun_check_realloc
591 #define free overrun_check_free
594 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
595 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
596 If that variable is set, block input while in one of Emacs's memory
597 allocation functions. There should be no need for this debugging
598 option, since signal handlers do not allocate memory, but Emacs
599 formerly allocated memory in signal handlers and this compile-time
600 option remains as a way to help debug the issue should it rear its
602 #ifdef XMALLOC_BLOCK_INPUT_CHECK
603 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
605 malloc_block_input (void)
607 if (block_input_in_memory_allocators
)
611 malloc_unblock_input (void)
613 if (block_input_in_memory_allocators
)
616 # define MALLOC_BLOCK_INPUT malloc_block_input ()
617 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
619 # define MALLOC_BLOCK_INPUT ((void) 0)
620 # define MALLOC_UNBLOCK_INPUT ((void) 0)
623 #define MALLOC_PROBE(size) \
625 if (profiler_memory_running) \
626 malloc_probe (size); \
630 /* Like malloc but check for no memory and block interrupt input.. */
633 xmalloc (size_t size
)
639 MALLOC_UNBLOCK_INPUT
;
647 /* Like the above, but zeroes out the memory just allocated. */
650 xzalloc (size_t size
)
656 MALLOC_UNBLOCK_INPUT
;
660 memset (val
, 0, size
);
665 /* Like realloc but check for no memory and block interrupt input.. */
668 xrealloc (void *block
, size_t size
)
673 /* We must call malloc explicitly when BLOCK is 0, since some
674 reallocs don't do this. */
678 val
= realloc (block
, size
);
679 MALLOC_UNBLOCK_INPUT
;
688 /* Like free but block interrupt input. */
697 MALLOC_UNBLOCK_INPUT
;
698 /* We don't call refill_memory_reserve here
699 because in practice the call in r_alloc_free seems to suffice. */
703 /* Other parts of Emacs pass large int values to allocator functions
704 expecting ptrdiff_t. This is portable in practice, but check it to
706 verify (INT_MAX
<= PTRDIFF_MAX
);
709 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
710 Signal an error on memory exhaustion, and block interrupt input. */
713 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
715 eassert (0 <= nitems
&& 0 < item_size
);
716 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
717 memory_full (SIZE_MAX
);
718 return xmalloc (nitems
* item_size
);
722 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
723 Signal an error on memory exhaustion, and block interrupt input. */
726 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
728 eassert (0 <= nitems
&& 0 < item_size
);
729 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
730 memory_full (SIZE_MAX
);
731 return xrealloc (pa
, nitems
* item_size
);
735 /* Grow PA, which points to an array of *NITEMS items, and return the
736 location of the reallocated array, updating *NITEMS to reflect its
737 new size. The new array will contain at least NITEMS_INCR_MIN more
738 items, but will not contain more than NITEMS_MAX items total.
739 ITEM_SIZE is the size of each item, in bytes.
741 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
742 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
745 If PA is null, then allocate a new array instead of reallocating
748 Block interrupt input as needed. If memory exhaustion occurs, set
749 *NITEMS to zero if PA is null, and signal an error (i.e., do not
752 Thus, to grow an array A without saving its old contents, do
753 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
754 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
755 and signals an error, and later this code is reexecuted and
756 attempts to free A. */
759 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
760 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
762 /* The approximate size to use for initial small allocation
763 requests. This is the largest "small" request for the GNU C
765 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
767 /* If the array is tiny, grow it to about (but no greater than)
768 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
769 ptrdiff_t n
= *nitems
;
770 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
771 ptrdiff_t half_again
= n
>> 1;
772 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
774 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
775 NITEMS_MAX, and what the C language can represent safely. */
776 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
777 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
778 ? nitems_max
: C_language_max
);
779 ptrdiff_t nitems_incr_max
= n_max
- n
;
780 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
782 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
785 if (nitems_incr_max
< incr
)
786 memory_full (SIZE_MAX
);
788 pa
= xrealloc (pa
, n
* item_size
);
794 /* Like strdup, but uses xmalloc. */
797 xstrdup (const char *s
)
799 size_t len
= strlen (s
) + 1;
800 char *p
= xmalloc (len
);
805 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
806 argument is a const pointer. */
809 xputenv (char const *string
)
811 if (putenv ((char *) string
) != 0)
815 /* Unwind for SAFE_ALLOCA */
818 safe_alloca_unwind (Lisp_Object arg
)
820 free_save_value (arg
);
824 /* Return a newly allocated memory block of SIZE bytes, remembering
825 to free it when unwinding. */
827 record_xmalloc (size_t size
)
829 void *p
= xmalloc (size
);
830 record_unwind_protect (safe_alloca_unwind
, make_save_pointer (p
));
835 /* Like malloc but used for allocating Lisp data. NBYTES is the
836 number of bytes to allocate, TYPE describes the intended use of the
837 allocated memory block (for strings, for conses, ...). */
840 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
844 lisp_malloc (size_t nbytes
, enum mem_type type
)
850 #ifdef GC_MALLOC_CHECK
851 allocated_mem_type
= type
;
854 val
= malloc (nbytes
);
857 /* If the memory just allocated cannot be addressed thru a Lisp
858 object's pointer, and it needs to be,
859 that's equivalent to running out of memory. */
860 if (val
&& type
!= MEM_TYPE_NON_LISP
)
863 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
864 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
866 lisp_malloc_loser
= val
;
873 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
874 if (val
&& type
!= MEM_TYPE_NON_LISP
)
875 mem_insert (val
, (char *) val
+ nbytes
, type
);
878 MALLOC_UNBLOCK_INPUT
;
880 memory_full (nbytes
);
881 MALLOC_PROBE (nbytes
);
885 /* Free BLOCK. This must be called to free memory allocated with a
886 call to lisp_malloc. */
889 lisp_free (void *block
)
893 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
894 mem_delete (mem_find (block
));
896 MALLOC_UNBLOCK_INPUT
;
899 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
901 /* The entry point is lisp_align_malloc which returns blocks of at most
902 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
904 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
905 #define USE_POSIX_MEMALIGN 1
908 /* BLOCK_ALIGN has to be a power of 2. */
909 #define BLOCK_ALIGN (1 << 10)
911 /* Padding to leave at the end of a malloc'd block. This is to give
912 malloc a chance to minimize the amount of memory wasted to alignment.
913 It should be tuned to the particular malloc library used.
914 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
915 posix_memalign on the other hand would ideally prefer a value of 4
916 because otherwise, there's 1020 bytes wasted between each ablocks.
917 In Emacs, testing shows that those 1020 can most of the time be
918 efficiently used by malloc to place other objects, so a value of 0 can
919 still preferable unless you have a lot of aligned blocks and virtually
921 #define BLOCK_PADDING 0
922 #define BLOCK_BYTES \
923 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
925 /* Internal data structures and constants. */
927 #define ABLOCKS_SIZE 16
929 /* An aligned block of memory. */
934 char payload
[BLOCK_BYTES
];
935 struct ablock
*next_free
;
937 /* `abase' is the aligned base of the ablocks. */
938 /* It is overloaded to hold the virtual `busy' field that counts
939 the number of used ablock in the parent ablocks.
940 The first ablock has the `busy' field, the others have the `abase'
941 field. To tell the difference, we assume that pointers will have
942 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
943 is used to tell whether the real base of the parent ablocks is `abase'
944 (if not, the word before the first ablock holds a pointer to the
946 struct ablocks
*abase
;
947 /* The padding of all but the last ablock is unused. The padding of
948 the last ablock in an ablocks is not allocated. */
950 char padding
[BLOCK_PADDING
];
954 /* A bunch of consecutive aligned blocks. */
957 struct ablock blocks
[ABLOCKS_SIZE
];
960 /* Size of the block requested from malloc or posix_memalign. */
961 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
963 #define ABLOCK_ABASE(block) \
964 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
965 ? (struct ablocks *)(block) \
968 /* Virtual `busy' field. */
969 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
971 /* Pointer to the (not necessarily aligned) malloc block. */
972 #ifdef USE_POSIX_MEMALIGN
973 #define ABLOCKS_BASE(abase) (abase)
975 #define ABLOCKS_BASE(abase) \
976 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
979 /* The list of free ablock. */
980 static struct ablock
*free_ablock
;
982 /* Allocate an aligned block of nbytes.
983 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
984 smaller or equal to BLOCK_BYTES. */
986 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
989 struct ablocks
*abase
;
991 eassert (nbytes
<= BLOCK_BYTES
);
995 #ifdef GC_MALLOC_CHECK
996 allocated_mem_type
= type
;
1002 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1004 #ifdef DOUG_LEA_MALLOC
1005 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1006 because mapped region contents are not preserved in
1008 mallopt (M_MMAP_MAX
, 0);
1011 #ifdef USE_POSIX_MEMALIGN
1013 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1019 base
= malloc (ABLOCKS_BYTES
);
1020 abase
= ALIGN (base
, BLOCK_ALIGN
);
1025 MALLOC_UNBLOCK_INPUT
;
1026 memory_full (ABLOCKS_BYTES
);
1029 aligned
= (base
== abase
);
1031 ((void**)abase
)[-1] = base
;
1033 #ifdef DOUG_LEA_MALLOC
1034 /* Back to a reasonable maximum of mmap'ed areas. */
1035 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1039 /* If the memory just allocated cannot be addressed thru a Lisp
1040 object's pointer, and it needs to be, that's equivalent to
1041 running out of memory. */
1042 if (type
!= MEM_TYPE_NON_LISP
)
1045 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1046 XSETCONS (tem
, end
);
1047 if ((char *) XCONS (tem
) != end
)
1049 lisp_malloc_loser
= base
;
1051 MALLOC_UNBLOCK_INPUT
;
1052 memory_full (SIZE_MAX
);
1057 /* Initialize the blocks and put them on the free list.
1058 If `base' was not properly aligned, we can't use the last block. */
1059 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1061 abase
->blocks
[i
].abase
= abase
;
1062 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1063 free_ablock
= &abase
->blocks
[i
];
1065 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1067 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1068 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1069 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1070 eassert (ABLOCKS_BASE (abase
) == base
);
1071 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1074 abase
= ABLOCK_ABASE (free_ablock
);
1075 ABLOCKS_BUSY (abase
) =
1076 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1078 free_ablock
= free_ablock
->x
.next_free
;
1080 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1081 if (type
!= MEM_TYPE_NON_LISP
)
1082 mem_insert (val
, (char *) val
+ nbytes
, type
);
1085 MALLOC_UNBLOCK_INPUT
;
1087 MALLOC_PROBE (nbytes
);
1089 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1094 lisp_align_free (void *block
)
1096 struct ablock
*ablock
= block
;
1097 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1100 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1101 mem_delete (mem_find (block
));
1103 /* Put on free list. */
1104 ablock
->x
.next_free
= free_ablock
;
1105 free_ablock
= ablock
;
1106 /* Update busy count. */
1107 ABLOCKS_BUSY (abase
)
1108 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1110 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1111 { /* All the blocks are free. */
1112 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1113 struct ablock
**tem
= &free_ablock
;
1114 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1118 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1121 *tem
= (*tem
)->x
.next_free
;
1124 tem
= &(*tem
)->x
.next_free
;
1126 eassert ((aligned
& 1) == aligned
);
1127 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1128 #ifdef USE_POSIX_MEMALIGN
1129 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1131 free (ABLOCKS_BASE (abase
));
1133 MALLOC_UNBLOCK_INPUT
;
1137 /***********************************************************************
1139 ***********************************************************************/
1141 /* Number of intervals allocated in an interval_block structure.
1142 The 1020 is 1024 minus malloc overhead. */
1144 #define INTERVAL_BLOCK_SIZE \
1145 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1147 /* Intervals are allocated in chunks in the form of an interval_block
1150 struct interval_block
1152 /* Place `intervals' first, to preserve alignment. */
1153 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1154 struct interval_block
*next
;
1157 /* Current interval block. Its `next' pointer points to older
1160 static struct interval_block
*interval_block
;
1162 /* Index in interval_block above of the next unused interval
1165 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1167 /* Number of free and live intervals. */
1169 static EMACS_INT total_free_intervals
, total_intervals
;
1171 /* List of free intervals. */
1173 static INTERVAL interval_free_list
;
1175 /* Return a new interval. */
1178 make_interval (void)
1184 if (interval_free_list
)
1186 val
= interval_free_list
;
1187 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1191 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1193 struct interval_block
*newi
1194 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1196 newi
->next
= interval_block
;
1197 interval_block
= newi
;
1198 interval_block_index
= 0;
1199 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1201 val
= &interval_block
->intervals
[interval_block_index
++];
1204 MALLOC_UNBLOCK_INPUT
;
1206 consing_since_gc
+= sizeof (struct interval
);
1208 total_free_intervals
--;
1209 RESET_INTERVAL (val
);
1215 /* Mark Lisp objects in interval I. */
1218 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1220 /* Intervals should never be shared. So, if extra internal checking is
1221 enabled, GC aborts if it seems to have visited an interval twice. */
1222 eassert (!i
->gcmarkbit
);
1224 mark_object (i
->plist
);
1227 /* Mark the interval tree rooted in I. */
1229 #define MARK_INTERVAL_TREE(i) \
1231 if (i && !i->gcmarkbit) \
1232 traverse_intervals_noorder (i, mark_interval, Qnil); \
1235 /***********************************************************************
1237 ***********************************************************************/
1239 /* Lisp_Strings are allocated in string_block structures. When a new
1240 string_block is allocated, all the Lisp_Strings it contains are
1241 added to a free-list string_free_list. When a new Lisp_String is
1242 needed, it is taken from that list. During the sweep phase of GC,
1243 string_blocks that are entirely free are freed, except two which
1246 String data is allocated from sblock structures. Strings larger
1247 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1248 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1250 Sblocks consist internally of sdata structures, one for each
1251 Lisp_String. The sdata structure points to the Lisp_String it
1252 belongs to. The Lisp_String points back to the `u.data' member of
1253 its sdata structure.
1255 When a Lisp_String is freed during GC, it is put back on
1256 string_free_list, and its `data' member and its sdata's `string'
1257 pointer is set to null. The size of the string is recorded in the
1258 `u.nbytes' member of the sdata. So, sdata structures that are no
1259 longer used, can be easily recognized, and it's easy to compact the
1260 sblocks of small strings which we do in compact_small_strings. */
1262 /* Size in bytes of an sblock structure used for small strings. This
1263 is 8192 minus malloc overhead. */
1265 #define SBLOCK_SIZE 8188
1267 /* Strings larger than this are considered large strings. String data
1268 for large strings is allocated from individual sblocks. */
1270 #define LARGE_STRING_BYTES 1024
1272 /* Structure describing string memory sub-allocated from an sblock.
1273 This is where the contents of Lisp strings are stored. */
1277 /* Back-pointer to the string this sdata belongs to. If null, this
1278 structure is free, and the NBYTES member of the union below
1279 contains the string's byte size (the same value that STRING_BYTES
1280 would return if STRING were non-null). If non-null, STRING_BYTES
1281 (STRING) is the size of the data, and DATA contains the string's
1283 struct Lisp_String
*string
;
1285 #ifdef GC_CHECK_STRING_BYTES
1288 unsigned char data
[1];
1290 #define SDATA_NBYTES(S) (S)->nbytes
1291 #define SDATA_DATA(S) (S)->data
1292 #define SDATA_SELECTOR(member) member
1294 #else /* not GC_CHECK_STRING_BYTES */
1298 /* When STRING is non-null. */
1299 unsigned char data
[1];
1301 /* When STRING is null. */
1305 #define SDATA_NBYTES(S) (S)->u.nbytes
1306 #define SDATA_DATA(S) (S)->u.data
1307 #define SDATA_SELECTOR(member) u.member
1309 #endif /* not GC_CHECK_STRING_BYTES */
1311 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1315 /* Structure describing a block of memory which is sub-allocated to
1316 obtain string data memory for strings. Blocks for small strings
1317 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1318 as large as needed. */
1323 struct sblock
*next
;
1325 /* Pointer to the next free sdata block. This points past the end
1326 of the sblock if there isn't any space left in this block. */
1327 struct sdata
*next_free
;
1329 /* Start of data. */
1330 struct sdata first_data
;
1333 /* Number of Lisp strings in a string_block structure. The 1020 is
1334 1024 minus malloc overhead. */
1336 #define STRING_BLOCK_SIZE \
1337 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1339 /* Structure describing a block from which Lisp_String structures
1344 /* Place `strings' first, to preserve alignment. */
1345 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1346 struct string_block
*next
;
1349 /* Head and tail of the list of sblock structures holding Lisp string
1350 data. We always allocate from current_sblock. The NEXT pointers
1351 in the sblock structures go from oldest_sblock to current_sblock. */
1353 static struct sblock
*oldest_sblock
, *current_sblock
;
1355 /* List of sblocks for large strings. */
1357 static struct sblock
*large_sblocks
;
1359 /* List of string_block structures. */
1361 static struct string_block
*string_blocks
;
1363 /* Free-list of Lisp_Strings. */
1365 static struct Lisp_String
*string_free_list
;
1367 /* Number of live and free Lisp_Strings. */
1369 static EMACS_INT total_strings
, total_free_strings
;
1371 /* Number of bytes used by live strings. */
1373 static EMACS_INT total_string_bytes
;
1375 /* Given a pointer to a Lisp_String S which is on the free-list
1376 string_free_list, return a pointer to its successor in the
1379 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1381 /* Return a pointer to the sdata structure belonging to Lisp string S.
1382 S must be live, i.e. S->data must not be null. S->data is actually
1383 a pointer to the `u.data' member of its sdata structure; the
1384 structure starts at a constant offset in front of that. */
1386 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1389 #ifdef GC_CHECK_STRING_OVERRUN
1391 /* We check for overrun in string data blocks by appending a small
1392 "cookie" after each allocated string data block, and check for the
1393 presence of this cookie during GC. */
1395 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1396 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1397 { '\xde', '\xad', '\xbe', '\xef' };
1400 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1403 /* Value is the size of an sdata structure large enough to hold NBYTES
1404 bytes of string data. The value returned includes a terminating
1405 NUL byte, the size of the sdata structure, and padding. */
1407 #ifdef GC_CHECK_STRING_BYTES
1409 #define SDATA_SIZE(NBYTES) \
1410 ((SDATA_DATA_OFFSET \
1412 + sizeof (ptrdiff_t) - 1) \
1413 & ~(sizeof (ptrdiff_t) - 1))
1415 #else /* not GC_CHECK_STRING_BYTES */
1417 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1418 less than the size of that member. The 'max' is not needed when
1419 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1420 alignment code reserves enough space. */
1422 #define SDATA_SIZE(NBYTES) \
1423 ((SDATA_DATA_OFFSET \
1424 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1426 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1428 + sizeof (ptrdiff_t) - 1) \
1429 & ~(sizeof (ptrdiff_t) - 1))
1431 #endif /* not GC_CHECK_STRING_BYTES */
1433 /* Extra bytes to allocate for each string. */
1435 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1437 /* Exact bound on the number of bytes in a string, not counting the
1438 terminating null. A string cannot contain more bytes than
1439 STRING_BYTES_BOUND, nor can it be so long that the size_t
1440 arithmetic in allocate_string_data would overflow while it is
1441 calculating a value to be passed to malloc. */
1442 static ptrdiff_t const STRING_BYTES_MAX
=
1443 min (STRING_BYTES_BOUND
,
1444 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1446 - offsetof (struct sblock
, first_data
)
1447 - SDATA_DATA_OFFSET
)
1448 & ~(sizeof (EMACS_INT
) - 1)));
1450 /* Initialize string allocation. Called from init_alloc_once. */
1455 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1456 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1460 #ifdef GC_CHECK_STRING_BYTES
1462 static int check_string_bytes_count
;
1464 /* Like STRING_BYTES, but with debugging check. Can be
1465 called during GC, so pay attention to the mark bit. */
1468 string_bytes (struct Lisp_String
*s
)
1471 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1473 if (!PURE_POINTER_P (s
)
1475 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1480 /* Check validity of Lisp strings' string_bytes member in B. */
1483 check_sblock (struct sblock
*b
)
1485 struct sdata
*from
, *end
, *from_end
;
1489 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1491 /* Compute the next FROM here because copying below may
1492 overwrite data we need to compute it. */
1495 /* Check that the string size recorded in the string is the
1496 same as the one recorded in the sdata structure. */
1497 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1498 : SDATA_NBYTES (from
));
1499 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1504 /* Check validity of Lisp strings' string_bytes member. ALL_P
1505 means check all strings, otherwise check only most
1506 recently allocated strings. Used for hunting a bug. */
1509 check_string_bytes (bool all_p
)
1515 for (b
= large_sblocks
; b
; b
= b
->next
)
1517 struct Lisp_String
*s
= b
->first_data
.string
;
1522 for (b
= oldest_sblock
; b
; b
= b
->next
)
1525 else if (current_sblock
)
1526 check_sblock (current_sblock
);
1529 #else /* not GC_CHECK_STRING_BYTES */
1531 #define check_string_bytes(all) ((void) 0)
1533 #endif /* GC_CHECK_STRING_BYTES */
1535 #ifdef GC_CHECK_STRING_FREE_LIST
1537 /* Walk through the string free list looking for bogus next pointers.
1538 This may catch buffer overrun from a previous string. */
1541 check_string_free_list (void)
1543 struct Lisp_String
*s
;
1545 /* Pop a Lisp_String off the free-list. */
1546 s
= string_free_list
;
1549 if ((uintptr_t) s
< 1024)
1551 s
= NEXT_FREE_LISP_STRING (s
);
1555 #define check_string_free_list()
1558 /* Return a new Lisp_String. */
1560 static struct Lisp_String
*
1561 allocate_string (void)
1563 struct Lisp_String
*s
;
1567 /* If the free-list is empty, allocate a new string_block, and
1568 add all the Lisp_Strings in it to the free-list. */
1569 if (string_free_list
== NULL
)
1571 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1574 b
->next
= string_blocks
;
1577 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1580 /* Every string on a free list should have NULL data pointer. */
1582 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1583 string_free_list
= s
;
1586 total_free_strings
+= STRING_BLOCK_SIZE
;
1589 check_string_free_list ();
1591 /* Pop a Lisp_String off the free-list. */
1592 s
= string_free_list
;
1593 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1595 MALLOC_UNBLOCK_INPUT
;
1597 --total_free_strings
;
1600 consing_since_gc
+= sizeof *s
;
1602 #ifdef GC_CHECK_STRING_BYTES
1603 if (!noninteractive
)
1605 if (++check_string_bytes_count
== 200)
1607 check_string_bytes_count
= 0;
1608 check_string_bytes (1);
1611 check_string_bytes (0);
1613 #endif /* GC_CHECK_STRING_BYTES */
1619 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1620 plus a NUL byte at the end. Allocate an sdata structure for S, and
1621 set S->data to its `u.data' member. Store a NUL byte at the end of
1622 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1623 S->data if it was initially non-null. */
1626 allocate_string_data (struct Lisp_String
*s
,
1627 EMACS_INT nchars
, EMACS_INT nbytes
)
1629 struct sdata
*data
, *old_data
;
1631 ptrdiff_t needed
, old_nbytes
;
1633 if (STRING_BYTES_MAX
< nbytes
)
1636 /* Determine the number of bytes needed to store NBYTES bytes
1638 needed
= SDATA_SIZE (nbytes
);
1641 old_data
= SDATA_OF_STRING (s
);
1642 old_nbytes
= STRING_BYTES (s
);
1649 if (nbytes
> LARGE_STRING_BYTES
)
1651 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1653 #ifdef DOUG_LEA_MALLOC
1654 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1655 because mapped region contents are not preserved in
1658 In case you think of allowing it in a dumped Emacs at the
1659 cost of not being able to re-dump, there's another reason:
1660 mmap'ed data typically have an address towards the top of the
1661 address space, which won't fit into an EMACS_INT (at least on
1662 32-bit systems with the current tagging scheme). --fx */
1663 mallopt (M_MMAP_MAX
, 0);
1666 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1668 #ifdef DOUG_LEA_MALLOC
1669 /* Back to a reasonable maximum of mmap'ed areas. */
1670 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1673 b
->next_free
= &b
->first_data
;
1674 b
->first_data
.string
= NULL
;
1675 b
->next
= large_sblocks
;
1678 else if (current_sblock
== NULL
1679 || (((char *) current_sblock
+ SBLOCK_SIZE
1680 - (char *) current_sblock
->next_free
)
1681 < (needed
+ GC_STRING_EXTRA
)))
1683 /* Not enough room in the current sblock. */
1684 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1685 b
->next_free
= &b
->first_data
;
1686 b
->first_data
.string
= NULL
;
1690 current_sblock
->next
= b
;
1698 data
= b
->next_free
;
1699 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1701 MALLOC_UNBLOCK_INPUT
;
1704 s
->data
= SDATA_DATA (data
);
1705 #ifdef GC_CHECK_STRING_BYTES
1706 SDATA_NBYTES (data
) = nbytes
;
1709 s
->size_byte
= nbytes
;
1710 s
->data
[nbytes
] = '\0';
1711 #ifdef GC_CHECK_STRING_OVERRUN
1712 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1713 GC_STRING_OVERRUN_COOKIE_SIZE
);
1716 /* Note that Faset may call to this function when S has already data
1717 assigned. In this case, mark data as free by setting it's string
1718 back-pointer to null, and record the size of the data in it. */
1721 SDATA_NBYTES (old_data
) = old_nbytes
;
1722 old_data
->string
= NULL
;
1725 consing_since_gc
+= needed
;
1729 /* Sweep and compact strings. */
1732 sweep_strings (void)
1734 struct string_block
*b
, *next
;
1735 struct string_block
*live_blocks
= NULL
;
1737 string_free_list
= NULL
;
1738 total_strings
= total_free_strings
= 0;
1739 total_string_bytes
= 0;
1741 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1742 for (b
= string_blocks
; b
; b
= next
)
1745 struct Lisp_String
*free_list_before
= string_free_list
;
1749 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1751 struct Lisp_String
*s
= b
->strings
+ i
;
1755 /* String was not on free-list before. */
1756 if (STRING_MARKED_P (s
))
1758 /* String is live; unmark it and its intervals. */
1761 /* Do not use string_(set|get)_intervals here. */
1762 s
->intervals
= balance_intervals (s
->intervals
);
1765 total_string_bytes
+= STRING_BYTES (s
);
1769 /* String is dead. Put it on the free-list. */
1770 struct sdata
*data
= SDATA_OF_STRING (s
);
1772 /* Save the size of S in its sdata so that we know
1773 how large that is. Reset the sdata's string
1774 back-pointer so that we know it's free. */
1775 #ifdef GC_CHECK_STRING_BYTES
1776 if (string_bytes (s
) != SDATA_NBYTES (data
))
1779 data
->u
.nbytes
= STRING_BYTES (s
);
1781 data
->string
= NULL
;
1783 /* Reset the strings's `data' member so that we
1787 /* Put the string on the free-list. */
1788 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1789 string_free_list
= s
;
1795 /* S was on the free-list before. Put it there again. */
1796 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1797 string_free_list
= s
;
1802 /* Free blocks that contain free Lisp_Strings only, except
1803 the first two of them. */
1804 if (nfree
== STRING_BLOCK_SIZE
1805 && total_free_strings
> STRING_BLOCK_SIZE
)
1808 string_free_list
= free_list_before
;
1812 total_free_strings
+= nfree
;
1813 b
->next
= live_blocks
;
1818 check_string_free_list ();
1820 string_blocks
= live_blocks
;
1821 free_large_strings ();
1822 compact_small_strings ();
1824 check_string_free_list ();
1828 /* Free dead large strings. */
1831 free_large_strings (void)
1833 struct sblock
*b
, *next
;
1834 struct sblock
*live_blocks
= NULL
;
1836 for (b
= large_sblocks
; b
; b
= next
)
1840 if (b
->first_data
.string
== NULL
)
1844 b
->next
= live_blocks
;
1849 large_sblocks
= live_blocks
;
1853 /* Compact data of small strings. Free sblocks that don't contain
1854 data of live strings after compaction. */
1857 compact_small_strings (void)
1859 struct sblock
*b
, *tb
, *next
;
1860 struct sdata
*from
, *to
, *end
, *tb_end
;
1861 struct sdata
*to_end
, *from_end
;
1863 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1864 to, and TB_END is the end of TB. */
1866 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1867 to
= &tb
->first_data
;
1869 /* Step through the blocks from the oldest to the youngest. We
1870 expect that old blocks will stabilize over time, so that less
1871 copying will happen this way. */
1872 for (b
= oldest_sblock
; b
; b
= b
->next
)
1875 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1877 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1879 /* Compute the next FROM here because copying below may
1880 overwrite data we need to compute it. */
1882 struct Lisp_String
*s
= from
->string
;
1884 #ifdef GC_CHECK_STRING_BYTES
1885 /* Check that the string size recorded in the string is the
1886 same as the one recorded in the sdata structure. */
1887 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1889 #endif /* GC_CHECK_STRING_BYTES */
1891 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1892 eassert (nbytes
<= LARGE_STRING_BYTES
);
1894 nbytes
= SDATA_SIZE (nbytes
);
1895 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1897 #ifdef GC_CHECK_STRING_OVERRUN
1898 if (memcmp (string_overrun_cookie
,
1899 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1900 GC_STRING_OVERRUN_COOKIE_SIZE
))
1904 /* Non-NULL S means it's alive. Copy its data. */
1907 /* If TB is full, proceed with the next sblock. */
1908 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1909 if (to_end
> tb_end
)
1913 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1914 to
= &tb
->first_data
;
1915 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1918 /* Copy, and update the string's `data' pointer. */
1921 eassert (tb
!= b
|| to
< from
);
1922 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1923 to
->string
->data
= SDATA_DATA (to
);
1926 /* Advance past the sdata we copied to. */
1932 /* The rest of the sblocks following TB don't contain live data, so
1933 we can free them. */
1934 for (b
= tb
->next
; b
; b
= next
)
1942 current_sblock
= tb
;
1946 string_overflow (void)
1948 error ("Maximum string size exceeded");
1951 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1952 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1953 LENGTH must be an integer.
1954 INIT must be an integer that represents a character. */)
1955 (Lisp_Object length
, Lisp_Object init
)
1957 register Lisp_Object val
;
1958 register unsigned char *p
, *end
;
1962 CHECK_NATNUM (length
);
1963 CHECK_CHARACTER (init
);
1965 c
= XFASTINT (init
);
1966 if (ASCII_CHAR_P (c
))
1968 nbytes
= XINT (length
);
1969 val
= make_uninit_string (nbytes
);
1971 end
= p
+ SCHARS (val
);
1977 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1978 int len
= CHAR_STRING (c
, str
);
1979 EMACS_INT string_len
= XINT (length
);
1981 if (string_len
> STRING_BYTES_MAX
/ len
)
1983 nbytes
= len
* string_len
;
1984 val
= make_uninit_multibyte_string (string_len
, nbytes
);
1989 memcpy (p
, str
, len
);
1999 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2000 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2001 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2002 (Lisp_Object length
, Lisp_Object init
)
2004 register Lisp_Object val
;
2005 struct Lisp_Bool_Vector
*p
;
2006 ptrdiff_t length_in_chars
;
2007 EMACS_INT length_in_elts
;
2009 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2012 CHECK_NATNUM (length
);
2014 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2016 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2018 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2020 /* No Lisp_Object to trace in there. */
2021 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2023 p
= XBOOL_VECTOR (val
);
2024 p
->size
= XFASTINT (length
);
2026 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2027 / BOOL_VECTOR_BITS_PER_CHAR
);
2028 if (length_in_chars
)
2030 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2032 /* Clear any extraneous bits in the last byte. */
2033 p
->data
[length_in_chars
- 1]
2034 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2041 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2042 of characters from the contents. This string may be unibyte or
2043 multibyte, depending on the contents. */
2046 make_string (const char *contents
, ptrdiff_t nbytes
)
2048 register Lisp_Object val
;
2049 ptrdiff_t nchars
, multibyte_nbytes
;
2051 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2052 &nchars
, &multibyte_nbytes
);
2053 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2054 /* CONTENTS contains no multibyte sequences or contains an invalid
2055 multibyte sequence. We must make unibyte string. */
2056 val
= make_unibyte_string (contents
, nbytes
);
2058 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2063 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2066 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2068 register Lisp_Object val
;
2069 val
= make_uninit_string (length
);
2070 memcpy (SDATA (val
), contents
, length
);
2075 /* Make a multibyte string from NCHARS characters occupying NBYTES
2076 bytes at CONTENTS. */
2079 make_multibyte_string (const char *contents
,
2080 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2082 register Lisp_Object val
;
2083 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2084 memcpy (SDATA (val
), contents
, nbytes
);
2089 /* Make a string from NCHARS characters occupying NBYTES bytes at
2090 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2093 make_string_from_bytes (const char *contents
,
2094 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2096 register Lisp_Object val
;
2097 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2098 memcpy (SDATA (val
), contents
, nbytes
);
2099 if (SBYTES (val
) == SCHARS (val
))
2100 STRING_SET_UNIBYTE (val
);
2105 /* Make a string from NCHARS characters occupying NBYTES bytes at
2106 CONTENTS. The argument MULTIBYTE controls whether to label the
2107 string as multibyte. If NCHARS is negative, it counts the number of
2108 characters by itself. */
2111 make_specified_string (const char *contents
,
2112 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2119 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2124 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2125 memcpy (SDATA (val
), contents
, nbytes
);
2127 STRING_SET_UNIBYTE (val
);
2132 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2133 occupying LENGTH bytes. */
2136 make_uninit_string (EMACS_INT length
)
2141 return empty_unibyte_string
;
2142 val
= make_uninit_multibyte_string (length
, length
);
2143 STRING_SET_UNIBYTE (val
);
2148 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2149 which occupy NBYTES bytes. */
2152 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2155 struct Lisp_String
*s
;
2160 return empty_multibyte_string
;
2162 s
= allocate_string ();
2163 s
->intervals
= NULL
;
2164 allocate_string_data (s
, nchars
, nbytes
);
2165 XSETSTRING (string
, s
);
2166 string_chars_consed
+= nbytes
;
2170 /* Print arguments to BUF according to a FORMAT, then return
2171 a Lisp_String initialized with the data from BUF. */
2174 make_formatted_string (char *buf
, const char *format
, ...)
2179 va_start (ap
, format
);
2180 length
= vsprintf (buf
, format
, ap
);
2182 return make_string (buf
, length
);
2186 /***********************************************************************
2188 ***********************************************************************/
2190 /* We store float cells inside of float_blocks, allocating a new
2191 float_block with malloc whenever necessary. Float cells reclaimed
2192 by GC are put on a free list to be reallocated before allocating
2193 any new float cells from the latest float_block. */
2195 #define FLOAT_BLOCK_SIZE \
2196 (((BLOCK_BYTES - sizeof (struct float_block *) \
2197 /* The compiler might add padding at the end. */ \
2198 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2199 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2201 #define GETMARKBIT(block,n) \
2202 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2203 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2206 #define SETMARKBIT(block,n) \
2207 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2208 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2210 #define UNSETMARKBIT(block,n) \
2211 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2212 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2214 #define FLOAT_BLOCK(fptr) \
2215 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2217 #define FLOAT_INDEX(fptr) \
2218 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2222 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2223 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2224 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2225 struct float_block
*next
;
2228 #define FLOAT_MARKED_P(fptr) \
2229 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2231 #define FLOAT_MARK(fptr) \
2232 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2234 #define FLOAT_UNMARK(fptr) \
2235 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2237 /* Current float_block. */
2239 static struct float_block
*float_block
;
2241 /* Index of first unused Lisp_Float in the current float_block. */
2243 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2245 /* Free-list of Lisp_Floats. */
2247 static struct Lisp_Float
*float_free_list
;
2249 /* Return a new float object with value FLOAT_VALUE. */
2252 make_float (double float_value
)
2254 register Lisp_Object val
;
2258 if (float_free_list
)
2260 /* We use the data field for chaining the free list
2261 so that we won't use the same field that has the mark bit. */
2262 XSETFLOAT (val
, float_free_list
);
2263 float_free_list
= float_free_list
->u
.chain
;
2267 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2269 struct float_block
*new
2270 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2271 new->next
= float_block
;
2272 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2274 float_block_index
= 0;
2275 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2277 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2278 float_block_index
++;
2281 MALLOC_UNBLOCK_INPUT
;
2283 XFLOAT_INIT (val
, float_value
);
2284 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2285 consing_since_gc
+= sizeof (struct Lisp_Float
);
2287 total_free_floats
--;
2293 /***********************************************************************
2295 ***********************************************************************/
2297 /* We store cons cells inside of cons_blocks, allocating a new
2298 cons_block with malloc whenever necessary. Cons cells reclaimed by
2299 GC are put on a free list to be reallocated before allocating
2300 any new cons cells from the latest cons_block. */
2302 #define CONS_BLOCK_SIZE \
2303 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2304 /* The compiler might add padding at the end. */ \
2305 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2306 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2308 #define CONS_BLOCK(fptr) \
2309 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2311 #define CONS_INDEX(fptr) \
2312 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2316 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2317 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2318 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2319 struct cons_block
*next
;
2322 #define CONS_MARKED_P(fptr) \
2323 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2325 #define CONS_MARK(fptr) \
2326 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2328 #define CONS_UNMARK(fptr) \
2329 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2331 /* Current cons_block. */
2333 static struct cons_block
*cons_block
;
2335 /* Index of first unused Lisp_Cons in the current block. */
2337 static int cons_block_index
= CONS_BLOCK_SIZE
;
2339 /* Free-list of Lisp_Cons structures. */
2341 static struct Lisp_Cons
*cons_free_list
;
2343 /* Explicitly free a cons cell by putting it on the free-list. */
2346 free_cons (struct Lisp_Cons
*ptr
)
2348 ptr
->u
.chain
= cons_free_list
;
2352 cons_free_list
= ptr
;
2353 consing_since_gc
-= sizeof *ptr
;
2354 total_free_conses
++;
2357 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2358 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2359 (Lisp_Object car
, Lisp_Object cdr
)
2361 register Lisp_Object val
;
2367 /* We use the cdr for chaining the free list
2368 so that we won't use the same field that has the mark bit. */
2369 XSETCONS (val
, cons_free_list
);
2370 cons_free_list
= cons_free_list
->u
.chain
;
2374 if (cons_block_index
== CONS_BLOCK_SIZE
)
2376 struct cons_block
*new
2377 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2378 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2379 new->next
= cons_block
;
2381 cons_block_index
= 0;
2382 total_free_conses
+= CONS_BLOCK_SIZE
;
2384 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2388 MALLOC_UNBLOCK_INPUT
;
2392 eassert (!CONS_MARKED_P (XCONS (val
)));
2393 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2394 total_free_conses
--;
2395 cons_cells_consed
++;
2399 #ifdef GC_CHECK_CONS_LIST
2400 /* Get an error now if there's any junk in the cons free list. */
2402 check_cons_list (void)
2404 struct Lisp_Cons
*tail
= cons_free_list
;
2407 tail
= tail
->u
.chain
;
2411 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2414 list1 (Lisp_Object arg1
)
2416 return Fcons (arg1
, Qnil
);
2420 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2422 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2427 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2429 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2434 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2436 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2441 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2443 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2444 Fcons (arg5
, Qnil
)))));
2447 /* Make a list of COUNT Lisp_Objects, where ARG is the
2448 first one. Allocate conses from pure space if TYPE
2449 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2452 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2456 Lisp_Object val
, *objp
;
2458 /* Change to SAFE_ALLOCA if you hit this eassert. */
2459 eassert (count
<= MAX_ALLOCA
/ word_size
);
2461 objp
= alloca (count
* word_size
);
2464 for (i
= 1; i
< count
; i
++)
2465 objp
[i
] = va_arg (ap
, Lisp_Object
);
2468 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2470 if (type
== CONSTYPE_PURE
)
2471 val
= pure_cons (objp
[i
], val
);
2472 else if (type
== CONSTYPE_HEAP
)
2473 val
= Fcons (objp
[i
], val
);
2480 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2481 doc
: /* Return a newly created list with specified arguments as elements.
2482 Any number of arguments, even zero arguments, are allowed.
2483 usage: (list &rest OBJECTS) */)
2484 (ptrdiff_t nargs
, Lisp_Object
*args
)
2486 register Lisp_Object val
;
2492 val
= Fcons (args
[nargs
], val
);
2498 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2499 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2500 (register Lisp_Object length
, Lisp_Object init
)
2502 register Lisp_Object val
;
2503 register EMACS_INT size
;
2505 CHECK_NATNUM (length
);
2506 size
= XFASTINT (length
);
2511 val
= Fcons (init
, val
);
2516 val
= Fcons (init
, val
);
2521 val
= Fcons (init
, val
);
2526 val
= Fcons (init
, val
);
2531 val
= Fcons (init
, val
);
2546 /***********************************************************************
2548 ***********************************************************************/
2550 /* This value is balanced well enough to avoid too much internal overhead
2551 for the most common cases; it's not required to be a power of two, but
2552 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2554 #define VECTOR_BLOCK_SIZE 4096
2556 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2559 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2562 /* ROUNDUP_SIZE must be a power of 2. */
2563 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2565 /* Verify assumptions described above. */
2566 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2567 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2569 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2571 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2573 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2575 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2577 /* Size of the minimal vector allocated from block. */
2579 #define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2581 /* Size of the largest vector allocated from block. */
2583 #define VBLOCK_BYTES_MAX \
2584 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2586 /* We maintain one free list for each possible block-allocated
2587 vector size, and this is the number of free lists we have. */
2589 #define VECTOR_MAX_FREE_LIST_INDEX \
2590 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2592 /* Common shortcut to advance vector pointer over a block data. */
2594 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2596 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2598 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2600 /* Get and set the next field in block-allocated vectorlike objects on
2601 the free list. Doing it this way respects C's aliasing rules.
2602 We could instead make 'contents' a union, but that would mean
2603 changes everywhere that the code uses 'contents'. */
2604 static struct Lisp_Vector
*
2605 next_in_free_list (struct Lisp_Vector
*v
)
2607 intptr_t i
= XLI (v
->contents
[0]);
2608 return (struct Lisp_Vector
*) i
;
2611 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2613 v
->contents
[0] = XIL ((intptr_t) next
);
2616 /* Common shortcut to setup vector on a free list. */
2618 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2620 (tmp) = ((nbytes - header_size) / word_size); \
2621 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2622 eassert ((nbytes) % roundup_size == 0); \
2623 (tmp) = VINDEX (nbytes); \
2624 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2625 set_next_in_free_list (v, vector_free_lists[tmp]); \
2626 vector_free_lists[tmp] = (v); \
2627 total_free_vector_slots += (nbytes) / word_size; \
2630 /* This internal type is used to maintain the list of large vectors
2631 which are allocated at their own, e.g. outside of vector blocks. */
2636 struct large_vector
*vector
;
2638 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2639 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2642 struct Lisp_Vector v
;
2645 /* This internal type is used to maintain an underlying storage
2646 for small vectors. */
2650 char data
[VECTOR_BLOCK_BYTES
];
2651 struct vector_block
*next
;
2654 /* Chain of vector blocks. */
2656 static struct vector_block
*vector_blocks
;
2658 /* Vector free lists, where NTH item points to a chain of free
2659 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2661 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2663 /* Singly-linked list of large vectors. */
2665 static struct large_vector
*large_vectors
;
2667 /* The only vector with 0 slots, allocated from pure space. */
2669 Lisp_Object zero_vector
;
2671 /* Number of live vectors. */
2673 static EMACS_INT total_vectors
;
2675 /* Total size of live and free vectors, in Lisp_Object units. */
2677 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2679 /* Get a new vector block. */
2681 static struct vector_block
*
2682 allocate_vector_block (void)
2684 struct vector_block
*block
= xmalloc (sizeof *block
);
2686 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2687 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2688 MEM_TYPE_VECTOR_BLOCK
);
2691 block
->next
= vector_blocks
;
2692 vector_blocks
= block
;
2696 /* Called once to initialize vector allocation. */
2701 zero_vector
= make_pure_vector (0);
2704 /* Allocate vector from a vector block. */
2706 static struct Lisp_Vector
*
2707 allocate_vector_from_block (size_t nbytes
)
2709 struct Lisp_Vector
*vector
;
2710 struct vector_block
*block
;
2711 size_t index
, restbytes
;
2713 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2714 eassert (nbytes
% roundup_size
== 0);
2716 /* First, try to allocate from a free list
2717 containing vectors of the requested size. */
2718 index
= VINDEX (nbytes
);
2719 if (vector_free_lists
[index
])
2721 vector
= vector_free_lists
[index
];
2722 vector_free_lists
[index
] = next_in_free_list (vector
);
2723 total_free_vector_slots
-= nbytes
/ word_size
;
2727 /* Next, check free lists containing larger vectors. Since
2728 we will split the result, we should have remaining space
2729 large enough to use for one-slot vector at least. */
2730 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2731 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2732 if (vector_free_lists
[index
])
2734 /* This vector is larger than requested. */
2735 vector
= vector_free_lists
[index
];
2736 vector_free_lists
[index
] = next_in_free_list (vector
);
2737 total_free_vector_slots
-= nbytes
/ word_size
;
2739 /* Excess bytes are used for the smaller vector,
2740 which should be set on an appropriate free list. */
2741 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2742 eassert (restbytes
% roundup_size
== 0);
2743 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2747 /* Finally, need a new vector block. */
2748 block
= allocate_vector_block ();
2750 /* New vector will be at the beginning of this block. */
2751 vector
= (struct Lisp_Vector
*) block
->data
;
2753 /* If the rest of space from this block is large enough
2754 for one-slot vector at least, set up it on a free list. */
2755 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2756 if (restbytes
>= VBLOCK_BYTES_MIN
)
2758 eassert (restbytes
% roundup_size
== 0);
2759 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2764 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2766 #define VECTOR_IN_BLOCK(vector, block) \
2767 ((char *) (vector) <= (block)->data \
2768 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2770 /* Return the memory footprint of V in bytes. */
2773 vector_nbytes (struct Lisp_Vector
*v
)
2775 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2777 if (size
& PSEUDOVECTOR_FLAG
)
2779 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2780 size
= (bool_header_size
2781 + (((struct Lisp_Bool_Vector
*) v
)->size
2782 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2783 / BOOL_VECTOR_BITS_PER_CHAR
);
2786 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2787 + ((size
& PSEUDOVECTOR_REST_MASK
)
2788 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2791 size
= header_size
+ size
* word_size
;
2792 return vroundup (size
);
2795 /* Reclaim space used by unmarked vectors. */
2798 sweep_vectors (void)
2800 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2801 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2802 struct Lisp_Vector
*vector
, *next
;
2804 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2805 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2807 /* Looking through vector blocks. */
2809 for (block
= vector_blocks
; block
; block
= *bprev
)
2811 bool free_this_block
= 0;
2814 for (vector
= (struct Lisp_Vector
*) block
->data
;
2815 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2817 if (VECTOR_MARKED_P (vector
))
2819 VECTOR_UNMARK (vector
);
2821 nbytes
= vector_nbytes (vector
);
2822 total_vector_slots
+= nbytes
/ word_size
;
2823 next
= ADVANCE (vector
, nbytes
);
2827 ptrdiff_t total_bytes
;
2829 nbytes
= vector_nbytes (vector
);
2830 total_bytes
= nbytes
;
2831 next
= ADVANCE (vector
, nbytes
);
2833 /* While NEXT is not marked, try to coalesce with VECTOR,
2834 thus making VECTOR of the largest possible size. */
2836 while (VECTOR_IN_BLOCK (next
, block
))
2838 if (VECTOR_MARKED_P (next
))
2840 nbytes
= vector_nbytes (next
);
2841 total_bytes
+= nbytes
;
2842 next
= ADVANCE (next
, nbytes
);
2845 eassert (total_bytes
% roundup_size
== 0);
2847 if (vector
== (struct Lisp_Vector
*) block
->data
2848 && !VECTOR_IN_BLOCK (next
, block
))
2849 /* This block should be freed because all of it's
2850 space was coalesced into the only free vector. */
2851 free_this_block
= 1;
2855 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2860 if (free_this_block
)
2862 *bprev
= block
->next
;
2863 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2864 mem_delete (mem_find (block
->data
));
2869 bprev
= &block
->next
;
2872 /* Sweep large vectors. */
2874 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2877 if (VECTOR_MARKED_P (vector
))
2879 VECTOR_UNMARK (vector
);
2881 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2883 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2885 /* All non-bool pseudovectors are small enough to be allocated
2886 from vector blocks. This code should be redesigned if some
2887 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2888 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2891 += (bool_header_size
2892 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2893 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2897 += header_size
/ word_size
+ vector
->header
.size
;
2898 lvprev
= &lv
->next
.vector
;
2902 *lvprev
= lv
->next
.vector
;
2908 /* Value is a pointer to a newly allocated Lisp_Vector structure
2909 with room for LEN Lisp_Objects. */
2911 static struct Lisp_Vector
*
2912 allocate_vectorlike (ptrdiff_t len
)
2914 struct Lisp_Vector
*p
;
2919 p
= XVECTOR (zero_vector
);
2922 size_t nbytes
= header_size
+ len
* word_size
;
2924 #ifdef DOUG_LEA_MALLOC
2925 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2926 because mapped region contents are not preserved in
2928 mallopt (M_MMAP_MAX
, 0);
2931 if (nbytes
<= VBLOCK_BYTES_MAX
)
2932 p
= allocate_vector_from_block (vroundup (nbytes
));
2935 struct large_vector
*lv
2936 = lisp_malloc (sizeof (*lv
) + (len
- 1) * word_size
,
2937 MEM_TYPE_VECTORLIKE
);
2938 lv
->next
.vector
= large_vectors
;
2943 #ifdef DOUG_LEA_MALLOC
2944 /* Back to a reasonable maximum of mmap'ed areas. */
2945 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2948 consing_since_gc
+= nbytes
;
2949 vector_cells_consed
+= len
;
2952 MALLOC_UNBLOCK_INPUT
;
2958 /* Allocate a vector with LEN slots. */
2960 struct Lisp_Vector
*
2961 allocate_vector (EMACS_INT len
)
2963 struct Lisp_Vector
*v
;
2964 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2966 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2967 memory_full (SIZE_MAX
);
2968 v
= allocate_vectorlike (len
);
2969 v
->header
.size
= len
;
2974 /* Allocate other vector-like structures. */
2976 struct Lisp_Vector
*
2977 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2979 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2982 /* Catch bogus values. */
2983 eassert (tag
<= PVEC_FONT
);
2984 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2985 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2987 /* Only the first lisplen slots will be traced normally by the GC. */
2988 for (i
= 0; i
< lisplen
; ++i
)
2989 v
->contents
[i
] = Qnil
;
2991 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
2996 allocate_buffer (void)
2998 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3000 BUFFER_PVEC_INIT (b
);
3001 /* Put B on the chain of all buffers including killed ones. */
3002 b
->next
= all_buffers
;
3004 /* Note that the rest fields of B are not initialized. */
3008 struct Lisp_Hash_Table
*
3009 allocate_hash_table (void)
3011 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3015 allocate_window (void)
3019 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3020 /* Users assumes that non-Lisp data is zeroed. */
3021 memset (&w
->current_matrix
, 0,
3022 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3027 allocate_terminal (void)
3031 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3032 /* Users assumes that non-Lisp data is zeroed. */
3033 memset (&t
->next_terminal
, 0,
3034 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3039 allocate_frame (void)
3043 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3044 /* Users assumes that non-Lisp data is zeroed. */
3045 memset (&f
->face_cache
, 0,
3046 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3050 struct Lisp_Process
*
3051 allocate_process (void)
3053 struct Lisp_Process
*p
;
3055 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3056 /* Users assumes that non-Lisp data is zeroed. */
3058 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3062 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3063 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3064 See also the function `vector'. */)
3065 (register Lisp_Object length
, Lisp_Object init
)
3068 register ptrdiff_t sizei
;
3069 register ptrdiff_t i
;
3070 register struct Lisp_Vector
*p
;
3072 CHECK_NATNUM (length
);
3074 p
= allocate_vector (XFASTINT (length
));
3075 sizei
= XFASTINT (length
);
3076 for (i
= 0; i
< sizei
; i
++)
3077 p
->contents
[i
] = init
;
3079 XSETVECTOR (vector
, p
);
3084 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3085 doc
: /* Return a newly created vector with specified arguments as elements.
3086 Any number of arguments, even zero arguments, are allowed.
3087 usage: (vector &rest OBJECTS) */)
3088 (ptrdiff_t nargs
, Lisp_Object
*args
)
3091 register Lisp_Object val
= make_uninit_vector (nargs
);
3092 register struct Lisp_Vector
*p
= XVECTOR (val
);
3094 for (i
= 0; i
< nargs
; i
++)
3095 p
->contents
[i
] = args
[i
];
3100 make_byte_code (struct Lisp_Vector
*v
)
3102 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3103 && STRING_MULTIBYTE (v
->contents
[1]))
3104 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3105 earlier because they produced a raw 8-bit string for byte-code
3106 and now such a byte-code string is loaded as multibyte while
3107 raw 8-bit characters converted to multibyte form. Thus, now we
3108 must convert them back to the original unibyte form. */
3109 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3110 XSETPVECTYPE (v
, PVEC_COMPILED
);
3113 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3114 doc
: /* Create a byte-code object with specified arguments as elements.
3115 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3116 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3117 and (optional) INTERACTIVE-SPEC.
3118 The first four arguments are required; at most six have any
3120 The ARGLIST can be either like the one of `lambda', in which case the arguments
3121 will be dynamically bound before executing the byte code, or it can be an
3122 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3123 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3124 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3125 argument to catch the left-over arguments. If such an integer is used, the
3126 arguments will not be dynamically bound but will be instead pushed on the
3127 stack before executing the byte-code.
3128 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3129 (ptrdiff_t nargs
, Lisp_Object
*args
)
3132 register Lisp_Object val
= make_uninit_vector (nargs
);
3133 register struct Lisp_Vector
*p
= XVECTOR (val
);
3135 /* We used to purecopy everything here, if purify-flag was set. This worked
3136 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3137 dangerous, since make-byte-code is used during execution to build
3138 closures, so any closure built during the preload phase would end up
3139 copied into pure space, including its free variables, which is sometimes
3140 just wasteful and other times plainly wrong (e.g. those free vars may want
3143 for (i
= 0; i
< nargs
; i
++)
3144 p
->contents
[i
] = args
[i
];
3146 XSETCOMPILED (val
, p
);
3152 /***********************************************************************
3154 ***********************************************************************/
3156 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3157 of the required alignment if LSB tags are used. */
3159 union aligned_Lisp_Symbol
3161 struct Lisp_Symbol s
;
3163 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3168 /* Each symbol_block is just under 1020 bytes long, since malloc
3169 really allocates in units of powers of two and uses 4 bytes for its
3172 #define SYMBOL_BLOCK_SIZE \
3173 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3177 /* Place `symbols' first, to preserve alignment. */
3178 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3179 struct symbol_block
*next
;
3182 /* Current symbol block and index of first unused Lisp_Symbol
3185 static struct symbol_block
*symbol_block
;
3186 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3188 /* List of free symbols. */
3190 static struct Lisp_Symbol
*symbol_free_list
;
3192 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3193 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3194 Its value is void, and its function definition and property list are nil. */)
3197 register Lisp_Object val
;
3198 register struct Lisp_Symbol
*p
;
3200 CHECK_STRING (name
);
3204 if (symbol_free_list
)
3206 XSETSYMBOL (val
, symbol_free_list
);
3207 symbol_free_list
= symbol_free_list
->next
;
3211 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3213 struct symbol_block
*new
3214 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3215 new->next
= symbol_block
;
3217 symbol_block_index
= 0;
3218 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3220 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3221 symbol_block_index
++;
3224 MALLOC_UNBLOCK_INPUT
;
3227 set_symbol_name (val
, name
);
3228 set_symbol_plist (val
, Qnil
);
3229 p
->redirect
= SYMBOL_PLAINVAL
;
3230 SET_SYMBOL_VAL (p
, Qunbound
);
3231 set_symbol_function (val
, Qnil
);
3232 set_symbol_next (val
, NULL
);
3234 p
->interned
= SYMBOL_UNINTERNED
;
3236 p
->declared_special
= 0;
3237 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3239 total_free_symbols
--;
3245 /***********************************************************************
3246 Marker (Misc) Allocation
3247 ***********************************************************************/
3249 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3250 the required alignment when LSB tags are used. */
3252 union aligned_Lisp_Misc
3256 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3261 /* Allocation of markers and other objects that share that structure.
3262 Works like allocation of conses. */
3264 #define MARKER_BLOCK_SIZE \
3265 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3269 /* Place `markers' first, to preserve alignment. */
3270 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3271 struct marker_block
*next
;
3274 static struct marker_block
*marker_block
;
3275 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3277 static union Lisp_Misc
*marker_free_list
;
3279 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3282 allocate_misc (enum Lisp_Misc_Type type
)
3288 if (marker_free_list
)
3290 XSETMISC (val
, marker_free_list
);
3291 marker_free_list
= marker_free_list
->u_free
.chain
;
3295 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3297 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3298 new->next
= marker_block
;
3300 marker_block_index
= 0;
3301 total_free_markers
+= MARKER_BLOCK_SIZE
;
3303 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3304 marker_block_index
++;
3307 MALLOC_UNBLOCK_INPUT
;
3309 --total_free_markers
;
3310 consing_since_gc
+= sizeof (union Lisp_Misc
);
3311 misc_objects_consed
++;
3312 XMISCTYPE (val
) = type
;
3313 XMISCANY (val
)->gcmarkbit
= 0;
3317 /* Free a Lisp_Misc object. */
3320 free_misc (Lisp_Object misc
)
3322 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3323 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3324 marker_free_list
= XMISC (misc
);
3325 consing_since_gc
-= sizeof (union Lisp_Misc
);
3326 total_free_markers
++;
3329 /* Return a Lisp_Save_Value object with the data saved according to
3330 FMT. Format specifiers are `i' for an integer, `p' for a pointer
3331 and `o' for Lisp_Object. Up to 4 objects can be specified. */
3334 make_save_value (const char *fmt
, ...)
3337 int len
= strlen (fmt
);
3338 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3339 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3341 eassert (0 < len
&& len
< 5);
3344 #define INITX(index) \
3347 p->type ## index = SAVE_UNUSED; \
3350 if (fmt[index] == 'i') \
3352 p->type ## index = SAVE_INTEGER; \
3353 p->data[index].integer = va_arg (ap, ptrdiff_t); \
3355 else if (fmt[index] == 'p') \
3357 p->type ## index = SAVE_POINTER; \
3358 p->data[index].pointer = va_arg (ap, void *); \
3360 else if (fmt[index] == 'o') \
3362 p->type ## index = SAVE_OBJECT; \
3363 p->data[index].object = va_arg (ap, Lisp_Object); \
3382 /* The most common task it to save just one C pointer. */
3385 make_save_pointer (void *pointer
)
3387 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3388 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3391 p
->type0
= SAVE_POINTER
;
3392 p
->data
[0].pointer
= pointer
;
3393 p
->type1
= p
->type2
= p
->type3
= SAVE_UNUSED
;
3397 /* Free a Lisp_Save_Value object. Do not use this function
3398 if SAVE contains pointer other than returned by xmalloc. */
3401 free_save_value (Lisp_Object save
)
3403 xfree (XSAVE_POINTER (save
, 0));
3407 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3410 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3412 register Lisp_Object overlay
;
3414 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3415 OVERLAY_START (overlay
) = start
;
3416 OVERLAY_END (overlay
) = end
;
3417 set_overlay_plist (overlay
, plist
);
3418 XOVERLAY (overlay
)->next
= NULL
;
3422 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3423 doc
: /* Return a newly allocated marker which does not point at any place. */)
3426 register Lisp_Object val
;
3427 register struct Lisp_Marker
*p
;
3429 val
= allocate_misc (Lisp_Misc_Marker
);
3435 p
->insertion_type
= 0;
3439 /* Return a newly allocated marker which points into BUF
3440 at character position CHARPOS and byte position BYTEPOS. */
3443 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3446 struct Lisp_Marker
*m
;
3448 /* No dead buffers here. */
3449 eassert (BUFFER_LIVE_P (buf
));
3451 /* Every character is at least one byte. */
3452 eassert (charpos
<= bytepos
);
3454 obj
= allocate_misc (Lisp_Misc_Marker
);
3457 m
->charpos
= charpos
;
3458 m
->bytepos
= bytepos
;
3459 m
->insertion_type
= 0;
3460 m
->next
= BUF_MARKERS (buf
);
3461 BUF_MARKERS (buf
) = m
;
3465 /* Put MARKER back on the free list after using it temporarily. */
3468 free_marker (Lisp_Object marker
)
3470 unchain_marker (XMARKER (marker
));
3475 /* Return a newly created vector or string with specified arguments as
3476 elements. If all the arguments are characters that can fit
3477 in a string of events, make a string; otherwise, make a vector.
3479 Any number of arguments, even zero arguments, are allowed. */
3482 make_event_array (register int nargs
, Lisp_Object
*args
)
3486 for (i
= 0; i
< nargs
; i
++)
3487 /* The things that fit in a string
3488 are characters that are in 0...127,
3489 after discarding the meta bit and all the bits above it. */
3490 if (!INTEGERP (args
[i
])
3491 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3492 return Fvector (nargs
, args
);
3494 /* Since the loop exited, we know that all the things in it are
3495 characters, so we can make a string. */
3499 result
= Fmake_string (make_number (nargs
), make_number (0));
3500 for (i
= 0; i
< nargs
; i
++)
3502 SSET (result
, i
, XINT (args
[i
]));
3503 /* Move the meta bit to the right place for a string char. */
3504 if (XINT (args
[i
]) & CHAR_META
)
3505 SSET (result
, i
, SREF (result
, i
) | 0x80);
3514 /************************************************************************
3515 Memory Full Handling
3516 ************************************************************************/
3519 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3520 there may have been size_t overflow so that malloc was never
3521 called, or perhaps malloc was invoked successfully but the
3522 resulting pointer had problems fitting into a tagged EMACS_INT. In
3523 either case this counts as memory being full even though malloc did
3527 memory_full (size_t nbytes
)
3529 /* Do not go into hysterics merely because a large request failed. */
3530 bool enough_free_memory
= 0;
3531 if (SPARE_MEMORY
< nbytes
)
3536 p
= malloc (SPARE_MEMORY
);
3540 enough_free_memory
= 1;
3542 MALLOC_UNBLOCK_INPUT
;
3545 if (! enough_free_memory
)
3551 memory_full_cons_threshold
= sizeof (struct cons_block
);
3553 /* The first time we get here, free the spare memory. */
3554 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3555 if (spare_memory
[i
])
3558 free (spare_memory
[i
]);
3559 else if (i
>= 1 && i
<= 4)
3560 lisp_align_free (spare_memory
[i
]);
3562 lisp_free (spare_memory
[i
]);
3563 spare_memory
[i
] = 0;
3567 /* This used to call error, but if we've run out of memory, we could
3568 get infinite recursion trying to build the string. */
3569 xsignal (Qnil
, Vmemory_signal_data
);
3572 /* If we released our reserve (due to running out of memory),
3573 and we have a fair amount free once again,
3574 try to set aside another reserve in case we run out once more.
3576 This is called when a relocatable block is freed in ralloc.c,
3577 and also directly from this file, in case we're not using ralloc.c. */
3580 refill_memory_reserve (void)
3582 #ifndef SYSTEM_MALLOC
3583 if (spare_memory
[0] == 0)
3584 spare_memory
[0] = malloc (SPARE_MEMORY
);
3585 if (spare_memory
[1] == 0)
3586 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3588 if (spare_memory
[2] == 0)
3589 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3591 if (spare_memory
[3] == 0)
3592 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3594 if (spare_memory
[4] == 0)
3595 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3597 if (spare_memory
[5] == 0)
3598 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3600 if (spare_memory
[6] == 0)
3601 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3603 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3604 Vmemory_full
= Qnil
;
3608 /************************************************************************
3610 ************************************************************************/
3612 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3614 /* Conservative C stack marking requires a method to identify possibly
3615 live Lisp objects given a pointer value. We do this by keeping
3616 track of blocks of Lisp data that are allocated in a red-black tree
3617 (see also the comment of mem_node which is the type of nodes in
3618 that tree). Function lisp_malloc adds information for an allocated
3619 block to the red-black tree with calls to mem_insert, and function
3620 lisp_free removes it with mem_delete. Functions live_string_p etc
3621 call mem_find to lookup information about a given pointer in the
3622 tree, and use that to determine if the pointer points to a Lisp
3625 /* Initialize this part of alloc.c. */
3630 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3631 mem_z
.parent
= NULL
;
3632 mem_z
.color
= MEM_BLACK
;
3633 mem_z
.start
= mem_z
.end
= NULL
;
3638 /* Value is a pointer to the mem_node containing START. Value is
3639 MEM_NIL if there is no node in the tree containing START. */
3641 static struct mem_node
*
3642 mem_find (void *start
)
3646 if (start
< min_heap_address
|| start
> max_heap_address
)
3649 /* Make the search always successful to speed up the loop below. */
3650 mem_z
.start
= start
;
3651 mem_z
.end
= (char *) start
+ 1;
3654 while (start
< p
->start
|| start
>= p
->end
)
3655 p
= start
< p
->start
? p
->left
: p
->right
;
3660 /* Insert a new node into the tree for a block of memory with start
3661 address START, end address END, and type TYPE. Value is a
3662 pointer to the node that was inserted. */
3664 static struct mem_node
*
3665 mem_insert (void *start
, void *end
, enum mem_type type
)
3667 struct mem_node
*c
, *parent
, *x
;
3669 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3670 min_heap_address
= start
;
3671 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3672 max_heap_address
= end
;
3674 /* See where in the tree a node for START belongs. In this
3675 particular application, it shouldn't happen that a node is already
3676 present. For debugging purposes, let's check that. */
3680 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3682 while (c
!= MEM_NIL
)
3684 if (start
>= c
->start
&& start
< c
->end
)
3687 c
= start
< c
->start
? c
->left
: c
->right
;
3690 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3692 while (c
!= MEM_NIL
)
3695 c
= start
< c
->start
? c
->left
: c
->right
;
3698 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3700 /* Create a new node. */
3701 #ifdef GC_MALLOC_CHECK
3702 x
= malloc (sizeof *x
);
3706 x
= xmalloc (sizeof *x
);
3712 x
->left
= x
->right
= MEM_NIL
;
3715 /* Insert it as child of PARENT or install it as root. */
3718 if (start
< parent
->start
)
3726 /* Re-establish red-black tree properties. */
3727 mem_insert_fixup (x
);
3733 /* Re-establish the red-black properties of the tree, and thereby
3734 balance the tree, after node X has been inserted; X is always red. */
3737 mem_insert_fixup (struct mem_node
*x
)
3739 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3741 /* X is red and its parent is red. This is a violation of
3742 red-black tree property #3. */
3744 if (x
->parent
== x
->parent
->parent
->left
)
3746 /* We're on the left side of our grandparent, and Y is our
3748 struct mem_node
*y
= x
->parent
->parent
->right
;
3750 if (y
->color
== MEM_RED
)
3752 /* Uncle and parent are red but should be black because
3753 X is red. Change the colors accordingly and proceed
3754 with the grandparent. */
3755 x
->parent
->color
= MEM_BLACK
;
3756 y
->color
= MEM_BLACK
;
3757 x
->parent
->parent
->color
= MEM_RED
;
3758 x
= x
->parent
->parent
;
3762 /* Parent and uncle have different colors; parent is
3763 red, uncle is black. */
3764 if (x
== x
->parent
->right
)
3767 mem_rotate_left (x
);
3770 x
->parent
->color
= MEM_BLACK
;
3771 x
->parent
->parent
->color
= MEM_RED
;
3772 mem_rotate_right (x
->parent
->parent
);
3777 /* This is the symmetrical case of above. */
3778 struct mem_node
*y
= x
->parent
->parent
->left
;
3780 if (y
->color
== MEM_RED
)
3782 x
->parent
->color
= MEM_BLACK
;
3783 y
->color
= MEM_BLACK
;
3784 x
->parent
->parent
->color
= MEM_RED
;
3785 x
= x
->parent
->parent
;
3789 if (x
== x
->parent
->left
)
3792 mem_rotate_right (x
);
3795 x
->parent
->color
= MEM_BLACK
;
3796 x
->parent
->parent
->color
= MEM_RED
;
3797 mem_rotate_left (x
->parent
->parent
);
3802 /* The root may have been changed to red due to the algorithm. Set
3803 it to black so that property #5 is satisfied. */
3804 mem_root
->color
= MEM_BLACK
;
3815 mem_rotate_left (struct mem_node
*x
)
3819 /* Turn y's left sub-tree into x's right sub-tree. */
3822 if (y
->left
!= MEM_NIL
)
3823 y
->left
->parent
= x
;
3825 /* Y's parent was x's parent. */
3827 y
->parent
= x
->parent
;
3829 /* Get the parent to point to y instead of x. */
3832 if (x
== x
->parent
->left
)
3833 x
->parent
->left
= y
;
3835 x
->parent
->right
= y
;
3840 /* Put x on y's left. */
3854 mem_rotate_right (struct mem_node
*x
)
3856 struct mem_node
*y
= x
->left
;
3859 if (y
->right
!= MEM_NIL
)
3860 y
->right
->parent
= x
;
3863 y
->parent
= x
->parent
;
3866 if (x
== x
->parent
->right
)
3867 x
->parent
->right
= y
;
3869 x
->parent
->left
= y
;
3880 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3883 mem_delete (struct mem_node
*z
)
3885 struct mem_node
*x
, *y
;
3887 if (!z
|| z
== MEM_NIL
)
3890 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3895 while (y
->left
!= MEM_NIL
)
3899 if (y
->left
!= MEM_NIL
)
3904 x
->parent
= y
->parent
;
3907 if (y
== y
->parent
->left
)
3908 y
->parent
->left
= x
;
3910 y
->parent
->right
= x
;
3917 z
->start
= y
->start
;
3922 if (y
->color
== MEM_BLACK
)
3923 mem_delete_fixup (x
);
3925 #ifdef GC_MALLOC_CHECK
3933 /* Re-establish the red-black properties of the tree, after a
3937 mem_delete_fixup (struct mem_node
*x
)
3939 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3941 if (x
== x
->parent
->left
)
3943 struct mem_node
*w
= x
->parent
->right
;
3945 if (w
->color
== MEM_RED
)
3947 w
->color
= MEM_BLACK
;
3948 x
->parent
->color
= MEM_RED
;
3949 mem_rotate_left (x
->parent
);
3950 w
= x
->parent
->right
;
3953 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3960 if (w
->right
->color
== MEM_BLACK
)
3962 w
->left
->color
= MEM_BLACK
;
3964 mem_rotate_right (w
);
3965 w
= x
->parent
->right
;
3967 w
->color
= x
->parent
->color
;
3968 x
->parent
->color
= MEM_BLACK
;
3969 w
->right
->color
= MEM_BLACK
;
3970 mem_rotate_left (x
->parent
);
3976 struct mem_node
*w
= x
->parent
->left
;
3978 if (w
->color
== MEM_RED
)
3980 w
->color
= MEM_BLACK
;
3981 x
->parent
->color
= MEM_RED
;
3982 mem_rotate_right (x
->parent
);
3983 w
= x
->parent
->left
;
3986 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3993 if (w
->left
->color
== MEM_BLACK
)
3995 w
->right
->color
= MEM_BLACK
;
3997 mem_rotate_left (w
);
3998 w
= x
->parent
->left
;
4001 w
->color
= x
->parent
->color
;
4002 x
->parent
->color
= MEM_BLACK
;
4003 w
->left
->color
= MEM_BLACK
;
4004 mem_rotate_right (x
->parent
);
4010 x
->color
= MEM_BLACK
;
4014 /* Value is non-zero if P is a pointer to a live Lisp string on
4015 the heap. M is a pointer to the mem_block for P. */
4018 live_string_p (struct mem_node
*m
, void *p
)
4020 if (m
->type
== MEM_TYPE_STRING
)
4022 struct string_block
*b
= (struct string_block
*) m
->start
;
4023 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4025 /* P must point to the start of a Lisp_String structure, and it
4026 must not be on the free-list. */
4028 && offset
% sizeof b
->strings
[0] == 0
4029 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4030 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4037 /* Value is non-zero if P is a pointer to a live Lisp cons on
4038 the heap. M is a pointer to the mem_block for P. */
4041 live_cons_p (struct mem_node
*m
, void *p
)
4043 if (m
->type
== MEM_TYPE_CONS
)
4045 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4046 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4048 /* P must point to the start of a Lisp_Cons, not be
4049 one of the unused cells in the current cons block,
4050 and not be on the free-list. */
4052 && offset
% sizeof b
->conses
[0] == 0
4053 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4055 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4056 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4063 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4064 the heap. M is a pointer to the mem_block for P. */
4067 live_symbol_p (struct mem_node
*m
, void *p
)
4069 if (m
->type
== MEM_TYPE_SYMBOL
)
4071 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4072 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4074 /* P must point to the start of a Lisp_Symbol, not be
4075 one of the unused cells in the current symbol block,
4076 and not be on the free-list. */
4078 && offset
% sizeof b
->symbols
[0] == 0
4079 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4080 && (b
!= symbol_block
4081 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4082 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4089 /* Value is non-zero if P is a pointer to a live Lisp float on
4090 the heap. M is a pointer to the mem_block for P. */
4093 live_float_p (struct mem_node
*m
, void *p
)
4095 if (m
->type
== MEM_TYPE_FLOAT
)
4097 struct float_block
*b
= (struct float_block
*) m
->start
;
4098 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4100 /* P must point to the start of a Lisp_Float and not be
4101 one of the unused cells in the current float block. */
4103 && offset
% sizeof b
->floats
[0] == 0
4104 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4105 && (b
!= float_block
4106 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4113 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4114 the heap. M is a pointer to the mem_block for P. */
4117 live_misc_p (struct mem_node
*m
, void *p
)
4119 if (m
->type
== MEM_TYPE_MISC
)
4121 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4122 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4124 /* P must point to the start of a Lisp_Misc, not be
4125 one of the unused cells in the current misc block,
4126 and not be on the free-list. */
4128 && offset
% sizeof b
->markers
[0] == 0
4129 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4130 && (b
!= marker_block
4131 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4132 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4139 /* Value is non-zero if P is a pointer to a live vector-like object.
4140 M is a pointer to the mem_block for P. */
4143 live_vector_p (struct mem_node
*m
, void *p
)
4145 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4147 /* This memory node corresponds to a vector block. */
4148 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4149 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4151 /* P is in the block's allocation range. Scan the block
4152 up to P and see whether P points to the start of some
4153 vector which is not on a free list. FIXME: check whether
4154 some allocation patterns (probably a lot of short vectors)
4155 may cause a substantial overhead of this loop. */
4156 while (VECTOR_IN_BLOCK (vector
, block
)
4157 && vector
<= (struct Lisp_Vector
*) p
)
4159 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4162 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4165 else if (m
->type
== MEM_TYPE_VECTORLIKE
4166 && (char *) p
== ((char *) m
->start
4167 + offsetof (struct large_vector
, v
)))
4168 /* This memory node corresponds to a large vector. */
4174 /* Value is non-zero if P is a pointer to a live buffer. M is a
4175 pointer to the mem_block for P. */
4178 live_buffer_p (struct mem_node
*m
, void *p
)
4180 /* P must point to the start of the block, and the buffer
4181 must not have been killed. */
4182 return (m
->type
== MEM_TYPE_BUFFER
4184 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4187 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4191 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4193 /* Array of objects that are kept alive because the C stack contains
4194 a pattern that looks like a reference to them . */
4196 #define MAX_ZOMBIES 10
4197 static Lisp_Object zombies
[MAX_ZOMBIES
];
4199 /* Number of zombie objects. */
4201 static EMACS_INT nzombies
;
4203 /* Number of garbage collections. */
4205 static EMACS_INT ngcs
;
4207 /* Average percentage of zombies per collection. */
4209 static double avg_zombies
;
4211 /* Max. number of live and zombie objects. */
4213 static EMACS_INT max_live
, max_zombies
;
4215 /* Average number of live objects per GC. */
4217 static double avg_live
;
4219 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4220 doc
: /* Show information about live and zombie objects. */)
4223 Lisp_Object args
[8], zombie_list
= Qnil
;
4225 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4226 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4227 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4228 args
[1] = make_number (ngcs
);
4229 args
[2] = make_float (avg_live
);
4230 args
[3] = make_float (avg_zombies
);
4231 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4232 args
[5] = make_number (max_live
);
4233 args
[6] = make_number (max_zombies
);
4234 args
[7] = zombie_list
;
4235 return Fmessage (8, args
);
4238 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4241 /* Mark OBJ if we can prove it's a Lisp_Object. */
4244 mark_maybe_object (Lisp_Object obj
)
4252 po
= (void *) XPNTR (obj
);
4259 switch (XTYPE (obj
))
4262 mark_p
= (live_string_p (m
, po
)
4263 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4267 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4271 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4275 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4278 case Lisp_Vectorlike
:
4279 /* Note: can't check BUFFERP before we know it's a
4280 buffer because checking that dereferences the pointer
4281 PO which might point anywhere. */
4282 if (live_vector_p (m
, po
))
4283 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4284 else if (live_buffer_p (m
, po
))
4285 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4289 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4298 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4299 if (nzombies
< MAX_ZOMBIES
)
4300 zombies
[nzombies
] = obj
;
4309 /* If P points to Lisp data, mark that as live if it isn't already
4313 mark_maybe_pointer (void *p
)
4317 /* Quickly rule out some values which can't point to Lisp data.
4318 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4319 Otherwise, assume that Lisp data is aligned on even addresses. */
4320 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4326 Lisp_Object obj
= Qnil
;
4330 case MEM_TYPE_NON_LISP
:
4331 case MEM_TYPE_SPARE
:
4332 /* Nothing to do; not a pointer to Lisp memory. */
4335 case MEM_TYPE_BUFFER
:
4336 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4337 XSETVECTOR (obj
, p
);
4341 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4345 case MEM_TYPE_STRING
:
4346 if (live_string_p (m
, p
)
4347 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4348 XSETSTRING (obj
, p
);
4352 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4356 case MEM_TYPE_SYMBOL
:
4357 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4358 XSETSYMBOL (obj
, p
);
4361 case MEM_TYPE_FLOAT
:
4362 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4366 case MEM_TYPE_VECTORLIKE
:
4367 case MEM_TYPE_VECTOR_BLOCK
:
4368 if (live_vector_p (m
, p
))
4371 XSETVECTOR (tem
, p
);
4372 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4387 /* Alignment of pointer values. Use alignof, as it sometimes returns
4388 a smaller alignment than GCC's __alignof__ and mark_memory might
4389 miss objects if __alignof__ were used. */
4390 #define GC_POINTER_ALIGNMENT alignof (void *)
4392 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4393 not suffice, which is the typical case. A host where a Lisp_Object is
4394 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4395 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4396 suffice to widen it to to a Lisp_Object and check it that way. */
4397 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4398 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4399 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4400 nor mark_maybe_object can follow the pointers. This should not occur on
4401 any practical porting target. */
4402 # error "MSB type bits straddle pointer-word boundaries"
4404 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4405 pointer words that hold pointers ORed with type bits. */
4406 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4408 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4409 words that hold unmodified pointers. */
4410 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4413 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4414 or END+OFFSET..START. */
4417 mark_memory (void *start
, void *end
)
4418 #if defined (__clang__) && defined (__has_feature)
4419 #if __has_feature(address_sanitizer)
4420 /* Do not allow -faddress-sanitizer to check this function, since it
4421 crosses the function stack boundary, and thus would yield many
4423 __attribute__((no_address_safety_analysis
))
4430 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4434 /* Make START the pointer to the start of the memory region,
4435 if it isn't already. */
4443 /* Mark Lisp data pointed to. This is necessary because, in some
4444 situations, the C compiler optimizes Lisp objects away, so that
4445 only a pointer to them remains. Example:
4447 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4450 Lisp_Object obj = build_string ("test");
4451 struct Lisp_String *s = XSTRING (obj);
4452 Fgarbage_collect ();
4453 fprintf (stderr, "test `%s'\n", s->data);
4457 Here, `obj' isn't really used, and the compiler optimizes it
4458 away. The only reference to the life string is through the
4461 for (pp
= start
; (void *) pp
< end
; pp
++)
4462 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4464 void *p
= *(void **) ((char *) pp
+ i
);
4465 mark_maybe_pointer (p
);
4466 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4467 mark_maybe_object (XIL ((intptr_t) p
));
4471 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4473 static bool setjmp_tested_p
;
4474 static int longjmps_done
;
4476 #define SETJMP_WILL_LIKELY_WORK "\
4478 Emacs garbage collector has been changed to use conservative stack\n\
4479 marking. Emacs has determined that the method it uses to do the\n\
4480 marking will likely work on your system, but this isn't sure.\n\
4482 If you are a system-programmer, or can get the help of a local wizard\n\
4483 who is, please take a look at the function mark_stack in alloc.c, and\n\
4484 verify that the methods used are appropriate for your system.\n\
4486 Please mail the result to <emacs-devel@gnu.org>.\n\
4489 #define SETJMP_WILL_NOT_WORK "\
4491 Emacs garbage collector has been changed to use conservative stack\n\
4492 marking. Emacs has determined that the default method it uses to do the\n\
4493 marking will not work on your system. We will need a system-dependent\n\
4494 solution for your system.\n\
4496 Please take a look at the function mark_stack in alloc.c, and\n\
4497 try to find a way to make it work on your system.\n\
4499 Note that you may get false negatives, depending on the compiler.\n\
4500 In particular, you need to use -O with GCC for this test.\n\
4502 Please mail the result to <emacs-devel@gnu.org>.\n\
4506 /* Perform a quick check if it looks like setjmp saves registers in a
4507 jmp_buf. Print a message to stderr saying so. When this test
4508 succeeds, this is _not_ a proof that setjmp is sufficient for
4509 conservative stack marking. Only the sources or a disassembly
4519 /* Arrange for X to be put in a register. */
4525 if (longjmps_done
== 1)
4527 /* Came here after the longjmp at the end of the function.
4529 If x == 1, the longjmp has restored the register to its
4530 value before the setjmp, and we can hope that setjmp
4531 saves all such registers in the jmp_buf, although that
4534 For other values of X, either something really strange is
4535 taking place, or the setjmp just didn't save the register. */
4538 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4541 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4548 if (longjmps_done
== 1)
4549 sys_longjmp (jbuf
, 1);
4552 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4555 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4557 /* Abort if anything GCPRO'd doesn't survive the GC. */
4565 for (p
= gcprolist
; p
; p
= p
->next
)
4566 for (i
= 0; i
< p
->nvars
; ++i
)
4567 if (!survives_gc_p (p
->var
[i
]))
4568 /* FIXME: It's not necessarily a bug. It might just be that the
4569 GCPRO is unnecessary or should release the object sooner. */
4573 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4580 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4581 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4583 fprintf (stderr
, " %d = ", i
);
4584 debug_print (zombies
[i
]);
4588 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4591 /* Mark live Lisp objects on the C stack.
4593 There are several system-dependent problems to consider when
4594 porting this to new architectures:
4598 We have to mark Lisp objects in CPU registers that can hold local
4599 variables or are used to pass parameters.
4601 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4602 something that either saves relevant registers on the stack, or
4603 calls mark_maybe_object passing it each register's contents.
4605 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4606 implementation assumes that calling setjmp saves registers we need
4607 to see in a jmp_buf which itself lies on the stack. This doesn't
4608 have to be true! It must be verified for each system, possibly
4609 by taking a look at the source code of setjmp.
4611 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4612 can use it as a machine independent method to store all registers
4613 to the stack. In this case the macros described in the previous
4614 two paragraphs are not used.
4618 Architectures differ in the way their processor stack is organized.
4619 For example, the stack might look like this
4622 | Lisp_Object | size = 4
4624 | something else | size = 2
4626 | Lisp_Object | size = 4
4630 In such a case, not every Lisp_Object will be aligned equally. To
4631 find all Lisp_Object on the stack it won't be sufficient to walk
4632 the stack in steps of 4 bytes. Instead, two passes will be
4633 necessary, one starting at the start of the stack, and a second
4634 pass starting at the start of the stack + 2. Likewise, if the
4635 minimal alignment of Lisp_Objects on the stack is 1, four passes
4636 would be necessary, each one starting with one byte more offset
4637 from the stack start. */
4644 #ifdef HAVE___BUILTIN_UNWIND_INIT
4645 /* Force callee-saved registers and register windows onto the stack.
4646 This is the preferred method if available, obviating the need for
4647 machine dependent methods. */
4648 __builtin_unwind_init ();
4650 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4651 #ifndef GC_SAVE_REGISTERS_ON_STACK
4652 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4653 union aligned_jmpbuf
{
4657 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4659 /* This trick flushes the register windows so that all the state of
4660 the process is contained in the stack. */
4661 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4662 needed on ia64 too. See mach_dep.c, where it also says inline
4663 assembler doesn't work with relevant proprietary compilers. */
4665 #if defined (__sparc64__) && defined (__FreeBSD__)
4666 /* FreeBSD does not have a ta 3 handler. */
4673 /* Save registers that we need to see on the stack. We need to see
4674 registers used to hold register variables and registers used to
4676 #ifdef GC_SAVE_REGISTERS_ON_STACK
4677 GC_SAVE_REGISTERS_ON_STACK (end
);
4678 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4680 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4681 setjmp will definitely work, test it
4682 and print a message with the result
4684 if (!setjmp_tested_p
)
4686 setjmp_tested_p
= 1;
4689 #endif /* GC_SETJMP_WORKS */
4692 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4693 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4694 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4696 /* This assumes that the stack is a contiguous region in memory. If
4697 that's not the case, something has to be done here to iterate
4698 over the stack segments. */
4699 mark_memory (stack_base
, end
);
4701 /* Allow for marking a secondary stack, like the register stack on the
4703 #ifdef GC_MARK_SECONDARY_STACK
4704 GC_MARK_SECONDARY_STACK ();
4707 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4712 #endif /* GC_MARK_STACK != 0 */
4715 /* Determine whether it is safe to access memory at address P. */
4717 valid_pointer_p (void *p
)
4720 return w32_valid_pointer_p (p
, 16);
4724 /* Obviously, we cannot just access it (we would SEGV trying), so we
4725 trick the o/s to tell us whether p is a valid pointer.
4726 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4727 not validate p in that case. */
4731 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4732 emacs_close (fd
[1]);
4733 emacs_close (fd
[0]);
4741 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4742 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4743 cannot validate OBJ. This function can be quite slow, so its primary
4744 use is the manual debugging. The only exception is print_object, where
4745 we use it to check whether the memory referenced by the pointer of
4746 Lisp_Save_Value object contains valid objects. */
4749 valid_lisp_object_p (Lisp_Object obj
)
4759 p
= (void *) XPNTR (obj
);
4760 if (PURE_POINTER_P (p
))
4763 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4767 return valid_pointer_p (p
);
4774 int valid
= valid_pointer_p (p
);
4786 case MEM_TYPE_NON_LISP
:
4787 case MEM_TYPE_SPARE
:
4790 case MEM_TYPE_BUFFER
:
4791 return live_buffer_p (m
, p
) ? 1 : 2;
4794 return live_cons_p (m
, p
);
4796 case MEM_TYPE_STRING
:
4797 return live_string_p (m
, p
);
4800 return live_misc_p (m
, p
);
4802 case MEM_TYPE_SYMBOL
:
4803 return live_symbol_p (m
, p
);
4805 case MEM_TYPE_FLOAT
:
4806 return live_float_p (m
, p
);
4808 case MEM_TYPE_VECTORLIKE
:
4809 case MEM_TYPE_VECTOR_BLOCK
:
4810 return live_vector_p (m
, p
);
4823 /***********************************************************************
4824 Pure Storage Management
4825 ***********************************************************************/
4827 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4828 pointer to it. TYPE is the Lisp type for which the memory is
4829 allocated. TYPE < 0 means it's not used for a Lisp object. */
4832 pure_alloc (size_t size
, int type
)
4836 size_t alignment
= GCALIGNMENT
;
4838 size_t alignment
= alignof (EMACS_INT
);
4840 /* Give Lisp_Floats an extra alignment. */
4841 if (type
== Lisp_Float
)
4842 alignment
= alignof (struct Lisp_Float
);
4848 /* Allocate space for a Lisp object from the beginning of the free
4849 space with taking account of alignment. */
4850 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4851 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4855 /* Allocate space for a non-Lisp object from the end of the free
4857 pure_bytes_used_non_lisp
+= size
;
4858 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4860 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4862 if (pure_bytes_used
<= pure_size
)
4865 /* Don't allocate a large amount here,
4866 because it might get mmap'd and then its address
4867 might not be usable. */
4868 purebeg
= xmalloc (10000);
4870 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4871 pure_bytes_used
= 0;
4872 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4877 /* Print a warning if PURESIZE is too small. */
4880 check_pure_size (void)
4882 if (pure_bytes_used_before_overflow
)
4883 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4885 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4889 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4890 the non-Lisp data pool of the pure storage, and return its start
4891 address. Return NULL if not found. */
4894 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4897 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4898 const unsigned char *p
;
4901 if (pure_bytes_used_non_lisp
<= nbytes
)
4904 /* Set up the Boyer-Moore table. */
4906 for (i
= 0; i
< 256; i
++)
4909 p
= (const unsigned char *) data
;
4911 bm_skip
[*p
++] = skip
;
4913 last_char_skip
= bm_skip
['\0'];
4915 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4916 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4918 /* See the comments in the function `boyer_moore' (search.c) for the
4919 use of `infinity'. */
4920 infinity
= pure_bytes_used_non_lisp
+ 1;
4921 bm_skip
['\0'] = infinity
;
4923 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4927 /* Check the last character (== '\0'). */
4930 start
+= bm_skip
[*(p
+ start
)];
4932 while (start
<= start_max
);
4934 if (start
< infinity
)
4935 /* Couldn't find the last character. */
4938 /* No less than `infinity' means we could find the last
4939 character at `p[start - infinity]'. */
4942 /* Check the remaining characters. */
4943 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4945 return non_lisp_beg
+ start
;
4947 start
+= last_char_skip
;
4949 while (start
<= start_max
);
4955 /* Return a string allocated in pure space. DATA is a buffer holding
4956 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4957 means make the result string multibyte.
4959 Must get an error if pure storage is full, since if it cannot hold
4960 a large string it may be able to hold conses that point to that
4961 string; then the string is not protected from gc. */
4964 make_pure_string (const char *data
,
4965 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
4968 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4969 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4970 if (s
->data
== NULL
)
4972 s
->data
= pure_alloc (nbytes
+ 1, -1);
4973 memcpy (s
->data
, data
, nbytes
);
4974 s
->data
[nbytes
] = '\0';
4977 s
->size_byte
= multibyte
? nbytes
: -1;
4978 s
->intervals
= NULL
;
4979 XSETSTRING (string
, s
);
4983 /* Return a string allocated in pure space. Do not
4984 allocate the string data, just point to DATA. */
4987 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
4990 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
4993 s
->data
= (unsigned char *) data
;
4994 s
->intervals
= NULL
;
4995 XSETSTRING (string
, s
);
4999 /* Return a cons allocated from pure space. Give it pure copies
5000 of CAR as car and CDR as cdr. */
5003 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5006 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5008 XSETCAR (new, Fpurecopy (car
));
5009 XSETCDR (new, Fpurecopy (cdr
));
5014 /* Value is a float object with value NUM allocated from pure space. */
5017 make_pure_float (double num
)
5020 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5022 XFLOAT_INIT (new, num
);
5027 /* Return a vector with room for LEN Lisp_Objects allocated from
5031 make_pure_vector (ptrdiff_t len
)
5034 size_t size
= header_size
+ len
* word_size
;
5035 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5036 XSETVECTOR (new, p
);
5037 XVECTOR (new)->header
.size
= len
;
5042 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5043 doc
: /* Make a copy of object OBJ in pure storage.
5044 Recursively copies contents of vectors and cons cells.
5045 Does not copy symbols. Copies strings without text properties. */)
5046 (register Lisp_Object obj
)
5048 if (NILP (Vpurify_flag
))
5051 if (PURE_POINTER_P (XPNTR (obj
)))
5054 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5056 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5062 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5063 else if (FLOATP (obj
))
5064 obj
= make_pure_float (XFLOAT_DATA (obj
));
5065 else if (STRINGP (obj
))
5066 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5068 STRING_MULTIBYTE (obj
));
5069 else if (COMPILEDP (obj
) || VECTORP (obj
))
5071 register struct Lisp_Vector
*vec
;
5072 register ptrdiff_t i
;
5076 if (size
& PSEUDOVECTOR_FLAG
)
5077 size
&= PSEUDOVECTOR_SIZE_MASK
;
5078 vec
= XVECTOR (make_pure_vector (size
));
5079 for (i
= 0; i
< size
; i
++)
5080 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5081 if (COMPILEDP (obj
))
5083 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5084 XSETCOMPILED (obj
, vec
);
5087 XSETVECTOR (obj
, vec
);
5089 else if (MARKERP (obj
))
5090 error ("Attempt to copy a marker to pure storage");
5092 /* Not purified, don't hash-cons. */
5095 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5096 Fputhash (obj
, obj
, Vpurify_flag
);
5103 /***********************************************************************
5105 ***********************************************************************/
5107 /* Put an entry in staticvec, pointing at the variable with address
5111 staticpro (Lisp_Object
*varaddress
)
5113 staticvec
[staticidx
++] = varaddress
;
5114 if (staticidx
>= NSTATICS
)
5115 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5119 /***********************************************************************
5121 ***********************************************************************/
5123 /* Temporarily prevent garbage collection. */
5126 inhibit_garbage_collection (void)
5128 ptrdiff_t count
= SPECPDL_INDEX ();
5130 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5134 /* Used to avoid possible overflows when
5135 converting from C to Lisp integers. */
5138 bounded_number (EMACS_INT number
)
5140 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5143 /* Calculate total bytes of live objects. */
5146 total_bytes_of_live_objects (void)
5149 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5150 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5151 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5152 tot
+= total_string_bytes
;
5153 tot
+= total_vector_slots
* word_size
;
5154 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5155 tot
+= total_intervals
* sizeof (struct interval
);
5156 tot
+= total_strings
* sizeof (struct Lisp_String
);
5160 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5161 doc
: /* Reclaim storage for Lisp objects no longer needed.
5162 Garbage collection happens automatically if you cons more than
5163 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5164 `garbage-collect' normally returns a list with info on amount of space in use,
5165 where each entry has the form (NAME SIZE USED FREE), where:
5166 - NAME is a symbol describing the kind of objects this entry represents,
5167 - SIZE is the number of bytes used by each one,
5168 - USED is the number of those objects that were found live in the heap,
5169 - FREE is the number of those objects that are not live but that Emacs
5170 keeps around for future allocations (maybe because it does not know how
5171 to return them to the OS).
5172 However, if there was overflow in pure space, `garbage-collect'
5173 returns nil, because real GC can't be done.
5174 See Info node `(elisp)Garbage Collection'. */)
5177 struct specbinding
*bind
;
5178 struct buffer
*nextb
;
5179 char stack_top_variable
;
5182 ptrdiff_t count
= SPECPDL_INDEX ();
5184 Lisp_Object retval
= Qnil
;
5185 size_t tot_before
= 0;
5186 struct backtrace backtrace
;
5191 /* Can't GC if pure storage overflowed because we can't determine
5192 if something is a pure object or not. */
5193 if (pure_bytes_used_before_overflow
)
5196 /* Record this function, so it appears on the profiler's backtraces. */
5197 backtrace
.next
= backtrace_list
;
5198 backtrace
.function
= Qautomatic_gc
;
5199 backtrace
.args
= &Qnil
;
5200 backtrace
.nargs
= 0;
5201 backtrace
.debug_on_exit
= 0;
5202 backtrace_list
= &backtrace
;
5206 /* Don't keep undo information around forever.
5207 Do this early on, so it is no problem if the user quits. */
5208 FOR_EACH_BUFFER (nextb
)
5209 compact_buffer (nextb
);
5211 if (profiler_memory_running
)
5212 tot_before
= total_bytes_of_live_objects ();
5214 start
= current_emacs_time ();
5216 /* In case user calls debug_print during GC,
5217 don't let that cause a recursive GC. */
5218 consing_since_gc
= 0;
5220 /* Save what's currently displayed in the echo area. */
5221 message_p
= push_message ();
5222 record_unwind_protect (pop_message_unwind
, Qnil
);
5224 /* Save a copy of the contents of the stack, for debugging. */
5225 #if MAX_SAVE_STACK > 0
5226 if (NILP (Vpurify_flag
))
5229 ptrdiff_t stack_size
;
5230 if (&stack_top_variable
< stack_bottom
)
5232 stack
= &stack_top_variable
;
5233 stack_size
= stack_bottom
- &stack_top_variable
;
5237 stack
= stack_bottom
;
5238 stack_size
= &stack_top_variable
- stack_bottom
;
5240 if (stack_size
<= MAX_SAVE_STACK
)
5242 if (stack_copy_size
< stack_size
)
5244 stack_copy
= xrealloc (stack_copy
, stack_size
);
5245 stack_copy_size
= stack_size
;
5247 memcpy (stack_copy
, stack
, stack_size
);
5250 #endif /* MAX_SAVE_STACK > 0 */
5252 if (garbage_collection_messages
)
5253 message1_nolog ("Garbage collecting...");
5257 shrink_regexp_cache ();
5261 /* Mark all the special slots that serve as the roots of accessibility. */
5263 mark_buffer (&buffer_defaults
);
5264 mark_buffer (&buffer_local_symbols
);
5266 for (i
= 0; i
< staticidx
; i
++)
5267 mark_object (*staticvec
[i
]);
5269 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5271 mark_object (bind
->symbol
);
5272 mark_object (bind
->old_value
);
5281 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5282 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5286 register struct gcpro
*tail
;
5287 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5288 for (i
= 0; i
< tail
->nvars
; i
++)
5289 mark_object (tail
->var
[i
]);
5293 struct catchtag
*catch;
5294 struct handler
*handler
;
5296 for (catch = catchlist
; catch; catch = catch->next
)
5298 mark_object (catch->tag
);
5299 mark_object (catch->val
);
5301 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5303 mark_object (handler
->handler
);
5304 mark_object (handler
->var
);
5310 #ifdef HAVE_WINDOW_SYSTEM
5311 mark_fringe_data ();
5314 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5318 /* Everything is now marked, except for the things that require special
5319 finalization, i.e. the undo_list.
5320 Look thru every buffer's undo list
5321 for elements that update markers that were not marked,
5323 FOR_EACH_BUFFER (nextb
)
5325 /* If a buffer's undo list is Qt, that means that undo is
5326 turned off in that buffer. Calling truncate_undo_list on
5327 Qt tends to return NULL, which effectively turns undo back on.
5328 So don't call truncate_undo_list if undo_list is Qt. */
5329 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5331 Lisp_Object tail
, prev
;
5332 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5334 while (CONSP (tail
))
5336 if (CONSP (XCAR (tail
))
5337 && MARKERP (XCAR (XCAR (tail
)))
5338 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5341 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5345 XSETCDR (prev
, tail
);
5355 /* Now that we have stripped the elements that need not be in the
5356 undo_list any more, we can finally mark the list. */
5357 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5362 /* Clear the mark bits that we set in certain root slots. */
5364 unmark_byte_stack ();
5365 VECTOR_UNMARK (&buffer_defaults
);
5366 VECTOR_UNMARK (&buffer_local_symbols
);
5368 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5378 consing_since_gc
= 0;
5379 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5380 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5382 gc_relative_threshold
= 0;
5383 if (FLOATP (Vgc_cons_percentage
))
5384 { /* Set gc_cons_combined_threshold. */
5385 double tot
= total_bytes_of_live_objects ();
5387 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5390 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5391 gc_relative_threshold
= tot
;
5393 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5397 if (garbage_collection_messages
)
5399 if (message_p
|| minibuf_level
> 0)
5402 message1_nolog ("Garbage collecting...done");
5405 unbind_to (count
, Qnil
);
5407 Lisp_Object total
[11];
5408 int total_size
= 10;
5410 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5411 bounded_number (total_conses
),
5412 bounded_number (total_free_conses
));
5414 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5415 bounded_number (total_symbols
),
5416 bounded_number (total_free_symbols
));
5418 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5419 bounded_number (total_markers
),
5420 bounded_number (total_free_markers
));
5422 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5423 bounded_number (total_strings
),
5424 bounded_number (total_free_strings
));
5426 total
[4] = list3 (Qstring_bytes
, make_number (1),
5427 bounded_number (total_string_bytes
));
5429 total
[5] = list3 (Qvectors
, make_number (sizeof (struct Lisp_Vector
)),
5430 bounded_number (total_vectors
));
5432 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5433 bounded_number (total_vector_slots
),
5434 bounded_number (total_free_vector_slots
));
5436 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5437 bounded_number (total_floats
),
5438 bounded_number (total_free_floats
));
5440 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5441 bounded_number (total_intervals
),
5442 bounded_number (total_free_intervals
));
5444 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5445 bounded_number (total_buffers
));
5447 #ifdef DOUG_LEA_MALLOC
5449 total
[10] = list4 (Qheap
, make_number (1024),
5450 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5451 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5453 retval
= Flist (total_size
, total
);
5456 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5458 /* Compute average percentage of zombies. */
5460 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5461 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5463 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5464 max_live
= max (nlive
, max_live
);
5465 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5466 max_zombies
= max (nzombies
, max_zombies
);
5471 if (!NILP (Vpost_gc_hook
))
5473 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5474 safe_run_hooks (Qpost_gc_hook
);
5475 unbind_to (gc_count
, Qnil
);
5478 /* Accumulate statistics. */
5479 if (FLOATP (Vgc_elapsed
))
5481 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5482 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5483 + EMACS_TIME_TO_DOUBLE (since_start
));
5488 /* Collect profiling data. */
5489 if (profiler_memory_running
)
5492 size_t tot_after
= total_bytes_of_live_objects ();
5493 if (tot_before
> tot_after
)
5494 swept
= tot_before
- tot_after
;
5495 malloc_probe (swept
);
5498 backtrace_list
= backtrace
.next
;
5503 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5504 only interesting objects referenced from glyphs are strings. */
5507 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5509 struct glyph_row
*row
= matrix
->rows
;
5510 struct glyph_row
*end
= row
+ matrix
->nrows
;
5512 for (; row
< end
; ++row
)
5516 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5518 struct glyph
*glyph
= row
->glyphs
[area
];
5519 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5521 for (; glyph
< end_glyph
; ++glyph
)
5522 if (STRINGP (glyph
->object
)
5523 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5524 mark_object (glyph
->object
);
5530 /* Mark Lisp faces in the face cache C. */
5533 mark_face_cache (struct face_cache
*c
)
5538 for (i
= 0; i
< c
->used
; ++i
)
5540 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5544 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5545 mark_object (face
->lface
[j
]);
5553 /* Mark reference to a Lisp_Object.
5554 If the object referred to has not been seen yet, recursively mark
5555 all the references contained in it. */
5557 #define LAST_MARKED_SIZE 500
5558 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5559 static int last_marked_index
;
5561 /* For debugging--call abort when we cdr down this many
5562 links of a list, in mark_object. In debugging,
5563 the call to abort will hit a breakpoint.
5564 Normally this is zero and the check never goes off. */
5565 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5568 mark_vectorlike (struct Lisp_Vector
*ptr
)
5570 ptrdiff_t size
= ptr
->header
.size
;
5573 eassert (!VECTOR_MARKED_P (ptr
));
5574 VECTOR_MARK (ptr
); /* Else mark it. */
5575 if (size
& PSEUDOVECTOR_FLAG
)
5576 size
&= PSEUDOVECTOR_SIZE_MASK
;
5578 /* Note that this size is not the memory-footprint size, but only
5579 the number of Lisp_Object fields that we should trace.
5580 The distinction is used e.g. by Lisp_Process which places extra
5581 non-Lisp_Object fields at the end of the structure... */
5582 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5583 mark_object (ptr
->contents
[i
]);
5586 /* Like mark_vectorlike but optimized for char-tables (and
5587 sub-char-tables) assuming that the contents are mostly integers or
5591 mark_char_table (struct Lisp_Vector
*ptr
)
5593 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5596 eassert (!VECTOR_MARKED_P (ptr
));
5598 for (i
= 0; i
< size
; i
++)
5600 Lisp_Object val
= ptr
->contents
[i
];
5602 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5604 if (SUB_CHAR_TABLE_P (val
))
5606 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5607 mark_char_table (XVECTOR (val
));
5614 /* Mark the chain of overlays starting at PTR. */
5617 mark_overlay (struct Lisp_Overlay
*ptr
)
5619 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5622 mark_object (ptr
->start
);
5623 mark_object (ptr
->end
);
5624 mark_object (ptr
->plist
);
5628 /* Mark Lisp_Objects and special pointers in BUFFER. */
5631 mark_buffer (struct buffer
*buffer
)
5633 /* This is handled much like other pseudovectors... */
5634 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5636 /* ...but there are some buffer-specific things. */
5638 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5640 /* For now, we just don't mark the undo_list. It's done later in
5641 a special way just before the sweep phase, and after stripping
5642 some of its elements that are not needed any more. */
5644 mark_overlay (buffer
->overlays_before
);
5645 mark_overlay (buffer
->overlays_after
);
5647 /* If this is an indirect buffer, mark its base buffer. */
5648 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5649 mark_buffer (buffer
->base_buffer
);
5652 /* Remove killed buffers or items whose car is a killed buffer from
5653 LIST, and mark other items. Return changed LIST, which is marked. */
5656 mark_discard_killed_buffers (Lisp_Object list
)
5658 Lisp_Object tail
, *prev
= &list
;
5660 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5663 Lisp_Object tem
= XCAR (tail
);
5666 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5667 *prev
= XCDR (tail
);
5670 CONS_MARK (XCONS (tail
));
5671 mark_object (XCAR (tail
));
5672 prev
= &XCDR_AS_LVALUE (tail
);
5679 /* Determine type of generic Lisp_Object and mark it accordingly. */
5682 mark_object (Lisp_Object arg
)
5684 register Lisp_Object obj
= arg
;
5685 #ifdef GC_CHECK_MARKED_OBJECTS
5689 ptrdiff_t cdr_count
= 0;
5693 if (PURE_POINTER_P (XPNTR (obj
)))
5696 last_marked
[last_marked_index
++] = obj
;
5697 if (last_marked_index
== LAST_MARKED_SIZE
)
5698 last_marked_index
= 0;
5700 /* Perform some sanity checks on the objects marked here. Abort if
5701 we encounter an object we know is bogus. This increases GC time
5702 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5703 #ifdef GC_CHECK_MARKED_OBJECTS
5705 po
= (void *) XPNTR (obj
);
5707 /* Check that the object pointed to by PO is known to be a Lisp
5708 structure allocated from the heap. */
5709 #define CHECK_ALLOCATED() \
5711 m = mem_find (po); \
5716 /* Check that the object pointed to by PO is live, using predicate
5718 #define CHECK_LIVE(LIVEP) \
5720 if (!LIVEP (m, po)) \
5724 /* Check both of the above conditions. */
5725 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5727 CHECK_ALLOCATED (); \
5728 CHECK_LIVE (LIVEP); \
5731 #else /* not GC_CHECK_MARKED_OBJECTS */
5733 #define CHECK_LIVE(LIVEP) (void) 0
5734 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5736 #endif /* not GC_CHECK_MARKED_OBJECTS */
5738 switch (XTYPE (obj
))
5742 register struct Lisp_String
*ptr
= XSTRING (obj
);
5743 if (STRING_MARKED_P (ptr
))
5745 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5747 MARK_INTERVAL_TREE (ptr
->intervals
);
5748 #ifdef GC_CHECK_STRING_BYTES
5749 /* Check that the string size recorded in the string is the
5750 same as the one recorded in the sdata structure. */
5752 #endif /* GC_CHECK_STRING_BYTES */
5756 case Lisp_Vectorlike
:
5758 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5759 register ptrdiff_t pvectype
;
5761 if (VECTOR_MARKED_P (ptr
))
5764 #ifdef GC_CHECK_MARKED_OBJECTS
5766 if (m
== MEM_NIL
&& !SUBRP (obj
))
5768 #endif /* GC_CHECK_MARKED_OBJECTS */
5770 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5771 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5772 >> PSEUDOVECTOR_AREA_BITS
);
5774 pvectype
= PVEC_NORMAL_VECTOR
;
5776 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5777 CHECK_LIVE (live_vector_p
);
5782 #ifdef GC_CHECK_MARKED_OBJECTS
5791 #endif /* GC_CHECK_MARKED_OBJECTS */
5792 mark_buffer ((struct buffer
*) ptr
);
5796 { /* We could treat this just like a vector, but it is better
5797 to save the COMPILED_CONSTANTS element for last and avoid
5799 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5803 for (i
= 0; i
< size
; i
++)
5804 if (i
!= COMPILED_CONSTANTS
)
5805 mark_object (ptr
->contents
[i
]);
5806 if (size
> COMPILED_CONSTANTS
)
5808 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5815 mark_vectorlike (ptr
);
5816 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5821 struct window
*w
= (struct window
*) ptr
;
5822 bool leaf
= NILP (w
->hchild
) && NILP (w
->vchild
);
5824 mark_vectorlike (ptr
);
5826 /* Mark glyphs for leaf windows. Marking window
5827 matrices is sufficient because frame matrices
5828 use the same glyph memory. */
5829 if (leaf
&& w
->current_matrix
)
5831 mark_glyph_matrix (w
->current_matrix
);
5832 mark_glyph_matrix (w
->desired_matrix
);
5835 /* Filter out killed buffers from both buffer lists
5836 in attempt to help GC to reclaim killed buffers faster.
5837 We can do it elsewhere for live windows, but this is the
5838 best place to do it for dead windows. */
5840 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5842 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5846 case PVEC_HASH_TABLE
:
5848 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5850 mark_vectorlike (ptr
);
5851 mark_object (h
->test
.name
);
5852 mark_object (h
->test
.user_hash_function
);
5853 mark_object (h
->test
.user_cmp_function
);
5854 /* If hash table is not weak, mark all keys and values.
5855 For weak tables, mark only the vector. */
5857 mark_object (h
->key_and_value
);
5859 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5863 case PVEC_CHAR_TABLE
:
5864 mark_char_table (ptr
);
5867 case PVEC_BOOL_VECTOR
:
5868 /* No Lisp_Objects to mark in a bool vector. */
5879 mark_vectorlike (ptr
);
5886 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5887 struct Lisp_Symbol
*ptrx
;
5891 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5893 mark_object (ptr
->function
);
5894 mark_object (ptr
->plist
);
5895 switch (ptr
->redirect
)
5897 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5898 case SYMBOL_VARALIAS
:
5901 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5905 case SYMBOL_LOCALIZED
:
5907 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5908 Lisp_Object where
= blv
->where
;
5909 /* If the value is set up for a killed buffer or deleted
5910 frame, restore it's global binding. If the value is
5911 forwarded to a C variable, either it's not a Lisp_Object
5912 var, or it's staticpro'd already. */
5913 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5914 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5915 swap_in_global_binding (ptr
);
5916 mark_object (blv
->where
);
5917 mark_object (blv
->valcell
);
5918 mark_object (blv
->defcell
);
5921 case SYMBOL_FORWARDED
:
5922 /* If the value is forwarded to a buffer or keyboard field,
5923 these are marked when we see the corresponding object.
5924 And if it's forwarded to a C variable, either it's not
5925 a Lisp_Object var, or it's staticpro'd already. */
5927 default: emacs_abort ();
5929 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5930 MARK_STRING (XSTRING (ptr
->name
));
5931 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5936 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5937 XSETSYMBOL (obj
, ptrx
);
5944 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5946 if (XMISCANY (obj
)->gcmarkbit
)
5949 switch (XMISCTYPE (obj
))
5951 case Lisp_Misc_Marker
:
5952 /* DO NOT mark thru the marker's chain.
5953 The buffer's markers chain does not preserve markers from gc;
5954 instead, markers are removed from the chain when freed by gc. */
5955 XMISCANY (obj
)->gcmarkbit
= 1;
5958 case Lisp_Misc_Save_Value
:
5959 XMISCANY (obj
)->gcmarkbit
= 1;
5961 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5962 /* If `area' is nonzero, `data[0].pointer' is the address
5963 of a memory area containing `data[1].integer' potential
5968 Lisp_Object
*p
= ptr
->data
[0].pointer
;
5970 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
5971 mark_maybe_object (*p
);
5974 #endif /* GC_MARK_STACK */
5976 /* Find Lisp_Objects in `data[N]' slots and mark them. */
5977 if (ptr
->type0
== SAVE_OBJECT
)
5978 mark_object (ptr
->data
[0].object
);
5979 if (ptr
->type1
== SAVE_OBJECT
)
5980 mark_object (ptr
->data
[1].object
);
5981 if (ptr
->type2
== SAVE_OBJECT
)
5982 mark_object (ptr
->data
[2].object
);
5983 if (ptr
->type3
== SAVE_OBJECT
)
5984 mark_object (ptr
->data
[3].object
);
5989 case Lisp_Misc_Overlay
:
5990 mark_overlay (XOVERLAY (obj
));
6000 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6001 if (CONS_MARKED_P (ptr
))
6003 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6005 /* If the cdr is nil, avoid recursion for the car. */
6006 if (EQ (ptr
->u
.cdr
, Qnil
))
6012 mark_object (ptr
->car
);
6015 if (cdr_count
== mark_object_loop_halt
)
6021 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6022 FLOAT_MARK (XFLOAT (obj
));
6033 #undef CHECK_ALLOCATED
6034 #undef CHECK_ALLOCATED_AND_LIVE
6036 /* Mark the Lisp pointers in the terminal objects.
6037 Called by Fgarbage_collect. */
6040 mark_terminals (void)
6043 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6045 eassert (t
->name
!= NULL
);
6046 #ifdef HAVE_WINDOW_SYSTEM
6047 /* If a terminal object is reachable from a stacpro'ed object,
6048 it might have been marked already. Make sure the image cache
6050 mark_image_cache (t
->image_cache
);
6051 #endif /* HAVE_WINDOW_SYSTEM */
6052 if (!VECTOR_MARKED_P (t
))
6053 mark_vectorlike ((struct Lisp_Vector
*)t
);
6059 /* Value is non-zero if OBJ will survive the current GC because it's
6060 either marked or does not need to be marked to survive. */
6063 survives_gc_p (Lisp_Object obj
)
6067 switch (XTYPE (obj
))
6074 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6078 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6082 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6085 case Lisp_Vectorlike
:
6086 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6090 survives_p
= CONS_MARKED_P (XCONS (obj
));
6094 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6101 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6106 /* Sweep: find all structures not marked, and free them. */
6111 /* Remove or mark entries in weak hash tables.
6112 This must be done before any object is unmarked. */
6113 sweep_weak_hash_tables ();
6116 check_string_bytes (!noninteractive
);
6118 /* Put all unmarked conses on free list */
6120 register struct cons_block
*cblk
;
6121 struct cons_block
**cprev
= &cons_block
;
6122 register int lim
= cons_block_index
;
6123 EMACS_INT num_free
= 0, num_used
= 0;
6127 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6131 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6133 /* Scan the mark bits an int at a time. */
6134 for (i
= 0; i
< ilim
; i
++)
6136 if (cblk
->gcmarkbits
[i
] == -1)
6138 /* Fast path - all cons cells for this int are marked. */
6139 cblk
->gcmarkbits
[i
] = 0;
6140 num_used
+= BITS_PER_INT
;
6144 /* Some cons cells for this int are not marked.
6145 Find which ones, and free them. */
6146 int start
, pos
, stop
;
6148 start
= i
* BITS_PER_INT
;
6150 if (stop
> BITS_PER_INT
)
6151 stop
= BITS_PER_INT
;
6154 for (pos
= start
; pos
< stop
; pos
++)
6156 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6159 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6160 cons_free_list
= &cblk
->conses
[pos
];
6162 cons_free_list
->car
= Vdead
;
6168 CONS_UNMARK (&cblk
->conses
[pos
]);
6174 lim
= CONS_BLOCK_SIZE
;
6175 /* If this block contains only free conses and we have already
6176 seen more than two blocks worth of free conses then deallocate
6178 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6180 *cprev
= cblk
->next
;
6181 /* Unhook from the free list. */
6182 cons_free_list
= cblk
->conses
[0].u
.chain
;
6183 lisp_align_free (cblk
);
6187 num_free
+= this_free
;
6188 cprev
= &cblk
->next
;
6191 total_conses
= num_used
;
6192 total_free_conses
= num_free
;
6195 /* Put all unmarked floats on free list */
6197 register struct float_block
*fblk
;
6198 struct float_block
**fprev
= &float_block
;
6199 register int lim
= float_block_index
;
6200 EMACS_INT num_free
= 0, num_used
= 0;
6202 float_free_list
= 0;
6204 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6208 for (i
= 0; i
< lim
; i
++)
6209 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6212 fblk
->floats
[i
].u
.chain
= float_free_list
;
6213 float_free_list
= &fblk
->floats
[i
];
6218 FLOAT_UNMARK (&fblk
->floats
[i
]);
6220 lim
= FLOAT_BLOCK_SIZE
;
6221 /* If this block contains only free floats and we have already
6222 seen more than two blocks worth of free floats then deallocate
6224 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6226 *fprev
= fblk
->next
;
6227 /* Unhook from the free list. */
6228 float_free_list
= fblk
->floats
[0].u
.chain
;
6229 lisp_align_free (fblk
);
6233 num_free
+= this_free
;
6234 fprev
= &fblk
->next
;
6237 total_floats
= num_used
;
6238 total_free_floats
= num_free
;
6241 /* Put all unmarked intervals on free list */
6243 register struct interval_block
*iblk
;
6244 struct interval_block
**iprev
= &interval_block
;
6245 register int lim
= interval_block_index
;
6246 EMACS_INT num_free
= 0, num_used
= 0;
6248 interval_free_list
= 0;
6250 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6255 for (i
= 0; i
< lim
; i
++)
6257 if (!iblk
->intervals
[i
].gcmarkbit
)
6259 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6260 interval_free_list
= &iblk
->intervals
[i
];
6266 iblk
->intervals
[i
].gcmarkbit
= 0;
6269 lim
= INTERVAL_BLOCK_SIZE
;
6270 /* If this block contains only free intervals and we have already
6271 seen more than two blocks worth of free intervals then
6272 deallocate this block. */
6273 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6275 *iprev
= iblk
->next
;
6276 /* Unhook from the free list. */
6277 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6282 num_free
+= this_free
;
6283 iprev
= &iblk
->next
;
6286 total_intervals
= num_used
;
6287 total_free_intervals
= num_free
;
6290 /* Put all unmarked symbols on free list */
6292 register struct symbol_block
*sblk
;
6293 struct symbol_block
**sprev
= &symbol_block
;
6294 register int lim
= symbol_block_index
;
6295 EMACS_INT num_free
= 0, num_used
= 0;
6297 symbol_free_list
= NULL
;
6299 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6302 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6303 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6305 for (; sym
< end
; ++sym
)
6307 /* Check if the symbol was created during loadup. In such a case
6308 it might be pointed to by pure bytecode which we don't trace,
6309 so we conservatively assume that it is live. */
6310 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6312 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6314 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6315 xfree (SYMBOL_BLV (&sym
->s
));
6316 sym
->s
.next
= symbol_free_list
;
6317 symbol_free_list
= &sym
->s
;
6319 symbol_free_list
->function
= Vdead
;
6327 UNMARK_STRING (XSTRING (sym
->s
.name
));
6328 sym
->s
.gcmarkbit
= 0;
6332 lim
= SYMBOL_BLOCK_SIZE
;
6333 /* If this block contains only free symbols and we have already
6334 seen more than two blocks worth of free symbols then deallocate
6336 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6338 *sprev
= sblk
->next
;
6339 /* Unhook from the free list. */
6340 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6345 num_free
+= this_free
;
6346 sprev
= &sblk
->next
;
6349 total_symbols
= num_used
;
6350 total_free_symbols
= num_free
;
6353 /* Put all unmarked misc's on free list.
6354 For a marker, first unchain it from the buffer it points into. */
6356 register struct marker_block
*mblk
;
6357 struct marker_block
**mprev
= &marker_block
;
6358 register int lim
= marker_block_index
;
6359 EMACS_INT num_free
= 0, num_used
= 0;
6361 marker_free_list
= 0;
6363 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6368 for (i
= 0; i
< lim
; i
++)
6370 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6372 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6373 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6374 /* Set the type of the freed object to Lisp_Misc_Free.
6375 We could leave the type alone, since nobody checks it,
6376 but this might catch bugs faster. */
6377 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6378 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6379 marker_free_list
= &mblk
->markers
[i
].m
;
6385 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6388 lim
= MARKER_BLOCK_SIZE
;
6389 /* If this block contains only free markers and we have already
6390 seen more than two blocks worth of free markers then deallocate
6392 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6394 *mprev
= mblk
->next
;
6395 /* Unhook from the free list. */
6396 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6401 num_free
+= this_free
;
6402 mprev
= &mblk
->next
;
6406 total_markers
= num_used
;
6407 total_free_markers
= num_free
;
6410 /* Free all unmarked buffers */
6412 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6415 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6416 if (!VECTOR_MARKED_P (buffer
))
6418 *bprev
= buffer
->next
;
6423 VECTOR_UNMARK (buffer
);
6424 /* Do not use buffer_(set|get)_intervals here. */
6425 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6427 bprev
= &buffer
->next
;
6432 check_string_bytes (!noninteractive
);
6438 /* Debugging aids. */
6440 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6441 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6442 This may be helpful in debugging Emacs's memory usage.
6443 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6448 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6453 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6454 doc
: /* Return a list of counters that measure how much consing there has been.
6455 Each of these counters increments for a certain kind of object.
6456 The counters wrap around from the largest positive integer to zero.
6457 Garbage collection does not decrease them.
6458 The elements of the value are as follows:
6459 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6460 All are in units of 1 = one object consed
6461 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6463 MISCS include overlays, markers, and some internal types.
6464 Frames, windows, buffers, and subprocesses count as vectors
6465 (but the contents of a buffer's text do not count here). */)
6468 return listn (CONSTYPE_HEAP
, 8,
6469 bounded_number (cons_cells_consed
),
6470 bounded_number (floats_consed
),
6471 bounded_number (vector_cells_consed
),
6472 bounded_number (symbols_consed
),
6473 bounded_number (string_chars_consed
),
6474 bounded_number (misc_objects_consed
),
6475 bounded_number (intervals_consed
),
6476 bounded_number (strings_consed
));
6479 /* Find at most FIND_MAX symbols which have OBJ as their value or
6480 function. This is used in gdbinit's `xwhichsymbols' command. */
6483 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6485 struct symbol_block
*sblk
;
6486 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6487 Lisp_Object found
= Qnil
;
6491 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6493 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6496 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6498 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6502 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6505 XSETSYMBOL (tem
, sym
);
6506 val
= find_symbol_value (tem
);
6508 || EQ (sym
->function
, obj
)
6509 || (!NILP (sym
->function
)
6510 && COMPILEDP (sym
->function
)
6511 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6514 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6516 found
= Fcons (tem
, found
);
6517 if (--find_max
== 0)
6525 unbind_to (gc_count
, Qnil
);
6529 #ifdef ENABLE_CHECKING
6531 bool suppress_checking
;
6534 die (const char *msg
, const char *file
, int line
)
6536 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6538 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6542 /* Initialization. */
6545 init_alloc_once (void)
6547 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6549 pure_size
= PURESIZE
;
6551 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6553 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6556 #ifdef DOUG_LEA_MALLOC
6557 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6558 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6559 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6564 refill_memory_reserve ();
6565 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6572 byte_stack_list
= 0;
6574 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6575 setjmp_tested_p
= longjmps_done
= 0;
6578 Vgc_elapsed
= make_float (0.0);
6583 syms_of_alloc (void)
6585 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6586 doc
: /* Number of bytes of consing between garbage collections.
6587 Garbage collection can happen automatically once this many bytes have been
6588 allocated since the last garbage collection. All data types count.
6590 Garbage collection happens automatically only when `eval' is called.
6592 By binding this temporarily to a large number, you can effectively
6593 prevent garbage collection during a part of the program.
6594 See also `gc-cons-percentage'. */);
6596 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6597 doc
: /* Portion of the heap used for allocation.
6598 Garbage collection can happen automatically once this portion of the heap
6599 has been allocated since the last garbage collection.
6600 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6601 Vgc_cons_percentage
= make_float (0.1);
6603 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6604 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6606 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6607 doc
: /* Number of cons cells that have been consed so far. */);
6609 DEFVAR_INT ("floats-consed", floats_consed
,
6610 doc
: /* Number of floats that have been consed so far. */);
6612 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6613 doc
: /* Number of vector cells that have been consed so far. */);
6615 DEFVAR_INT ("symbols-consed", symbols_consed
,
6616 doc
: /* Number of symbols that have been consed so far. */);
6618 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6619 doc
: /* Number of string characters that have been consed so far. */);
6621 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6622 doc
: /* Number of miscellaneous objects that have been consed so far.
6623 These include markers and overlays, plus certain objects not visible
6626 DEFVAR_INT ("intervals-consed", intervals_consed
,
6627 doc
: /* Number of intervals that have been consed so far. */);
6629 DEFVAR_INT ("strings-consed", strings_consed
,
6630 doc
: /* Number of strings that have been consed so far. */);
6632 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6633 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6634 This means that certain objects should be allocated in shared (pure) space.
6635 It can also be set to a hash-table, in which case this table is used to
6636 do hash-consing of the objects allocated to pure space. */);
6638 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6639 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6640 garbage_collection_messages
= 0;
6642 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6643 doc
: /* Hook run after garbage collection has finished. */);
6644 Vpost_gc_hook
= Qnil
;
6645 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6647 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6648 doc
: /* Precomputed `signal' argument for memory-full error. */);
6649 /* We build this in advance because if we wait until we need it, we might
6650 not be able to allocate the memory to hold it. */
6652 = listn (CONSTYPE_PURE
, 2, Qerror
,
6653 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6655 DEFVAR_LISP ("memory-full", Vmemory_full
,
6656 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6657 Vmemory_full
= Qnil
;
6659 DEFSYM (Qconses
, "conses");
6660 DEFSYM (Qsymbols
, "symbols");
6661 DEFSYM (Qmiscs
, "miscs");
6662 DEFSYM (Qstrings
, "strings");
6663 DEFSYM (Qvectors
, "vectors");
6664 DEFSYM (Qfloats
, "floats");
6665 DEFSYM (Qintervals
, "intervals");
6666 DEFSYM (Qbuffers
, "buffers");
6667 DEFSYM (Qstring_bytes
, "string-bytes");
6668 DEFSYM (Qvector_slots
, "vector-slots");
6669 DEFSYM (Qheap
, "heap");
6670 DEFSYM (Qautomatic_gc
, "Automatic GC");
6672 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6673 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6675 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6676 doc
: /* Accumulated time elapsed in garbage collections.
6677 The time is in seconds as a floating point value. */);
6678 DEFVAR_INT ("gcs-done", gcs_done
,
6679 doc
: /* Accumulated number of garbage collections done. */);
6684 defsubr (&Smake_byte_code
);
6685 defsubr (&Smake_list
);
6686 defsubr (&Smake_vector
);
6687 defsubr (&Smake_string
);
6688 defsubr (&Smake_bool_vector
);
6689 defsubr (&Smake_symbol
);
6690 defsubr (&Smake_marker
);
6691 defsubr (&Spurecopy
);
6692 defsubr (&Sgarbage_collect
);
6693 defsubr (&Smemory_limit
);
6694 defsubr (&Smemory_use_counts
);
6696 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6697 defsubr (&Sgc_status
);
6701 /* When compiled with GCC, GDB might say "No enum type named
6702 pvec_type" if we don't have at least one symbol with that type, and
6703 then xbacktrace could fail. Similarly for the other enums and
6704 their values. Some non-GCC compilers don't like these constructs. */
6708 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6709 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6710 enum char_bits char_bits
;
6711 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6712 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6713 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6714 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6715 enum Lisp_Bits Lisp_Bits
;
6716 enum Lisp_Compiled Lisp_Compiled
;
6717 enum maxargs maxargs
;
6718 enum MAX_ALLOCA MAX_ALLOCA
;
6719 enum More_Lisp_Bits More_Lisp_Bits
;
6720 enum pvec_type pvec_type
;
6722 enum lsb_bits lsb_bits
;
6724 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6725 #endif /* __GNUC__ */