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/>. */
24 #include <limits.h> /* For CHAR_BIT. */
26 #ifdef ENABLE_CHECKING
27 #include <signal.h> /* For SIGABRT. */
36 #include "intervals.h"
38 #include "character.h"
43 #include "blockinput.h"
44 #include "termhooks.h" /* For struct terminal. */
45 #ifdef HAVE_WINDOW_SYSTEM
47 #endif /* HAVE_WINDOW_SYSTEM */
51 #if (defined ENABLE_CHECKING \
52 && defined HAVE_VALGRIND_VALGRIND_H \
53 && !defined USE_VALGRIND)
54 # define USE_VALGRIND 1
58 #include <valgrind/valgrind.h>
59 #include <valgrind/memcheck.h>
60 static bool valgrind_p
;
63 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
64 Doable only if GC_MARK_STACK. */
66 # undef GC_CHECK_MARKED_OBJECTS
69 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
70 memory. Can do this only if using gmalloc.c and if not checking
73 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
74 || defined GC_CHECK_MARKED_OBJECTS)
75 #undef GC_MALLOC_CHECK
86 #include "w32heap.h" /* for sbrk */
89 #ifdef DOUG_LEA_MALLOC
93 /* Specify maximum number of areas to mmap. It would be nice to use a
94 value that explicitly means "no limit". */
96 #define MMAP_MAX_AREAS 100000000
98 #endif /* not DOUG_LEA_MALLOC */
100 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
101 to a struct Lisp_String. */
103 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
104 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
105 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
107 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
108 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
109 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
111 /* Default value of gc_cons_threshold (see below). */
113 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
115 /* Global variables. */
116 struct emacs_globals globals
;
118 /* Number of bytes of consing done since the last gc. */
120 EMACS_INT consing_since_gc
;
122 /* Similar minimum, computed from Vgc_cons_percentage. */
124 EMACS_INT gc_relative_threshold
;
126 /* Minimum number of bytes of consing since GC before next GC,
127 when memory is full. */
129 EMACS_INT memory_full_cons_threshold
;
131 /* True during GC. */
135 /* True means abort if try to GC.
136 This is for code which is written on the assumption that
137 no GC will happen, so as to verify that assumption. */
141 /* Number of live and free conses etc. */
143 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
144 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
145 static EMACS_INT total_free_floats
, total_floats
;
147 /* Points to memory space allocated as "spare", to be freed if we run
148 out of memory. We keep one large block, four cons-blocks, and
149 two string blocks. */
151 static char *spare_memory
[7];
153 /* Amount of spare memory to keep in large reserve block, or to see
154 whether this much is available when malloc fails on a larger request. */
156 #define SPARE_MEMORY (1 << 14)
158 /* Initialize it to a nonzero value to force it into data space
159 (rather than bss space). That way unexec will remap it into text
160 space (pure), on some systems. We have not implemented the
161 remapping on more recent systems because this is less important
162 nowadays than in the days of small memories and timesharing. */
164 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
165 #define PUREBEG (char *) pure
167 /* Pointer to the pure area, and its size. */
169 static char *purebeg
;
170 static ptrdiff_t pure_size
;
172 /* Number of bytes of pure storage used before pure storage overflowed.
173 If this is non-zero, this implies that an overflow occurred. */
175 static ptrdiff_t pure_bytes_used_before_overflow
;
177 /* True if P points into pure space. */
179 #define PURE_POINTER_P(P) \
180 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
182 /* Index in pure at which next pure Lisp object will be allocated.. */
184 static ptrdiff_t pure_bytes_used_lisp
;
186 /* Number of bytes allocated for non-Lisp objects in pure storage. */
188 static ptrdiff_t pure_bytes_used_non_lisp
;
190 /* If nonzero, this is a warning delivered by malloc and not yet
193 const char *pending_malloc_warning
;
195 /* Maximum amount of C stack to save when a GC happens. */
197 #ifndef MAX_SAVE_STACK
198 #define MAX_SAVE_STACK 16000
201 /* Buffer in which we save a copy of the C stack at each GC. */
203 #if MAX_SAVE_STACK > 0
204 static char *stack_copy
;
205 static ptrdiff_t stack_copy_size
;
208 static Lisp_Object Qconses
;
209 static Lisp_Object Qsymbols
;
210 static Lisp_Object Qmiscs
;
211 static Lisp_Object Qstrings
;
212 static Lisp_Object Qvectors
;
213 static Lisp_Object Qfloats
;
214 static Lisp_Object Qintervals
;
215 static Lisp_Object Qbuffers
;
216 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
217 static Lisp_Object Qgc_cons_threshold
;
218 Lisp_Object Qautomatic_gc
;
219 Lisp_Object Qchar_table_extra_slots
;
221 /* Hook run after GC has finished. */
223 static Lisp_Object Qpost_gc_hook
;
225 static void mark_terminals (void);
226 static void gc_sweep (void);
227 static Lisp_Object
make_pure_vector (ptrdiff_t);
228 static void mark_buffer (struct buffer
*);
230 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
231 static void refill_memory_reserve (void);
233 static void compact_small_strings (void);
234 static void free_large_strings (void);
235 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
237 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
238 what memory allocated via lisp_malloc and lisp_align_malloc is intended
239 for what purpose. This enumeration specifies the type of memory. */
250 /* Since all non-bool pseudovectors are small enough to be
251 allocated from vector blocks, this memory type denotes
252 large regular vectors and large bool pseudovectors. */
254 /* Special type to denote vector blocks. */
255 MEM_TYPE_VECTOR_BLOCK
,
256 /* Special type to denote reserved memory. */
260 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
262 /* A unique object in pure space used to make some Lisp objects
263 on free lists recognizable in O(1). */
265 static Lisp_Object Vdead
;
266 #define DEADP(x) EQ (x, Vdead)
268 #ifdef GC_MALLOC_CHECK
270 enum mem_type allocated_mem_type
;
272 #endif /* GC_MALLOC_CHECK */
274 /* A node in the red-black tree describing allocated memory containing
275 Lisp data. Each such block is recorded with its start and end
276 address when it is allocated, and removed from the tree when it
279 A red-black tree is a balanced binary tree with the following
282 1. Every node is either red or black.
283 2. Every leaf is black.
284 3. If a node is red, then both of its children are black.
285 4. Every simple path from a node to a descendant leaf contains
286 the same number of black nodes.
287 5. The root is always black.
289 When nodes are inserted into the tree, or deleted from the tree,
290 the tree is "fixed" so that these properties are always true.
292 A red-black tree with N internal nodes has height at most 2
293 log(N+1). Searches, insertions and deletions are done in O(log N).
294 Please see a text book about data structures for a detailed
295 description of red-black trees. Any book worth its salt should
300 /* Children of this node. These pointers are never NULL. When there
301 is no child, the value is MEM_NIL, which points to a dummy node. */
302 struct mem_node
*left
, *right
;
304 /* The parent of this node. In the root node, this is NULL. */
305 struct mem_node
*parent
;
307 /* Start and end of allocated region. */
311 enum {MEM_BLACK
, MEM_RED
} color
;
317 /* Base address of stack. Set in main. */
319 Lisp_Object
*stack_base
;
321 /* Root of the tree describing allocated Lisp memory. */
323 static struct mem_node
*mem_root
;
325 /* Lowest and highest known address in the heap. */
327 static void *min_heap_address
, *max_heap_address
;
329 /* Sentinel node of the tree. */
331 static struct mem_node mem_z
;
332 #define MEM_NIL &mem_z
334 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
335 static void mem_insert_fixup (struct mem_node
*);
336 static void mem_rotate_left (struct mem_node
*);
337 static void mem_rotate_right (struct mem_node
*);
338 static void mem_delete (struct mem_node
*);
339 static void mem_delete_fixup (struct mem_node
*);
340 static struct mem_node
*mem_find (void *);
342 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
348 /* Recording what needs to be marked for gc. */
350 struct gcpro
*gcprolist
;
352 /* Addresses of staticpro'd variables. Initialize it to a nonzero
353 value; otherwise some compilers put it into BSS. */
355 enum { NSTATICS
= 2048 };
356 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
358 /* Index of next unused slot in staticvec. */
360 static int staticidx
;
362 static void *pure_alloc (size_t, int);
365 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
366 ALIGNMENT must be a power of 2. */
368 #define ALIGN(ptr, ALIGNMENT) \
369 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
370 & ~ ((ALIGNMENT) - 1)))
373 XFLOAT_INIT (Lisp_Object f
, double n
)
375 XFLOAT (f
)->u
.data
= n
;
379 /************************************************************************
381 ************************************************************************/
383 /* Function malloc calls this if it finds we are near exhausting storage. */
386 malloc_warning (const char *str
)
388 pending_malloc_warning
= str
;
392 /* Display an already-pending malloc warning. */
395 display_malloc_warning (void)
397 call3 (intern ("display-warning"),
399 build_string (pending_malloc_warning
),
400 intern ("emergency"));
401 pending_malloc_warning
= 0;
404 /* Called if we can't allocate relocatable space for a buffer. */
407 buffer_memory_full (ptrdiff_t nbytes
)
409 /* If buffers use the relocating allocator, no need to free
410 spare_memory, because we may have plenty of malloc space left
411 that we could get, and if we don't, the malloc that fails will
412 itself cause spare_memory to be freed. If buffers don't use the
413 relocating allocator, treat this like any other failing
417 memory_full (nbytes
);
419 /* This used to call error, but if we've run out of memory, we could
420 get infinite recursion trying to build the string. */
421 xsignal (Qnil
, Vmemory_signal_data
);
425 /* A common multiple of the positive integers A and B. Ideally this
426 would be the least common multiple, but there's no way to do that
427 as a constant expression in C, so do the best that we can easily do. */
428 #define COMMON_MULTIPLE(a, b) \
429 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
431 #ifndef XMALLOC_OVERRUN_CHECK
432 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
435 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
438 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
439 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
440 block size in little-endian order. The trailer consists of
441 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
443 The header is used to detect whether this block has been allocated
444 through these functions, as some low-level libc functions may
445 bypass the malloc hooks. */
447 #define XMALLOC_OVERRUN_CHECK_SIZE 16
448 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
449 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
451 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
452 hold a size_t value and (2) the header size is a multiple of the
453 alignment that Emacs needs for C types and for USE_LSB_TAG. */
454 #define XMALLOC_BASE_ALIGNMENT \
455 alignof (union { long double d; intmax_t i; void *p; })
458 # define XMALLOC_HEADER_ALIGNMENT \
459 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
461 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
463 #define XMALLOC_OVERRUN_SIZE_SIZE \
464 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
465 + XMALLOC_HEADER_ALIGNMENT - 1) \
466 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
467 - XMALLOC_OVERRUN_CHECK_SIZE)
469 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
470 { '\x9a', '\x9b', '\xae', '\xaf',
471 '\xbf', '\xbe', '\xce', '\xcf',
472 '\xea', '\xeb', '\xec', '\xed',
473 '\xdf', '\xde', '\x9c', '\x9d' };
475 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
476 { '\xaa', '\xab', '\xac', '\xad',
477 '\xba', '\xbb', '\xbc', '\xbd',
478 '\xca', '\xcb', '\xcc', '\xcd',
479 '\xda', '\xdb', '\xdc', '\xdd' };
481 /* Insert and extract the block size in the header. */
484 xmalloc_put_size (unsigned char *ptr
, size_t size
)
487 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
489 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
495 xmalloc_get_size (unsigned char *ptr
)
499 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
500 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
509 /* Like malloc, but wraps allocated block with header and trailer. */
512 overrun_check_malloc (size_t size
)
514 register unsigned char *val
;
515 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
518 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
521 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
522 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
523 xmalloc_put_size (val
, size
);
524 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
525 XMALLOC_OVERRUN_CHECK_SIZE
);
531 /* Like realloc, but checks old block for overrun, and wraps new block
532 with header and trailer. */
535 overrun_check_realloc (void *block
, size_t size
)
537 register unsigned char *val
= (unsigned char *) block
;
538 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
542 && memcmp (xmalloc_overrun_check_header
,
543 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
544 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
546 size_t osize
= xmalloc_get_size (val
);
547 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
548 XMALLOC_OVERRUN_CHECK_SIZE
))
550 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
551 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
552 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
555 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
559 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
560 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
561 xmalloc_put_size (val
, size
);
562 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
563 XMALLOC_OVERRUN_CHECK_SIZE
);
568 /* Like free, but checks block for overrun. */
571 overrun_check_free (void *block
)
573 unsigned char *val
= (unsigned char *) block
;
576 && memcmp (xmalloc_overrun_check_header
,
577 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
578 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
580 size_t osize
= xmalloc_get_size (val
);
581 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
582 XMALLOC_OVERRUN_CHECK_SIZE
))
584 #ifdef XMALLOC_CLEAR_FREE_MEMORY
585 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
586 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
588 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
589 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
590 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
600 #define malloc overrun_check_malloc
601 #define realloc overrun_check_realloc
602 #define free overrun_check_free
605 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
606 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
607 If that variable is set, block input while in one of Emacs's memory
608 allocation functions. There should be no need for this debugging
609 option, since signal handlers do not allocate memory, but Emacs
610 formerly allocated memory in signal handlers and this compile-time
611 option remains as a way to help debug the issue should it rear its
613 #ifdef XMALLOC_BLOCK_INPUT_CHECK
614 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
616 malloc_block_input (void)
618 if (block_input_in_memory_allocators
)
622 malloc_unblock_input (void)
624 if (block_input_in_memory_allocators
)
627 # define MALLOC_BLOCK_INPUT malloc_block_input ()
628 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
630 # define MALLOC_BLOCK_INPUT ((void) 0)
631 # define MALLOC_UNBLOCK_INPUT ((void) 0)
634 #define MALLOC_PROBE(size) \
636 if (profiler_memory_running) \
637 malloc_probe (size); \
641 /* Like malloc but check for no memory and block interrupt input.. */
644 xmalloc (size_t size
)
650 MALLOC_UNBLOCK_INPUT
;
658 /* Like the above, but zeroes out the memory just allocated. */
661 xzalloc (size_t size
)
667 MALLOC_UNBLOCK_INPUT
;
671 memset (val
, 0, size
);
676 /* Like realloc but check for no memory and block interrupt input.. */
679 xrealloc (void *block
, size_t size
)
684 /* We must call malloc explicitly when BLOCK is 0, since some
685 reallocs don't do this. */
689 val
= realloc (block
, size
);
690 MALLOC_UNBLOCK_INPUT
;
699 /* Like free but block interrupt input. */
708 MALLOC_UNBLOCK_INPUT
;
709 /* We don't call refill_memory_reserve here
710 because in practice the call in r_alloc_free seems to suffice. */
714 /* Other parts of Emacs pass large int values to allocator functions
715 expecting ptrdiff_t. This is portable in practice, but check it to
717 verify (INT_MAX
<= PTRDIFF_MAX
);
720 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
721 Signal an error on memory exhaustion, and block interrupt input. */
724 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
726 eassert (0 <= nitems
&& 0 < item_size
);
727 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
728 memory_full (SIZE_MAX
);
729 return xmalloc (nitems
* item_size
);
733 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
734 Signal an error on memory exhaustion, and block interrupt input. */
737 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
739 eassert (0 <= nitems
&& 0 < item_size
);
740 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
741 memory_full (SIZE_MAX
);
742 return xrealloc (pa
, nitems
* item_size
);
746 /* Grow PA, which points to an array of *NITEMS items, and return the
747 location of the reallocated array, updating *NITEMS to reflect its
748 new size. The new array will contain at least NITEMS_INCR_MIN more
749 items, but will not contain more than NITEMS_MAX items total.
750 ITEM_SIZE is the size of each item, in bytes.
752 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
753 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
756 If PA is null, then allocate a new array instead of reallocating
759 Block interrupt input as needed. If memory exhaustion occurs, set
760 *NITEMS to zero if PA is null, and signal an error (i.e., do not
763 Thus, to grow an array A without saving its old contents, do
764 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
765 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
766 and signals an error, and later this code is reexecuted and
767 attempts to free A. */
770 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
771 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
773 /* The approximate size to use for initial small allocation
774 requests. This is the largest "small" request for the GNU C
776 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
778 /* If the array is tiny, grow it to about (but no greater than)
779 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
780 ptrdiff_t n
= *nitems
;
781 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
782 ptrdiff_t half_again
= n
>> 1;
783 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
785 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
786 NITEMS_MAX, and what the C language can represent safely. */
787 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
788 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
789 ? nitems_max
: C_language_max
);
790 ptrdiff_t nitems_incr_max
= n_max
- n
;
791 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
793 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
796 if (nitems_incr_max
< incr
)
797 memory_full (SIZE_MAX
);
799 pa
= xrealloc (pa
, n
* item_size
);
805 /* Like strdup, but uses xmalloc. */
808 xstrdup (const char *s
)
812 size
= strlen (s
) + 1;
813 return memcpy (xmalloc (size
), s
, size
);
816 /* Like above, but duplicates Lisp string to C string. */
819 xlispstrdup (Lisp_Object string
)
821 ptrdiff_t size
= SBYTES (string
) + 1;
822 return memcpy (xmalloc (size
), SSDATA (string
), size
);
825 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
826 argument is a const pointer. */
829 xputenv (char const *string
)
831 if (putenv ((char *) string
) != 0)
835 /* Return a newly allocated memory block of SIZE bytes, remembering
836 to free it when unwinding. */
838 record_xmalloc (size_t size
)
840 void *p
= xmalloc (size
);
841 record_unwind_protect_ptr (xfree
, p
);
846 /* Like malloc but used for allocating Lisp data. NBYTES is the
847 number of bytes to allocate, TYPE describes the intended use of the
848 allocated memory block (for strings, for conses, ...). */
851 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
855 lisp_malloc (size_t nbytes
, enum mem_type type
)
861 #ifdef GC_MALLOC_CHECK
862 allocated_mem_type
= type
;
865 val
= malloc (nbytes
);
868 /* If the memory just allocated cannot be addressed thru a Lisp
869 object's pointer, and it needs to be,
870 that's equivalent to running out of memory. */
871 if (val
&& type
!= MEM_TYPE_NON_LISP
)
874 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
875 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
877 lisp_malloc_loser
= val
;
884 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
885 if (val
&& type
!= MEM_TYPE_NON_LISP
)
886 mem_insert (val
, (char *) val
+ nbytes
, type
);
889 MALLOC_UNBLOCK_INPUT
;
891 memory_full (nbytes
);
892 MALLOC_PROBE (nbytes
);
896 /* Free BLOCK. This must be called to free memory allocated with a
897 call to lisp_malloc. */
900 lisp_free (void *block
)
904 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
905 mem_delete (mem_find (block
));
907 MALLOC_UNBLOCK_INPUT
;
910 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
912 /* The entry point is lisp_align_malloc which returns blocks of at most
913 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
915 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
916 #define USE_POSIX_MEMALIGN 1
919 /* BLOCK_ALIGN has to be a power of 2. */
920 #define BLOCK_ALIGN (1 << 10)
922 /* Padding to leave at the end of a malloc'd block. This is to give
923 malloc a chance to minimize the amount of memory wasted to alignment.
924 It should be tuned to the particular malloc library used.
925 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
926 posix_memalign on the other hand would ideally prefer a value of 4
927 because otherwise, there's 1020 bytes wasted between each ablocks.
928 In Emacs, testing shows that those 1020 can most of the time be
929 efficiently used by malloc to place other objects, so a value of 0 can
930 still preferable unless you have a lot of aligned blocks and virtually
932 #define BLOCK_PADDING 0
933 #define BLOCK_BYTES \
934 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
936 /* Internal data structures and constants. */
938 #define ABLOCKS_SIZE 16
940 /* An aligned block of memory. */
945 char payload
[BLOCK_BYTES
];
946 struct ablock
*next_free
;
948 /* `abase' is the aligned base of the ablocks. */
949 /* It is overloaded to hold the virtual `busy' field that counts
950 the number of used ablock in the parent ablocks.
951 The first ablock has the `busy' field, the others have the `abase'
952 field. To tell the difference, we assume that pointers will have
953 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
954 is used to tell whether the real base of the parent ablocks is `abase'
955 (if not, the word before the first ablock holds a pointer to the
957 struct ablocks
*abase
;
958 /* The padding of all but the last ablock is unused. The padding of
959 the last ablock in an ablocks is not allocated. */
961 char padding
[BLOCK_PADDING
];
965 /* A bunch of consecutive aligned blocks. */
968 struct ablock blocks
[ABLOCKS_SIZE
];
971 /* Size of the block requested from malloc or posix_memalign. */
972 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
974 #define ABLOCK_ABASE(block) \
975 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
976 ? (struct ablocks *)(block) \
979 /* Virtual `busy' field. */
980 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
982 /* Pointer to the (not necessarily aligned) malloc block. */
983 #ifdef USE_POSIX_MEMALIGN
984 #define ABLOCKS_BASE(abase) (abase)
986 #define ABLOCKS_BASE(abase) \
987 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
990 /* The list of free ablock. */
991 static struct ablock
*free_ablock
;
993 /* Allocate an aligned block of nbytes.
994 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
995 smaller or equal to BLOCK_BYTES. */
997 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1000 struct ablocks
*abase
;
1002 eassert (nbytes
<= BLOCK_BYTES
);
1006 #ifdef GC_MALLOC_CHECK
1007 allocated_mem_type
= type
;
1013 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1015 #ifdef DOUG_LEA_MALLOC
1016 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1017 because mapped region contents are not preserved in
1019 mallopt (M_MMAP_MAX
, 0);
1022 #ifdef USE_POSIX_MEMALIGN
1024 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1030 base
= malloc (ABLOCKS_BYTES
);
1031 abase
= ALIGN (base
, BLOCK_ALIGN
);
1036 MALLOC_UNBLOCK_INPUT
;
1037 memory_full (ABLOCKS_BYTES
);
1040 aligned
= (base
== abase
);
1042 ((void **) abase
)[-1] = base
;
1044 #ifdef DOUG_LEA_MALLOC
1045 /* Back to a reasonable maximum of mmap'ed areas. */
1046 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1050 /* If the memory just allocated cannot be addressed thru a Lisp
1051 object's pointer, and it needs to be, that's equivalent to
1052 running out of memory. */
1053 if (type
!= MEM_TYPE_NON_LISP
)
1056 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1057 XSETCONS (tem
, end
);
1058 if ((char *) XCONS (tem
) != end
)
1060 lisp_malloc_loser
= base
;
1062 MALLOC_UNBLOCK_INPUT
;
1063 memory_full (SIZE_MAX
);
1068 /* Initialize the blocks and put them on the free list.
1069 If `base' was not properly aligned, we can't use the last block. */
1070 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1072 abase
->blocks
[i
].abase
= abase
;
1073 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1074 free_ablock
= &abase
->blocks
[i
];
1076 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1078 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1079 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1080 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1081 eassert (ABLOCKS_BASE (abase
) == base
);
1082 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1085 abase
= ABLOCK_ABASE (free_ablock
);
1086 ABLOCKS_BUSY (abase
) =
1087 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1089 free_ablock
= free_ablock
->x
.next_free
;
1091 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1092 if (type
!= MEM_TYPE_NON_LISP
)
1093 mem_insert (val
, (char *) val
+ nbytes
, type
);
1096 MALLOC_UNBLOCK_INPUT
;
1098 MALLOC_PROBE (nbytes
);
1100 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1105 lisp_align_free (void *block
)
1107 struct ablock
*ablock
= block
;
1108 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1111 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1112 mem_delete (mem_find (block
));
1114 /* Put on free list. */
1115 ablock
->x
.next_free
= free_ablock
;
1116 free_ablock
= ablock
;
1117 /* Update busy count. */
1118 ABLOCKS_BUSY (abase
)
1119 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1121 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1122 { /* All the blocks are free. */
1123 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1124 struct ablock
**tem
= &free_ablock
;
1125 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1129 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1132 *tem
= (*tem
)->x
.next_free
;
1135 tem
= &(*tem
)->x
.next_free
;
1137 eassert ((aligned
& 1) == aligned
);
1138 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1139 #ifdef USE_POSIX_MEMALIGN
1140 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1142 free (ABLOCKS_BASE (abase
));
1144 MALLOC_UNBLOCK_INPUT
;
1148 /***********************************************************************
1150 ***********************************************************************/
1152 /* Number of intervals allocated in an interval_block structure.
1153 The 1020 is 1024 minus malloc overhead. */
1155 #define INTERVAL_BLOCK_SIZE \
1156 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1158 /* Intervals are allocated in chunks in the form of an interval_block
1161 struct interval_block
1163 /* Place `intervals' first, to preserve alignment. */
1164 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1165 struct interval_block
*next
;
1168 /* Current interval block. Its `next' pointer points to older
1171 static struct interval_block
*interval_block
;
1173 /* Index in interval_block above of the next unused interval
1176 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1178 /* Number of free and live intervals. */
1180 static EMACS_INT total_free_intervals
, total_intervals
;
1182 /* List of free intervals. */
1184 static INTERVAL interval_free_list
;
1186 /* Return a new interval. */
1189 make_interval (void)
1195 if (interval_free_list
)
1197 val
= interval_free_list
;
1198 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1202 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1204 struct interval_block
*newi
1205 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1207 newi
->next
= interval_block
;
1208 interval_block
= newi
;
1209 interval_block_index
= 0;
1210 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1212 val
= &interval_block
->intervals
[interval_block_index
++];
1215 MALLOC_UNBLOCK_INPUT
;
1217 consing_since_gc
+= sizeof (struct interval
);
1219 total_free_intervals
--;
1220 RESET_INTERVAL (val
);
1226 /* Mark Lisp objects in interval I. */
1229 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1231 /* Intervals should never be shared. So, if extra internal checking is
1232 enabled, GC aborts if it seems to have visited an interval twice. */
1233 eassert (!i
->gcmarkbit
);
1235 mark_object (i
->plist
);
1238 /* Mark the interval tree rooted in I. */
1240 #define MARK_INTERVAL_TREE(i) \
1242 if (i && !i->gcmarkbit) \
1243 traverse_intervals_noorder (i, mark_interval, Qnil); \
1246 /***********************************************************************
1248 ***********************************************************************/
1250 /* Lisp_Strings are allocated in string_block structures. When a new
1251 string_block is allocated, all the Lisp_Strings it contains are
1252 added to a free-list string_free_list. When a new Lisp_String is
1253 needed, it is taken from that list. During the sweep phase of GC,
1254 string_blocks that are entirely free are freed, except two which
1257 String data is allocated from sblock structures. Strings larger
1258 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1259 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1261 Sblocks consist internally of sdata structures, one for each
1262 Lisp_String. The sdata structure points to the Lisp_String it
1263 belongs to. The Lisp_String points back to the `u.data' member of
1264 its sdata structure.
1266 When a Lisp_String is freed during GC, it is put back on
1267 string_free_list, and its `data' member and its sdata's `string'
1268 pointer is set to null. The size of the string is recorded in the
1269 `n.nbytes' member of the sdata. So, sdata structures that are no
1270 longer used, can be easily recognized, and it's easy to compact the
1271 sblocks of small strings which we do in compact_small_strings. */
1273 /* Size in bytes of an sblock structure used for small strings. This
1274 is 8192 minus malloc overhead. */
1276 #define SBLOCK_SIZE 8188
1278 /* Strings larger than this are considered large strings. String data
1279 for large strings is allocated from individual sblocks. */
1281 #define LARGE_STRING_BYTES 1024
1283 /* Struct or union describing string memory sub-allocated from an sblock.
1284 This is where the contents of Lisp strings are stored. */
1286 #ifdef GC_CHECK_STRING_BYTES
1290 /* Back-pointer to the string this sdata belongs to. If null, this
1291 structure is free, and the NBYTES member of the union below
1292 contains the string's byte size (the same value that STRING_BYTES
1293 would return if STRING were non-null). If non-null, STRING_BYTES
1294 (STRING) is the size of the data, and DATA contains the string's
1296 struct Lisp_String
*string
;
1299 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1302 #define SDATA_NBYTES(S) (S)->nbytes
1303 #define SDATA_DATA(S) (S)->data
1304 #define SDATA_SELECTOR(member) member
1310 struct Lisp_String
*string
;
1312 /* When STRING is non-null. */
1315 struct Lisp_String
*string
;
1316 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1319 /* When STRING is null. */
1322 struct Lisp_String
*string
;
1327 #define SDATA_NBYTES(S) (S)->n.nbytes
1328 #define SDATA_DATA(S) (S)->u.data
1329 #define SDATA_SELECTOR(member) u.member
1331 #endif /* not GC_CHECK_STRING_BYTES */
1333 #define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1336 /* Structure describing a block of memory which is sub-allocated to
1337 obtain string data memory for strings. Blocks for small strings
1338 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1339 as large as needed. */
1344 struct sblock
*next
;
1346 /* Pointer to the next free sdata block. This points past the end
1347 of the sblock if there isn't any space left in this block. */
1350 /* Start of data. */
1354 /* Number of Lisp strings in a string_block structure. The 1020 is
1355 1024 minus malloc overhead. */
1357 #define STRING_BLOCK_SIZE \
1358 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1360 /* Structure describing a block from which Lisp_String structures
1365 /* Place `strings' first, to preserve alignment. */
1366 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1367 struct string_block
*next
;
1370 /* Head and tail of the list of sblock structures holding Lisp string
1371 data. We always allocate from current_sblock. The NEXT pointers
1372 in the sblock structures go from oldest_sblock to current_sblock. */
1374 static struct sblock
*oldest_sblock
, *current_sblock
;
1376 /* List of sblocks for large strings. */
1378 static struct sblock
*large_sblocks
;
1380 /* List of string_block structures. */
1382 static struct string_block
*string_blocks
;
1384 /* Free-list of Lisp_Strings. */
1386 static struct Lisp_String
*string_free_list
;
1388 /* Number of live and free Lisp_Strings. */
1390 static EMACS_INT total_strings
, total_free_strings
;
1392 /* Number of bytes used by live strings. */
1394 static EMACS_INT total_string_bytes
;
1396 /* Given a pointer to a Lisp_String S which is on the free-list
1397 string_free_list, return a pointer to its successor in the
1400 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1402 /* Return a pointer to the sdata structure belonging to Lisp string S.
1403 S must be live, i.e. S->data must not be null. S->data is actually
1404 a pointer to the `u.data' member of its sdata structure; the
1405 structure starts at a constant offset in front of that. */
1407 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1410 #ifdef GC_CHECK_STRING_OVERRUN
1412 /* We check for overrun in string data blocks by appending a small
1413 "cookie" after each allocated string data block, and check for the
1414 presence of this cookie during GC. */
1416 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1417 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1418 { '\xde', '\xad', '\xbe', '\xef' };
1421 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1424 /* Value is the size of an sdata structure large enough to hold NBYTES
1425 bytes of string data. The value returned includes a terminating
1426 NUL byte, the size of the sdata structure, and padding. */
1428 #ifdef GC_CHECK_STRING_BYTES
1430 #define SDATA_SIZE(NBYTES) \
1431 ((SDATA_DATA_OFFSET \
1433 + sizeof (ptrdiff_t) - 1) \
1434 & ~(sizeof (ptrdiff_t) - 1))
1436 #else /* not GC_CHECK_STRING_BYTES */
1438 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1439 less than the size of that member. The 'max' is not needed when
1440 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1441 alignment code reserves enough space. */
1443 #define SDATA_SIZE(NBYTES) \
1444 ((SDATA_DATA_OFFSET \
1445 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1447 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1449 + sizeof (ptrdiff_t) - 1) \
1450 & ~(sizeof (ptrdiff_t) - 1))
1452 #endif /* not GC_CHECK_STRING_BYTES */
1454 /* Extra bytes to allocate for each string. */
1456 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1458 /* Exact bound on the number of bytes in a string, not counting the
1459 terminating null. A string cannot contain more bytes than
1460 STRING_BYTES_BOUND, nor can it be so long that the size_t
1461 arithmetic in allocate_string_data would overflow while it is
1462 calculating a value to be passed to malloc. */
1463 static ptrdiff_t const STRING_BYTES_MAX
=
1464 min (STRING_BYTES_BOUND
,
1465 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1467 - offsetof (struct sblock
, first_data
)
1468 - SDATA_DATA_OFFSET
)
1469 & ~(sizeof (EMACS_INT
) - 1)));
1471 /* Initialize string allocation. Called from init_alloc_once. */
1476 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1477 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1481 #ifdef GC_CHECK_STRING_BYTES
1483 static int check_string_bytes_count
;
1485 /* Like STRING_BYTES, but with debugging check. Can be
1486 called during GC, so pay attention to the mark bit. */
1489 string_bytes (struct Lisp_String
*s
)
1492 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1494 if (!PURE_POINTER_P (s
)
1496 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1501 /* Check validity of Lisp strings' string_bytes member in B. */
1504 check_sblock (struct sblock
*b
)
1506 sdata
*from
, *end
, *from_end
;
1510 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1512 /* Compute the next FROM here because copying below may
1513 overwrite data we need to compute it. */
1516 /* Check that the string size recorded in the string is the
1517 same as the one recorded in the sdata structure. */
1518 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1519 : SDATA_NBYTES (from
));
1520 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1525 /* Check validity of Lisp strings' string_bytes member. ALL_P
1526 means check all strings, otherwise check only most
1527 recently allocated strings. Used for hunting a bug. */
1530 check_string_bytes (bool all_p
)
1536 for (b
= large_sblocks
; b
; b
= b
->next
)
1538 struct Lisp_String
*s
= b
->first_data
.string
;
1543 for (b
= oldest_sblock
; b
; b
= b
->next
)
1546 else if (current_sblock
)
1547 check_sblock (current_sblock
);
1550 #else /* not GC_CHECK_STRING_BYTES */
1552 #define check_string_bytes(all) ((void) 0)
1554 #endif /* GC_CHECK_STRING_BYTES */
1556 #ifdef GC_CHECK_STRING_FREE_LIST
1558 /* Walk through the string free list looking for bogus next pointers.
1559 This may catch buffer overrun from a previous string. */
1562 check_string_free_list (void)
1564 struct Lisp_String
*s
;
1566 /* Pop a Lisp_String off the free-list. */
1567 s
= string_free_list
;
1570 if ((uintptr_t) s
< 1024)
1572 s
= NEXT_FREE_LISP_STRING (s
);
1576 #define check_string_free_list()
1579 /* Return a new Lisp_String. */
1581 static struct Lisp_String
*
1582 allocate_string (void)
1584 struct Lisp_String
*s
;
1588 /* If the free-list is empty, allocate a new string_block, and
1589 add all the Lisp_Strings in it to the free-list. */
1590 if (string_free_list
== NULL
)
1592 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1595 b
->next
= string_blocks
;
1598 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1601 /* Every string on a free list should have NULL data pointer. */
1603 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1604 string_free_list
= s
;
1607 total_free_strings
+= STRING_BLOCK_SIZE
;
1610 check_string_free_list ();
1612 /* Pop a Lisp_String off the free-list. */
1613 s
= string_free_list
;
1614 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1616 MALLOC_UNBLOCK_INPUT
;
1618 --total_free_strings
;
1621 consing_since_gc
+= sizeof *s
;
1623 #ifdef GC_CHECK_STRING_BYTES
1624 if (!noninteractive
)
1626 if (++check_string_bytes_count
== 200)
1628 check_string_bytes_count
= 0;
1629 check_string_bytes (1);
1632 check_string_bytes (0);
1634 #endif /* GC_CHECK_STRING_BYTES */
1640 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1641 plus a NUL byte at the end. Allocate an sdata structure for S, and
1642 set S->data to its `u.data' member. Store a NUL byte at the end of
1643 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1644 S->data if it was initially non-null. */
1647 allocate_string_data (struct Lisp_String
*s
,
1648 EMACS_INT nchars
, EMACS_INT nbytes
)
1650 sdata
*data
, *old_data
;
1652 ptrdiff_t needed
, old_nbytes
;
1654 if (STRING_BYTES_MAX
< nbytes
)
1657 /* Determine the number of bytes needed to store NBYTES bytes
1659 needed
= SDATA_SIZE (nbytes
);
1662 old_data
= SDATA_OF_STRING (s
);
1663 old_nbytes
= STRING_BYTES (s
);
1670 if (nbytes
> LARGE_STRING_BYTES
)
1672 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1674 #ifdef DOUG_LEA_MALLOC
1675 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1676 because mapped region contents are not preserved in
1679 In case you think of allowing it in a dumped Emacs at the
1680 cost of not being able to re-dump, there's another reason:
1681 mmap'ed data typically have an address towards the top of the
1682 address space, which won't fit into an EMACS_INT (at least on
1683 32-bit systems with the current tagging scheme). --fx */
1684 mallopt (M_MMAP_MAX
, 0);
1687 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1689 #ifdef DOUG_LEA_MALLOC
1690 /* Back to a reasonable maximum of mmap'ed areas. */
1691 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1694 b
->next_free
= &b
->first_data
;
1695 b
->first_data
.string
= NULL
;
1696 b
->next
= large_sblocks
;
1699 else if (current_sblock
== NULL
1700 || (((char *) current_sblock
+ SBLOCK_SIZE
1701 - (char *) current_sblock
->next_free
)
1702 < (needed
+ GC_STRING_EXTRA
)))
1704 /* Not enough room in the current sblock. */
1705 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1706 b
->next_free
= &b
->first_data
;
1707 b
->first_data
.string
= NULL
;
1711 current_sblock
->next
= b
;
1719 data
= b
->next_free
;
1720 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1722 MALLOC_UNBLOCK_INPUT
;
1725 s
->data
= SDATA_DATA (data
);
1726 #ifdef GC_CHECK_STRING_BYTES
1727 SDATA_NBYTES (data
) = nbytes
;
1730 s
->size_byte
= nbytes
;
1731 s
->data
[nbytes
] = '\0';
1732 #ifdef GC_CHECK_STRING_OVERRUN
1733 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1734 GC_STRING_OVERRUN_COOKIE_SIZE
);
1737 /* Note that Faset may call to this function when S has already data
1738 assigned. In this case, mark data as free by setting it's string
1739 back-pointer to null, and record the size of the data in it. */
1742 SDATA_NBYTES (old_data
) = old_nbytes
;
1743 old_data
->string
= NULL
;
1746 consing_since_gc
+= needed
;
1750 /* Sweep and compact strings. */
1753 sweep_strings (void)
1755 struct string_block
*b
, *next
;
1756 struct string_block
*live_blocks
= NULL
;
1758 string_free_list
= NULL
;
1759 total_strings
= total_free_strings
= 0;
1760 total_string_bytes
= 0;
1762 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1763 for (b
= string_blocks
; b
; b
= next
)
1766 struct Lisp_String
*free_list_before
= string_free_list
;
1770 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1772 struct Lisp_String
*s
= b
->strings
+ i
;
1776 /* String was not on free-list before. */
1777 if (STRING_MARKED_P (s
))
1779 /* String is live; unmark it and its intervals. */
1782 /* Do not use string_(set|get)_intervals here. */
1783 s
->intervals
= balance_intervals (s
->intervals
);
1786 total_string_bytes
+= STRING_BYTES (s
);
1790 /* String is dead. Put it on the free-list. */
1791 sdata
*data
= SDATA_OF_STRING (s
);
1793 /* Save the size of S in its sdata so that we know
1794 how large that is. Reset the sdata's string
1795 back-pointer so that we know it's free. */
1796 #ifdef GC_CHECK_STRING_BYTES
1797 if (string_bytes (s
) != SDATA_NBYTES (data
))
1800 data
->n
.nbytes
= STRING_BYTES (s
);
1802 data
->string
= NULL
;
1804 /* Reset the strings's `data' member so that we
1808 /* Put the string on the free-list. */
1809 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1810 string_free_list
= s
;
1816 /* S was on the free-list before. Put it there again. */
1817 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1818 string_free_list
= s
;
1823 /* Free blocks that contain free Lisp_Strings only, except
1824 the first two of them. */
1825 if (nfree
== STRING_BLOCK_SIZE
1826 && total_free_strings
> STRING_BLOCK_SIZE
)
1829 string_free_list
= free_list_before
;
1833 total_free_strings
+= nfree
;
1834 b
->next
= live_blocks
;
1839 check_string_free_list ();
1841 string_blocks
= live_blocks
;
1842 free_large_strings ();
1843 compact_small_strings ();
1845 check_string_free_list ();
1849 /* Free dead large strings. */
1852 free_large_strings (void)
1854 struct sblock
*b
, *next
;
1855 struct sblock
*live_blocks
= NULL
;
1857 for (b
= large_sblocks
; b
; b
= next
)
1861 if (b
->first_data
.string
== NULL
)
1865 b
->next
= live_blocks
;
1870 large_sblocks
= live_blocks
;
1874 /* Compact data of small strings. Free sblocks that don't contain
1875 data of live strings after compaction. */
1878 compact_small_strings (void)
1880 struct sblock
*b
, *tb
, *next
;
1881 sdata
*from
, *to
, *end
, *tb_end
;
1882 sdata
*to_end
, *from_end
;
1884 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1885 to, and TB_END is the end of TB. */
1887 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1888 to
= &tb
->first_data
;
1890 /* Step through the blocks from the oldest to the youngest. We
1891 expect that old blocks will stabilize over time, so that less
1892 copying will happen this way. */
1893 for (b
= oldest_sblock
; b
; b
= b
->next
)
1896 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1898 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1900 /* Compute the next FROM here because copying below may
1901 overwrite data we need to compute it. */
1903 struct Lisp_String
*s
= from
->string
;
1905 #ifdef GC_CHECK_STRING_BYTES
1906 /* Check that the string size recorded in the string is the
1907 same as the one recorded in the sdata structure. */
1908 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1910 #endif /* GC_CHECK_STRING_BYTES */
1912 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1913 eassert (nbytes
<= LARGE_STRING_BYTES
);
1915 nbytes
= SDATA_SIZE (nbytes
);
1916 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1918 #ifdef GC_CHECK_STRING_OVERRUN
1919 if (memcmp (string_overrun_cookie
,
1920 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1921 GC_STRING_OVERRUN_COOKIE_SIZE
))
1925 /* Non-NULL S means it's alive. Copy its data. */
1928 /* If TB is full, proceed with the next sblock. */
1929 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1930 if (to_end
> tb_end
)
1934 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1935 to
= &tb
->first_data
;
1936 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1939 /* Copy, and update the string's `data' pointer. */
1942 eassert (tb
!= b
|| to
< from
);
1943 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1944 to
->string
->data
= SDATA_DATA (to
);
1947 /* Advance past the sdata we copied to. */
1953 /* The rest of the sblocks following TB don't contain live data, so
1954 we can free them. */
1955 for (b
= tb
->next
; b
; b
= next
)
1963 current_sblock
= tb
;
1967 string_overflow (void)
1969 error ("Maximum string size exceeded");
1972 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1973 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1974 LENGTH must be an integer.
1975 INIT must be an integer that represents a character. */)
1976 (Lisp_Object length
, Lisp_Object init
)
1978 register Lisp_Object val
;
1982 CHECK_NATNUM (length
);
1983 CHECK_CHARACTER (init
);
1985 c
= XFASTINT (init
);
1986 if (ASCII_CHAR_P (c
))
1988 nbytes
= XINT (length
);
1989 val
= make_uninit_string (nbytes
);
1990 memset (SDATA (val
), c
, nbytes
);
1991 SDATA (val
)[nbytes
] = 0;
1995 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1996 ptrdiff_t len
= CHAR_STRING (c
, str
);
1997 EMACS_INT string_len
= XINT (length
);
1998 unsigned char *p
, *beg
, *end
;
2000 if (string_len
> STRING_BYTES_MAX
/ len
)
2002 nbytes
= len
* string_len
;
2003 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2004 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2006 /* First time we just copy `str' to the data of `val'. */
2008 memcpy (p
, str
, len
);
2011 /* Next time we copy largest possible chunk from
2012 initialized to uninitialized part of `val'. */
2013 len
= min (p
- beg
, end
- p
);
2014 memcpy (p
, beg
, len
);
2023 verify (sizeof (size_t) * CHAR_BIT
== BITS_PER_BITS_WORD
);
2024 verify ((BITS_PER_BITS_WORD
& (BITS_PER_BITS_WORD
- 1)) == 0);
2027 bool_vector_payload_bytes (ptrdiff_t nr_bits
,
2028 ptrdiff_t *exact_needed_bytes_out
)
2030 ptrdiff_t exact_needed_bytes
;
2031 ptrdiff_t needed_bytes
;
2033 eassume (nr_bits
>= 0);
2035 exact_needed_bytes
= ROUNDUP ((size_t) nr_bits
, CHAR_BIT
) / CHAR_BIT
;
2036 needed_bytes
= ROUNDUP ((size_t) nr_bits
, BITS_PER_BITS_WORD
) / CHAR_BIT
;
2038 if (needed_bytes
== 0)
2040 /* Always allocate at least one machine word of payload so that
2041 bool-vector operations in data.c don't need a special case
2042 for empty vectors. */
2043 needed_bytes
= sizeof (bits_word
);
2046 if (exact_needed_bytes_out
!= NULL
)
2047 *exact_needed_bytes_out
= exact_needed_bytes
;
2049 return needed_bytes
;
2052 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2053 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2054 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2055 (Lisp_Object length
, Lisp_Object init
)
2057 register Lisp_Object val
;
2058 struct Lisp_Bool_Vector
*p
;
2059 ptrdiff_t exact_payload_bytes
;
2060 ptrdiff_t total_payload_bytes
;
2061 ptrdiff_t needed_elements
;
2063 CHECK_NATNUM (length
);
2064 if (PTRDIFF_MAX
< XFASTINT (length
))
2065 memory_full (SIZE_MAX
);
2067 total_payload_bytes
= bool_vector_payload_bytes
2068 (XFASTINT (length
), &exact_payload_bytes
);
2070 eassume (exact_payload_bytes
<= total_payload_bytes
);
2071 eassume (0 <= exact_payload_bytes
);
2073 needed_elements
= ROUNDUP ((size_t) ((bool_header_size
- header_size
)
2074 + total_payload_bytes
),
2075 word_size
) / word_size
;
2077 p
= (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2078 XSETVECTOR (val
, p
);
2079 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2081 p
->size
= XFASTINT (length
);
2082 if (exact_payload_bytes
)
2084 memset (p
->data
, ! NILP (init
) ? -1 : 0, exact_payload_bytes
);
2086 /* Clear any extraneous bits in the last byte. */
2087 p
->data
[exact_payload_bytes
- 1]
2088 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2091 /* Clear padding at the end. */
2092 memset (p
->data
+ exact_payload_bytes
,
2094 total_payload_bytes
- exact_payload_bytes
);
2100 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2101 of characters from the contents. This string may be unibyte or
2102 multibyte, depending on the contents. */
2105 make_string (const char *contents
, ptrdiff_t nbytes
)
2107 register Lisp_Object val
;
2108 ptrdiff_t nchars
, multibyte_nbytes
;
2110 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2111 &nchars
, &multibyte_nbytes
);
2112 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2113 /* CONTENTS contains no multibyte sequences or contains an invalid
2114 multibyte sequence. We must make unibyte string. */
2115 val
= make_unibyte_string (contents
, nbytes
);
2117 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2122 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2125 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2127 register Lisp_Object val
;
2128 val
= make_uninit_string (length
);
2129 memcpy (SDATA (val
), contents
, length
);
2134 /* Make a multibyte string from NCHARS characters occupying NBYTES
2135 bytes at CONTENTS. */
2138 make_multibyte_string (const char *contents
,
2139 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2141 register Lisp_Object val
;
2142 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2143 memcpy (SDATA (val
), contents
, nbytes
);
2148 /* Make a string from NCHARS characters occupying NBYTES bytes at
2149 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2152 make_string_from_bytes (const char *contents
,
2153 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2155 register Lisp_Object val
;
2156 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2157 memcpy (SDATA (val
), contents
, nbytes
);
2158 if (SBYTES (val
) == SCHARS (val
))
2159 STRING_SET_UNIBYTE (val
);
2164 /* Make a string from NCHARS characters occupying NBYTES bytes at
2165 CONTENTS. The argument MULTIBYTE controls whether to label the
2166 string as multibyte. If NCHARS is negative, it counts the number of
2167 characters by itself. */
2170 make_specified_string (const char *contents
,
2171 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2178 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2183 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2184 memcpy (SDATA (val
), contents
, nbytes
);
2186 STRING_SET_UNIBYTE (val
);
2191 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2192 occupying LENGTH bytes. */
2195 make_uninit_string (EMACS_INT length
)
2200 return empty_unibyte_string
;
2201 val
= make_uninit_multibyte_string (length
, length
);
2202 STRING_SET_UNIBYTE (val
);
2207 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2208 which occupy NBYTES bytes. */
2211 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2214 struct Lisp_String
*s
;
2219 return empty_multibyte_string
;
2221 s
= allocate_string ();
2222 s
->intervals
= NULL
;
2223 allocate_string_data (s
, nchars
, nbytes
);
2224 XSETSTRING (string
, s
);
2225 string_chars_consed
+= nbytes
;
2229 /* Print arguments to BUF according to a FORMAT, then return
2230 a Lisp_String initialized with the data from BUF. */
2233 make_formatted_string (char *buf
, const char *format
, ...)
2238 va_start (ap
, format
);
2239 length
= vsprintf (buf
, format
, ap
);
2241 return make_string (buf
, length
);
2245 /***********************************************************************
2247 ***********************************************************************/
2249 /* We store float cells inside of float_blocks, allocating a new
2250 float_block with malloc whenever necessary. Float cells reclaimed
2251 by GC are put on a free list to be reallocated before allocating
2252 any new float cells from the latest float_block. */
2254 #define FLOAT_BLOCK_SIZE \
2255 (((BLOCK_BYTES - sizeof (struct float_block *) \
2256 /* The compiler might add padding at the end. */ \
2257 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2258 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2260 #define GETMARKBIT(block,n) \
2261 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2262 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2265 #define SETMARKBIT(block,n) \
2266 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2267 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2269 #define UNSETMARKBIT(block,n) \
2270 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2271 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2273 #define FLOAT_BLOCK(fptr) \
2274 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2276 #define FLOAT_INDEX(fptr) \
2277 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2281 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2282 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2283 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2284 struct float_block
*next
;
2287 #define FLOAT_MARKED_P(fptr) \
2288 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2290 #define FLOAT_MARK(fptr) \
2291 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2293 #define FLOAT_UNMARK(fptr) \
2294 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2296 /* Current float_block. */
2298 static struct float_block
*float_block
;
2300 /* Index of first unused Lisp_Float in the current float_block. */
2302 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2304 /* Free-list of Lisp_Floats. */
2306 static struct Lisp_Float
*float_free_list
;
2308 /* Return a new float object with value FLOAT_VALUE. */
2311 make_float (double float_value
)
2313 register Lisp_Object val
;
2317 if (float_free_list
)
2319 /* We use the data field for chaining the free list
2320 so that we won't use the same field that has the mark bit. */
2321 XSETFLOAT (val
, float_free_list
);
2322 float_free_list
= float_free_list
->u
.chain
;
2326 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2328 struct float_block
*new
2329 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2330 new->next
= float_block
;
2331 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2333 float_block_index
= 0;
2334 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2336 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2337 float_block_index
++;
2340 MALLOC_UNBLOCK_INPUT
;
2342 XFLOAT_INIT (val
, float_value
);
2343 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2344 consing_since_gc
+= sizeof (struct Lisp_Float
);
2346 total_free_floats
--;
2352 /***********************************************************************
2354 ***********************************************************************/
2356 /* We store cons cells inside of cons_blocks, allocating a new
2357 cons_block with malloc whenever necessary. Cons cells reclaimed by
2358 GC are put on a free list to be reallocated before allocating
2359 any new cons cells from the latest cons_block. */
2361 #define CONS_BLOCK_SIZE \
2362 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2363 /* The compiler might add padding at the end. */ \
2364 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2365 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2367 #define CONS_BLOCK(fptr) \
2368 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2370 #define CONS_INDEX(fptr) \
2371 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2375 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2376 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2377 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2378 struct cons_block
*next
;
2381 #define CONS_MARKED_P(fptr) \
2382 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2384 #define CONS_MARK(fptr) \
2385 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2387 #define CONS_UNMARK(fptr) \
2388 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2390 /* Current cons_block. */
2392 static struct cons_block
*cons_block
;
2394 /* Index of first unused Lisp_Cons in the current block. */
2396 static int cons_block_index
= CONS_BLOCK_SIZE
;
2398 /* Free-list of Lisp_Cons structures. */
2400 static struct Lisp_Cons
*cons_free_list
;
2402 /* Explicitly free a cons cell by putting it on the free-list. */
2405 free_cons (struct Lisp_Cons
*ptr
)
2407 ptr
->u
.chain
= cons_free_list
;
2411 cons_free_list
= ptr
;
2412 consing_since_gc
-= sizeof *ptr
;
2413 total_free_conses
++;
2416 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2417 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2418 (Lisp_Object car
, Lisp_Object cdr
)
2420 register Lisp_Object val
;
2426 /* We use the cdr for chaining the free list
2427 so that we won't use the same field that has the mark bit. */
2428 XSETCONS (val
, cons_free_list
);
2429 cons_free_list
= cons_free_list
->u
.chain
;
2433 if (cons_block_index
== CONS_BLOCK_SIZE
)
2435 struct cons_block
*new
2436 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2437 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2438 new->next
= cons_block
;
2440 cons_block_index
= 0;
2441 total_free_conses
+= CONS_BLOCK_SIZE
;
2443 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2447 MALLOC_UNBLOCK_INPUT
;
2451 eassert (!CONS_MARKED_P (XCONS (val
)));
2452 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2453 total_free_conses
--;
2454 cons_cells_consed
++;
2458 #ifdef GC_CHECK_CONS_LIST
2459 /* Get an error now if there's any junk in the cons free list. */
2461 check_cons_list (void)
2463 struct Lisp_Cons
*tail
= cons_free_list
;
2466 tail
= tail
->u
.chain
;
2470 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2473 list1 (Lisp_Object arg1
)
2475 return Fcons (arg1
, Qnil
);
2479 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2481 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2486 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2488 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2493 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2495 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2500 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2502 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2503 Fcons (arg5
, Qnil
)))));
2506 /* Make a list of COUNT Lisp_Objects, where ARG is the
2507 first one. Allocate conses from pure space if TYPE
2508 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2511 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2515 Lisp_Object val
, *objp
;
2517 /* Change to SAFE_ALLOCA if you hit this eassert. */
2518 eassert (count
<= MAX_ALLOCA
/ word_size
);
2520 objp
= alloca (count
* word_size
);
2523 for (i
= 1; i
< count
; i
++)
2524 objp
[i
] = va_arg (ap
, Lisp_Object
);
2527 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2529 if (type
== CONSTYPE_PURE
)
2530 val
= pure_cons (objp
[i
], val
);
2531 else if (type
== CONSTYPE_HEAP
)
2532 val
= Fcons (objp
[i
], val
);
2539 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2540 doc
: /* Return a newly created list with specified arguments as elements.
2541 Any number of arguments, even zero arguments, are allowed.
2542 usage: (list &rest OBJECTS) */)
2543 (ptrdiff_t nargs
, Lisp_Object
*args
)
2545 register Lisp_Object val
;
2551 val
= Fcons (args
[nargs
], val
);
2557 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2558 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2559 (register Lisp_Object length
, Lisp_Object init
)
2561 register Lisp_Object val
;
2562 register EMACS_INT size
;
2564 CHECK_NATNUM (length
);
2565 size
= XFASTINT (length
);
2570 val
= Fcons (init
, val
);
2575 val
= Fcons (init
, val
);
2580 val
= Fcons (init
, val
);
2585 val
= Fcons (init
, val
);
2590 val
= Fcons (init
, val
);
2605 /***********************************************************************
2607 ***********************************************************************/
2609 /* This value is balanced well enough to avoid too much internal overhead
2610 for the most common cases; it's not required to be a power of two, but
2611 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2613 #define VECTOR_BLOCK_SIZE 4096
2615 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2618 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2621 /* Verify assumptions described above. */
2622 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2623 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2625 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2626 #define vroundup_ct(x) ROUNDUP ((size_t) (x), roundup_size)
2627 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2628 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2630 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2632 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2634 /* Size of the minimal vector allocated from block. */
2636 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2638 /* Size of the largest vector allocated from block. */
2640 #define VBLOCK_BYTES_MAX \
2641 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2643 /* We maintain one free list for each possible block-allocated
2644 vector size, and this is the number of free lists we have. */
2646 #define VECTOR_MAX_FREE_LIST_INDEX \
2647 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2649 /* Common shortcut to advance vector pointer over a block data. */
2651 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2653 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2655 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2657 /* Common shortcut to setup vector on a free list. */
2659 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2661 (tmp) = ((nbytes - header_size) / word_size); \
2662 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2663 eassert ((nbytes) % roundup_size == 0); \
2664 (tmp) = VINDEX (nbytes); \
2665 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2666 v->u.next = vector_free_lists[tmp]; \
2667 vector_free_lists[tmp] = (v); \
2668 total_free_vector_slots += (nbytes) / word_size; \
2671 /* This internal type is used to maintain the list of large vectors
2672 which are allocated at their own, e.g. outside of vector blocks. */
2677 struct large_vector
*vector
;
2679 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2680 unsigned char c
[vroundup_ct (sizeof (struct large_vector
*))];
2683 struct Lisp_Vector v
;
2686 /* This internal type is used to maintain an underlying storage
2687 for small vectors. */
2691 char data
[VECTOR_BLOCK_BYTES
];
2692 struct vector_block
*next
;
2695 /* Chain of vector blocks. */
2697 static struct vector_block
*vector_blocks
;
2699 /* Vector free lists, where NTH item points to a chain of free
2700 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2702 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2704 /* Singly-linked list of large vectors. */
2706 static struct large_vector
*large_vectors
;
2708 /* The only vector with 0 slots, allocated from pure space. */
2710 Lisp_Object zero_vector
;
2712 /* Number of live vectors. */
2714 static EMACS_INT total_vectors
;
2716 /* Total size of live and free vectors, in Lisp_Object units. */
2718 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2720 /* Get a new vector block. */
2722 static struct vector_block
*
2723 allocate_vector_block (void)
2725 struct vector_block
*block
= xmalloc (sizeof *block
);
2727 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2728 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2729 MEM_TYPE_VECTOR_BLOCK
);
2732 block
->next
= vector_blocks
;
2733 vector_blocks
= block
;
2737 /* Called once to initialize vector allocation. */
2742 zero_vector
= make_pure_vector (0);
2745 /* Allocate vector from a vector block. */
2747 static struct Lisp_Vector
*
2748 allocate_vector_from_block (size_t nbytes
)
2750 struct Lisp_Vector
*vector
;
2751 struct vector_block
*block
;
2752 size_t index
, restbytes
;
2754 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2755 eassert (nbytes
% roundup_size
== 0);
2757 /* First, try to allocate from a free list
2758 containing vectors of the requested size. */
2759 index
= VINDEX (nbytes
);
2760 if (vector_free_lists
[index
])
2762 vector
= vector_free_lists
[index
];
2763 vector_free_lists
[index
] = vector
->u
.next
;
2764 total_free_vector_slots
-= nbytes
/ word_size
;
2768 /* Next, check free lists containing larger vectors. Since
2769 we will split the result, we should have remaining space
2770 large enough to use for one-slot vector at least. */
2771 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2772 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2773 if (vector_free_lists
[index
])
2775 /* This vector is larger than requested. */
2776 vector
= vector_free_lists
[index
];
2777 vector_free_lists
[index
] = vector
->u
.next
;
2778 total_free_vector_slots
-= nbytes
/ word_size
;
2780 /* Excess bytes are used for the smaller vector,
2781 which should be set on an appropriate free list. */
2782 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2783 eassert (restbytes
% roundup_size
== 0);
2784 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2788 /* Finally, need a new vector block. */
2789 block
= allocate_vector_block ();
2791 /* New vector will be at the beginning of this block. */
2792 vector
= (struct Lisp_Vector
*) block
->data
;
2794 /* If the rest of space from this block is large enough
2795 for one-slot vector at least, set up it on a free list. */
2796 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2797 if (restbytes
>= VBLOCK_BYTES_MIN
)
2799 eassert (restbytes
% roundup_size
== 0);
2800 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2805 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2807 #define VECTOR_IN_BLOCK(vector, block) \
2808 ((char *) (vector) <= (block)->data \
2809 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2811 /* Return the memory footprint of V in bytes. */
2814 vector_nbytes (struct Lisp_Vector
*v
)
2816 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2818 if (size
& PSEUDOVECTOR_FLAG
)
2820 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2822 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
2823 ptrdiff_t payload_bytes
=
2824 bool_vector_payload_bytes (bv
->size
, NULL
);
2826 eassume (payload_bytes
>= 0);
2827 size
= bool_header_size
+ ROUNDUP (payload_bytes
, word_size
);
2831 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2832 + ((size
& PSEUDOVECTOR_REST_MASK
)
2833 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2836 size
= header_size
+ size
* word_size
;
2837 return vroundup (size
);
2840 /* Reclaim space used by unmarked vectors. */
2843 sweep_vectors (void)
2845 struct vector_block
*block
, **bprev
= &vector_blocks
;
2846 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2847 struct Lisp_Vector
*vector
, *next
;
2849 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2850 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2852 /* Looking through vector blocks. */
2854 for (block
= vector_blocks
; block
; block
= *bprev
)
2856 bool free_this_block
= 0;
2859 for (vector
= (struct Lisp_Vector
*) block
->data
;
2860 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2862 if (VECTOR_MARKED_P (vector
))
2864 VECTOR_UNMARK (vector
);
2866 nbytes
= vector_nbytes (vector
);
2867 total_vector_slots
+= nbytes
/ word_size
;
2868 next
= ADVANCE (vector
, nbytes
);
2872 ptrdiff_t total_bytes
;
2874 nbytes
= vector_nbytes (vector
);
2875 total_bytes
= nbytes
;
2876 next
= ADVANCE (vector
, nbytes
);
2878 /* While NEXT is not marked, try to coalesce with VECTOR,
2879 thus making VECTOR of the largest possible size. */
2881 while (VECTOR_IN_BLOCK (next
, block
))
2883 if (VECTOR_MARKED_P (next
))
2885 nbytes
= vector_nbytes (next
);
2886 total_bytes
+= nbytes
;
2887 next
= ADVANCE (next
, nbytes
);
2890 eassert (total_bytes
% roundup_size
== 0);
2892 if (vector
== (struct Lisp_Vector
*) block
->data
2893 && !VECTOR_IN_BLOCK (next
, block
))
2894 /* This block should be freed because all of it's
2895 space was coalesced into the only free vector. */
2896 free_this_block
= 1;
2900 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2905 if (free_this_block
)
2907 *bprev
= block
->next
;
2908 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2909 mem_delete (mem_find (block
->data
));
2914 bprev
= &block
->next
;
2917 /* Sweep large vectors. */
2919 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2922 if (VECTOR_MARKED_P (vector
))
2924 VECTOR_UNMARK (vector
);
2926 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2928 /* All non-bool pseudovectors are small enough to be allocated
2929 from vector blocks. This code should be redesigned if some
2930 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2931 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2932 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
2936 += header_size
/ word_size
+ vector
->header
.size
;
2937 lvprev
= &lv
->next
.vector
;
2941 *lvprev
= lv
->next
.vector
;
2947 /* Value is a pointer to a newly allocated Lisp_Vector structure
2948 with room for LEN Lisp_Objects. */
2950 static struct Lisp_Vector
*
2951 allocate_vectorlike (ptrdiff_t len
)
2953 struct Lisp_Vector
*p
;
2958 p
= XVECTOR (zero_vector
);
2961 size_t nbytes
= header_size
+ len
* word_size
;
2963 #ifdef DOUG_LEA_MALLOC
2964 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2965 because mapped region contents are not preserved in
2967 mallopt (M_MMAP_MAX
, 0);
2970 if (nbytes
<= VBLOCK_BYTES_MAX
)
2971 p
= allocate_vector_from_block (vroundup (nbytes
));
2974 struct large_vector
*lv
2975 = lisp_malloc ((offsetof (struct large_vector
, v
.u
.contents
)
2977 MEM_TYPE_VECTORLIKE
);
2978 lv
->next
.vector
= large_vectors
;
2983 #ifdef DOUG_LEA_MALLOC
2984 /* Back to a reasonable maximum of mmap'ed areas. */
2985 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2988 consing_since_gc
+= nbytes
;
2989 vector_cells_consed
+= len
;
2992 MALLOC_UNBLOCK_INPUT
;
2998 /* Allocate a vector with LEN slots. */
3000 struct Lisp_Vector
*
3001 allocate_vector (EMACS_INT len
)
3003 struct Lisp_Vector
*v
;
3004 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3006 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3007 memory_full (SIZE_MAX
);
3008 v
= allocate_vectorlike (len
);
3009 v
->header
.size
= len
;
3014 /* Allocate other vector-like structures. */
3016 struct Lisp_Vector
*
3017 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3019 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3022 /* Catch bogus values. */
3023 eassert (tag
<= PVEC_FONT
);
3024 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3025 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3027 /* Only the first lisplen slots will be traced normally by the GC. */
3028 for (i
= 0; i
< lisplen
; ++i
)
3029 v
->u
.contents
[i
] = Qnil
;
3031 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3036 allocate_buffer (void)
3038 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3040 BUFFER_PVEC_INIT (b
);
3041 /* Put B on the chain of all buffers including killed ones. */
3042 b
->next
= all_buffers
;
3044 /* Note that the rest fields of B are not initialized. */
3048 struct Lisp_Hash_Table
*
3049 allocate_hash_table (void)
3051 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3055 allocate_window (void)
3059 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3060 /* Users assumes that non-Lisp data is zeroed. */
3061 memset (&w
->current_matrix
, 0,
3062 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3067 allocate_terminal (void)
3071 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3072 /* Users assumes that non-Lisp data is zeroed. */
3073 memset (&t
->next_terminal
, 0,
3074 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3079 allocate_frame (void)
3083 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3084 /* Users assumes that non-Lisp data is zeroed. */
3085 memset (&f
->face_cache
, 0,
3086 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3090 struct Lisp_Process
*
3091 allocate_process (void)
3093 struct Lisp_Process
*p
;
3095 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3096 /* Users assumes that non-Lisp data is zeroed. */
3098 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3102 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3103 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3104 See also the function `vector'. */)
3105 (register Lisp_Object length
, Lisp_Object init
)
3108 register ptrdiff_t sizei
;
3109 register ptrdiff_t i
;
3110 register struct Lisp_Vector
*p
;
3112 CHECK_NATNUM (length
);
3114 p
= allocate_vector (XFASTINT (length
));
3115 sizei
= XFASTINT (length
);
3116 for (i
= 0; i
< sizei
; i
++)
3117 p
->u
.contents
[i
] = init
;
3119 XSETVECTOR (vector
, p
);
3124 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3125 doc
: /* Return a newly created vector with specified arguments as elements.
3126 Any number of arguments, even zero arguments, are allowed.
3127 usage: (vector &rest OBJECTS) */)
3128 (ptrdiff_t nargs
, Lisp_Object
*args
)
3131 register Lisp_Object val
= make_uninit_vector (nargs
);
3132 register struct Lisp_Vector
*p
= XVECTOR (val
);
3134 for (i
= 0; i
< nargs
; i
++)
3135 p
->u
.contents
[i
] = args
[i
];
3140 make_byte_code (struct Lisp_Vector
*v
)
3142 /* Don't allow the global zero_vector to become a byte code object. */
3143 eassert(0 < v
->header
.size
);
3144 if (v
->header
.size
> 1 && STRINGP (v
->u
.contents
[1])
3145 && STRING_MULTIBYTE (v
->u
.contents
[1]))
3146 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3147 earlier because they produced a raw 8-bit string for byte-code
3148 and now such a byte-code string is loaded as multibyte while
3149 raw 8-bit characters converted to multibyte form. Thus, now we
3150 must convert them back to the original unibyte form. */
3151 v
->u
.contents
[1] = Fstring_as_unibyte (v
->u
.contents
[1]);
3152 XSETPVECTYPE (v
, PVEC_COMPILED
);
3155 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3156 doc
: /* Create a byte-code object with specified arguments as elements.
3157 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3158 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3159 and (optional) INTERACTIVE-SPEC.
3160 The first four arguments are required; at most six have any
3162 The ARGLIST can be either like the one of `lambda', in which case the arguments
3163 will be dynamically bound before executing the byte code, or it can be an
3164 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3165 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3166 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3167 argument to catch the left-over arguments. If such an integer is used, the
3168 arguments will not be dynamically bound but will be instead pushed on the
3169 stack before executing the byte-code.
3170 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3171 (ptrdiff_t nargs
, Lisp_Object
*args
)
3174 register Lisp_Object val
= make_uninit_vector (nargs
);
3175 register struct Lisp_Vector
*p
= XVECTOR (val
);
3177 /* We used to purecopy everything here, if purify-flag was set. This worked
3178 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3179 dangerous, since make-byte-code is used during execution to build
3180 closures, so any closure built during the preload phase would end up
3181 copied into pure space, including its free variables, which is sometimes
3182 just wasteful and other times plainly wrong (e.g. those free vars may want
3185 for (i
= 0; i
< nargs
; i
++)
3186 p
->u
.contents
[i
] = args
[i
];
3188 XSETCOMPILED (val
, p
);
3194 /***********************************************************************
3196 ***********************************************************************/
3198 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3199 of the required alignment if LSB tags are used. */
3201 union aligned_Lisp_Symbol
3203 struct Lisp_Symbol s
;
3205 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3210 /* Each symbol_block is just under 1020 bytes long, since malloc
3211 really allocates in units of powers of two and uses 4 bytes for its
3214 #define SYMBOL_BLOCK_SIZE \
3215 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3219 /* Place `symbols' first, to preserve alignment. */
3220 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3221 struct symbol_block
*next
;
3224 /* Current symbol block and index of first unused Lisp_Symbol
3227 static struct symbol_block
*symbol_block
;
3228 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3230 /* List of free symbols. */
3232 static struct Lisp_Symbol
*symbol_free_list
;
3235 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3237 XSYMBOL (sym
)->name
= name
;
3240 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3241 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3242 Its value is void, and its function definition and property list are nil. */)
3245 register Lisp_Object val
;
3246 register struct Lisp_Symbol
*p
;
3248 CHECK_STRING (name
);
3252 if (symbol_free_list
)
3254 XSETSYMBOL (val
, symbol_free_list
);
3255 symbol_free_list
= symbol_free_list
->next
;
3259 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3261 struct symbol_block
*new
3262 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3263 new->next
= symbol_block
;
3265 symbol_block_index
= 0;
3266 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3268 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3269 symbol_block_index
++;
3272 MALLOC_UNBLOCK_INPUT
;
3275 set_symbol_name (val
, name
);
3276 set_symbol_plist (val
, Qnil
);
3277 p
->redirect
= SYMBOL_PLAINVAL
;
3278 SET_SYMBOL_VAL (p
, Qunbound
);
3279 set_symbol_function (val
, Qnil
);
3280 set_symbol_next (val
, NULL
);
3282 p
->interned
= SYMBOL_UNINTERNED
;
3284 p
->declared_special
= 0;
3285 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3287 total_free_symbols
--;
3293 /***********************************************************************
3294 Marker (Misc) Allocation
3295 ***********************************************************************/
3297 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3298 the required alignment when LSB tags are used. */
3300 union aligned_Lisp_Misc
3304 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3309 /* Allocation of markers and other objects that share that structure.
3310 Works like allocation of conses. */
3312 #define MARKER_BLOCK_SIZE \
3313 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3317 /* Place `markers' first, to preserve alignment. */
3318 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3319 struct marker_block
*next
;
3322 static struct marker_block
*marker_block
;
3323 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3325 static union Lisp_Misc
*marker_free_list
;
3327 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3330 allocate_misc (enum Lisp_Misc_Type type
)
3336 if (marker_free_list
)
3338 XSETMISC (val
, marker_free_list
);
3339 marker_free_list
= marker_free_list
->u_free
.chain
;
3343 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3345 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3346 new->next
= marker_block
;
3348 marker_block_index
= 0;
3349 total_free_markers
+= MARKER_BLOCK_SIZE
;
3351 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3352 marker_block_index
++;
3355 MALLOC_UNBLOCK_INPUT
;
3357 --total_free_markers
;
3358 consing_since_gc
+= sizeof (union Lisp_Misc
);
3359 misc_objects_consed
++;
3360 XMISCANY (val
)->type
= type
;
3361 XMISCANY (val
)->gcmarkbit
= 0;
3365 /* Free a Lisp_Misc object. */
3368 free_misc (Lisp_Object misc
)
3370 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3371 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3372 marker_free_list
= XMISC (misc
);
3373 consing_since_gc
-= sizeof (union Lisp_Misc
);
3374 total_free_markers
++;
3377 /* Verify properties of Lisp_Save_Value's representation
3378 that are assumed here and elsewhere. */
3380 verify (SAVE_UNUSED
== 0);
3381 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3385 /* Return Lisp_Save_Value objects for the various combinations
3386 that callers need. */
3389 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3391 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3392 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3393 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3394 p
->data
[0].integer
= a
;
3395 p
->data
[1].integer
= b
;
3396 p
->data
[2].integer
= c
;
3401 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3404 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3405 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3406 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3407 p
->data
[0].object
= a
;
3408 p
->data
[1].object
= b
;
3409 p
->data
[2].object
= c
;
3410 p
->data
[3].object
= d
;
3415 make_save_ptr (void *a
)
3417 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3418 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3419 p
->save_type
= SAVE_POINTER
;
3420 p
->data
[0].pointer
= a
;
3425 make_save_ptr_int (void *a
, ptrdiff_t b
)
3427 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3428 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3429 p
->save_type
= SAVE_TYPE_PTR_INT
;
3430 p
->data
[0].pointer
= a
;
3431 p
->data
[1].integer
= b
;
3435 #if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3437 make_save_ptr_ptr (void *a
, void *b
)
3439 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3440 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3441 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3442 p
->data
[0].pointer
= a
;
3443 p
->data
[1].pointer
= b
;
3449 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3451 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3452 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3453 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3454 p
->data
[0].funcpointer
= a
;
3455 p
->data
[1].pointer
= b
;
3456 p
->data
[2].object
= c
;
3460 /* Return a Lisp_Save_Value object that represents an array A
3461 of N Lisp objects. */
3464 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3466 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3467 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3468 p
->save_type
= SAVE_TYPE_MEMORY
;
3469 p
->data
[0].pointer
= a
;
3470 p
->data
[1].integer
= n
;
3474 /* Free a Lisp_Save_Value object. Do not use this function
3475 if SAVE contains pointer other than returned by xmalloc. */
3478 free_save_value (Lisp_Object save
)
3480 xfree (XSAVE_POINTER (save
, 0));
3484 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3487 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3489 register Lisp_Object overlay
;
3491 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3492 OVERLAY_START (overlay
) = start
;
3493 OVERLAY_END (overlay
) = end
;
3494 set_overlay_plist (overlay
, plist
);
3495 XOVERLAY (overlay
)->next
= NULL
;
3499 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3500 doc
: /* Return a newly allocated marker which does not point at any place. */)
3503 register Lisp_Object val
;
3504 register struct Lisp_Marker
*p
;
3506 val
= allocate_misc (Lisp_Misc_Marker
);
3512 p
->insertion_type
= 0;
3513 p
->need_adjustment
= 0;
3517 /* Return a newly allocated marker which points into BUF
3518 at character position CHARPOS and byte position BYTEPOS. */
3521 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3524 struct Lisp_Marker
*m
;
3526 /* No dead buffers here. */
3527 eassert (BUFFER_LIVE_P (buf
));
3529 /* Every character is at least one byte. */
3530 eassert (charpos
<= bytepos
);
3532 obj
= allocate_misc (Lisp_Misc_Marker
);
3535 m
->charpos
= charpos
;
3536 m
->bytepos
= bytepos
;
3537 m
->insertion_type
= 0;
3538 m
->need_adjustment
= 0;
3539 m
->next
= BUF_MARKERS (buf
);
3540 BUF_MARKERS (buf
) = m
;
3544 /* Put MARKER back on the free list after using it temporarily. */
3547 free_marker (Lisp_Object marker
)
3549 unchain_marker (XMARKER (marker
));
3554 /* Return a newly created vector or string with specified arguments as
3555 elements. If all the arguments are characters that can fit
3556 in a string of events, make a string; otherwise, make a vector.
3558 Any number of arguments, even zero arguments, are allowed. */
3561 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3565 for (i
= 0; i
< nargs
; i
++)
3566 /* The things that fit in a string
3567 are characters that are in 0...127,
3568 after discarding the meta bit and all the bits above it. */
3569 if (!INTEGERP (args
[i
])
3570 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3571 return Fvector (nargs
, args
);
3573 /* Since the loop exited, we know that all the things in it are
3574 characters, so we can make a string. */
3578 result
= Fmake_string (make_number (nargs
), make_number (0));
3579 for (i
= 0; i
< nargs
; i
++)
3581 SSET (result
, i
, XINT (args
[i
]));
3582 /* Move the meta bit to the right place for a string char. */
3583 if (XINT (args
[i
]) & CHAR_META
)
3584 SSET (result
, i
, SREF (result
, i
) | 0x80);
3593 /************************************************************************
3594 Memory Full Handling
3595 ************************************************************************/
3598 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3599 there may have been size_t overflow so that malloc was never
3600 called, or perhaps malloc was invoked successfully but the
3601 resulting pointer had problems fitting into a tagged EMACS_INT. In
3602 either case this counts as memory being full even though malloc did
3606 memory_full (size_t nbytes
)
3608 /* Do not go into hysterics merely because a large request failed. */
3609 bool enough_free_memory
= 0;
3610 if (SPARE_MEMORY
< nbytes
)
3615 p
= malloc (SPARE_MEMORY
);
3619 enough_free_memory
= 1;
3621 MALLOC_UNBLOCK_INPUT
;
3624 if (! enough_free_memory
)
3630 memory_full_cons_threshold
= sizeof (struct cons_block
);
3632 /* The first time we get here, free the spare memory. */
3633 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3634 if (spare_memory
[i
])
3637 free (spare_memory
[i
]);
3638 else if (i
>= 1 && i
<= 4)
3639 lisp_align_free (spare_memory
[i
]);
3641 lisp_free (spare_memory
[i
]);
3642 spare_memory
[i
] = 0;
3646 /* This used to call error, but if we've run out of memory, we could
3647 get infinite recursion trying to build the string. */
3648 xsignal (Qnil
, Vmemory_signal_data
);
3651 /* If we released our reserve (due to running out of memory),
3652 and we have a fair amount free once again,
3653 try to set aside another reserve in case we run out once more.
3655 This is called when a relocatable block is freed in ralloc.c,
3656 and also directly from this file, in case we're not using ralloc.c. */
3659 refill_memory_reserve (void)
3661 #ifndef SYSTEM_MALLOC
3662 if (spare_memory
[0] == 0)
3663 spare_memory
[0] = malloc (SPARE_MEMORY
);
3664 if (spare_memory
[1] == 0)
3665 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3667 if (spare_memory
[2] == 0)
3668 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3670 if (spare_memory
[3] == 0)
3671 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3673 if (spare_memory
[4] == 0)
3674 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3676 if (spare_memory
[5] == 0)
3677 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3679 if (spare_memory
[6] == 0)
3680 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3682 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3683 Vmemory_full
= Qnil
;
3687 /************************************************************************
3689 ************************************************************************/
3691 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3693 /* Conservative C stack marking requires a method to identify possibly
3694 live Lisp objects given a pointer value. We do this by keeping
3695 track of blocks of Lisp data that are allocated in a red-black tree
3696 (see also the comment of mem_node which is the type of nodes in
3697 that tree). Function lisp_malloc adds information for an allocated
3698 block to the red-black tree with calls to mem_insert, and function
3699 lisp_free removes it with mem_delete. Functions live_string_p etc
3700 call mem_find to lookup information about a given pointer in the
3701 tree, and use that to determine if the pointer points to a Lisp
3704 /* Initialize this part of alloc.c. */
3709 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3710 mem_z
.parent
= NULL
;
3711 mem_z
.color
= MEM_BLACK
;
3712 mem_z
.start
= mem_z
.end
= NULL
;
3717 /* Value is a pointer to the mem_node containing START. Value is
3718 MEM_NIL if there is no node in the tree containing START. */
3720 static struct mem_node
*
3721 mem_find (void *start
)
3725 if (start
< min_heap_address
|| start
> max_heap_address
)
3728 /* Make the search always successful to speed up the loop below. */
3729 mem_z
.start
= start
;
3730 mem_z
.end
= (char *) start
+ 1;
3733 while (start
< p
->start
|| start
>= p
->end
)
3734 p
= start
< p
->start
? p
->left
: p
->right
;
3739 /* Insert a new node into the tree for a block of memory with start
3740 address START, end address END, and type TYPE. Value is a
3741 pointer to the node that was inserted. */
3743 static struct mem_node
*
3744 mem_insert (void *start
, void *end
, enum mem_type type
)
3746 struct mem_node
*c
, *parent
, *x
;
3748 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3749 min_heap_address
= start
;
3750 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3751 max_heap_address
= end
;
3753 /* See where in the tree a node for START belongs. In this
3754 particular application, it shouldn't happen that a node is already
3755 present. For debugging purposes, let's check that. */
3759 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3761 while (c
!= MEM_NIL
)
3763 if (start
>= c
->start
&& start
< c
->end
)
3766 c
= start
< c
->start
? c
->left
: c
->right
;
3769 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3771 while (c
!= MEM_NIL
)
3774 c
= start
< c
->start
? c
->left
: c
->right
;
3777 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3779 /* Create a new node. */
3780 #ifdef GC_MALLOC_CHECK
3781 x
= malloc (sizeof *x
);
3785 x
= xmalloc (sizeof *x
);
3791 x
->left
= x
->right
= MEM_NIL
;
3794 /* Insert it as child of PARENT or install it as root. */
3797 if (start
< parent
->start
)
3805 /* Re-establish red-black tree properties. */
3806 mem_insert_fixup (x
);
3812 /* Re-establish the red-black properties of the tree, and thereby
3813 balance the tree, after node X has been inserted; X is always red. */
3816 mem_insert_fixup (struct mem_node
*x
)
3818 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3820 /* X is red and its parent is red. This is a violation of
3821 red-black tree property #3. */
3823 if (x
->parent
== x
->parent
->parent
->left
)
3825 /* We're on the left side of our grandparent, and Y is our
3827 struct mem_node
*y
= x
->parent
->parent
->right
;
3829 if (y
->color
== MEM_RED
)
3831 /* Uncle and parent are red but should be black because
3832 X is red. Change the colors accordingly and proceed
3833 with the grandparent. */
3834 x
->parent
->color
= MEM_BLACK
;
3835 y
->color
= MEM_BLACK
;
3836 x
->parent
->parent
->color
= MEM_RED
;
3837 x
= x
->parent
->parent
;
3841 /* Parent and uncle have different colors; parent is
3842 red, uncle is black. */
3843 if (x
== x
->parent
->right
)
3846 mem_rotate_left (x
);
3849 x
->parent
->color
= MEM_BLACK
;
3850 x
->parent
->parent
->color
= MEM_RED
;
3851 mem_rotate_right (x
->parent
->parent
);
3856 /* This is the symmetrical case of above. */
3857 struct mem_node
*y
= x
->parent
->parent
->left
;
3859 if (y
->color
== MEM_RED
)
3861 x
->parent
->color
= MEM_BLACK
;
3862 y
->color
= MEM_BLACK
;
3863 x
->parent
->parent
->color
= MEM_RED
;
3864 x
= x
->parent
->parent
;
3868 if (x
== x
->parent
->left
)
3871 mem_rotate_right (x
);
3874 x
->parent
->color
= MEM_BLACK
;
3875 x
->parent
->parent
->color
= MEM_RED
;
3876 mem_rotate_left (x
->parent
->parent
);
3881 /* The root may have been changed to red due to the algorithm. Set
3882 it to black so that property #5 is satisfied. */
3883 mem_root
->color
= MEM_BLACK
;
3894 mem_rotate_left (struct mem_node
*x
)
3898 /* Turn y's left sub-tree into x's right sub-tree. */
3901 if (y
->left
!= MEM_NIL
)
3902 y
->left
->parent
= x
;
3904 /* Y's parent was x's parent. */
3906 y
->parent
= x
->parent
;
3908 /* Get the parent to point to y instead of x. */
3911 if (x
== x
->parent
->left
)
3912 x
->parent
->left
= y
;
3914 x
->parent
->right
= y
;
3919 /* Put x on y's left. */
3933 mem_rotate_right (struct mem_node
*x
)
3935 struct mem_node
*y
= x
->left
;
3938 if (y
->right
!= MEM_NIL
)
3939 y
->right
->parent
= x
;
3942 y
->parent
= x
->parent
;
3945 if (x
== x
->parent
->right
)
3946 x
->parent
->right
= y
;
3948 x
->parent
->left
= y
;
3959 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3962 mem_delete (struct mem_node
*z
)
3964 struct mem_node
*x
, *y
;
3966 if (!z
|| z
== MEM_NIL
)
3969 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3974 while (y
->left
!= MEM_NIL
)
3978 if (y
->left
!= MEM_NIL
)
3983 x
->parent
= y
->parent
;
3986 if (y
== y
->parent
->left
)
3987 y
->parent
->left
= x
;
3989 y
->parent
->right
= x
;
3996 z
->start
= y
->start
;
4001 if (y
->color
== MEM_BLACK
)
4002 mem_delete_fixup (x
);
4004 #ifdef GC_MALLOC_CHECK
4012 /* Re-establish the red-black properties of the tree, after a
4016 mem_delete_fixup (struct mem_node
*x
)
4018 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4020 if (x
== x
->parent
->left
)
4022 struct mem_node
*w
= x
->parent
->right
;
4024 if (w
->color
== MEM_RED
)
4026 w
->color
= MEM_BLACK
;
4027 x
->parent
->color
= MEM_RED
;
4028 mem_rotate_left (x
->parent
);
4029 w
= x
->parent
->right
;
4032 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4039 if (w
->right
->color
== MEM_BLACK
)
4041 w
->left
->color
= MEM_BLACK
;
4043 mem_rotate_right (w
);
4044 w
= x
->parent
->right
;
4046 w
->color
= x
->parent
->color
;
4047 x
->parent
->color
= MEM_BLACK
;
4048 w
->right
->color
= MEM_BLACK
;
4049 mem_rotate_left (x
->parent
);
4055 struct mem_node
*w
= x
->parent
->left
;
4057 if (w
->color
== MEM_RED
)
4059 w
->color
= MEM_BLACK
;
4060 x
->parent
->color
= MEM_RED
;
4061 mem_rotate_right (x
->parent
);
4062 w
= x
->parent
->left
;
4065 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4072 if (w
->left
->color
== MEM_BLACK
)
4074 w
->right
->color
= MEM_BLACK
;
4076 mem_rotate_left (w
);
4077 w
= x
->parent
->left
;
4080 w
->color
= x
->parent
->color
;
4081 x
->parent
->color
= MEM_BLACK
;
4082 w
->left
->color
= MEM_BLACK
;
4083 mem_rotate_right (x
->parent
);
4089 x
->color
= MEM_BLACK
;
4093 /* Value is non-zero if P is a pointer to a live Lisp string on
4094 the heap. M is a pointer to the mem_block for P. */
4097 live_string_p (struct mem_node
*m
, void *p
)
4099 if (m
->type
== MEM_TYPE_STRING
)
4101 struct string_block
*b
= m
->start
;
4102 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4104 /* P must point to the start of a Lisp_String structure, and it
4105 must not be on the free-list. */
4107 && offset
% sizeof b
->strings
[0] == 0
4108 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4109 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4116 /* Value is non-zero if P is a pointer to a live Lisp cons on
4117 the heap. M is a pointer to the mem_block for P. */
4120 live_cons_p (struct mem_node
*m
, void *p
)
4122 if (m
->type
== MEM_TYPE_CONS
)
4124 struct cons_block
*b
= m
->start
;
4125 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4127 /* P must point to the start of a Lisp_Cons, not be
4128 one of the unused cells in the current cons block,
4129 and not be on the free-list. */
4131 && offset
% sizeof b
->conses
[0] == 0
4132 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4134 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4135 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4142 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4143 the heap. M is a pointer to the mem_block for P. */
4146 live_symbol_p (struct mem_node
*m
, void *p
)
4148 if (m
->type
== MEM_TYPE_SYMBOL
)
4150 struct symbol_block
*b
= m
->start
;
4151 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4153 /* P must point to the start of a Lisp_Symbol, not be
4154 one of the unused cells in the current symbol block,
4155 and not be on the free-list. */
4157 && offset
% sizeof b
->symbols
[0] == 0
4158 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4159 && (b
!= symbol_block
4160 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4161 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4168 /* Value is non-zero if P is a pointer to a live Lisp float on
4169 the heap. M is a pointer to the mem_block for P. */
4172 live_float_p (struct mem_node
*m
, void *p
)
4174 if (m
->type
== MEM_TYPE_FLOAT
)
4176 struct float_block
*b
= m
->start
;
4177 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4179 /* P must point to the start of a Lisp_Float and not be
4180 one of the unused cells in the current float block. */
4182 && offset
% sizeof b
->floats
[0] == 0
4183 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4184 && (b
!= float_block
4185 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4192 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4193 the heap. M is a pointer to the mem_block for P. */
4196 live_misc_p (struct mem_node
*m
, void *p
)
4198 if (m
->type
== MEM_TYPE_MISC
)
4200 struct marker_block
*b
= m
->start
;
4201 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4203 /* P must point to the start of a Lisp_Misc, not be
4204 one of the unused cells in the current misc block,
4205 and not be on the free-list. */
4207 && offset
% sizeof b
->markers
[0] == 0
4208 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4209 && (b
!= marker_block
4210 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4211 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4218 /* Value is non-zero if P is a pointer to a live vector-like object.
4219 M is a pointer to the mem_block for P. */
4222 live_vector_p (struct mem_node
*m
, void *p
)
4224 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4226 /* This memory node corresponds to a vector block. */
4227 struct vector_block
*block
= m
->start
;
4228 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4230 /* P is in the block's allocation range. Scan the block
4231 up to P and see whether P points to the start of some
4232 vector which is not on a free list. FIXME: check whether
4233 some allocation patterns (probably a lot of short vectors)
4234 may cause a substantial overhead of this loop. */
4235 while (VECTOR_IN_BLOCK (vector
, block
)
4236 && vector
<= (struct Lisp_Vector
*) p
)
4238 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4241 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4244 else if (m
->type
== MEM_TYPE_VECTORLIKE
4245 && (char *) p
== ((char *) m
->start
4246 + offsetof (struct large_vector
, v
)))
4247 /* This memory node corresponds to a large vector. */
4253 /* Value is non-zero if P is a pointer to a live buffer. M is a
4254 pointer to the mem_block for P. */
4257 live_buffer_p (struct mem_node
*m
, void *p
)
4259 /* P must point to the start of the block, and the buffer
4260 must not have been killed. */
4261 return (m
->type
== MEM_TYPE_BUFFER
4263 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4266 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4270 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4272 /* Currently not used, but may be called from gdb. */
4274 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4276 /* Array of objects that are kept alive because the C stack contains
4277 a pattern that looks like a reference to them . */
4279 #define MAX_ZOMBIES 10
4280 static Lisp_Object zombies
[MAX_ZOMBIES
];
4282 /* Number of zombie objects. */
4284 static EMACS_INT nzombies
;
4286 /* Number of garbage collections. */
4288 static EMACS_INT ngcs
;
4290 /* Average percentage of zombies per collection. */
4292 static double avg_zombies
;
4294 /* Max. number of live and zombie objects. */
4296 static EMACS_INT max_live
, max_zombies
;
4298 /* Average number of live objects per GC. */
4300 static double avg_live
;
4302 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4303 doc
: /* Show information about live and zombie objects. */)
4306 Lisp_Object args
[8], zombie_list
= Qnil
;
4308 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4309 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4310 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4311 args
[1] = make_number (ngcs
);
4312 args
[2] = make_float (avg_live
);
4313 args
[3] = make_float (avg_zombies
);
4314 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4315 args
[5] = make_number (max_live
);
4316 args
[6] = make_number (max_zombies
);
4317 args
[7] = zombie_list
;
4318 return Fmessage (8, args
);
4321 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4324 /* Mark OBJ if we can prove it's a Lisp_Object. */
4327 mark_maybe_object (Lisp_Object obj
)
4334 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4340 po
= (void *) XPNTR (obj
);
4347 switch (XTYPE (obj
))
4350 mark_p
= (live_string_p (m
, po
)
4351 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4355 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4359 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4363 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4366 case Lisp_Vectorlike
:
4367 /* Note: can't check BUFFERP before we know it's a
4368 buffer because checking that dereferences the pointer
4369 PO which might point anywhere. */
4370 if (live_vector_p (m
, po
))
4371 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4372 else if (live_buffer_p (m
, po
))
4373 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4377 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4386 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4387 if (nzombies
< MAX_ZOMBIES
)
4388 zombies
[nzombies
] = obj
;
4397 /* If P points to Lisp data, mark that as live if it isn't already
4401 mark_maybe_pointer (void *p
)
4407 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4410 /* Quickly rule out some values which can't point to Lisp data.
4411 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4412 Otherwise, assume that Lisp data is aligned on even addresses. */
4413 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4419 Lisp_Object obj
= Qnil
;
4423 case MEM_TYPE_NON_LISP
:
4424 case MEM_TYPE_SPARE
:
4425 /* Nothing to do; not a pointer to Lisp memory. */
4428 case MEM_TYPE_BUFFER
:
4429 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4430 XSETVECTOR (obj
, p
);
4434 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4438 case MEM_TYPE_STRING
:
4439 if (live_string_p (m
, p
)
4440 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4441 XSETSTRING (obj
, p
);
4445 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4449 case MEM_TYPE_SYMBOL
:
4450 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4451 XSETSYMBOL (obj
, p
);
4454 case MEM_TYPE_FLOAT
:
4455 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4459 case MEM_TYPE_VECTORLIKE
:
4460 case MEM_TYPE_VECTOR_BLOCK
:
4461 if (live_vector_p (m
, p
))
4464 XSETVECTOR (tem
, p
);
4465 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4480 /* Alignment of pointer values. Use alignof, as it sometimes returns
4481 a smaller alignment than GCC's __alignof__ and mark_memory might
4482 miss objects if __alignof__ were used. */
4483 #define GC_POINTER_ALIGNMENT alignof (void *)
4485 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4486 not suffice, which is the typical case. A host where a Lisp_Object is
4487 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4488 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4489 suffice to widen it to to a Lisp_Object and check it that way. */
4490 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4491 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4492 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4493 nor mark_maybe_object can follow the pointers. This should not occur on
4494 any practical porting target. */
4495 # error "MSB type bits straddle pointer-word boundaries"
4497 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4498 pointer words that hold pointers ORed with type bits. */
4499 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4501 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4502 words that hold unmodified pointers. */
4503 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4506 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4507 or END+OFFSET..START. */
4510 mark_memory (void *start
, void *end
)
4511 #if defined (__clang__) && defined (__has_feature)
4512 #if __has_feature(address_sanitizer)
4513 /* Do not allow -faddress-sanitizer to check this function, since it
4514 crosses the function stack boundary, and thus would yield many
4516 __attribute__((no_address_safety_analysis
))
4523 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4527 /* Make START the pointer to the start of the memory region,
4528 if it isn't already. */
4536 /* Mark Lisp data pointed to. This is necessary because, in some
4537 situations, the C compiler optimizes Lisp objects away, so that
4538 only a pointer to them remains. Example:
4540 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4543 Lisp_Object obj = build_string ("test");
4544 struct Lisp_String *s = XSTRING (obj);
4545 Fgarbage_collect ();
4546 fprintf (stderr, "test `%s'\n", s->data);
4550 Here, `obj' isn't really used, and the compiler optimizes it
4551 away. The only reference to the life string is through the
4554 for (pp
= start
; (void *) pp
< end
; pp
++)
4555 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4557 void *p
= *(void **) ((char *) pp
+ i
);
4558 mark_maybe_pointer (p
);
4559 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4560 mark_maybe_object (XIL ((intptr_t) p
));
4564 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4566 static bool setjmp_tested_p
;
4567 static int longjmps_done
;
4569 #define SETJMP_WILL_LIKELY_WORK "\
4571 Emacs garbage collector has been changed to use conservative stack\n\
4572 marking. Emacs has determined that the method it uses to do the\n\
4573 marking will likely work on your system, but this isn't sure.\n\
4575 If you are a system-programmer, or can get the help of a local wizard\n\
4576 who is, please take a look at the function mark_stack in alloc.c, and\n\
4577 verify that the methods used are appropriate for your system.\n\
4579 Please mail the result to <emacs-devel@gnu.org>.\n\
4582 #define SETJMP_WILL_NOT_WORK "\
4584 Emacs garbage collector has been changed to use conservative stack\n\
4585 marking. Emacs has determined that the default method it uses to do the\n\
4586 marking will not work on your system. We will need a system-dependent\n\
4587 solution for your system.\n\
4589 Please take a look at the function mark_stack in alloc.c, and\n\
4590 try to find a way to make it work on your system.\n\
4592 Note that you may get false negatives, depending on the compiler.\n\
4593 In particular, you need to use -O with GCC for this test.\n\
4595 Please mail the result to <emacs-devel@gnu.org>.\n\
4599 /* Perform a quick check if it looks like setjmp saves registers in a
4600 jmp_buf. Print a message to stderr saying so. When this test
4601 succeeds, this is _not_ a proof that setjmp is sufficient for
4602 conservative stack marking. Only the sources or a disassembly
4612 /* Arrange for X to be put in a register. */
4618 if (longjmps_done
== 1)
4620 /* Came here after the longjmp at the end of the function.
4622 If x == 1, the longjmp has restored the register to its
4623 value before the setjmp, and we can hope that setjmp
4624 saves all such registers in the jmp_buf, although that
4627 For other values of X, either something really strange is
4628 taking place, or the setjmp just didn't save the register. */
4631 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4634 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4641 if (longjmps_done
== 1)
4642 sys_longjmp (jbuf
, 1);
4645 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4648 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4650 /* Abort if anything GCPRO'd doesn't survive the GC. */
4658 for (p
= gcprolist
; p
; p
= p
->next
)
4659 for (i
= 0; i
< p
->nvars
; ++i
)
4660 if (!survives_gc_p (p
->var
[i
]))
4661 /* FIXME: It's not necessarily a bug. It might just be that the
4662 GCPRO is unnecessary or should release the object sooner. */
4666 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4673 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4674 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4676 fprintf (stderr
, " %d = ", i
);
4677 debug_print (zombies
[i
]);
4681 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4684 /* Mark live Lisp objects on the C stack.
4686 There are several system-dependent problems to consider when
4687 porting this to new architectures:
4691 We have to mark Lisp objects in CPU registers that can hold local
4692 variables or are used to pass parameters.
4694 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4695 something that either saves relevant registers on the stack, or
4696 calls mark_maybe_object passing it each register's contents.
4698 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4699 implementation assumes that calling setjmp saves registers we need
4700 to see in a jmp_buf which itself lies on the stack. This doesn't
4701 have to be true! It must be verified for each system, possibly
4702 by taking a look at the source code of setjmp.
4704 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4705 can use it as a machine independent method to store all registers
4706 to the stack. In this case the macros described in the previous
4707 two paragraphs are not used.
4711 Architectures differ in the way their processor stack is organized.
4712 For example, the stack might look like this
4715 | Lisp_Object | size = 4
4717 | something else | size = 2
4719 | Lisp_Object | size = 4
4723 In such a case, not every Lisp_Object will be aligned equally. To
4724 find all Lisp_Object on the stack it won't be sufficient to walk
4725 the stack in steps of 4 bytes. Instead, two passes will be
4726 necessary, one starting at the start of the stack, and a second
4727 pass starting at the start of the stack + 2. Likewise, if the
4728 minimal alignment of Lisp_Objects on the stack is 1, four passes
4729 would be necessary, each one starting with one byte more offset
4730 from the stack start. */
4737 #ifdef HAVE___BUILTIN_UNWIND_INIT
4738 /* Force callee-saved registers and register windows onto the stack.
4739 This is the preferred method if available, obviating the need for
4740 machine dependent methods. */
4741 __builtin_unwind_init ();
4743 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4744 #ifndef GC_SAVE_REGISTERS_ON_STACK
4745 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4746 union aligned_jmpbuf
{
4750 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4752 /* This trick flushes the register windows so that all the state of
4753 the process is contained in the stack. */
4754 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4755 needed on ia64 too. See mach_dep.c, where it also says inline
4756 assembler doesn't work with relevant proprietary compilers. */
4758 #if defined (__sparc64__) && defined (__FreeBSD__)
4759 /* FreeBSD does not have a ta 3 handler. */
4766 /* Save registers that we need to see on the stack. We need to see
4767 registers used to hold register variables and registers used to
4769 #ifdef GC_SAVE_REGISTERS_ON_STACK
4770 GC_SAVE_REGISTERS_ON_STACK (end
);
4771 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4773 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4774 setjmp will definitely work, test it
4775 and print a message with the result
4777 if (!setjmp_tested_p
)
4779 setjmp_tested_p
= 1;
4782 #endif /* GC_SETJMP_WORKS */
4785 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4786 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4787 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4789 /* This assumes that the stack is a contiguous region in memory. If
4790 that's not the case, something has to be done here to iterate
4791 over the stack segments. */
4792 mark_memory (stack_base
, end
);
4794 /* Allow for marking a secondary stack, like the register stack on the
4796 #ifdef GC_MARK_SECONDARY_STACK
4797 GC_MARK_SECONDARY_STACK ();
4800 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4805 #else /* GC_MARK_STACK == 0 */
4807 #define mark_maybe_object(obj) emacs_abort ()
4809 #endif /* GC_MARK_STACK != 0 */
4812 /* Determine whether it is safe to access memory at address P. */
4814 valid_pointer_p (void *p
)
4817 return w32_valid_pointer_p (p
, 16);
4821 /* Obviously, we cannot just access it (we would SEGV trying), so we
4822 trick the o/s to tell us whether p is a valid pointer.
4823 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4824 not validate p in that case. */
4826 if (emacs_pipe (fd
) == 0)
4828 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4829 emacs_close (fd
[1]);
4830 emacs_close (fd
[0]);
4838 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4839 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4840 cannot validate OBJ. This function can be quite slow, so its primary
4841 use is the manual debugging. The only exception is print_object, where
4842 we use it to check whether the memory referenced by the pointer of
4843 Lisp_Save_Value object contains valid objects. */
4846 valid_lisp_object_p (Lisp_Object obj
)
4856 p
= (void *) XPNTR (obj
);
4857 if (PURE_POINTER_P (p
))
4860 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4864 return valid_pointer_p (p
);
4871 int valid
= valid_pointer_p (p
);
4883 case MEM_TYPE_NON_LISP
:
4884 case MEM_TYPE_SPARE
:
4887 case MEM_TYPE_BUFFER
:
4888 return live_buffer_p (m
, p
) ? 1 : 2;
4891 return live_cons_p (m
, p
);
4893 case MEM_TYPE_STRING
:
4894 return live_string_p (m
, p
);
4897 return live_misc_p (m
, p
);
4899 case MEM_TYPE_SYMBOL
:
4900 return live_symbol_p (m
, p
);
4902 case MEM_TYPE_FLOAT
:
4903 return live_float_p (m
, p
);
4905 case MEM_TYPE_VECTORLIKE
:
4906 case MEM_TYPE_VECTOR_BLOCK
:
4907 return live_vector_p (m
, p
);
4920 /***********************************************************************
4921 Pure Storage Management
4922 ***********************************************************************/
4924 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4925 pointer to it. TYPE is the Lisp type for which the memory is
4926 allocated. TYPE < 0 means it's not used for a Lisp object. */
4929 pure_alloc (size_t size
, int type
)
4933 size_t alignment
= GCALIGNMENT
;
4935 size_t alignment
= alignof (EMACS_INT
);
4937 /* Give Lisp_Floats an extra alignment. */
4938 if (type
== Lisp_Float
)
4939 alignment
= alignof (struct Lisp_Float
);
4945 /* Allocate space for a Lisp object from the beginning of the free
4946 space with taking account of alignment. */
4947 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4948 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4952 /* Allocate space for a non-Lisp object from the end of the free
4954 pure_bytes_used_non_lisp
+= size
;
4955 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4957 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4959 if (pure_bytes_used
<= pure_size
)
4962 /* Don't allocate a large amount here,
4963 because it might get mmap'd and then its address
4964 might not be usable. */
4965 purebeg
= xmalloc (10000);
4967 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4968 pure_bytes_used
= 0;
4969 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4974 /* Print a warning if PURESIZE is too small. */
4977 check_pure_size (void)
4979 if (pure_bytes_used_before_overflow
)
4980 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4982 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4986 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4987 the non-Lisp data pool of the pure storage, and return its start
4988 address. Return NULL if not found. */
4991 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4994 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4995 const unsigned char *p
;
4998 if (pure_bytes_used_non_lisp
<= nbytes
)
5001 /* Set up the Boyer-Moore table. */
5003 for (i
= 0; i
< 256; i
++)
5006 p
= (const unsigned char *) data
;
5008 bm_skip
[*p
++] = skip
;
5010 last_char_skip
= bm_skip
['\0'];
5012 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5013 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5015 /* See the comments in the function `boyer_moore' (search.c) for the
5016 use of `infinity'. */
5017 infinity
= pure_bytes_used_non_lisp
+ 1;
5018 bm_skip
['\0'] = infinity
;
5020 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5024 /* Check the last character (== '\0'). */
5027 start
+= bm_skip
[*(p
+ start
)];
5029 while (start
<= start_max
);
5031 if (start
< infinity
)
5032 /* Couldn't find the last character. */
5035 /* No less than `infinity' means we could find the last
5036 character at `p[start - infinity]'. */
5039 /* Check the remaining characters. */
5040 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5042 return non_lisp_beg
+ start
;
5044 start
+= last_char_skip
;
5046 while (start
<= start_max
);
5052 /* Return a string allocated in pure space. DATA is a buffer holding
5053 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5054 means make the result string multibyte.
5056 Must get an error if pure storage is full, since if it cannot hold
5057 a large string it may be able to hold conses that point to that
5058 string; then the string is not protected from gc. */
5061 make_pure_string (const char *data
,
5062 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5065 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5066 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5067 if (s
->data
== NULL
)
5069 s
->data
= pure_alloc (nbytes
+ 1, -1);
5070 memcpy (s
->data
, data
, nbytes
);
5071 s
->data
[nbytes
] = '\0';
5074 s
->size_byte
= multibyte
? nbytes
: -1;
5075 s
->intervals
= NULL
;
5076 XSETSTRING (string
, s
);
5080 /* Return a string allocated in pure space. Do not
5081 allocate the string data, just point to DATA. */
5084 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5087 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5090 s
->data
= (unsigned char *) data
;
5091 s
->intervals
= NULL
;
5092 XSETSTRING (string
, s
);
5096 /* Return a cons allocated from pure space. Give it pure copies
5097 of CAR as car and CDR as cdr. */
5100 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5103 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5105 XSETCAR (new, Fpurecopy (car
));
5106 XSETCDR (new, Fpurecopy (cdr
));
5111 /* Value is a float object with value NUM allocated from pure space. */
5114 make_pure_float (double num
)
5117 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5119 XFLOAT_INIT (new, num
);
5124 /* Return a vector with room for LEN Lisp_Objects allocated from
5128 make_pure_vector (ptrdiff_t len
)
5131 size_t size
= header_size
+ len
* word_size
;
5132 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5133 XSETVECTOR (new, p
);
5134 XVECTOR (new)->header
.size
= len
;
5139 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5140 doc
: /* Make a copy of object OBJ in pure storage.
5141 Recursively copies contents of vectors and cons cells.
5142 Does not copy symbols. Copies strings without text properties. */)
5143 (register Lisp_Object obj
)
5145 if (NILP (Vpurify_flag
))
5148 if (PURE_POINTER_P (XPNTR (obj
)))
5151 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5153 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5159 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5160 else if (FLOATP (obj
))
5161 obj
= make_pure_float (XFLOAT_DATA (obj
));
5162 else if (STRINGP (obj
))
5163 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5165 STRING_MULTIBYTE (obj
));
5166 else if (COMPILEDP (obj
) || VECTORP (obj
))
5168 register struct Lisp_Vector
*vec
;
5169 register ptrdiff_t i
;
5173 if (size
& PSEUDOVECTOR_FLAG
)
5174 size
&= PSEUDOVECTOR_SIZE_MASK
;
5175 vec
= XVECTOR (make_pure_vector (size
));
5176 for (i
= 0; i
< size
; i
++)
5177 vec
->u
.contents
[i
] = Fpurecopy (AREF (obj
, i
));
5178 if (COMPILEDP (obj
))
5180 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5181 XSETCOMPILED (obj
, vec
);
5184 XSETVECTOR (obj
, vec
);
5186 else if (MARKERP (obj
))
5187 error ("Attempt to copy a marker to pure storage");
5189 /* Not purified, don't hash-cons. */
5192 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5193 Fputhash (obj
, obj
, Vpurify_flag
);
5200 /***********************************************************************
5202 ***********************************************************************/
5204 /* Put an entry in staticvec, pointing at the variable with address
5208 staticpro (Lisp_Object
*varaddress
)
5210 if (staticidx
>= NSTATICS
)
5211 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5212 staticvec
[staticidx
++] = varaddress
;
5216 /***********************************************************************
5218 ***********************************************************************/
5220 /* Temporarily prevent garbage collection. */
5223 inhibit_garbage_collection (void)
5225 ptrdiff_t count
= SPECPDL_INDEX ();
5227 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5231 /* Used to avoid possible overflows when
5232 converting from C to Lisp integers. */
5235 bounded_number (EMACS_INT number
)
5237 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5240 /* Calculate total bytes of live objects. */
5243 total_bytes_of_live_objects (void)
5246 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5247 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5248 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5249 tot
+= total_string_bytes
;
5250 tot
+= total_vector_slots
* word_size
;
5251 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5252 tot
+= total_intervals
* sizeof (struct interval
);
5253 tot
+= total_strings
* sizeof (struct Lisp_String
);
5257 #ifdef HAVE_WINDOW_SYSTEM
5259 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5260 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5263 compact_font_cache_entry (Lisp_Object entry
)
5265 Lisp_Object tail
, *prev
= &entry
;
5267 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5270 Lisp_Object obj
= XCAR (tail
);
5272 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5273 if (CONSP (obj
) && FONT_SPEC_P (XCAR (obj
))
5274 && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj
)))
5275 && VECTORP (XCDR (obj
)))
5277 ptrdiff_t i
, size
= ASIZE (XCDR (obj
)) & ~ARRAY_MARK_FLAG
;
5279 /* If font-spec is not marked, most likely all font-entities
5280 are not marked too. But we must be sure that nothing is
5281 marked within OBJ before we really drop it. */
5282 for (i
= 0; i
< size
; i
++)
5283 if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj
), i
))))
5290 *prev
= XCDR (tail
);
5292 prev
= xcdr_addr (tail
);
5297 /* Compact font caches on all terminals and mark
5298 everything which is still here after compaction. */
5301 compact_font_caches (void)
5305 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5307 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5313 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5314 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5316 mark_object (cache
);
5320 #else /* not HAVE_WINDOW_SYSTEM */
5322 #define compact_font_caches() (void)(0)
5324 #endif /* HAVE_WINDOW_SYSTEM */
5326 /* Remove (MARKER . DATA) entries with unmarked MARKER
5327 from buffer undo LIST and return changed list. */
5330 compact_undo_list (Lisp_Object list
)
5332 Lisp_Object tail
, *prev
= &list
;
5334 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5336 if (CONSP (XCAR (tail
))
5337 && MARKERP (XCAR (XCAR (tail
)))
5338 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5339 *prev
= XCDR (tail
);
5341 prev
= xcdr_addr (tail
);
5346 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5347 doc
: /* Reclaim storage for Lisp objects no longer needed.
5348 Garbage collection happens automatically if you cons more than
5349 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5350 `garbage-collect' normally returns a list with info on amount of space in use,
5351 where each entry has the form (NAME SIZE USED FREE), where:
5352 - NAME is a symbol describing the kind of objects this entry represents,
5353 - SIZE is the number of bytes used by each one,
5354 - USED is the number of those objects that were found live in the heap,
5355 - FREE is the number of those objects that are not live but that Emacs
5356 keeps around for future allocations (maybe because it does not know how
5357 to return them to the OS).
5358 However, if there was overflow in pure space, `garbage-collect'
5359 returns nil, because real GC can't be done.
5360 See Info node `(elisp)Garbage Collection'. */)
5363 struct buffer
*nextb
;
5364 char stack_top_variable
;
5367 ptrdiff_t count
= SPECPDL_INDEX ();
5368 struct timespec start
;
5369 Lisp_Object retval
= Qnil
;
5370 size_t tot_before
= 0;
5375 /* Can't GC if pure storage overflowed because we can't determine
5376 if something is a pure object or not. */
5377 if (pure_bytes_used_before_overflow
)
5380 /* Record this function, so it appears on the profiler's backtraces. */
5381 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5385 /* Don't keep undo information around forever.
5386 Do this early on, so it is no problem if the user quits. */
5387 FOR_EACH_BUFFER (nextb
)
5388 compact_buffer (nextb
);
5390 if (profiler_memory_running
)
5391 tot_before
= total_bytes_of_live_objects ();
5393 start
= current_timespec ();
5395 /* In case user calls debug_print during GC,
5396 don't let that cause a recursive GC. */
5397 consing_since_gc
= 0;
5399 /* Save what's currently displayed in the echo area. */
5400 message_p
= push_message ();
5401 record_unwind_protect_void (pop_message_unwind
);
5403 /* Save a copy of the contents of the stack, for debugging. */
5404 #if MAX_SAVE_STACK > 0
5405 if (NILP (Vpurify_flag
))
5408 ptrdiff_t stack_size
;
5409 if (&stack_top_variable
< stack_bottom
)
5411 stack
= &stack_top_variable
;
5412 stack_size
= stack_bottom
- &stack_top_variable
;
5416 stack
= stack_bottom
;
5417 stack_size
= &stack_top_variable
- stack_bottom
;
5419 if (stack_size
<= MAX_SAVE_STACK
)
5421 if (stack_copy_size
< stack_size
)
5423 stack_copy
= xrealloc (stack_copy
, stack_size
);
5424 stack_copy_size
= stack_size
;
5426 memcpy (stack_copy
, stack
, stack_size
);
5429 #endif /* MAX_SAVE_STACK > 0 */
5431 if (garbage_collection_messages
)
5432 message1_nolog ("Garbage collecting...");
5436 shrink_regexp_cache ();
5440 /* Mark all the special slots that serve as the roots of accessibility. */
5442 mark_buffer (&buffer_defaults
);
5443 mark_buffer (&buffer_local_symbols
);
5445 for (i
= 0; i
< staticidx
; i
++)
5446 mark_object (*staticvec
[i
]);
5456 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5457 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5461 register struct gcpro
*tail
;
5462 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5463 for (i
= 0; i
< tail
->nvars
; i
++)
5464 mark_object (tail
->var
[i
]);
5469 struct handler
*handler
;
5470 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5472 mark_object (handler
->tag_or_ch
);
5473 mark_object (handler
->val
);
5476 #ifdef HAVE_WINDOW_SYSTEM
5477 mark_fringe_data ();
5480 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5484 /* Everything is now marked, except for the data in font caches
5485 and undo lists. They're compacted by removing an items which
5486 aren't reachable otherwise. */
5488 compact_font_caches ();
5490 FOR_EACH_BUFFER (nextb
)
5492 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5493 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5494 /* Now that we have stripped the elements that need not be
5495 in the undo_list any more, we can finally mark the list. */
5496 mark_object (BVAR (nextb
, undo_list
));
5501 /* Clear the mark bits that we set in certain root slots. */
5503 unmark_byte_stack ();
5504 VECTOR_UNMARK (&buffer_defaults
);
5505 VECTOR_UNMARK (&buffer_local_symbols
);
5507 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5517 consing_since_gc
= 0;
5518 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5519 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5521 gc_relative_threshold
= 0;
5522 if (FLOATP (Vgc_cons_percentage
))
5523 { /* Set gc_cons_combined_threshold. */
5524 double tot
= total_bytes_of_live_objects ();
5526 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5529 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5530 gc_relative_threshold
= tot
;
5532 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5536 if (garbage_collection_messages
)
5538 if (message_p
|| minibuf_level
> 0)
5541 message1_nolog ("Garbage collecting...done");
5544 unbind_to (count
, Qnil
);
5546 Lisp_Object total
[11];
5547 int total_size
= 10;
5549 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5550 bounded_number (total_conses
),
5551 bounded_number (total_free_conses
));
5553 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5554 bounded_number (total_symbols
),
5555 bounded_number (total_free_symbols
));
5557 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5558 bounded_number (total_markers
),
5559 bounded_number (total_free_markers
));
5561 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5562 bounded_number (total_strings
),
5563 bounded_number (total_free_strings
));
5565 total
[4] = list3 (Qstring_bytes
, make_number (1),
5566 bounded_number (total_string_bytes
));
5568 total
[5] = list3 (Qvectors
,
5569 make_number (header_size
+ sizeof (Lisp_Object
)),
5570 bounded_number (total_vectors
));
5572 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5573 bounded_number (total_vector_slots
),
5574 bounded_number (total_free_vector_slots
));
5576 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5577 bounded_number (total_floats
),
5578 bounded_number (total_free_floats
));
5580 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5581 bounded_number (total_intervals
),
5582 bounded_number (total_free_intervals
));
5584 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5585 bounded_number (total_buffers
));
5587 #ifdef DOUG_LEA_MALLOC
5589 total
[10] = list4 (Qheap
, make_number (1024),
5590 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5591 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5593 retval
= Flist (total_size
, total
);
5596 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5598 /* Compute average percentage of zombies. */
5600 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5601 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5603 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5604 max_live
= max (nlive
, max_live
);
5605 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5606 max_zombies
= max (nzombies
, max_zombies
);
5611 if (!NILP (Vpost_gc_hook
))
5613 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5614 safe_run_hooks (Qpost_gc_hook
);
5615 unbind_to (gc_count
, Qnil
);
5618 /* Accumulate statistics. */
5619 if (FLOATP (Vgc_elapsed
))
5621 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5622 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5623 + timespectod (since_start
));
5628 /* Collect profiling data. */
5629 if (profiler_memory_running
)
5632 size_t tot_after
= total_bytes_of_live_objects ();
5633 if (tot_before
> tot_after
)
5634 swept
= tot_before
- tot_after
;
5635 malloc_probe (swept
);
5642 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5643 only interesting objects referenced from glyphs are strings. */
5646 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5648 struct glyph_row
*row
= matrix
->rows
;
5649 struct glyph_row
*end
= row
+ matrix
->nrows
;
5651 for (; row
< end
; ++row
)
5655 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5657 struct glyph
*glyph
= row
->glyphs
[area
];
5658 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5660 for (; glyph
< end_glyph
; ++glyph
)
5661 if (STRINGP (glyph
->object
)
5662 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5663 mark_object (glyph
->object
);
5668 /* Mark reference to a Lisp_Object.
5669 If the object referred to has not been seen yet, recursively mark
5670 all the references contained in it. */
5672 #define LAST_MARKED_SIZE 500
5673 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5674 static int last_marked_index
;
5676 /* For debugging--call abort when we cdr down this many
5677 links of a list, in mark_object. In debugging,
5678 the call to abort will hit a breakpoint.
5679 Normally this is zero and the check never goes off. */
5680 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5683 mark_vectorlike (struct Lisp_Vector
*ptr
)
5685 ptrdiff_t size
= ptr
->header
.size
;
5688 eassert (!VECTOR_MARKED_P (ptr
));
5689 VECTOR_MARK (ptr
); /* Else mark it. */
5690 if (size
& PSEUDOVECTOR_FLAG
)
5691 size
&= PSEUDOVECTOR_SIZE_MASK
;
5693 /* Note that this size is not the memory-footprint size, but only
5694 the number of Lisp_Object fields that we should trace.
5695 The distinction is used e.g. by Lisp_Process which places extra
5696 non-Lisp_Object fields at the end of the structure... */
5697 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5698 mark_object (ptr
->u
.contents
[i
]);
5701 /* Like mark_vectorlike but optimized for char-tables (and
5702 sub-char-tables) assuming that the contents are mostly integers or
5706 mark_char_table (struct Lisp_Vector
*ptr
)
5708 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5711 eassert (!VECTOR_MARKED_P (ptr
));
5713 for (i
= 0; i
< size
; i
++)
5715 Lisp_Object val
= ptr
->u
.contents
[i
];
5717 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5719 if (SUB_CHAR_TABLE_P (val
))
5721 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5722 mark_char_table (XVECTOR (val
));
5729 /* Mark the chain of overlays starting at PTR. */
5732 mark_overlay (struct Lisp_Overlay
*ptr
)
5734 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5737 mark_object (ptr
->start
);
5738 mark_object (ptr
->end
);
5739 mark_object (ptr
->plist
);
5743 /* Mark Lisp_Objects and special pointers in BUFFER. */
5746 mark_buffer (struct buffer
*buffer
)
5748 /* This is handled much like other pseudovectors... */
5749 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5751 /* ...but there are some buffer-specific things. */
5753 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5755 /* For now, we just don't mark the undo_list. It's done later in
5756 a special way just before the sweep phase, and after stripping
5757 some of its elements that are not needed any more. */
5759 mark_overlay (buffer
->overlays_before
);
5760 mark_overlay (buffer
->overlays_after
);
5762 /* If this is an indirect buffer, mark its base buffer. */
5763 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5764 mark_buffer (buffer
->base_buffer
);
5767 /* Mark Lisp faces in the face cache C. */
5770 mark_face_cache (struct face_cache
*c
)
5775 for (i
= 0; i
< c
->used
; ++i
)
5777 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5781 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
5782 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
5784 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5785 mark_object (face
->lface
[j
]);
5791 /* Remove killed buffers or items whose car is a killed buffer from
5792 LIST, and mark other items. Return changed LIST, which is marked. */
5795 mark_discard_killed_buffers (Lisp_Object list
)
5797 Lisp_Object tail
, *prev
= &list
;
5799 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5802 Lisp_Object tem
= XCAR (tail
);
5805 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5806 *prev
= XCDR (tail
);
5809 CONS_MARK (XCONS (tail
));
5810 mark_object (XCAR (tail
));
5811 prev
= xcdr_addr (tail
);
5818 /* Determine type of generic Lisp_Object and mark it accordingly. */
5821 mark_object (Lisp_Object arg
)
5823 register Lisp_Object obj
= arg
;
5824 #ifdef GC_CHECK_MARKED_OBJECTS
5828 ptrdiff_t cdr_count
= 0;
5832 if (PURE_POINTER_P (XPNTR (obj
)))
5835 last_marked
[last_marked_index
++] = obj
;
5836 if (last_marked_index
== LAST_MARKED_SIZE
)
5837 last_marked_index
= 0;
5839 /* Perform some sanity checks on the objects marked here. Abort if
5840 we encounter an object we know is bogus. This increases GC time
5841 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5842 #ifdef GC_CHECK_MARKED_OBJECTS
5844 po
= (void *) XPNTR (obj
);
5846 /* Check that the object pointed to by PO is known to be a Lisp
5847 structure allocated from the heap. */
5848 #define CHECK_ALLOCATED() \
5850 m = mem_find (po); \
5855 /* Check that the object pointed to by PO is live, using predicate
5857 #define CHECK_LIVE(LIVEP) \
5859 if (!LIVEP (m, po)) \
5863 /* Check both of the above conditions. */
5864 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5866 CHECK_ALLOCATED (); \
5867 CHECK_LIVE (LIVEP); \
5870 #else /* not GC_CHECK_MARKED_OBJECTS */
5872 #define CHECK_LIVE(LIVEP) (void) 0
5873 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5875 #endif /* not GC_CHECK_MARKED_OBJECTS */
5877 switch (XTYPE (obj
))
5881 register struct Lisp_String
*ptr
= XSTRING (obj
);
5882 if (STRING_MARKED_P (ptr
))
5884 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5886 MARK_INTERVAL_TREE (ptr
->intervals
);
5887 #ifdef GC_CHECK_STRING_BYTES
5888 /* Check that the string size recorded in the string is the
5889 same as the one recorded in the sdata structure. */
5891 #endif /* GC_CHECK_STRING_BYTES */
5895 case Lisp_Vectorlike
:
5897 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5898 register ptrdiff_t pvectype
;
5900 if (VECTOR_MARKED_P (ptr
))
5903 #ifdef GC_CHECK_MARKED_OBJECTS
5905 if (m
== MEM_NIL
&& !SUBRP (obj
))
5907 #endif /* GC_CHECK_MARKED_OBJECTS */
5909 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5910 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5911 >> PSEUDOVECTOR_AREA_BITS
);
5913 pvectype
= PVEC_NORMAL_VECTOR
;
5915 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5916 CHECK_LIVE (live_vector_p
);
5921 #ifdef GC_CHECK_MARKED_OBJECTS
5930 #endif /* GC_CHECK_MARKED_OBJECTS */
5931 mark_buffer ((struct buffer
*) ptr
);
5935 { /* We could treat this just like a vector, but it is better
5936 to save the COMPILED_CONSTANTS element for last and avoid
5938 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5942 for (i
= 0; i
< size
; i
++)
5943 if (i
!= COMPILED_CONSTANTS
)
5944 mark_object (ptr
->u
.contents
[i
]);
5945 if (size
> COMPILED_CONSTANTS
)
5947 obj
= ptr
->u
.contents
[COMPILED_CONSTANTS
];
5955 struct frame
*f
= (struct frame
*) ptr
;
5957 mark_vectorlike (ptr
);
5958 mark_face_cache (f
->face_cache
);
5959 #ifdef HAVE_WINDOW_SYSTEM
5960 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
5962 struct font
*font
= FRAME_FONT (f
);
5964 if (font
&& !VECTOR_MARKED_P (font
))
5965 mark_vectorlike ((struct Lisp_Vector
*) font
);
5973 struct window
*w
= (struct window
*) ptr
;
5975 mark_vectorlike (ptr
);
5977 /* Mark glyph matrices, if any. Marking window
5978 matrices is sufficient because frame matrices
5979 use the same glyph memory. */
5980 if (w
->current_matrix
)
5982 mark_glyph_matrix (w
->current_matrix
);
5983 mark_glyph_matrix (w
->desired_matrix
);
5986 /* Filter out killed buffers from both buffer lists
5987 in attempt to help GC to reclaim killed buffers faster.
5988 We can do it elsewhere for live windows, but this is the
5989 best place to do it for dead windows. */
5991 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5993 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5997 case PVEC_HASH_TABLE
:
5999 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6001 mark_vectorlike (ptr
);
6002 mark_object (h
->test
.name
);
6003 mark_object (h
->test
.user_hash_function
);
6004 mark_object (h
->test
.user_cmp_function
);
6005 /* If hash table is not weak, mark all keys and values.
6006 For weak tables, mark only the vector. */
6008 mark_object (h
->key_and_value
);
6010 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6014 case PVEC_CHAR_TABLE
:
6015 mark_char_table (ptr
);
6018 case PVEC_BOOL_VECTOR
:
6019 /* No Lisp_Objects to mark in a bool vector. */
6030 mark_vectorlike (ptr
);
6037 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6038 struct Lisp_Symbol
*ptrx
;
6042 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6044 mark_object (ptr
->function
);
6045 mark_object (ptr
->plist
);
6046 switch (ptr
->redirect
)
6048 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6049 case SYMBOL_VARALIAS
:
6052 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6056 case SYMBOL_LOCALIZED
:
6058 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6059 Lisp_Object where
= blv
->where
;
6060 /* If the value is set up for a killed buffer or deleted
6061 frame, restore it's global binding. If the value is
6062 forwarded to a C variable, either it's not a Lisp_Object
6063 var, or it's staticpro'd already. */
6064 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6065 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6066 swap_in_global_binding (ptr
);
6067 mark_object (blv
->where
);
6068 mark_object (blv
->valcell
);
6069 mark_object (blv
->defcell
);
6072 case SYMBOL_FORWARDED
:
6073 /* If the value is forwarded to a buffer or keyboard field,
6074 these are marked when we see the corresponding object.
6075 And if it's forwarded to a C variable, either it's not
6076 a Lisp_Object var, or it's staticpro'd already. */
6078 default: emacs_abort ();
6080 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6081 MARK_STRING (XSTRING (ptr
->name
));
6082 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6087 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6088 XSETSYMBOL (obj
, ptrx
);
6095 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6097 if (XMISCANY (obj
)->gcmarkbit
)
6100 switch (XMISCTYPE (obj
))
6102 case Lisp_Misc_Marker
:
6103 /* DO NOT mark thru the marker's chain.
6104 The buffer's markers chain does not preserve markers from gc;
6105 instead, markers are removed from the chain when freed by gc. */
6106 XMISCANY (obj
)->gcmarkbit
= 1;
6109 case Lisp_Misc_Save_Value
:
6110 XMISCANY (obj
)->gcmarkbit
= 1;
6112 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6113 /* If `save_type' is zero, `data[0].pointer' is the address
6114 of a memory area containing `data[1].integer' potential
6116 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6118 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6120 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6121 mark_maybe_object (*p
);
6125 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6127 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6128 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6129 mark_object (ptr
->data
[i
].object
);
6134 case Lisp_Misc_Overlay
:
6135 mark_overlay (XOVERLAY (obj
));
6145 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6146 if (CONS_MARKED_P (ptr
))
6148 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6150 /* If the cdr is nil, avoid recursion for the car. */
6151 if (EQ (ptr
->u
.cdr
, Qnil
))
6157 mark_object (ptr
->car
);
6160 if (cdr_count
== mark_object_loop_halt
)
6166 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6167 FLOAT_MARK (XFLOAT (obj
));
6178 #undef CHECK_ALLOCATED
6179 #undef CHECK_ALLOCATED_AND_LIVE
6181 /* Mark the Lisp pointers in the terminal objects.
6182 Called by Fgarbage_collect. */
6185 mark_terminals (void)
6188 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6190 eassert (t
->name
!= NULL
);
6191 #ifdef HAVE_WINDOW_SYSTEM
6192 /* If a terminal object is reachable from a stacpro'ed object,
6193 it might have been marked already. Make sure the image cache
6195 mark_image_cache (t
->image_cache
);
6196 #endif /* HAVE_WINDOW_SYSTEM */
6197 if (!VECTOR_MARKED_P (t
))
6198 mark_vectorlike ((struct Lisp_Vector
*)t
);
6204 /* Value is non-zero if OBJ will survive the current GC because it's
6205 either marked or does not need to be marked to survive. */
6208 survives_gc_p (Lisp_Object obj
)
6212 switch (XTYPE (obj
))
6219 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6223 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6227 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6230 case Lisp_Vectorlike
:
6231 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6235 survives_p
= CONS_MARKED_P (XCONS (obj
));
6239 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6246 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6251 /* Sweep: find all structures not marked, and free them. */
6256 /* Remove or mark entries in weak hash tables.
6257 This must be done before any object is unmarked. */
6258 sweep_weak_hash_tables ();
6261 check_string_bytes (!noninteractive
);
6263 /* Put all unmarked conses on free list */
6265 register struct cons_block
*cblk
;
6266 struct cons_block
**cprev
= &cons_block
;
6267 register int lim
= cons_block_index
;
6268 EMACS_INT num_free
= 0, num_used
= 0;
6272 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6276 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6278 /* Scan the mark bits an int at a time. */
6279 for (i
= 0; i
< ilim
; i
++)
6281 if (cblk
->gcmarkbits
[i
] == -1)
6283 /* Fast path - all cons cells for this int are marked. */
6284 cblk
->gcmarkbits
[i
] = 0;
6285 num_used
+= BITS_PER_INT
;
6289 /* Some cons cells for this int are not marked.
6290 Find which ones, and free them. */
6291 int start
, pos
, stop
;
6293 start
= i
* BITS_PER_INT
;
6295 if (stop
> BITS_PER_INT
)
6296 stop
= BITS_PER_INT
;
6299 for (pos
= start
; pos
< stop
; pos
++)
6301 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6304 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6305 cons_free_list
= &cblk
->conses
[pos
];
6307 cons_free_list
->car
= Vdead
;
6313 CONS_UNMARK (&cblk
->conses
[pos
]);
6319 lim
= CONS_BLOCK_SIZE
;
6320 /* If this block contains only free conses and we have already
6321 seen more than two blocks worth of free conses then deallocate
6323 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6325 *cprev
= cblk
->next
;
6326 /* Unhook from the free list. */
6327 cons_free_list
= cblk
->conses
[0].u
.chain
;
6328 lisp_align_free (cblk
);
6332 num_free
+= this_free
;
6333 cprev
= &cblk
->next
;
6336 total_conses
= num_used
;
6337 total_free_conses
= num_free
;
6340 /* Put all unmarked floats on free list */
6342 register struct float_block
*fblk
;
6343 struct float_block
**fprev
= &float_block
;
6344 register int lim
= float_block_index
;
6345 EMACS_INT num_free
= 0, num_used
= 0;
6347 float_free_list
= 0;
6349 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6353 for (i
= 0; i
< lim
; i
++)
6354 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6357 fblk
->floats
[i
].u
.chain
= float_free_list
;
6358 float_free_list
= &fblk
->floats
[i
];
6363 FLOAT_UNMARK (&fblk
->floats
[i
]);
6365 lim
= FLOAT_BLOCK_SIZE
;
6366 /* If this block contains only free floats and we have already
6367 seen more than two blocks worth of free floats then deallocate
6369 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6371 *fprev
= fblk
->next
;
6372 /* Unhook from the free list. */
6373 float_free_list
= fblk
->floats
[0].u
.chain
;
6374 lisp_align_free (fblk
);
6378 num_free
+= this_free
;
6379 fprev
= &fblk
->next
;
6382 total_floats
= num_used
;
6383 total_free_floats
= num_free
;
6386 /* Put all unmarked intervals on free list */
6388 register struct interval_block
*iblk
;
6389 struct interval_block
**iprev
= &interval_block
;
6390 register int lim
= interval_block_index
;
6391 EMACS_INT num_free
= 0, num_used
= 0;
6393 interval_free_list
= 0;
6395 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6400 for (i
= 0; i
< lim
; i
++)
6402 if (!iblk
->intervals
[i
].gcmarkbit
)
6404 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6405 interval_free_list
= &iblk
->intervals
[i
];
6411 iblk
->intervals
[i
].gcmarkbit
= 0;
6414 lim
= INTERVAL_BLOCK_SIZE
;
6415 /* If this block contains only free intervals and we have already
6416 seen more than two blocks worth of free intervals then
6417 deallocate this block. */
6418 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6420 *iprev
= iblk
->next
;
6421 /* Unhook from the free list. */
6422 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6427 num_free
+= this_free
;
6428 iprev
= &iblk
->next
;
6431 total_intervals
= num_used
;
6432 total_free_intervals
= num_free
;
6435 /* Put all unmarked symbols on free list */
6437 register struct symbol_block
*sblk
;
6438 struct symbol_block
**sprev
= &symbol_block
;
6439 register int lim
= symbol_block_index
;
6440 EMACS_INT num_free
= 0, num_used
= 0;
6442 symbol_free_list
= NULL
;
6444 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6447 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6448 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6450 for (; sym
< end
; ++sym
)
6452 /* Check if the symbol was created during loadup. In such a case
6453 it might be pointed to by pure bytecode which we don't trace,
6454 so we conservatively assume that it is live. */
6455 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6457 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6459 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6460 xfree (SYMBOL_BLV (&sym
->s
));
6461 sym
->s
.next
= symbol_free_list
;
6462 symbol_free_list
= &sym
->s
;
6464 symbol_free_list
->function
= Vdead
;
6472 UNMARK_STRING (XSTRING (sym
->s
.name
));
6473 sym
->s
.gcmarkbit
= 0;
6477 lim
= SYMBOL_BLOCK_SIZE
;
6478 /* If this block contains only free symbols and we have already
6479 seen more than two blocks worth of free symbols then deallocate
6481 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6483 *sprev
= sblk
->next
;
6484 /* Unhook from the free list. */
6485 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6490 num_free
+= this_free
;
6491 sprev
= &sblk
->next
;
6494 total_symbols
= num_used
;
6495 total_free_symbols
= num_free
;
6498 /* Put all unmarked misc's on free list.
6499 For a marker, first unchain it from the buffer it points into. */
6501 register struct marker_block
*mblk
;
6502 struct marker_block
**mprev
= &marker_block
;
6503 register int lim
= marker_block_index
;
6504 EMACS_INT num_free
= 0, num_used
= 0;
6506 marker_free_list
= 0;
6508 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6513 for (i
= 0; i
< lim
; i
++)
6515 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6517 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6518 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6519 /* Set the type of the freed object to Lisp_Misc_Free.
6520 We could leave the type alone, since nobody checks it,
6521 but this might catch bugs faster. */
6522 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6523 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6524 marker_free_list
= &mblk
->markers
[i
].m
;
6530 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6533 lim
= MARKER_BLOCK_SIZE
;
6534 /* If this block contains only free markers and we have already
6535 seen more than two blocks worth of free markers then deallocate
6537 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6539 *mprev
= mblk
->next
;
6540 /* Unhook from the free list. */
6541 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6546 num_free
+= this_free
;
6547 mprev
= &mblk
->next
;
6551 total_markers
= num_used
;
6552 total_free_markers
= num_free
;
6555 /* Free all unmarked buffers */
6557 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6560 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6561 if (!VECTOR_MARKED_P (buffer
))
6563 *bprev
= buffer
->next
;
6568 VECTOR_UNMARK (buffer
);
6569 /* Do not use buffer_(set|get)_intervals here. */
6570 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6572 bprev
= &buffer
->next
;
6577 check_string_bytes (!noninteractive
);
6583 /* Debugging aids. */
6585 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6586 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6587 This may be helpful in debugging Emacs's memory usage.
6588 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6593 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6598 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6599 doc
: /* Return a list of counters that measure how much consing there has been.
6600 Each of these counters increments for a certain kind of object.
6601 The counters wrap around from the largest positive integer to zero.
6602 Garbage collection does not decrease them.
6603 The elements of the value are as follows:
6604 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6605 All are in units of 1 = one object consed
6606 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6608 MISCS include overlays, markers, and some internal types.
6609 Frames, windows, buffers, and subprocesses count as vectors
6610 (but the contents of a buffer's text do not count here). */)
6613 return listn (CONSTYPE_HEAP
, 8,
6614 bounded_number (cons_cells_consed
),
6615 bounded_number (floats_consed
),
6616 bounded_number (vector_cells_consed
),
6617 bounded_number (symbols_consed
),
6618 bounded_number (string_chars_consed
),
6619 bounded_number (misc_objects_consed
),
6620 bounded_number (intervals_consed
),
6621 bounded_number (strings_consed
));
6624 /* Find at most FIND_MAX symbols which have OBJ as their value or
6625 function. This is used in gdbinit's `xwhichsymbols' command. */
6628 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6630 struct symbol_block
*sblk
;
6631 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6632 Lisp_Object found
= Qnil
;
6636 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6638 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6641 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6643 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6647 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6650 XSETSYMBOL (tem
, sym
);
6651 val
= find_symbol_value (tem
);
6653 || EQ (sym
->function
, obj
)
6654 || (!NILP (sym
->function
)
6655 && COMPILEDP (sym
->function
)
6656 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6659 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6661 found
= Fcons (tem
, found
);
6662 if (--find_max
== 0)
6670 unbind_to (gc_count
, Qnil
);
6674 #ifdef ENABLE_CHECKING
6676 bool suppress_checking
;
6679 die (const char *msg
, const char *file
, int line
)
6681 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6683 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6687 /* Initialization. */
6690 init_alloc_once (void)
6692 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6694 pure_size
= PURESIZE
;
6696 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6698 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6701 #ifdef DOUG_LEA_MALLOC
6702 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6703 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6704 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6709 refill_memory_reserve ();
6710 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6717 byte_stack_list
= 0;
6719 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6720 setjmp_tested_p
= longjmps_done
= 0;
6723 Vgc_elapsed
= make_float (0.0);
6727 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
6732 syms_of_alloc (void)
6734 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6735 doc
: /* Number of bytes of consing between garbage collections.
6736 Garbage collection can happen automatically once this many bytes have been
6737 allocated since the last garbage collection. All data types count.
6739 Garbage collection happens automatically only when `eval' is called.
6741 By binding this temporarily to a large number, you can effectively
6742 prevent garbage collection during a part of the program.
6743 See also `gc-cons-percentage'. */);
6745 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6746 doc
: /* Portion of the heap used for allocation.
6747 Garbage collection can happen automatically once this portion of the heap
6748 has been allocated since the last garbage collection.
6749 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6750 Vgc_cons_percentage
= make_float (0.1);
6752 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6753 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6755 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6756 doc
: /* Number of cons cells that have been consed so far. */);
6758 DEFVAR_INT ("floats-consed", floats_consed
,
6759 doc
: /* Number of floats that have been consed so far. */);
6761 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6762 doc
: /* Number of vector cells that have been consed so far. */);
6764 DEFVAR_INT ("symbols-consed", symbols_consed
,
6765 doc
: /* Number of symbols that have been consed so far. */);
6767 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6768 doc
: /* Number of string characters that have been consed so far. */);
6770 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6771 doc
: /* Number of miscellaneous objects that have been consed so far.
6772 These include markers and overlays, plus certain objects not visible
6775 DEFVAR_INT ("intervals-consed", intervals_consed
,
6776 doc
: /* Number of intervals that have been consed so far. */);
6778 DEFVAR_INT ("strings-consed", strings_consed
,
6779 doc
: /* Number of strings that have been consed so far. */);
6781 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6782 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6783 This means that certain objects should be allocated in shared (pure) space.
6784 It can also be set to a hash-table, in which case this table is used to
6785 do hash-consing of the objects allocated to pure space. */);
6787 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6788 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6789 garbage_collection_messages
= 0;
6791 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6792 doc
: /* Hook run after garbage collection has finished. */);
6793 Vpost_gc_hook
= Qnil
;
6794 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6796 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6797 doc
: /* Precomputed `signal' argument for memory-full error. */);
6798 /* We build this in advance because if we wait until we need it, we might
6799 not be able to allocate the memory to hold it. */
6801 = listn (CONSTYPE_PURE
, 2, Qerror
,
6802 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6804 DEFVAR_LISP ("memory-full", Vmemory_full
,
6805 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6806 Vmemory_full
= Qnil
;
6808 DEFSYM (Qconses
, "conses");
6809 DEFSYM (Qsymbols
, "symbols");
6810 DEFSYM (Qmiscs
, "miscs");
6811 DEFSYM (Qstrings
, "strings");
6812 DEFSYM (Qvectors
, "vectors");
6813 DEFSYM (Qfloats
, "floats");
6814 DEFSYM (Qintervals
, "intervals");
6815 DEFSYM (Qbuffers
, "buffers");
6816 DEFSYM (Qstring_bytes
, "string-bytes");
6817 DEFSYM (Qvector_slots
, "vector-slots");
6818 DEFSYM (Qheap
, "heap");
6819 DEFSYM (Qautomatic_gc
, "Automatic GC");
6821 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6822 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6824 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6825 doc
: /* Accumulated time elapsed in garbage collections.
6826 The time is in seconds as a floating point value. */);
6827 DEFVAR_INT ("gcs-done", gcs_done
,
6828 doc
: /* Accumulated number of garbage collections done. */);
6833 defsubr (&Smake_byte_code
);
6834 defsubr (&Smake_list
);
6835 defsubr (&Smake_vector
);
6836 defsubr (&Smake_string
);
6837 defsubr (&Smake_bool_vector
);
6838 defsubr (&Smake_symbol
);
6839 defsubr (&Smake_marker
);
6840 defsubr (&Spurecopy
);
6841 defsubr (&Sgarbage_collect
);
6842 defsubr (&Smemory_limit
);
6843 defsubr (&Smemory_use_counts
);
6845 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6846 defsubr (&Sgc_status
);
6850 /* When compiled with GCC, GDB might say "No enum type named
6851 pvec_type" if we don't have at least one symbol with that type, and
6852 then xbacktrace could fail. Similarly for the other enums and
6853 their values. Some non-GCC compilers don't like these constructs. */
6857 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6858 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6859 enum char_bits char_bits
;
6860 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6861 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6862 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6863 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6864 enum Lisp_Bits Lisp_Bits
;
6865 enum Lisp_Compiled Lisp_Compiled
;
6866 enum maxargs maxargs
;
6867 enum MAX_ALLOCA MAX_ALLOCA
;
6868 enum More_Lisp_Bits More_Lisp_Bits
;
6869 enum pvec_type pvec_type
;
6870 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6871 #endif /* __GNUC__ */