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 /* Release extra resources still in use by VECTOR, which may be any
2841 vector-like object. For now, this is used just to free data in
2845 cleanup_vector (struct Lisp_Vector
*vector
)
2847 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
2848 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
2849 == FONT_OBJECT_MAX
))
2850 ((struct font
*) vector
)->driver
->close ((struct font
*) vector
);
2853 /* Reclaim space used by unmarked vectors. */
2856 sweep_vectors (void)
2858 struct vector_block
*block
, **bprev
= &vector_blocks
;
2859 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2860 struct Lisp_Vector
*vector
, *next
;
2862 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2863 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2865 /* Looking through vector blocks. */
2867 for (block
= vector_blocks
; block
; block
= *bprev
)
2869 bool free_this_block
= 0;
2872 for (vector
= (struct Lisp_Vector
*) block
->data
;
2873 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2875 if (VECTOR_MARKED_P (vector
))
2877 VECTOR_UNMARK (vector
);
2879 nbytes
= vector_nbytes (vector
);
2880 total_vector_slots
+= nbytes
/ word_size
;
2881 next
= ADVANCE (vector
, nbytes
);
2885 ptrdiff_t total_bytes
;
2887 cleanup_vector (vector
);
2888 nbytes
= vector_nbytes (vector
);
2889 total_bytes
= nbytes
;
2890 next
= ADVANCE (vector
, nbytes
);
2892 /* While NEXT is not marked, try to coalesce with VECTOR,
2893 thus making VECTOR of the largest possible size. */
2895 while (VECTOR_IN_BLOCK (next
, block
))
2897 if (VECTOR_MARKED_P (next
))
2899 cleanup_vector (next
);
2900 nbytes
= vector_nbytes (next
);
2901 total_bytes
+= nbytes
;
2902 next
= ADVANCE (next
, nbytes
);
2905 eassert (total_bytes
% roundup_size
== 0);
2907 if (vector
== (struct Lisp_Vector
*) block
->data
2908 && !VECTOR_IN_BLOCK (next
, block
))
2909 /* This block should be freed because all of it's
2910 space was coalesced into the only free vector. */
2911 free_this_block
= 1;
2915 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2920 if (free_this_block
)
2922 *bprev
= block
->next
;
2923 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2924 mem_delete (mem_find (block
->data
));
2929 bprev
= &block
->next
;
2932 /* Sweep large vectors. */
2934 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2937 if (VECTOR_MARKED_P (vector
))
2939 VECTOR_UNMARK (vector
);
2941 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2943 /* All non-bool pseudovectors are small enough to be allocated
2944 from vector blocks. This code should be redesigned if some
2945 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2946 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2947 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
2951 += header_size
/ word_size
+ vector
->header
.size
;
2952 lvprev
= &lv
->next
.vector
;
2956 *lvprev
= lv
->next
.vector
;
2962 /* Value is a pointer to a newly allocated Lisp_Vector structure
2963 with room for LEN Lisp_Objects. */
2965 static struct Lisp_Vector
*
2966 allocate_vectorlike (ptrdiff_t len
)
2968 struct Lisp_Vector
*p
;
2973 p
= XVECTOR (zero_vector
);
2976 size_t nbytes
= header_size
+ len
* word_size
;
2978 #ifdef DOUG_LEA_MALLOC
2979 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2980 because mapped region contents are not preserved in
2982 mallopt (M_MMAP_MAX
, 0);
2985 if (nbytes
<= VBLOCK_BYTES_MAX
)
2986 p
= allocate_vector_from_block (vroundup (nbytes
));
2989 struct large_vector
*lv
2990 = lisp_malloc ((offsetof (struct large_vector
, v
.u
.contents
)
2992 MEM_TYPE_VECTORLIKE
);
2993 lv
->next
.vector
= large_vectors
;
2998 #ifdef DOUG_LEA_MALLOC
2999 /* Back to a reasonable maximum of mmap'ed areas. */
3000 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3003 consing_since_gc
+= nbytes
;
3004 vector_cells_consed
+= len
;
3007 MALLOC_UNBLOCK_INPUT
;
3013 /* Allocate a vector with LEN slots. */
3015 struct Lisp_Vector
*
3016 allocate_vector (EMACS_INT len
)
3018 struct Lisp_Vector
*v
;
3019 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3021 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3022 memory_full (SIZE_MAX
);
3023 v
= allocate_vectorlike (len
);
3024 v
->header
.size
= len
;
3029 /* Allocate other vector-like structures. */
3031 struct Lisp_Vector
*
3032 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3034 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3037 /* Catch bogus values. */
3038 eassert (tag
<= PVEC_FONT
);
3039 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3040 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3042 /* Only the first lisplen slots will be traced normally by the GC. */
3043 for (i
= 0; i
< lisplen
; ++i
)
3044 v
->u
.contents
[i
] = Qnil
;
3046 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3051 allocate_buffer (void)
3053 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3055 BUFFER_PVEC_INIT (b
);
3056 /* Put B on the chain of all buffers including killed ones. */
3057 b
->next
= all_buffers
;
3059 /* Note that the rest fields of B are not initialized. */
3063 struct Lisp_Hash_Table
*
3064 allocate_hash_table (void)
3066 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3070 allocate_window (void)
3074 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3075 /* Users assumes that non-Lisp data is zeroed. */
3076 memset (&w
->current_matrix
, 0,
3077 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3082 allocate_terminal (void)
3086 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3087 /* Users assumes that non-Lisp data is zeroed. */
3088 memset (&t
->next_terminal
, 0,
3089 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3094 allocate_frame (void)
3098 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3099 /* Users assumes that non-Lisp data is zeroed. */
3100 memset (&f
->face_cache
, 0,
3101 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3105 struct Lisp_Process
*
3106 allocate_process (void)
3108 struct Lisp_Process
*p
;
3110 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3111 /* Users assumes that non-Lisp data is zeroed. */
3113 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3117 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3118 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3119 See also the function `vector'. */)
3120 (register Lisp_Object length
, Lisp_Object init
)
3123 register ptrdiff_t sizei
;
3124 register ptrdiff_t i
;
3125 register struct Lisp_Vector
*p
;
3127 CHECK_NATNUM (length
);
3129 p
= allocate_vector (XFASTINT (length
));
3130 sizei
= XFASTINT (length
);
3131 for (i
= 0; i
< sizei
; i
++)
3132 p
->u
.contents
[i
] = init
;
3134 XSETVECTOR (vector
, p
);
3139 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3140 doc
: /* Return a newly created vector with specified arguments as elements.
3141 Any number of arguments, even zero arguments, are allowed.
3142 usage: (vector &rest OBJECTS) */)
3143 (ptrdiff_t nargs
, Lisp_Object
*args
)
3146 register Lisp_Object val
= make_uninit_vector (nargs
);
3147 register struct Lisp_Vector
*p
= XVECTOR (val
);
3149 for (i
= 0; i
< nargs
; i
++)
3150 p
->u
.contents
[i
] = args
[i
];
3155 make_byte_code (struct Lisp_Vector
*v
)
3157 /* Don't allow the global zero_vector to become a byte code object. */
3158 eassert(0 < v
->header
.size
);
3159 if (v
->header
.size
> 1 && STRINGP (v
->u
.contents
[1])
3160 && STRING_MULTIBYTE (v
->u
.contents
[1]))
3161 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3162 earlier because they produced a raw 8-bit string for byte-code
3163 and now such a byte-code string is loaded as multibyte while
3164 raw 8-bit characters converted to multibyte form. Thus, now we
3165 must convert them back to the original unibyte form. */
3166 v
->u
.contents
[1] = Fstring_as_unibyte (v
->u
.contents
[1]);
3167 XSETPVECTYPE (v
, PVEC_COMPILED
);
3170 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3171 doc
: /* Create a byte-code object with specified arguments as elements.
3172 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3173 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3174 and (optional) INTERACTIVE-SPEC.
3175 The first four arguments are required; at most six have any
3177 The ARGLIST can be either like the one of `lambda', in which case the arguments
3178 will be dynamically bound before executing the byte code, or it can be an
3179 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3180 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3181 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3182 argument to catch the left-over arguments. If such an integer is used, the
3183 arguments will not be dynamically bound but will be instead pushed on the
3184 stack before executing the byte-code.
3185 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3186 (ptrdiff_t nargs
, Lisp_Object
*args
)
3189 register Lisp_Object val
= make_uninit_vector (nargs
);
3190 register struct Lisp_Vector
*p
= XVECTOR (val
);
3192 /* We used to purecopy everything here, if purify-flag was set. This worked
3193 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3194 dangerous, since make-byte-code is used during execution to build
3195 closures, so any closure built during the preload phase would end up
3196 copied into pure space, including its free variables, which is sometimes
3197 just wasteful and other times plainly wrong (e.g. those free vars may want
3200 for (i
= 0; i
< nargs
; i
++)
3201 p
->u
.contents
[i
] = args
[i
];
3203 XSETCOMPILED (val
, p
);
3209 /***********************************************************************
3211 ***********************************************************************/
3213 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3214 of the required alignment if LSB tags are used. */
3216 union aligned_Lisp_Symbol
3218 struct Lisp_Symbol s
;
3220 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3225 /* Each symbol_block is just under 1020 bytes long, since malloc
3226 really allocates in units of powers of two and uses 4 bytes for its
3229 #define SYMBOL_BLOCK_SIZE \
3230 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3234 /* Place `symbols' first, to preserve alignment. */
3235 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3236 struct symbol_block
*next
;
3239 /* Current symbol block and index of first unused Lisp_Symbol
3242 static struct symbol_block
*symbol_block
;
3243 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3245 /* List of free symbols. */
3247 static struct Lisp_Symbol
*symbol_free_list
;
3250 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3252 XSYMBOL (sym
)->name
= name
;
3255 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3256 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3257 Its value is void, and its function definition and property list are nil. */)
3260 register Lisp_Object val
;
3261 register struct Lisp_Symbol
*p
;
3263 CHECK_STRING (name
);
3267 if (symbol_free_list
)
3269 XSETSYMBOL (val
, symbol_free_list
);
3270 symbol_free_list
= symbol_free_list
->next
;
3274 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3276 struct symbol_block
*new
3277 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3278 new->next
= symbol_block
;
3280 symbol_block_index
= 0;
3281 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3283 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3284 symbol_block_index
++;
3287 MALLOC_UNBLOCK_INPUT
;
3290 set_symbol_name (val
, name
);
3291 set_symbol_plist (val
, Qnil
);
3292 p
->redirect
= SYMBOL_PLAINVAL
;
3293 SET_SYMBOL_VAL (p
, Qunbound
);
3294 set_symbol_function (val
, Qnil
);
3295 set_symbol_next (val
, NULL
);
3297 p
->interned
= SYMBOL_UNINTERNED
;
3299 p
->declared_special
= 0;
3300 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3302 total_free_symbols
--;
3308 /***********************************************************************
3309 Marker (Misc) Allocation
3310 ***********************************************************************/
3312 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3313 the required alignment when LSB tags are used. */
3315 union aligned_Lisp_Misc
3319 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3324 /* Allocation of markers and other objects that share that structure.
3325 Works like allocation of conses. */
3327 #define MARKER_BLOCK_SIZE \
3328 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3332 /* Place `markers' first, to preserve alignment. */
3333 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3334 struct marker_block
*next
;
3337 static struct marker_block
*marker_block
;
3338 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3340 static union Lisp_Misc
*marker_free_list
;
3342 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3345 allocate_misc (enum Lisp_Misc_Type type
)
3351 if (marker_free_list
)
3353 XSETMISC (val
, marker_free_list
);
3354 marker_free_list
= marker_free_list
->u_free
.chain
;
3358 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3360 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3361 new->next
= marker_block
;
3363 marker_block_index
= 0;
3364 total_free_markers
+= MARKER_BLOCK_SIZE
;
3366 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3367 marker_block_index
++;
3370 MALLOC_UNBLOCK_INPUT
;
3372 --total_free_markers
;
3373 consing_since_gc
+= sizeof (union Lisp_Misc
);
3374 misc_objects_consed
++;
3375 XMISCANY (val
)->type
= type
;
3376 XMISCANY (val
)->gcmarkbit
= 0;
3380 /* Free a Lisp_Misc object. */
3383 free_misc (Lisp_Object misc
)
3385 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3386 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3387 marker_free_list
= XMISC (misc
);
3388 consing_since_gc
-= sizeof (union Lisp_Misc
);
3389 total_free_markers
++;
3392 /* Verify properties of Lisp_Save_Value's representation
3393 that are assumed here and elsewhere. */
3395 verify (SAVE_UNUSED
== 0);
3396 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3400 /* Return Lisp_Save_Value objects for the various combinations
3401 that callers need. */
3404 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3406 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3407 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3408 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3409 p
->data
[0].integer
= a
;
3410 p
->data
[1].integer
= b
;
3411 p
->data
[2].integer
= c
;
3416 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3419 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3420 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3421 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3422 p
->data
[0].object
= a
;
3423 p
->data
[1].object
= b
;
3424 p
->data
[2].object
= c
;
3425 p
->data
[3].object
= d
;
3430 make_save_ptr (void *a
)
3432 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3433 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3434 p
->save_type
= SAVE_POINTER
;
3435 p
->data
[0].pointer
= a
;
3440 make_save_ptr_int (void *a
, ptrdiff_t b
)
3442 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3443 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3444 p
->save_type
= SAVE_TYPE_PTR_INT
;
3445 p
->data
[0].pointer
= a
;
3446 p
->data
[1].integer
= b
;
3450 #if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3452 make_save_ptr_ptr (void *a
, void *b
)
3454 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3455 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3456 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3457 p
->data
[0].pointer
= a
;
3458 p
->data
[1].pointer
= b
;
3464 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
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_FUNCPTR_PTR_OBJ
;
3469 p
->data
[0].funcpointer
= a
;
3470 p
->data
[1].pointer
= b
;
3471 p
->data
[2].object
= c
;
3475 /* Return a Lisp_Save_Value object that represents an array A
3476 of N Lisp objects. */
3479 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3481 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3482 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3483 p
->save_type
= SAVE_TYPE_MEMORY
;
3484 p
->data
[0].pointer
= a
;
3485 p
->data
[1].integer
= n
;
3489 /* Free a Lisp_Save_Value object. Do not use this function
3490 if SAVE contains pointer other than returned by xmalloc. */
3493 free_save_value (Lisp_Object save
)
3495 xfree (XSAVE_POINTER (save
, 0));
3499 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3502 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3504 register Lisp_Object overlay
;
3506 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3507 OVERLAY_START (overlay
) = start
;
3508 OVERLAY_END (overlay
) = end
;
3509 set_overlay_plist (overlay
, plist
);
3510 XOVERLAY (overlay
)->next
= NULL
;
3514 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3515 doc
: /* Return a newly allocated marker which does not point at any place. */)
3518 register Lisp_Object val
;
3519 register struct Lisp_Marker
*p
;
3521 val
= allocate_misc (Lisp_Misc_Marker
);
3527 p
->insertion_type
= 0;
3528 p
->need_adjustment
= 0;
3532 /* Return a newly allocated marker which points into BUF
3533 at character position CHARPOS and byte position BYTEPOS. */
3536 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3539 struct Lisp_Marker
*m
;
3541 /* No dead buffers here. */
3542 eassert (BUFFER_LIVE_P (buf
));
3544 /* Every character is at least one byte. */
3545 eassert (charpos
<= bytepos
);
3547 obj
= allocate_misc (Lisp_Misc_Marker
);
3550 m
->charpos
= charpos
;
3551 m
->bytepos
= bytepos
;
3552 m
->insertion_type
= 0;
3553 m
->need_adjustment
= 0;
3554 m
->next
= BUF_MARKERS (buf
);
3555 BUF_MARKERS (buf
) = m
;
3559 /* Put MARKER back on the free list after using it temporarily. */
3562 free_marker (Lisp_Object marker
)
3564 unchain_marker (XMARKER (marker
));
3569 /* Return a newly created vector or string with specified arguments as
3570 elements. If all the arguments are characters that can fit
3571 in a string of events, make a string; otherwise, make a vector.
3573 Any number of arguments, even zero arguments, are allowed. */
3576 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3580 for (i
= 0; i
< nargs
; i
++)
3581 /* The things that fit in a string
3582 are characters that are in 0...127,
3583 after discarding the meta bit and all the bits above it. */
3584 if (!INTEGERP (args
[i
])
3585 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3586 return Fvector (nargs
, args
);
3588 /* Since the loop exited, we know that all the things in it are
3589 characters, so we can make a string. */
3593 result
= Fmake_string (make_number (nargs
), make_number (0));
3594 for (i
= 0; i
< nargs
; i
++)
3596 SSET (result
, i
, XINT (args
[i
]));
3597 /* Move the meta bit to the right place for a string char. */
3598 if (XINT (args
[i
]) & CHAR_META
)
3599 SSET (result
, i
, SREF (result
, i
) | 0x80);
3608 /************************************************************************
3609 Memory Full Handling
3610 ************************************************************************/
3613 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3614 there may have been size_t overflow so that malloc was never
3615 called, or perhaps malloc was invoked successfully but the
3616 resulting pointer had problems fitting into a tagged EMACS_INT. In
3617 either case this counts as memory being full even though malloc did
3621 memory_full (size_t nbytes
)
3623 /* Do not go into hysterics merely because a large request failed. */
3624 bool enough_free_memory
= 0;
3625 if (SPARE_MEMORY
< nbytes
)
3630 p
= malloc (SPARE_MEMORY
);
3634 enough_free_memory
= 1;
3636 MALLOC_UNBLOCK_INPUT
;
3639 if (! enough_free_memory
)
3645 memory_full_cons_threshold
= sizeof (struct cons_block
);
3647 /* The first time we get here, free the spare memory. */
3648 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3649 if (spare_memory
[i
])
3652 free (spare_memory
[i
]);
3653 else if (i
>= 1 && i
<= 4)
3654 lisp_align_free (spare_memory
[i
]);
3656 lisp_free (spare_memory
[i
]);
3657 spare_memory
[i
] = 0;
3661 /* This used to call error, but if we've run out of memory, we could
3662 get infinite recursion trying to build the string. */
3663 xsignal (Qnil
, Vmemory_signal_data
);
3666 /* If we released our reserve (due to running out of memory),
3667 and we have a fair amount free once again,
3668 try to set aside another reserve in case we run out once more.
3670 This is called when a relocatable block is freed in ralloc.c,
3671 and also directly from this file, in case we're not using ralloc.c. */
3674 refill_memory_reserve (void)
3676 #ifndef SYSTEM_MALLOC
3677 if (spare_memory
[0] == 0)
3678 spare_memory
[0] = malloc (SPARE_MEMORY
);
3679 if (spare_memory
[1] == 0)
3680 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3682 if (spare_memory
[2] == 0)
3683 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3685 if (spare_memory
[3] == 0)
3686 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3688 if (spare_memory
[4] == 0)
3689 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3691 if (spare_memory
[5] == 0)
3692 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3694 if (spare_memory
[6] == 0)
3695 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3697 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3698 Vmemory_full
= Qnil
;
3702 /************************************************************************
3704 ************************************************************************/
3706 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3708 /* Conservative C stack marking requires a method to identify possibly
3709 live Lisp objects given a pointer value. We do this by keeping
3710 track of blocks of Lisp data that are allocated in a red-black tree
3711 (see also the comment of mem_node which is the type of nodes in
3712 that tree). Function lisp_malloc adds information for an allocated
3713 block to the red-black tree with calls to mem_insert, and function
3714 lisp_free removes it with mem_delete. Functions live_string_p etc
3715 call mem_find to lookup information about a given pointer in the
3716 tree, and use that to determine if the pointer points to a Lisp
3719 /* Initialize this part of alloc.c. */
3724 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3725 mem_z
.parent
= NULL
;
3726 mem_z
.color
= MEM_BLACK
;
3727 mem_z
.start
= mem_z
.end
= NULL
;
3732 /* Value is a pointer to the mem_node containing START. Value is
3733 MEM_NIL if there is no node in the tree containing START. */
3735 static struct mem_node
*
3736 mem_find (void *start
)
3740 if (start
< min_heap_address
|| start
> max_heap_address
)
3743 /* Make the search always successful to speed up the loop below. */
3744 mem_z
.start
= start
;
3745 mem_z
.end
= (char *) start
+ 1;
3748 while (start
< p
->start
|| start
>= p
->end
)
3749 p
= start
< p
->start
? p
->left
: p
->right
;
3754 /* Insert a new node into the tree for a block of memory with start
3755 address START, end address END, and type TYPE. Value is a
3756 pointer to the node that was inserted. */
3758 static struct mem_node
*
3759 mem_insert (void *start
, void *end
, enum mem_type type
)
3761 struct mem_node
*c
, *parent
, *x
;
3763 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3764 min_heap_address
= start
;
3765 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3766 max_heap_address
= end
;
3768 /* See where in the tree a node for START belongs. In this
3769 particular application, it shouldn't happen that a node is already
3770 present. For debugging purposes, let's check that. */
3774 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3776 while (c
!= MEM_NIL
)
3778 if (start
>= c
->start
&& start
< c
->end
)
3781 c
= start
< c
->start
? c
->left
: c
->right
;
3784 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3786 while (c
!= MEM_NIL
)
3789 c
= start
< c
->start
? c
->left
: c
->right
;
3792 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3794 /* Create a new node. */
3795 #ifdef GC_MALLOC_CHECK
3796 x
= malloc (sizeof *x
);
3800 x
= xmalloc (sizeof *x
);
3806 x
->left
= x
->right
= MEM_NIL
;
3809 /* Insert it as child of PARENT or install it as root. */
3812 if (start
< parent
->start
)
3820 /* Re-establish red-black tree properties. */
3821 mem_insert_fixup (x
);
3827 /* Re-establish the red-black properties of the tree, and thereby
3828 balance the tree, after node X has been inserted; X is always red. */
3831 mem_insert_fixup (struct mem_node
*x
)
3833 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3835 /* X is red and its parent is red. This is a violation of
3836 red-black tree property #3. */
3838 if (x
->parent
== x
->parent
->parent
->left
)
3840 /* We're on the left side of our grandparent, and Y is our
3842 struct mem_node
*y
= x
->parent
->parent
->right
;
3844 if (y
->color
== MEM_RED
)
3846 /* Uncle and parent are red but should be black because
3847 X is red. Change the colors accordingly and proceed
3848 with the grandparent. */
3849 x
->parent
->color
= MEM_BLACK
;
3850 y
->color
= MEM_BLACK
;
3851 x
->parent
->parent
->color
= MEM_RED
;
3852 x
= x
->parent
->parent
;
3856 /* Parent and uncle have different colors; parent is
3857 red, uncle is black. */
3858 if (x
== x
->parent
->right
)
3861 mem_rotate_left (x
);
3864 x
->parent
->color
= MEM_BLACK
;
3865 x
->parent
->parent
->color
= MEM_RED
;
3866 mem_rotate_right (x
->parent
->parent
);
3871 /* This is the symmetrical case of above. */
3872 struct mem_node
*y
= x
->parent
->parent
->left
;
3874 if (y
->color
== MEM_RED
)
3876 x
->parent
->color
= MEM_BLACK
;
3877 y
->color
= MEM_BLACK
;
3878 x
->parent
->parent
->color
= MEM_RED
;
3879 x
= x
->parent
->parent
;
3883 if (x
== x
->parent
->left
)
3886 mem_rotate_right (x
);
3889 x
->parent
->color
= MEM_BLACK
;
3890 x
->parent
->parent
->color
= MEM_RED
;
3891 mem_rotate_left (x
->parent
->parent
);
3896 /* The root may have been changed to red due to the algorithm. Set
3897 it to black so that property #5 is satisfied. */
3898 mem_root
->color
= MEM_BLACK
;
3909 mem_rotate_left (struct mem_node
*x
)
3913 /* Turn y's left sub-tree into x's right sub-tree. */
3916 if (y
->left
!= MEM_NIL
)
3917 y
->left
->parent
= x
;
3919 /* Y's parent was x's parent. */
3921 y
->parent
= x
->parent
;
3923 /* Get the parent to point to y instead of x. */
3926 if (x
== x
->parent
->left
)
3927 x
->parent
->left
= y
;
3929 x
->parent
->right
= y
;
3934 /* Put x on y's left. */
3948 mem_rotate_right (struct mem_node
*x
)
3950 struct mem_node
*y
= x
->left
;
3953 if (y
->right
!= MEM_NIL
)
3954 y
->right
->parent
= x
;
3957 y
->parent
= x
->parent
;
3960 if (x
== x
->parent
->right
)
3961 x
->parent
->right
= y
;
3963 x
->parent
->left
= y
;
3974 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3977 mem_delete (struct mem_node
*z
)
3979 struct mem_node
*x
, *y
;
3981 if (!z
|| z
== MEM_NIL
)
3984 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3989 while (y
->left
!= MEM_NIL
)
3993 if (y
->left
!= MEM_NIL
)
3998 x
->parent
= y
->parent
;
4001 if (y
== y
->parent
->left
)
4002 y
->parent
->left
= x
;
4004 y
->parent
->right
= x
;
4011 z
->start
= y
->start
;
4016 if (y
->color
== MEM_BLACK
)
4017 mem_delete_fixup (x
);
4019 #ifdef GC_MALLOC_CHECK
4027 /* Re-establish the red-black properties of the tree, after a
4031 mem_delete_fixup (struct mem_node
*x
)
4033 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4035 if (x
== x
->parent
->left
)
4037 struct mem_node
*w
= x
->parent
->right
;
4039 if (w
->color
== MEM_RED
)
4041 w
->color
= MEM_BLACK
;
4042 x
->parent
->color
= MEM_RED
;
4043 mem_rotate_left (x
->parent
);
4044 w
= x
->parent
->right
;
4047 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4054 if (w
->right
->color
== MEM_BLACK
)
4056 w
->left
->color
= MEM_BLACK
;
4058 mem_rotate_right (w
);
4059 w
= x
->parent
->right
;
4061 w
->color
= x
->parent
->color
;
4062 x
->parent
->color
= MEM_BLACK
;
4063 w
->right
->color
= MEM_BLACK
;
4064 mem_rotate_left (x
->parent
);
4070 struct mem_node
*w
= x
->parent
->left
;
4072 if (w
->color
== MEM_RED
)
4074 w
->color
= MEM_BLACK
;
4075 x
->parent
->color
= MEM_RED
;
4076 mem_rotate_right (x
->parent
);
4077 w
= x
->parent
->left
;
4080 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4087 if (w
->left
->color
== MEM_BLACK
)
4089 w
->right
->color
= MEM_BLACK
;
4091 mem_rotate_left (w
);
4092 w
= x
->parent
->left
;
4095 w
->color
= x
->parent
->color
;
4096 x
->parent
->color
= MEM_BLACK
;
4097 w
->left
->color
= MEM_BLACK
;
4098 mem_rotate_right (x
->parent
);
4104 x
->color
= MEM_BLACK
;
4108 /* Value is non-zero if P is a pointer to a live Lisp string on
4109 the heap. M is a pointer to the mem_block for P. */
4112 live_string_p (struct mem_node
*m
, void *p
)
4114 if (m
->type
== MEM_TYPE_STRING
)
4116 struct string_block
*b
= m
->start
;
4117 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4119 /* P must point to the start of a Lisp_String structure, and it
4120 must not be on the free-list. */
4122 && offset
% sizeof b
->strings
[0] == 0
4123 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4124 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4131 /* Value is non-zero if P is a pointer to a live Lisp cons on
4132 the heap. M is a pointer to the mem_block for P. */
4135 live_cons_p (struct mem_node
*m
, void *p
)
4137 if (m
->type
== MEM_TYPE_CONS
)
4139 struct cons_block
*b
= m
->start
;
4140 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4142 /* P must point to the start of a Lisp_Cons, not be
4143 one of the unused cells in the current cons block,
4144 and not be on the free-list. */
4146 && offset
% sizeof b
->conses
[0] == 0
4147 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4149 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4150 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4157 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4158 the heap. M is a pointer to the mem_block for P. */
4161 live_symbol_p (struct mem_node
*m
, void *p
)
4163 if (m
->type
== MEM_TYPE_SYMBOL
)
4165 struct symbol_block
*b
= m
->start
;
4166 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4168 /* P must point to the start of a Lisp_Symbol, not be
4169 one of the unused cells in the current symbol block,
4170 and not be on the free-list. */
4172 && offset
% sizeof b
->symbols
[0] == 0
4173 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4174 && (b
!= symbol_block
4175 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4176 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4183 /* Value is non-zero if P is a pointer to a live Lisp float on
4184 the heap. M is a pointer to the mem_block for P. */
4187 live_float_p (struct mem_node
*m
, void *p
)
4189 if (m
->type
== MEM_TYPE_FLOAT
)
4191 struct float_block
*b
= m
->start
;
4192 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4194 /* P must point to the start of a Lisp_Float and not be
4195 one of the unused cells in the current float block. */
4197 && offset
% sizeof b
->floats
[0] == 0
4198 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4199 && (b
!= float_block
4200 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4207 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4208 the heap. M is a pointer to the mem_block for P. */
4211 live_misc_p (struct mem_node
*m
, void *p
)
4213 if (m
->type
== MEM_TYPE_MISC
)
4215 struct marker_block
*b
= m
->start
;
4216 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4218 /* P must point to the start of a Lisp_Misc, not be
4219 one of the unused cells in the current misc block,
4220 and not be on the free-list. */
4222 && offset
% sizeof b
->markers
[0] == 0
4223 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4224 && (b
!= marker_block
4225 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4226 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4233 /* Value is non-zero if P is a pointer to a live vector-like object.
4234 M is a pointer to the mem_block for P. */
4237 live_vector_p (struct mem_node
*m
, void *p
)
4239 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4241 /* This memory node corresponds to a vector block. */
4242 struct vector_block
*block
= m
->start
;
4243 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4245 /* P is in the block's allocation range. Scan the block
4246 up to P and see whether P points to the start of some
4247 vector which is not on a free list. FIXME: check whether
4248 some allocation patterns (probably a lot of short vectors)
4249 may cause a substantial overhead of this loop. */
4250 while (VECTOR_IN_BLOCK (vector
, block
)
4251 && vector
<= (struct Lisp_Vector
*) p
)
4253 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4256 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4259 else if (m
->type
== MEM_TYPE_VECTORLIKE
4260 && (char *) p
== ((char *) m
->start
4261 + offsetof (struct large_vector
, v
)))
4262 /* This memory node corresponds to a large vector. */
4268 /* Value is non-zero if P is a pointer to a live buffer. M is a
4269 pointer to the mem_block for P. */
4272 live_buffer_p (struct mem_node
*m
, void *p
)
4274 /* P must point to the start of the block, and the buffer
4275 must not have been killed. */
4276 return (m
->type
== MEM_TYPE_BUFFER
4278 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4281 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4285 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4287 /* Currently not used, but may be called from gdb. */
4289 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4291 /* Array of objects that are kept alive because the C stack contains
4292 a pattern that looks like a reference to them . */
4294 #define MAX_ZOMBIES 10
4295 static Lisp_Object zombies
[MAX_ZOMBIES
];
4297 /* Number of zombie objects. */
4299 static EMACS_INT nzombies
;
4301 /* Number of garbage collections. */
4303 static EMACS_INT ngcs
;
4305 /* Average percentage of zombies per collection. */
4307 static double avg_zombies
;
4309 /* Max. number of live and zombie objects. */
4311 static EMACS_INT max_live
, max_zombies
;
4313 /* Average number of live objects per GC. */
4315 static double avg_live
;
4317 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4318 doc
: /* Show information about live and zombie objects. */)
4321 Lisp_Object args
[8], zombie_list
= Qnil
;
4323 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4324 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4325 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4326 args
[1] = make_number (ngcs
);
4327 args
[2] = make_float (avg_live
);
4328 args
[3] = make_float (avg_zombies
);
4329 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4330 args
[5] = make_number (max_live
);
4331 args
[6] = make_number (max_zombies
);
4332 args
[7] = zombie_list
;
4333 return Fmessage (8, args
);
4336 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4339 /* Mark OBJ if we can prove it's a Lisp_Object. */
4342 mark_maybe_object (Lisp_Object obj
)
4349 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4355 po
= (void *) XPNTR (obj
);
4362 switch (XTYPE (obj
))
4365 mark_p
= (live_string_p (m
, po
)
4366 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4370 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4374 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4378 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4381 case Lisp_Vectorlike
:
4382 /* Note: can't check BUFFERP before we know it's a
4383 buffer because checking that dereferences the pointer
4384 PO which might point anywhere. */
4385 if (live_vector_p (m
, po
))
4386 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4387 else if (live_buffer_p (m
, po
))
4388 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4392 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4401 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4402 if (nzombies
< MAX_ZOMBIES
)
4403 zombies
[nzombies
] = obj
;
4412 /* If P points to Lisp data, mark that as live if it isn't already
4416 mark_maybe_pointer (void *p
)
4422 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4425 /* Quickly rule out some values which can't point to Lisp data.
4426 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4427 Otherwise, assume that Lisp data is aligned on even addresses. */
4428 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4434 Lisp_Object obj
= Qnil
;
4438 case MEM_TYPE_NON_LISP
:
4439 case MEM_TYPE_SPARE
:
4440 /* Nothing to do; not a pointer to Lisp memory. */
4443 case MEM_TYPE_BUFFER
:
4444 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4445 XSETVECTOR (obj
, p
);
4449 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4453 case MEM_TYPE_STRING
:
4454 if (live_string_p (m
, p
)
4455 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4456 XSETSTRING (obj
, p
);
4460 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4464 case MEM_TYPE_SYMBOL
:
4465 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4466 XSETSYMBOL (obj
, p
);
4469 case MEM_TYPE_FLOAT
:
4470 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4474 case MEM_TYPE_VECTORLIKE
:
4475 case MEM_TYPE_VECTOR_BLOCK
:
4476 if (live_vector_p (m
, p
))
4479 XSETVECTOR (tem
, p
);
4480 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4495 /* Alignment of pointer values. Use alignof, as it sometimes returns
4496 a smaller alignment than GCC's __alignof__ and mark_memory might
4497 miss objects if __alignof__ were used. */
4498 #define GC_POINTER_ALIGNMENT alignof (void *)
4500 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4501 not suffice, which is the typical case. A host where a Lisp_Object is
4502 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4503 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4504 suffice to widen it to to a Lisp_Object and check it that way. */
4505 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4506 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4507 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4508 nor mark_maybe_object can follow the pointers. This should not occur on
4509 any practical porting target. */
4510 # error "MSB type bits straddle pointer-word boundaries"
4512 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4513 pointer words that hold pointers ORed with type bits. */
4514 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4516 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4517 words that hold unmodified pointers. */
4518 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4521 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4522 or END+OFFSET..START. */
4525 mark_memory (void *start
, void *end
)
4526 #if defined (__clang__) && defined (__has_feature)
4527 #if __has_feature(address_sanitizer)
4528 /* Do not allow -faddress-sanitizer to check this function, since it
4529 crosses the function stack boundary, and thus would yield many
4531 __attribute__((no_address_safety_analysis
))
4538 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4542 /* Make START the pointer to the start of the memory region,
4543 if it isn't already. */
4551 /* Mark Lisp data pointed to. This is necessary because, in some
4552 situations, the C compiler optimizes Lisp objects away, so that
4553 only a pointer to them remains. Example:
4555 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4558 Lisp_Object obj = build_string ("test");
4559 struct Lisp_String *s = XSTRING (obj);
4560 Fgarbage_collect ();
4561 fprintf (stderr, "test `%s'\n", s->data);
4565 Here, `obj' isn't really used, and the compiler optimizes it
4566 away. The only reference to the life string is through the
4569 for (pp
= start
; (void *) pp
< end
; pp
++)
4570 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4572 void *p
= *(void **) ((char *) pp
+ i
);
4573 mark_maybe_pointer (p
);
4574 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4575 mark_maybe_object (XIL ((intptr_t) p
));
4579 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4581 static bool setjmp_tested_p
;
4582 static int longjmps_done
;
4584 #define SETJMP_WILL_LIKELY_WORK "\
4586 Emacs garbage collector has been changed to use conservative stack\n\
4587 marking. Emacs has determined that the method it uses to do the\n\
4588 marking will likely work on your system, but this isn't sure.\n\
4590 If you are a system-programmer, or can get the help of a local wizard\n\
4591 who is, please take a look at the function mark_stack in alloc.c, and\n\
4592 verify that the methods used are appropriate for your system.\n\
4594 Please mail the result to <emacs-devel@gnu.org>.\n\
4597 #define SETJMP_WILL_NOT_WORK "\
4599 Emacs garbage collector has been changed to use conservative stack\n\
4600 marking. Emacs has determined that the default method it uses to do the\n\
4601 marking will not work on your system. We will need a system-dependent\n\
4602 solution for your system.\n\
4604 Please take a look at the function mark_stack in alloc.c, and\n\
4605 try to find a way to make it work on your system.\n\
4607 Note that you may get false negatives, depending on the compiler.\n\
4608 In particular, you need to use -O with GCC for this test.\n\
4610 Please mail the result to <emacs-devel@gnu.org>.\n\
4614 /* Perform a quick check if it looks like setjmp saves registers in a
4615 jmp_buf. Print a message to stderr saying so. When this test
4616 succeeds, this is _not_ a proof that setjmp is sufficient for
4617 conservative stack marking. Only the sources or a disassembly
4627 /* Arrange for X to be put in a register. */
4633 if (longjmps_done
== 1)
4635 /* Came here after the longjmp at the end of the function.
4637 If x == 1, the longjmp has restored the register to its
4638 value before the setjmp, and we can hope that setjmp
4639 saves all such registers in the jmp_buf, although that
4642 For other values of X, either something really strange is
4643 taking place, or the setjmp just didn't save the register. */
4646 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4649 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4656 if (longjmps_done
== 1)
4657 sys_longjmp (jbuf
, 1);
4660 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4663 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4665 /* Abort if anything GCPRO'd doesn't survive the GC. */
4673 for (p
= gcprolist
; p
; p
= p
->next
)
4674 for (i
= 0; i
< p
->nvars
; ++i
)
4675 if (!survives_gc_p (p
->var
[i
]))
4676 /* FIXME: It's not necessarily a bug. It might just be that the
4677 GCPRO is unnecessary or should release the object sooner. */
4681 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4688 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4689 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4691 fprintf (stderr
, " %d = ", i
);
4692 debug_print (zombies
[i
]);
4696 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4699 /* Mark live Lisp objects on the C stack.
4701 There are several system-dependent problems to consider when
4702 porting this to new architectures:
4706 We have to mark Lisp objects in CPU registers that can hold local
4707 variables or are used to pass parameters.
4709 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4710 something that either saves relevant registers on the stack, or
4711 calls mark_maybe_object passing it each register's contents.
4713 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4714 implementation assumes that calling setjmp saves registers we need
4715 to see in a jmp_buf which itself lies on the stack. This doesn't
4716 have to be true! It must be verified for each system, possibly
4717 by taking a look at the source code of setjmp.
4719 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4720 can use it as a machine independent method to store all registers
4721 to the stack. In this case the macros described in the previous
4722 two paragraphs are not used.
4726 Architectures differ in the way their processor stack is organized.
4727 For example, the stack might look like this
4730 | Lisp_Object | size = 4
4732 | something else | size = 2
4734 | Lisp_Object | size = 4
4738 In such a case, not every Lisp_Object will be aligned equally. To
4739 find all Lisp_Object on the stack it won't be sufficient to walk
4740 the stack in steps of 4 bytes. Instead, two passes will be
4741 necessary, one starting at the start of the stack, and a second
4742 pass starting at the start of the stack + 2. Likewise, if the
4743 minimal alignment of Lisp_Objects on the stack is 1, four passes
4744 would be necessary, each one starting with one byte more offset
4745 from the stack start. */
4752 #ifdef HAVE___BUILTIN_UNWIND_INIT
4753 /* Force callee-saved registers and register windows onto the stack.
4754 This is the preferred method if available, obviating the need for
4755 machine dependent methods. */
4756 __builtin_unwind_init ();
4758 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4759 #ifndef GC_SAVE_REGISTERS_ON_STACK
4760 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4761 union aligned_jmpbuf
{
4765 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4767 /* This trick flushes the register windows so that all the state of
4768 the process is contained in the stack. */
4769 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4770 needed on ia64 too. See mach_dep.c, where it also says inline
4771 assembler doesn't work with relevant proprietary compilers. */
4773 #if defined (__sparc64__) && defined (__FreeBSD__)
4774 /* FreeBSD does not have a ta 3 handler. */
4781 /* Save registers that we need to see on the stack. We need to see
4782 registers used to hold register variables and registers used to
4784 #ifdef GC_SAVE_REGISTERS_ON_STACK
4785 GC_SAVE_REGISTERS_ON_STACK (end
);
4786 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4788 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4789 setjmp will definitely work, test it
4790 and print a message with the result
4792 if (!setjmp_tested_p
)
4794 setjmp_tested_p
= 1;
4797 #endif /* GC_SETJMP_WORKS */
4800 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4801 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4802 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4804 /* This assumes that the stack is a contiguous region in memory. If
4805 that's not the case, something has to be done here to iterate
4806 over the stack segments. */
4807 mark_memory (stack_base
, end
);
4809 /* Allow for marking a secondary stack, like the register stack on the
4811 #ifdef GC_MARK_SECONDARY_STACK
4812 GC_MARK_SECONDARY_STACK ();
4815 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4820 #else /* GC_MARK_STACK == 0 */
4822 #define mark_maybe_object(obj) emacs_abort ()
4824 #endif /* GC_MARK_STACK != 0 */
4827 /* Determine whether it is safe to access memory at address P. */
4829 valid_pointer_p (void *p
)
4832 return w32_valid_pointer_p (p
, 16);
4836 /* Obviously, we cannot just access it (we would SEGV trying), so we
4837 trick the o/s to tell us whether p is a valid pointer.
4838 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4839 not validate p in that case. */
4841 if (emacs_pipe (fd
) == 0)
4843 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4844 emacs_close (fd
[1]);
4845 emacs_close (fd
[0]);
4853 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4854 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4855 cannot validate OBJ. This function can be quite slow, so its primary
4856 use is the manual debugging. The only exception is print_object, where
4857 we use it to check whether the memory referenced by the pointer of
4858 Lisp_Save_Value object contains valid objects. */
4861 valid_lisp_object_p (Lisp_Object obj
)
4871 p
= (void *) XPNTR (obj
);
4872 if (PURE_POINTER_P (p
))
4875 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4879 return valid_pointer_p (p
);
4886 int valid
= valid_pointer_p (p
);
4898 case MEM_TYPE_NON_LISP
:
4899 case MEM_TYPE_SPARE
:
4902 case MEM_TYPE_BUFFER
:
4903 return live_buffer_p (m
, p
) ? 1 : 2;
4906 return live_cons_p (m
, p
);
4908 case MEM_TYPE_STRING
:
4909 return live_string_p (m
, p
);
4912 return live_misc_p (m
, p
);
4914 case MEM_TYPE_SYMBOL
:
4915 return live_symbol_p (m
, p
);
4917 case MEM_TYPE_FLOAT
:
4918 return live_float_p (m
, p
);
4920 case MEM_TYPE_VECTORLIKE
:
4921 case MEM_TYPE_VECTOR_BLOCK
:
4922 return live_vector_p (m
, p
);
4935 /***********************************************************************
4936 Pure Storage Management
4937 ***********************************************************************/
4939 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4940 pointer to it. TYPE is the Lisp type for which the memory is
4941 allocated. TYPE < 0 means it's not used for a Lisp object. */
4944 pure_alloc (size_t size
, int type
)
4948 size_t alignment
= GCALIGNMENT
;
4950 size_t alignment
= alignof (EMACS_INT
);
4952 /* Give Lisp_Floats an extra alignment. */
4953 if (type
== Lisp_Float
)
4954 alignment
= alignof (struct Lisp_Float
);
4960 /* Allocate space for a Lisp object from the beginning of the free
4961 space with taking account of alignment. */
4962 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4963 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4967 /* Allocate space for a non-Lisp object from the end of the free
4969 pure_bytes_used_non_lisp
+= size
;
4970 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4972 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4974 if (pure_bytes_used
<= pure_size
)
4977 /* Don't allocate a large amount here,
4978 because it might get mmap'd and then its address
4979 might not be usable. */
4980 purebeg
= xmalloc (10000);
4982 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4983 pure_bytes_used
= 0;
4984 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4989 /* Print a warning if PURESIZE is too small. */
4992 check_pure_size (void)
4994 if (pure_bytes_used_before_overflow
)
4995 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4997 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5001 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5002 the non-Lisp data pool of the pure storage, and return its start
5003 address. Return NULL if not found. */
5006 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5009 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5010 const unsigned char *p
;
5013 if (pure_bytes_used_non_lisp
<= nbytes
)
5016 /* Set up the Boyer-Moore table. */
5018 for (i
= 0; i
< 256; i
++)
5021 p
= (const unsigned char *) data
;
5023 bm_skip
[*p
++] = skip
;
5025 last_char_skip
= bm_skip
['\0'];
5027 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5028 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5030 /* See the comments in the function `boyer_moore' (search.c) for the
5031 use of `infinity'. */
5032 infinity
= pure_bytes_used_non_lisp
+ 1;
5033 bm_skip
['\0'] = infinity
;
5035 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5039 /* Check the last character (== '\0'). */
5042 start
+= bm_skip
[*(p
+ start
)];
5044 while (start
<= start_max
);
5046 if (start
< infinity
)
5047 /* Couldn't find the last character. */
5050 /* No less than `infinity' means we could find the last
5051 character at `p[start - infinity]'. */
5054 /* Check the remaining characters. */
5055 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5057 return non_lisp_beg
+ start
;
5059 start
+= last_char_skip
;
5061 while (start
<= start_max
);
5067 /* Return a string allocated in pure space. DATA is a buffer holding
5068 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5069 means make the result string multibyte.
5071 Must get an error if pure storage is full, since if it cannot hold
5072 a large string it may be able to hold conses that point to that
5073 string; then the string is not protected from gc. */
5076 make_pure_string (const char *data
,
5077 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5080 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5081 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5082 if (s
->data
== NULL
)
5084 s
->data
= pure_alloc (nbytes
+ 1, -1);
5085 memcpy (s
->data
, data
, nbytes
);
5086 s
->data
[nbytes
] = '\0';
5089 s
->size_byte
= multibyte
? nbytes
: -1;
5090 s
->intervals
= NULL
;
5091 XSETSTRING (string
, s
);
5095 /* Return a string allocated in pure space. Do not
5096 allocate the string data, just point to DATA. */
5099 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5102 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5105 s
->data
= (unsigned char *) data
;
5106 s
->intervals
= NULL
;
5107 XSETSTRING (string
, s
);
5111 /* Return a cons allocated from pure space. Give it pure copies
5112 of CAR as car and CDR as cdr. */
5115 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5118 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5120 XSETCAR (new, Fpurecopy (car
));
5121 XSETCDR (new, Fpurecopy (cdr
));
5126 /* Value is a float object with value NUM allocated from pure space. */
5129 make_pure_float (double num
)
5132 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5134 XFLOAT_INIT (new, num
);
5139 /* Return a vector with room for LEN Lisp_Objects allocated from
5143 make_pure_vector (ptrdiff_t len
)
5146 size_t size
= header_size
+ len
* word_size
;
5147 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5148 XSETVECTOR (new, p
);
5149 XVECTOR (new)->header
.size
= len
;
5154 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5155 doc
: /* Make a copy of object OBJ in pure storage.
5156 Recursively copies contents of vectors and cons cells.
5157 Does not copy symbols. Copies strings without text properties. */)
5158 (register Lisp_Object obj
)
5160 if (NILP (Vpurify_flag
))
5163 if (PURE_POINTER_P (XPNTR (obj
)))
5166 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5168 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5174 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5175 else if (FLOATP (obj
))
5176 obj
= make_pure_float (XFLOAT_DATA (obj
));
5177 else if (STRINGP (obj
))
5178 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5180 STRING_MULTIBYTE (obj
));
5181 else if (COMPILEDP (obj
) || VECTORP (obj
))
5183 register struct Lisp_Vector
*vec
;
5184 register ptrdiff_t i
;
5188 if (size
& PSEUDOVECTOR_FLAG
)
5189 size
&= PSEUDOVECTOR_SIZE_MASK
;
5190 vec
= XVECTOR (make_pure_vector (size
));
5191 for (i
= 0; i
< size
; i
++)
5192 vec
->u
.contents
[i
] = Fpurecopy (AREF (obj
, i
));
5193 if (COMPILEDP (obj
))
5195 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5196 XSETCOMPILED (obj
, vec
);
5199 XSETVECTOR (obj
, vec
);
5201 else if (MARKERP (obj
))
5202 error ("Attempt to copy a marker to pure storage");
5204 /* Not purified, don't hash-cons. */
5207 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5208 Fputhash (obj
, obj
, Vpurify_flag
);
5215 /***********************************************************************
5217 ***********************************************************************/
5219 /* Put an entry in staticvec, pointing at the variable with address
5223 staticpro (Lisp_Object
*varaddress
)
5225 if (staticidx
>= NSTATICS
)
5226 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5227 staticvec
[staticidx
++] = varaddress
;
5231 /***********************************************************************
5233 ***********************************************************************/
5235 /* Temporarily prevent garbage collection. */
5238 inhibit_garbage_collection (void)
5240 ptrdiff_t count
= SPECPDL_INDEX ();
5242 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5246 /* Used to avoid possible overflows when
5247 converting from C to Lisp integers. */
5250 bounded_number (EMACS_INT number
)
5252 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5255 /* Calculate total bytes of live objects. */
5258 total_bytes_of_live_objects (void)
5261 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5262 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5263 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5264 tot
+= total_string_bytes
;
5265 tot
+= total_vector_slots
* word_size
;
5266 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5267 tot
+= total_intervals
* sizeof (struct interval
);
5268 tot
+= total_strings
* sizeof (struct Lisp_String
);
5272 #ifdef HAVE_WINDOW_SYSTEM
5274 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5275 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5278 compact_font_cache_entry (Lisp_Object entry
)
5280 Lisp_Object tail
, *prev
= &entry
;
5282 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5285 Lisp_Object obj
= XCAR (tail
);
5287 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5288 if (CONSP (obj
) && FONT_SPEC_P (XCAR (obj
))
5289 && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj
)))
5290 && VECTORP (XCDR (obj
)))
5292 ptrdiff_t i
, size
= ASIZE (XCDR (obj
)) & ~ARRAY_MARK_FLAG
;
5294 /* If font-spec is not marked, most likely all font-entities
5295 are not marked too. But we must be sure that nothing is
5296 marked within OBJ before we really drop it. */
5297 for (i
= 0; i
< size
; i
++)
5298 if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj
), i
))))
5305 *prev
= XCDR (tail
);
5307 prev
= xcdr_addr (tail
);
5312 /* Compact font caches on all terminals and mark
5313 everything which is still here after compaction. */
5316 compact_font_caches (void)
5320 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5322 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5328 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5329 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5331 mark_object (cache
);
5335 #else /* not HAVE_WINDOW_SYSTEM */
5337 #define compact_font_caches() (void)(0)
5339 #endif /* HAVE_WINDOW_SYSTEM */
5341 /* Remove (MARKER . DATA) entries with unmarked MARKER
5342 from buffer undo LIST and return changed list. */
5345 compact_undo_list (Lisp_Object list
)
5347 Lisp_Object tail
, *prev
= &list
;
5349 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5351 if (CONSP (XCAR (tail
))
5352 && MARKERP (XCAR (XCAR (tail
)))
5353 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5354 *prev
= XCDR (tail
);
5356 prev
= xcdr_addr (tail
);
5361 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5362 doc
: /* Reclaim storage for Lisp objects no longer needed.
5363 Garbage collection happens automatically if you cons more than
5364 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5365 `garbage-collect' normally returns a list with info on amount of space in use,
5366 where each entry has the form (NAME SIZE USED FREE), where:
5367 - NAME is a symbol describing the kind of objects this entry represents,
5368 - SIZE is the number of bytes used by each one,
5369 - USED is the number of those objects that were found live in the heap,
5370 - FREE is the number of those objects that are not live but that Emacs
5371 keeps around for future allocations (maybe because it does not know how
5372 to return them to the OS).
5373 However, if there was overflow in pure space, `garbage-collect'
5374 returns nil, because real GC can't be done.
5375 See Info node `(elisp)Garbage Collection'. */)
5378 struct buffer
*nextb
;
5379 char stack_top_variable
;
5382 ptrdiff_t count
= SPECPDL_INDEX ();
5383 struct timespec start
;
5384 Lisp_Object retval
= Qnil
;
5385 size_t tot_before
= 0;
5390 /* Can't GC if pure storage overflowed because we can't determine
5391 if something is a pure object or not. */
5392 if (pure_bytes_used_before_overflow
)
5395 /* Record this function, so it appears on the profiler's backtraces. */
5396 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5400 /* Don't keep undo information around forever.
5401 Do this early on, so it is no problem if the user quits. */
5402 FOR_EACH_BUFFER (nextb
)
5403 compact_buffer (nextb
);
5405 if (profiler_memory_running
)
5406 tot_before
= total_bytes_of_live_objects ();
5408 start
= current_timespec ();
5410 /* In case user calls debug_print during GC,
5411 don't let that cause a recursive GC. */
5412 consing_since_gc
= 0;
5414 /* Save what's currently displayed in the echo area. */
5415 message_p
= push_message ();
5416 record_unwind_protect_void (pop_message_unwind
);
5418 /* Save a copy of the contents of the stack, for debugging. */
5419 #if MAX_SAVE_STACK > 0
5420 if (NILP (Vpurify_flag
))
5423 ptrdiff_t stack_size
;
5424 if (&stack_top_variable
< stack_bottom
)
5426 stack
= &stack_top_variable
;
5427 stack_size
= stack_bottom
- &stack_top_variable
;
5431 stack
= stack_bottom
;
5432 stack_size
= &stack_top_variable
- stack_bottom
;
5434 if (stack_size
<= MAX_SAVE_STACK
)
5436 if (stack_copy_size
< stack_size
)
5438 stack_copy
= xrealloc (stack_copy
, stack_size
);
5439 stack_copy_size
= stack_size
;
5441 memcpy (stack_copy
, stack
, stack_size
);
5444 #endif /* MAX_SAVE_STACK > 0 */
5446 if (garbage_collection_messages
)
5447 message1_nolog ("Garbage collecting...");
5451 shrink_regexp_cache ();
5455 /* Mark all the special slots that serve as the roots of accessibility. */
5457 mark_buffer (&buffer_defaults
);
5458 mark_buffer (&buffer_local_symbols
);
5460 for (i
= 0; i
< staticidx
; i
++)
5461 mark_object (*staticvec
[i
]);
5471 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5472 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5476 register struct gcpro
*tail
;
5477 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5478 for (i
= 0; i
< tail
->nvars
; i
++)
5479 mark_object (tail
->var
[i
]);
5484 struct handler
*handler
;
5485 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5487 mark_object (handler
->tag_or_ch
);
5488 mark_object (handler
->val
);
5491 #ifdef HAVE_WINDOW_SYSTEM
5492 mark_fringe_data ();
5495 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5499 /* Everything is now marked, except for the data in font caches
5500 and undo lists. They're compacted by removing an items which
5501 aren't reachable otherwise. */
5503 compact_font_caches ();
5505 FOR_EACH_BUFFER (nextb
)
5507 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5508 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5509 /* Now that we have stripped the elements that need not be
5510 in the undo_list any more, we can finally mark the list. */
5511 mark_object (BVAR (nextb
, undo_list
));
5516 /* Clear the mark bits that we set in certain root slots. */
5518 unmark_byte_stack ();
5519 VECTOR_UNMARK (&buffer_defaults
);
5520 VECTOR_UNMARK (&buffer_local_symbols
);
5522 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5532 consing_since_gc
= 0;
5533 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5534 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5536 gc_relative_threshold
= 0;
5537 if (FLOATP (Vgc_cons_percentage
))
5538 { /* Set gc_cons_combined_threshold. */
5539 double tot
= total_bytes_of_live_objects ();
5541 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5544 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5545 gc_relative_threshold
= tot
;
5547 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5551 if (garbage_collection_messages
)
5553 if (message_p
|| minibuf_level
> 0)
5556 message1_nolog ("Garbage collecting...done");
5559 unbind_to (count
, Qnil
);
5561 Lisp_Object total
[11];
5562 int total_size
= 10;
5564 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5565 bounded_number (total_conses
),
5566 bounded_number (total_free_conses
));
5568 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5569 bounded_number (total_symbols
),
5570 bounded_number (total_free_symbols
));
5572 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5573 bounded_number (total_markers
),
5574 bounded_number (total_free_markers
));
5576 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5577 bounded_number (total_strings
),
5578 bounded_number (total_free_strings
));
5580 total
[4] = list3 (Qstring_bytes
, make_number (1),
5581 bounded_number (total_string_bytes
));
5583 total
[5] = list3 (Qvectors
,
5584 make_number (header_size
+ sizeof (Lisp_Object
)),
5585 bounded_number (total_vectors
));
5587 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5588 bounded_number (total_vector_slots
),
5589 bounded_number (total_free_vector_slots
));
5591 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5592 bounded_number (total_floats
),
5593 bounded_number (total_free_floats
));
5595 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5596 bounded_number (total_intervals
),
5597 bounded_number (total_free_intervals
));
5599 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5600 bounded_number (total_buffers
));
5602 #ifdef DOUG_LEA_MALLOC
5604 total
[10] = list4 (Qheap
, make_number (1024),
5605 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5606 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5608 retval
= Flist (total_size
, total
);
5611 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5613 /* Compute average percentage of zombies. */
5615 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5616 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5618 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5619 max_live
= max (nlive
, max_live
);
5620 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5621 max_zombies
= max (nzombies
, max_zombies
);
5626 if (!NILP (Vpost_gc_hook
))
5628 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5629 safe_run_hooks (Qpost_gc_hook
);
5630 unbind_to (gc_count
, Qnil
);
5633 /* Accumulate statistics. */
5634 if (FLOATP (Vgc_elapsed
))
5636 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5637 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5638 + timespectod (since_start
));
5643 /* Collect profiling data. */
5644 if (profiler_memory_running
)
5647 size_t tot_after
= total_bytes_of_live_objects ();
5648 if (tot_before
> tot_after
)
5649 swept
= tot_before
- tot_after
;
5650 malloc_probe (swept
);
5657 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5658 only interesting objects referenced from glyphs are strings. */
5661 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5663 struct glyph_row
*row
= matrix
->rows
;
5664 struct glyph_row
*end
= row
+ matrix
->nrows
;
5666 for (; row
< end
; ++row
)
5670 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5672 struct glyph
*glyph
= row
->glyphs
[area
];
5673 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5675 for (; glyph
< end_glyph
; ++glyph
)
5676 if (STRINGP (glyph
->object
)
5677 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5678 mark_object (glyph
->object
);
5683 /* Mark reference to a Lisp_Object.
5684 If the object referred to has not been seen yet, recursively mark
5685 all the references contained in it. */
5687 #define LAST_MARKED_SIZE 500
5688 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5689 static int last_marked_index
;
5691 /* For debugging--call abort when we cdr down this many
5692 links of a list, in mark_object. In debugging,
5693 the call to abort will hit a breakpoint.
5694 Normally this is zero and the check never goes off. */
5695 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5698 mark_vectorlike (struct Lisp_Vector
*ptr
)
5700 ptrdiff_t size
= ptr
->header
.size
;
5703 eassert (!VECTOR_MARKED_P (ptr
));
5704 VECTOR_MARK (ptr
); /* Else mark it. */
5705 if (size
& PSEUDOVECTOR_FLAG
)
5706 size
&= PSEUDOVECTOR_SIZE_MASK
;
5708 /* Note that this size is not the memory-footprint size, but only
5709 the number of Lisp_Object fields that we should trace.
5710 The distinction is used e.g. by Lisp_Process which places extra
5711 non-Lisp_Object fields at the end of the structure... */
5712 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5713 mark_object (ptr
->u
.contents
[i
]);
5716 /* Like mark_vectorlike but optimized for char-tables (and
5717 sub-char-tables) assuming that the contents are mostly integers or
5721 mark_char_table (struct Lisp_Vector
*ptr
)
5723 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5726 eassert (!VECTOR_MARKED_P (ptr
));
5728 for (i
= 0; i
< size
; i
++)
5730 Lisp_Object val
= ptr
->u
.contents
[i
];
5732 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5734 if (SUB_CHAR_TABLE_P (val
))
5736 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5737 mark_char_table (XVECTOR (val
));
5744 /* Mark the chain of overlays starting at PTR. */
5747 mark_overlay (struct Lisp_Overlay
*ptr
)
5749 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5752 mark_object (ptr
->start
);
5753 mark_object (ptr
->end
);
5754 mark_object (ptr
->plist
);
5758 /* Mark Lisp_Objects and special pointers in BUFFER. */
5761 mark_buffer (struct buffer
*buffer
)
5763 /* This is handled much like other pseudovectors... */
5764 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5766 /* ...but there are some buffer-specific things. */
5768 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5770 /* For now, we just don't mark the undo_list. It's done later in
5771 a special way just before the sweep phase, and after stripping
5772 some of its elements that are not needed any more. */
5774 mark_overlay (buffer
->overlays_before
);
5775 mark_overlay (buffer
->overlays_after
);
5777 /* If this is an indirect buffer, mark its base buffer. */
5778 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5779 mark_buffer (buffer
->base_buffer
);
5782 /* Mark Lisp faces in the face cache C. */
5785 mark_face_cache (struct face_cache
*c
)
5790 for (i
= 0; i
< c
->used
; ++i
)
5792 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5796 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
5797 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
5799 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5800 mark_object (face
->lface
[j
]);
5806 /* Remove killed buffers or items whose car is a killed buffer from
5807 LIST, and mark other items. Return changed LIST, which is marked. */
5810 mark_discard_killed_buffers (Lisp_Object list
)
5812 Lisp_Object tail
, *prev
= &list
;
5814 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5817 Lisp_Object tem
= XCAR (tail
);
5820 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5821 *prev
= XCDR (tail
);
5824 CONS_MARK (XCONS (tail
));
5825 mark_object (XCAR (tail
));
5826 prev
= xcdr_addr (tail
);
5833 /* Determine type of generic Lisp_Object and mark it accordingly. */
5836 mark_object (Lisp_Object arg
)
5838 register Lisp_Object obj
= arg
;
5839 #ifdef GC_CHECK_MARKED_OBJECTS
5843 ptrdiff_t cdr_count
= 0;
5847 if (PURE_POINTER_P (XPNTR (obj
)))
5850 last_marked
[last_marked_index
++] = obj
;
5851 if (last_marked_index
== LAST_MARKED_SIZE
)
5852 last_marked_index
= 0;
5854 /* Perform some sanity checks on the objects marked here. Abort if
5855 we encounter an object we know is bogus. This increases GC time
5856 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5857 #ifdef GC_CHECK_MARKED_OBJECTS
5859 po
= (void *) XPNTR (obj
);
5861 /* Check that the object pointed to by PO is known to be a Lisp
5862 structure allocated from the heap. */
5863 #define CHECK_ALLOCATED() \
5865 m = mem_find (po); \
5870 /* Check that the object pointed to by PO is live, using predicate
5872 #define CHECK_LIVE(LIVEP) \
5874 if (!LIVEP (m, po)) \
5878 /* Check both of the above conditions. */
5879 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5881 CHECK_ALLOCATED (); \
5882 CHECK_LIVE (LIVEP); \
5885 #else /* not GC_CHECK_MARKED_OBJECTS */
5887 #define CHECK_LIVE(LIVEP) (void) 0
5888 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5890 #endif /* not GC_CHECK_MARKED_OBJECTS */
5892 switch (XTYPE (obj
))
5896 register struct Lisp_String
*ptr
= XSTRING (obj
);
5897 if (STRING_MARKED_P (ptr
))
5899 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5901 MARK_INTERVAL_TREE (ptr
->intervals
);
5902 #ifdef GC_CHECK_STRING_BYTES
5903 /* Check that the string size recorded in the string is the
5904 same as the one recorded in the sdata structure. */
5906 #endif /* GC_CHECK_STRING_BYTES */
5910 case Lisp_Vectorlike
:
5912 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5913 register ptrdiff_t pvectype
;
5915 if (VECTOR_MARKED_P (ptr
))
5918 #ifdef GC_CHECK_MARKED_OBJECTS
5920 if (m
== MEM_NIL
&& !SUBRP (obj
))
5922 #endif /* GC_CHECK_MARKED_OBJECTS */
5924 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5925 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5926 >> PSEUDOVECTOR_AREA_BITS
);
5928 pvectype
= PVEC_NORMAL_VECTOR
;
5930 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5931 CHECK_LIVE (live_vector_p
);
5936 #ifdef GC_CHECK_MARKED_OBJECTS
5945 #endif /* GC_CHECK_MARKED_OBJECTS */
5946 mark_buffer ((struct buffer
*) ptr
);
5950 { /* We could treat this just like a vector, but it is better
5951 to save the COMPILED_CONSTANTS element for last and avoid
5953 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5957 for (i
= 0; i
< size
; i
++)
5958 if (i
!= COMPILED_CONSTANTS
)
5959 mark_object (ptr
->u
.contents
[i
]);
5960 if (size
> COMPILED_CONSTANTS
)
5962 obj
= ptr
->u
.contents
[COMPILED_CONSTANTS
];
5970 struct frame
*f
= (struct frame
*) ptr
;
5972 mark_vectorlike (ptr
);
5973 mark_face_cache (f
->face_cache
);
5974 #ifdef HAVE_WINDOW_SYSTEM
5975 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
5977 struct font
*font
= FRAME_FONT (f
);
5979 if (font
&& !VECTOR_MARKED_P (font
))
5980 mark_vectorlike ((struct Lisp_Vector
*) font
);
5988 struct window
*w
= (struct window
*) ptr
;
5990 mark_vectorlike (ptr
);
5992 /* Mark glyph matrices, if any. Marking window
5993 matrices is sufficient because frame matrices
5994 use the same glyph memory. */
5995 if (w
->current_matrix
)
5997 mark_glyph_matrix (w
->current_matrix
);
5998 mark_glyph_matrix (w
->desired_matrix
);
6001 /* Filter out killed buffers from both buffer lists
6002 in attempt to help GC to reclaim killed buffers faster.
6003 We can do it elsewhere for live windows, but this is the
6004 best place to do it for dead windows. */
6006 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6008 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6012 case PVEC_HASH_TABLE
:
6014 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6016 mark_vectorlike (ptr
);
6017 mark_object (h
->test
.name
);
6018 mark_object (h
->test
.user_hash_function
);
6019 mark_object (h
->test
.user_cmp_function
);
6020 /* If hash table is not weak, mark all keys and values.
6021 For weak tables, mark only the vector. */
6023 mark_object (h
->key_and_value
);
6025 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6029 case PVEC_CHAR_TABLE
:
6030 mark_char_table (ptr
);
6033 case PVEC_BOOL_VECTOR
:
6034 /* No Lisp_Objects to mark in a bool vector. */
6045 mark_vectorlike (ptr
);
6052 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6053 struct Lisp_Symbol
*ptrx
;
6057 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6059 mark_object (ptr
->function
);
6060 mark_object (ptr
->plist
);
6061 switch (ptr
->redirect
)
6063 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6064 case SYMBOL_VARALIAS
:
6067 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6071 case SYMBOL_LOCALIZED
:
6073 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6074 Lisp_Object where
= blv
->where
;
6075 /* If the value is set up for a killed buffer or deleted
6076 frame, restore it's global binding. If the value is
6077 forwarded to a C variable, either it's not a Lisp_Object
6078 var, or it's staticpro'd already. */
6079 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6080 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6081 swap_in_global_binding (ptr
);
6082 mark_object (blv
->where
);
6083 mark_object (blv
->valcell
);
6084 mark_object (blv
->defcell
);
6087 case SYMBOL_FORWARDED
:
6088 /* If the value is forwarded to a buffer or keyboard field,
6089 these are marked when we see the corresponding object.
6090 And if it's forwarded to a C variable, either it's not
6091 a Lisp_Object var, or it's staticpro'd already. */
6093 default: emacs_abort ();
6095 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6096 MARK_STRING (XSTRING (ptr
->name
));
6097 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6102 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6103 XSETSYMBOL (obj
, ptrx
);
6110 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6112 if (XMISCANY (obj
)->gcmarkbit
)
6115 switch (XMISCTYPE (obj
))
6117 case Lisp_Misc_Marker
:
6118 /* DO NOT mark thru the marker's chain.
6119 The buffer's markers chain does not preserve markers from gc;
6120 instead, markers are removed from the chain when freed by gc. */
6121 XMISCANY (obj
)->gcmarkbit
= 1;
6124 case Lisp_Misc_Save_Value
:
6125 XMISCANY (obj
)->gcmarkbit
= 1;
6127 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6128 /* If `save_type' is zero, `data[0].pointer' is the address
6129 of a memory area containing `data[1].integer' potential
6131 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6133 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6135 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6136 mark_maybe_object (*p
);
6140 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6142 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6143 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6144 mark_object (ptr
->data
[i
].object
);
6149 case Lisp_Misc_Overlay
:
6150 mark_overlay (XOVERLAY (obj
));
6160 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6161 if (CONS_MARKED_P (ptr
))
6163 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6165 /* If the cdr is nil, avoid recursion for the car. */
6166 if (EQ (ptr
->u
.cdr
, Qnil
))
6172 mark_object (ptr
->car
);
6175 if (cdr_count
== mark_object_loop_halt
)
6181 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6182 FLOAT_MARK (XFLOAT (obj
));
6193 #undef CHECK_ALLOCATED
6194 #undef CHECK_ALLOCATED_AND_LIVE
6196 /* Mark the Lisp pointers in the terminal objects.
6197 Called by Fgarbage_collect. */
6200 mark_terminals (void)
6203 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6205 eassert (t
->name
!= NULL
);
6206 #ifdef HAVE_WINDOW_SYSTEM
6207 /* If a terminal object is reachable from a stacpro'ed object,
6208 it might have been marked already. Make sure the image cache
6210 mark_image_cache (t
->image_cache
);
6211 #endif /* HAVE_WINDOW_SYSTEM */
6212 if (!VECTOR_MARKED_P (t
))
6213 mark_vectorlike ((struct Lisp_Vector
*)t
);
6219 /* Value is non-zero if OBJ will survive the current GC because it's
6220 either marked or does not need to be marked to survive. */
6223 survives_gc_p (Lisp_Object obj
)
6227 switch (XTYPE (obj
))
6234 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6238 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6242 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6245 case Lisp_Vectorlike
:
6246 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6250 survives_p
= CONS_MARKED_P (XCONS (obj
));
6254 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6261 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6266 /* Sweep: find all structures not marked, and free them. */
6271 /* Remove or mark entries in weak hash tables.
6272 This must be done before any object is unmarked. */
6273 sweep_weak_hash_tables ();
6276 check_string_bytes (!noninteractive
);
6278 /* Put all unmarked conses on free list */
6280 register struct cons_block
*cblk
;
6281 struct cons_block
**cprev
= &cons_block
;
6282 register int lim
= cons_block_index
;
6283 EMACS_INT num_free
= 0, num_used
= 0;
6287 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6291 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6293 /* Scan the mark bits an int at a time. */
6294 for (i
= 0; i
< ilim
; i
++)
6296 if (cblk
->gcmarkbits
[i
] == -1)
6298 /* Fast path - all cons cells for this int are marked. */
6299 cblk
->gcmarkbits
[i
] = 0;
6300 num_used
+= BITS_PER_INT
;
6304 /* Some cons cells for this int are not marked.
6305 Find which ones, and free them. */
6306 int start
, pos
, stop
;
6308 start
= i
* BITS_PER_INT
;
6310 if (stop
> BITS_PER_INT
)
6311 stop
= BITS_PER_INT
;
6314 for (pos
= start
; pos
< stop
; pos
++)
6316 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6319 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6320 cons_free_list
= &cblk
->conses
[pos
];
6322 cons_free_list
->car
= Vdead
;
6328 CONS_UNMARK (&cblk
->conses
[pos
]);
6334 lim
= CONS_BLOCK_SIZE
;
6335 /* If this block contains only free conses and we have already
6336 seen more than two blocks worth of free conses then deallocate
6338 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6340 *cprev
= cblk
->next
;
6341 /* Unhook from the free list. */
6342 cons_free_list
= cblk
->conses
[0].u
.chain
;
6343 lisp_align_free (cblk
);
6347 num_free
+= this_free
;
6348 cprev
= &cblk
->next
;
6351 total_conses
= num_used
;
6352 total_free_conses
= num_free
;
6355 /* Put all unmarked floats on free list */
6357 register struct float_block
*fblk
;
6358 struct float_block
**fprev
= &float_block
;
6359 register int lim
= float_block_index
;
6360 EMACS_INT num_free
= 0, num_used
= 0;
6362 float_free_list
= 0;
6364 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6368 for (i
= 0; i
< lim
; i
++)
6369 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6372 fblk
->floats
[i
].u
.chain
= float_free_list
;
6373 float_free_list
= &fblk
->floats
[i
];
6378 FLOAT_UNMARK (&fblk
->floats
[i
]);
6380 lim
= FLOAT_BLOCK_SIZE
;
6381 /* If this block contains only free floats and we have already
6382 seen more than two blocks worth of free floats then deallocate
6384 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6386 *fprev
= fblk
->next
;
6387 /* Unhook from the free list. */
6388 float_free_list
= fblk
->floats
[0].u
.chain
;
6389 lisp_align_free (fblk
);
6393 num_free
+= this_free
;
6394 fprev
= &fblk
->next
;
6397 total_floats
= num_used
;
6398 total_free_floats
= num_free
;
6401 /* Put all unmarked intervals on free list */
6403 register struct interval_block
*iblk
;
6404 struct interval_block
**iprev
= &interval_block
;
6405 register int lim
= interval_block_index
;
6406 EMACS_INT num_free
= 0, num_used
= 0;
6408 interval_free_list
= 0;
6410 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6415 for (i
= 0; i
< lim
; i
++)
6417 if (!iblk
->intervals
[i
].gcmarkbit
)
6419 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6420 interval_free_list
= &iblk
->intervals
[i
];
6426 iblk
->intervals
[i
].gcmarkbit
= 0;
6429 lim
= INTERVAL_BLOCK_SIZE
;
6430 /* If this block contains only free intervals and we have already
6431 seen more than two blocks worth of free intervals then
6432 deallocate this block. */
6433 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6435 *iprev
= iblk
->next
;
6436 /* Unhook from the free list. */
6437 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6442 num_free
+= this_free
;
6443 iprev
= &iblk
->next
;
6446 total_intervals
= num_used
;
6447 total_free_intervals
= num_free
;
6450 /* Put all unmarked symbols on free list */
6452 register struct symbol_block
*sblk
;
6453 struct symbol_block
**sprev
= &symbol_block
;
6454 register int lim
= symbol_block_index
;
6455 EMACS_INT num_free
= 0, num_used
= 0;
6457 symbol_free_list
= NULL
;
6459 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6462 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6463 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6465 for (; sym
< end
; ++sym
)
6467 /* Check if the symbol was created during loadup. In such a case
6468 it might be pointed to by pure bytecode which we don't trace,
6469 so we conservatively assume that it is live. */
6470 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6472 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6474 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6475 xfree (SYMBOL_BLV (&sym
->s
));
6476 sym
->s
.next
= symbol_free_list
;
6477 symbol_free_list
= &sym
->s
;
6479 symbol_free_list
->function
= Vdead
;
6487 UNMARK_STRING (XSTRING (sym
->s
.name
));
6488 sym
->s
.gcmarkbit
= 0;
6492 lim
= SYMBOL_BLOCK_SIZE
;
6493 /* If this block contains only free symbols and we have already
6494 seen more than two blocks worth of free symbols then deallocate
6496 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6498 *sprev
= sblk
->next
;
6499 /* Unhook from the free list. */
6500 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6505 num_free
+= this_free
;
6506 sprev
= &sblk
->next
;
6509 total_symbols
= num_used
;
6510 total_free_symbols
= num_free
;
6513 /* Put all unmarked misc's on free list.
6514 For a marker, first unchain it from the buffer it points into. */
6516 register struct marker_block
*mblk
;
6517 struct marker_block
**mprev
= &marker_block
;
6518 register int lim
= marker_block_index
;
6519 EMACS_INT num_free
= 0, num_used
= 0;
6521 marker_free_list
= 0;
6523 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6528 for (i
= 0; i
< lim
; i
++)
6530 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6532 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6533 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6534 /* Set the type of the freed object to Lisp_Misc_Free.
6535 We could leave the type alone, since nobody checks it,
6536 but this might catch bugs faster. */
6537 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6538 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6539 marker_free_list
= &mblk
->markers
[i
].m
;
6545 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6548 lim
= MARKER_BLOCK_SIZE
;
6549 /* If this block contains only free markers and we have already
6550 seen more than two blocks worth of free markers then deallocate
6552 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6554 *mprev
= mblk
->next
;
6555 /* Unhook from the free list. */
6556 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6561 num_free
+= this_free
;
6562 mprev
= &mblk
->next
;
6566 total_markers
= num_used
;
6567 total_free_markers
= num_free
;
6570 /* Free all unmarked buffers */
6572 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6575 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6576 if (!VECTOR_MARKED_P (buffer
))
6578 *bprev
= buffer
->next
;
6583 VECTOR_UNMARK (buffer
);
6584 /* Do not use buffer_(set|get)_intervals here. */
6585 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6587 bprev
= &buffer
->next
;
6592 check_string_bytes (!noninteractive
);
6598 /* Debugging aids. */
6600 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6601 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6602 This may be helpful in debugging Emacs's memory usage.
6603 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6608 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6613 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6614 doc
: /* Return a list of counters that measure how much consing there has been.
6615 Each of these counters increments for a certain kind of object.
6616 The counters wrap around from the largest positive integer to zero.
6617 Garbage collection does not decrease them.
6618 The elements of the value are as follows:
6619 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6620 All are in units of 1 = one object consed
6621 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6623 MISCS include overlays, markers, and some internal types.
6624 Frames, windows, buffers, and subprocesses count as vectors
6625 (but the contents of a buffer's text do not count here). */)
6628 return listn (CONSTYPE_HEAP
, 8,
6629 bounded_number (cons_cells_consed
),
6630 bounded_number (floats_consed
),
6631 bounded_number (vector_cells_consed
),
6632 bounded_number (symbols_consed
),
6633 bounded_number (string_chars_consed
),
6634 bounded_number (misc_objects_consed
),
6635 bounded_number (intervals_consed
),
6636 bounded_number (strings_consed
));
6639 /* Find at most FIND_MAX symbols which have OBJ as their value or
6640 function. This is used in gdbinit's `xwhichsymbols' command. */
6643 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6645 struct symbol_block
*sblk
;
6646 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6647 Lisp_Object found
= Qnil
;
6651 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6653 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6656 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6658 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6662 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6665 XSETSYMBOL (tem
, sym
);
6666 val
= find_symbol_value (tem
);
6668 || EQ (sym
->function
, obj
)
6669 || (!NILP (sym
->function
)
6670 && COMPILEDP (sym
->function
)
6671 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6674 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6676 found
= Fcons (tem
, found
);
6677 if (--find_max
== 0)
6685 unbind_to (gc_count
, Qnil
);
6689 #ifdef ENABLE_CHECKING
6691 bool suppress_checking
;
6694 die (const char *msg
, const char *file
, int line
)
6696 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6698 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6702 /* Initialization. */
6705 init_alloc_once (void)
6707 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6709 pure_size
= PURESIZE
;
6711 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6713 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6716 #ifdef DOUG_LEA_MALLOC
6717 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6718 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6719 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6724 refill_memory_reserve ();
6725 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6732 byte_stack_list
= 0;
6734 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6735 setjmp_tested_p
= longjmps_done
= 0;
6738 Vgc_elapsed
= make_float (0.0);
6742 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
6747 syms_of_alloc (void)
6749 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6750 doc
: /* Number of bytes of consing between garbage collections.
6751 Garbage collection can happen automatically once this many bytes have been
6752 allocated since the last garbage collection. All data types count.
6754 Garbage collection happens automatically only when `eval' is called.
6756 By binding this temporarily to a large number, you can effectively
6757 prevent garbage collection during a part of the program.
6758 See also `gc-cons-percentage'. */);
6760 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6761 doc
: /* Portion of the heap used for allocation.
6762 Garbage collection can happen automatically once this portion of the heap
6763 has been allocated since the last garbage collection.
6764 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6765 Vgc_cons_percentage
= make_float (0.1);
6767 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6768 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6770 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6771 doc
: /* Number of cons cells that have been consed so far. */);
6773 DEFVAR_INT ("floats-consed", floats_consed
,
6774 doc
: /* Number of floats that have been consed so far. */);
6776 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6777 doc
: /* Number of vector cells that have been consed so far. */);
6779 DEFVAR_INT ("symbols-consed", symbols_consed
,
6780 doc
: /* Number of symbols that have been consed so far. */);
6782 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6783 doc
: /* Number of string characters that have been consed so far. */);
6785 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6786 doc
: /* Number of miscellaneous objects that have been consed so far.
6787 These include markers and overlays, plus certain objects not visible
6790 DEFVAR_INT ("intervals-consed", intervals_consed
,
6791 doc
: /* Number of intervals that have been consed so far. */);
6793 DEFVAR_INT ("strings-consed", strings_consed
,
6794 doc
: /* Number of strings that have been consed so far. */);
6796 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6797 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6798 This means that certain objects should be allocated in shared (pure) space.
6799 It can also be set to a hash-table, in which case this table is used to
6800 do hash-consing of the objects allocated to pure space. */);
6802 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6803 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6804 garbage_collection_messages
= 0;
6806 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6807 doc
: /* Hook run after garbage collection has finished. */);
6808 Vpost_gc_hook
= Qnil
;
6809 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6811 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6812 doc
: /* Precomputed `signal' argument for memory-full error. */);
6813 /* We build this in advance because if we wait until we need it, we might
6814 not be able to allocate the memory to hold it. */
6816 = listn (CONSTYPE_PURE
, 2, Qerror
,
6817 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6819 DEFVAR_LISP ("memory-full", Vmemory_full
,
6820 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6821 Vmemory_full
= Qnil
;
6823 DEFSYM (Qconses
, "conses");
6824 DEFSYM (Qsymbols
, "symbols");
6825 DEFSYM (Qmiscs
, "miscs");
6826 DEFSYM (Qstrings
, "strings");
6827 DEFSYM (Qvectors
, "vectors");
6828 DEFSYM (Qfloats
, "floats");
6829 DEFSYM (Qintervals
, "intervals");
6830 DEFSYM (Qbuffers
, "buffers");
6831 DEFSYM (Qstring_bytes
, "string-bytes");
6832 DEFSYM (Qvector_slots
, "vector-slots");
6833 DEFSYM (Qheap
, "heap");
6834 DEFSYM (Qautomatic_gc
, "Automatic GC");
6836 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6837 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6839 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6840 doc
: /* Accumulated time elapsed in garbage collections.
6841 The time is in seconds as a floating point value. */);
6842 DEFVAR_INT ("gcs-done", gcs_done
,
6843 doc
: /* Accumulated number of garbage collections done. */);
6848 defsubr (&Smake_byte_code
);
6849 defsubr (&Smake_list
);
6850 defsubr (&Smake_vector
);
6851 defsubr (&Smake_string
);
6852 defsubr (&Smake_bool_vector
);
6853 defsubr (&Smake_symbol
);
6854 defsubr (&Smake_marker
);
6855 defsubr (&Spurecopy
);
6856 defsubr (&Sgarbage_collect
);
6857 defsubr (&Smemory_limit
);
6858 defsubr (&Smemory_use_counts
);
6860 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6861 defsubr (&Sgc_status
);
6865 /* When compiled with GCC, GDB might say "No enum type named
6866 pvec_type" if we don't have at least one symbol with that type, and
6867 then xbacktrace could fail. Similarly for the other enums and
6868 their values. Some non-GCC compilers don't like these constructs. */
6872 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6873 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6874 enum char_bits char_bits
;
6875 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6876 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6877 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6878 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6879 enum Lisp_Bits Lisp_Bits
;
6880 enum Lisp_Compiled Lisp_Compiled
;
6881 enum maxargs maxargs
;
6882 enum MAX_ALLOCA MAX_ALLOCA
;
6883 enum More_Lisp_Bits More_Lisp_Bits
;
6884 enum pvec_type pvec_type
;
6885 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6886 #endif /* __GNUC__ */