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);
364 /* Return X rounded to the next multiple of Y. Arguments should not
365 have side effects, as they are evaluated more than once. Assume X
366 + Y - 1 does not overflow. Tune for Y being a power of 2. */
368 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
369 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
370 : ((x) + (y) - 1) & ~ ((y) - 1))
372 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
375 ALIGN (void *ptr
, int alignment
)
377 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
381 XFLOAT_INIT (Lisp_Object f
, double n
)
383 XFLOAT (f
)->u
.data
= n
;
387 /************************************************************************
389 ************************************************************************/
391 /* Function malloc calls this if it finds we are near exhausting storage. */
394 malloc_warning (const char *str
)
396 pending_malloc_warning
= str
;
400 /* Display an already-pending malloc warning. */
403 display_malloc_warning (void)
405 call3 (intern ("display-warning"),
407 build_string (pending_malloc_warning
),
408 intern ("emergency"));
409 pending_malloc_warning
= 0;
412 /* Called if we can't allocate relocatable space for a buffer. */
415 buffer_memory_full (ptrdiff_t nbytes
)
417 /* If buffers use the relocating allocator, no need to free
418 spare_memory, because we may have plenty of malloc space left
419 that we could get, and if we don't, the malloc that fails will
420 itself cause spare_memory to be freed. If buffers don't use the
421 relocating allocator, treat this like any other failing
425 memory_full (nbytes
);
427 /* This used to call error, but if we've run out of memory, we could
428 get infinite recursion trying to build the string. */
429 xsignal (Qnil
, Vmemory_signal_data
);
433 /* A common multiple of the positive integers A and B. Ideally this
434 would be the least common multiple, but there's no way to do that
435 as a constant expression in C, so do the best that we can easily do. */
436 #define COMMON_MULTIPLE(a, b) \
437 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
439 #ifndef XMALLOC_OVERRUN_CHECK
440 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
443 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
446 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
447 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
448 block size in little-endian order. The trailer consists of
449 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
451 The header is used to detect whether this block has been allocated
452 through these functions, as some low-level libc functions may
453 bypass the malloc hooks. */
455 #define XMALLOC_OVERRUN_CHECK_SIZE 16
456 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
457 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
459 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
460 hold a size_t value and (2) the header size is a multiple of the
461 alignment that Emacs needs for C types and for USE_LSB_TAG. */
462 #define XMALLOC_BASE_ALIGNMENT \
463 alignof (union { long double d; intmax_t i; void *p; })
466 # define XMALLOC_HEADER_ALIGNMENT \
467 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
469 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
471 #define XMALLOC_OVERRUN_SIZE_SIZE \
472 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
473 + XMALLOC_HEADER_ALIGNMENT - 1) \
474 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
475 - XMALLOC_OVERRUN_CHECK_SIZE)
477 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
478 { '\x9a', '\x9b', '\xae', '\xaf',
479 '\xbf', '\xbe', '\xce', '\xcf',
480 '\xea', '\xeb', '\xec', '\xed',
481 '\xdf', '\xde', '\x9c', '\x9d' };
483 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
484 { '\xaa', '\xab', '\xac', '\xad',
485 '\xba', '\xbb', '\xbc', '\xbd',
486 '\xca', '\xcb', '\xcc', '\xcd',
487 '\xda', '\xdb', '\xdc', '\xdd' };
489 /* Insert and extract the block size in the header. */
492 xmalloc_put_size (unsigned char *ptr
, size_t size
)
495 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
497 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
503 xmalloc_get_size (unsigned char *ptr
)
507 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
508 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
517 /* Like malloc, but wraps allocated block with header and trailer. */
520 overrun_check_malloc (size_t size
)
522 register unsigned char *val
;
523 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
526 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
529 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
530 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
531 xmalloc_put_size (val
, size
);
532 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
533 XMALLOC_OVERRUN_CHECK_SIZE
);
539 /* Like realloc, but checks old block for overrun, and wraps new block
540 with header and trailer. */
543 overrun_check_realloc (void *block
, size_t size
)
545 register unsigned char *val
= (unsigned char *) block
;
546 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
550 && memcmp (xmalloc_overrun_check_header
,
551 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
552 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
554 size_t osize
= xmalloc_get_size (val
);
555 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
556 XMALLOC_OVERRUN_CHECK_SIZE
))
558 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
559 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
560 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
563 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
567 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
568 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
569 xmalloc_put_size (val
, size
);
570 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
571 XMALLOC_OVERRUN_CHECK_SIZE
);
576 /* Like free, but checks block for overrun. */
579 overrun_check_free (void *block
)
581 unsigned char *val
= (unsigned char *) block
;
584 && memcmp (xmalloc_overrun_check_header
,
585 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
586 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
588 size_t osize
= xmalloc_get_size (val
);
589 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
590 XMALLOC_OVERRUN_CHECK_SIZE
))
592 #ifdef XMALLOC_CLEAR_FREE_MEMORY
593 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
594 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
596 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
597 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
598 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
608 #define malloc overrun_check_malloc
609 #define realloc overrun_check_realloc
610 #define free overrun_check_free
613 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
614 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
615 If that variable is set, block input while in one of Emacs's memory
616 allocation functions. There should be no need for this debugging
617 option, since signal handlers do not allocate memory, but Emacs
618 formerly allocated memory in signal handlers and this compile-time
619 option remains as a way to help debug the issue should it rear its
621 #ifdef XMALLOC_BLOCK_INPUT_CHECK
622 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
624 malloc_block_input (void)
626 if (block_input_in_memory_allocators
)
630 malloc_unblock_input (void)
632 if (block_input_in_memory_allocators
)
635 # define MALLOC_BLOCK_INPUT malloc_block_input ()
636 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
638 # define MALLOC_BLOCK_INPUT ((void) 0)
639 # define MALLOC_UNBLOCK_INPUT ((void) 0)
642 #define MALLOC_PROBE(size) \
644 if (profiler_memory_running) \
645 malloc_probe (size); \
649 /* Like malloc but check for no memory and block interrupt input.. */
652 xmalloc (size_t size
)
658 MALLOC_UNBLOCK_INPUT
;
666 /* Like the above, but zeroes out the memory just allocated. */
669 xzalloc (size_t size
)
675 MALLOC_UNBLOCK_INPUT
;
679 memset (val
, 0, size
);
684 /* Like realloc but check for no memory and block interrupt input.. */
687 xrealloc (void *block
, size_t size
)
692 /* We must call malloc explicitly when BLOCK is 0, since some
693 reallocs don't do this. */
697 val
= realloc (block
, size
);
698 MALLOC_UNBLOCK_INPUT
;
707 /* Like free but block interrupt input. */
716 MALLOC_UNBLOCK_INPUT
;
717 /* We don't call refill_memory_reserve here
718 because in practice the call in r_alloc_free seems to suffice. */
722 /* Other parts of Emacs pass large int values to allocator functions
723 expecting ptrdiff_t. This is portable in practice, but check it to
725 verify (INT_MAX
<= PTRDIFF_MAX
);
728 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
729 Signal an error on memory exhaustion, and block interrupt input. */
732 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
734 eassert (0 <= nitems
&& 0 < item_size
);
735 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
736 memory_full (SIZE_MAX
);
737 return xmalloc (nitems
* item_size
);
741 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
742 Signal an error on memory exhaustion, and block interrupt input. */
745 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
747 eassert (0 <= nitems
&& 0 < item_size
);
748 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
749 memory_full (SIZE_MAX
);
750 return xrealloc (pa
, nitems
* item_size
);
754 /* Grow PA, which points to an array of *NITEMS items, and return the
755 location of the reallocated array, updating *NITEMS to reflect its
756 new size. The new array will contain at least NITEMS_INCR_MIN more
757 items, but will not contain more than NITEMS_MAX items total.
758 ITEM_SIZE is the size of each item, in bytes.
760 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
761 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
764 If PA is null, then allocate a new array instead of reallocating
767 Block interrupt input as needed. If memory exhaustion occurs, set
768 *NITEMS to zero if PA is null, and signal an error (i.e., do not
771 Thus, to grow an array A without saving its old contents, do
772 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
773 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
774 and signals an error, and later this code is reexecuted and
775 attempts to free A. */
778 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
779 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
781 /* The approximate size to use for initial small allocation
782 requests. This is the largest "small" request for the GNU C
784 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
786 /* If the array is tiny, grow it to about (but no greater than)
787 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
788 ptrdiff_t n
= *nitems
;
789 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
790 ptrdiff_t half_again
= n
>> 1;
791 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
793 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
794 NITEMS_MAX, and what the C language can represent safely. */
795 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
796 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
797 ? nitems_max
: C_language_max
);
798 ptrdiff_t nitems_incr_max
= n_max
- n
;
799 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
801 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
804 if (nitems_incr_max
< incr
)
805 memory_full (SIZE_MAX
);
807 pa
= xrealloc (pa
, n
* item_size
);
813 /* Like strdup, but uses xmalloc. */
816 xstrdup (const char *s
)
820 size
= strlen (s
) + 1;
821 return memcpy (xmalloc (size
), s
, size
);
824 /* Like above, but duplicates Lisp string to C string. */
827 xlispstrdup (Lisp_Object string
)
829 ptrdiff_t size
= SBYTES (string
) + 1;
830 return memcpy (xmalloc (size
), SSDATA (string
), size
);
833 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
834 argument is a const pointer. */
837 xputenv (char const *string
)
839 if (putenv ((char *) string
) != 0)
843 /* Return a newly allocated memory block of SIZE bytes, remembering
844 to free it when unwinding. */
846 record_xmalloc (size_t size
)
848 void *p
= xmalloc (size
);
849 record_unwind_protect_ptr (xfree
, p
);
854 /* Like malloc but used for allocating Lisp data. NBYTES is the
855 number of bytes to allocate, TYPE describes the intended use of the
856 allocated memory block (for strings, for conses, ...). */
859 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
863 lisp_malloc (size_t nbytes
, enum mem_type type
)
869 #ifdef GC_MALLOC_CHECK
870 allocated_mem_type
= type
;
873 val
= malloc (nbytes
);
876 /* If the memory just allocated cannot be addressed thru a Lisp
877 object's pointer, and it needs to be,
878 that's equivalent to running out of memory. */
879 if (val
&& type
!= MEM_TYPE_NON_LISP
)
882 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
883 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
885 lisp_malloc_loser
= val
;
892 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
893 if (val
&& type
!= MEM_TYPE_NON_LISP
)
894 mem_insert (val
, (char *) val
+ nbytes
, type
);
897 MALLOC_UNBLOCK_INPUT
;
899 memory_full (nbytes
);
900 MALLOC_PROBE (nbytes
);
904 /* Free BLOCK. This must be called to free memory allocated with a
905 call to lisp_malloc. */
908 lisp_free (void *block
)
912 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
913 mem_delete (mem_find (block
));
915 MALLOC_UNBLOCK_INPUT
;
918 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
920 /* The entry point is lisp_align_malloc which returns blocks of at most
921 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
923 #if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC
924 # define USE_ALIGNED_ALLOC 1
925 /* Defined in gmalloc.c. */
926 void *aligned_alloc (size_t, size_t);
927 #elif defined HAVE_ALIGNED_ALLOC
928 # define USE_ALIGNED_ALLOC 1
929 #elif defined HAVE_POSIX_MEMALIGN
930 # define USE_ALIGNED_ALLOC 1
932 aligned_alloc (size_t alignment
, size_t size
)
935 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
939 /* BLOCK_ALIGN has to be a power of 2. */
940 #define BLOCK_ALIGN (1 << 10)
942 /* Padding to leave at the end of a malloc'd block. This is to give
943 malloc a chance to minimize the amount of memory wasted to alignment.
944 It should be tuned to the particular malloc library used.
945 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
946 aligned_alloc on the other hand would ideally prefer a value of 4
947 because otherwise, there's 1020 bytes wasted between each ablocks.
948 In Emacs, testing shows that those 1020 can most of the time be
949 efficiently used by malloc to place other objects, so a value of 0 can
950 still preferable unless you have a lot of aligned blocks and virtually
952 #define BLOCK_PADDING 0
953 #define BLOCK_BYTES \
954 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
956 /* Internal data structures and constants. */
958 #define ABLOCKS_SIZE 16
960 /* An aligned block of memory. */
965 char payload
[BLOCK_BYTES
];
966 struct ablock
*next_free
;
968 /* `abase' is the aligned base of the ablocks. */
969 /* It is overloaded to hold the virtual `busy' field that counts
970 the number of used ablock in the parent ablocks.
971 The first ablock has the `busy' field, the others have the `abase'
972 field. To tell the difference, we assume that pointers will have
973 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
974 is used to tell whether the real base of the parent ablocks is `abase'
975 (if not, the word before the first ablock holds a pointer to the
977 struct ablocks
*abase
;
978 /* The padding of all but the last ablock is unused. The padding of
979 the last ablock in an ablocks is not allocated. */
981 char padding
[BLOCK_PADDING
];
985 /* A bunch of consecutive aligned blocks. */
988 struct ablock blocks
[ABLOCKS_SIZE
];
991 /* Size of the block requested from malloc or aligned_alloc. */
992 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
994 #define ABLOCK_ABASE(block) \
995 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
996 ? (struct ablocks *)(block) \
999 /* Virtual `busy' field. */
1000 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1002 /* Pointer to the (not necessarily aligned) malloc block. */
1003 #ifdef USE_ALIGNED_ALLOC
1004 #define ABLOCKS_BASE(abase) (abase)
1006 #define ABLOCKS_BASE(abase) \
1007 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1010 /* The list of free ablock. */
1011 static struct ablock
*free_ablock
;
1013 /* Allocate an aligned block of nbytes.
1014 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1015 smaller or equal to BLOCK_BYTES. */
1017 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1020 struct ablocks
*abase
;
1022 eassert (nbytes
<= BLOCK_BYTES
);
1026 #ifdef GC_MALLOC_CHECK
1027 allocated_mem_type
= type
;
1033 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1035 #ifdef DOUG_LEA_MALLOC
1036 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1037 because mapped region contents are not preserved in
1039 mallopt (M_MMAP_MAX
, 0);
1042 #ifdef USE_ALIGNED_ALLOC
1043 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1045 base
= malloc (ABLOCKS_BYTES
);
1046 abase
= ALIGN (base
, BLOCK_ALIGN
);
1051 MALLOC_UNBLOCK_INPUT
;
1052 memory_full (ABLOCKS_BYTES
);
1055 aligned
= (base
== abase
);
1057 ((void **) abase
)[-1] = base
;
1059 #ifdef DOUG_LEA_MALLOC
1060 /* Back to a reasonable maximum of mmap'ed areas. */
1061 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1065 /* If the memory just allocated cannot be addressed thru a Lisp
1066 object's pointer, and it needs to be, that's equivalent to
1067 running out of memory. */
1068 if (type
!= MEM_TYPE_NON_LISP
)
1071 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1072 XSETCONS (tem
, end
);
1073 if ((char *) XCONS (tem
) != end
)
1075 lisp_malloc_loser
= base
;
1077 MALLOC_UNBLOCK_INPUT
;
1078 memory_full (SIZE_MAX
);
1083 /* Initialize the blocks and put them on the free list.
1084 If `base' was not properly aligned, we can't use the last block. */
1085 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1087 abase
->blocks
[i
].abase
= abase
;
1088 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1089 free_ablock
= &abase
->blocks
[i
];
1091 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1093 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1094 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1095 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1096 eassert (ABLOCKS_BASE (abase
) == base
);
1097 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1100 abase
= ABLOCK_ABASE (free_ablock
);
1101 ABLOCKS_BUSY (abase
) =
1102 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1104 free_ablock
= free_ablock
->x
.next_free
;
1106 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1107 if (type
!= MEM_TYPE_NON_LISP
)
1108 mem_insert (val
, (char *) val
+ nbytes
, type
);
1111 MALLOC_UNBLOCK_INPUT
;
1113 MALLOC_PROBE (nbytes
);
1115 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1120 lisp_align_free (void *block
)
1122 struct ablock
*ablock
= block
;
1123 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1126 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1127 mem_delete (mem_find (block
));
1129 /* Put on free list. */
1130 ablock
->x
.next_free
= free_ablock
;
1131 free_ablock
= ablock
;
1132 /* Update busy count. */
1133 ABLOCKS_BUSY (abase
)
1134 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1136 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1137 { /* All the blocks are free. */
1138 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1139 struct ablock
**tem
= &free_ablock
;
1140 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1144 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1147 *tem
= (*tem
)->x
.next_free
;
1150 tem
= &(*tem
)->x
.next_free
;
1152 eassert ((aligned
& 1) == aligned
);
1153 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1154 #ifdef USE_POSIX_MEMALIGN
1155 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1157 free (ABLOCKS_BASE (abase
));
1159 MALLOC_UNBLOCK_INPUT
;
1163 /***********************************************************************
1165 ***********************************************************************/
1167 /* Number of intervals allocated in an interval_block structure.
1168 The 1020 is 1024 minus malloc overhead. */
1170 #define INTERVAL_BLOCK_SIZE \
1171 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1173 /* Intervals are allocated in chunks in the form of an interval_block
1176 struct interval_block
1178 /* Place `intervals' first, to preserve alignment. */
1179 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1180 struct interval_block
*next
;
1183 /* Current interval block. Its `next' pointer points to older
1186 static struct interval_block
*interval_block
;
1188 /* Index in interval_block above of the next unused interval
1191 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1193 /* Number of free and live intervals. */
1195 static EMACS_INT total_free_intervals
, total_intervals
;
1197 /* List of free intervals. */
1199 static INTERVAL interval_free_list
;
1201 /* Return a new interval. */
1204 make_interval (void)
1210 if (interval_free_list
)
1212 val
= interval_free_list
;
1213 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1217 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1219 struct interval_block
*newi
1220 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1222 newi
->next
= interval_block
;
1223 interval_block
= newi
;
1224 interval_block_index
= 0;
1225 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1227 val
= &interval_block
->intervals
[interval_block_index
++];
1230 MALLOC_UNBLOCK_INPUT
;
1232 consing_since_gc
+= sizeof (struct interval
);
1234 total_free_intervals
--;
1235 RESET_INTERVAL (val
);
1241 /* Mark Lisp objects in interval I. */
1244 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1246 /* Intervals should never be shared. So, if extra internal checking is
1247 enabled, GC aborts if it seems to have visited an interval twice. */
1248 eassert (!i
->gcmarkbit
);
1250 mark_object (i
->plist
);
1253 /* Mark the interval tree rooted in I. */
1255 #define MARK_INTERVAL_TREE(i) \
1257 if (i && !i->gcmarkbit) \
1258 traverse_intervals_noorder (i, mark_interval, Qnil); \
1261 /***********************************************************************
1263 ***********************************************************************/
1265 /* Lisp_Strings are allocated in string_block structures. When a new
1266 string_block is allocated, all the Lisp_Strings it contains are
1267 added to a free-list string_free_list. When a new Lisp_String is
1268 needed, it is taken from that list. During the sweep phase of GC,
1269 string_blocks that are entirely free are freed, except two which
1272 String data is allocated from sblock structures. Strings larger
1273 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1274 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1276 Sblocks consist internally of sdata structures, one for each
1277 Lisp_String. The sdata structure points to the Lisp_String it
1278 belongs to. The Lisp_String points back to the `u.data' member of
1279 its sdata structure.
1281 When a Lisp_String is freed during GC, it is put back on
1282 string_free_list, and its `data' member and its sdata's `string'
1283 pointer is set to null. The size of the string is recorded in the
1284 `n.nbytes' member of the sdata. So, sdata structures that are no
1285 longer used, can be easily recognized, and it's easy to compact the
1286 sblocks of small strings which we do in compact_small_strings. */
1288 /* Size in bytes of an sblock structure used for small strings. This
1289 is 8192 minus malloc overhead. */
1291 #define SBLOCK_SIZE 8188
1293 /* Strings larger than this are considered large strings. String data
1294 for large strings is allocated from individual sblocks. */
1296 #define LARGE_STRING_BYTES 1024
1298 /* The SDATA typedef is a struct or union describing string memory
1299 sub-allocated from an sblock. This is where the contents of Lisp
1300 strings are stored. */
1304 /* Back-pointer to the string this sdata belongs to. If null, this
1305 structure is free, and NBYTES (in this structure or in the union below)
1306 contains the string's byte size (the same value that STRING_BYTES
1307 would return if STRING were non-null). If non-null, STRING_BYTES
1308 (STRING) is the size of the data, and DATA contains the string's
1310 struct Lisp_String
*string
;
1312 #ifdef GC_CHECK_STRING_BYTES
1316 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1319 #ifdef GC_CHECK_STRING_BYTES
1321 typedef struct sdata sdata
;
1322 #define SDATA_NBYTES(S) (S)->nbytes
1323 #define SDATA_DATA(S) (S)->data
1329 struct Lisp_String
*string
;
1331 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1332 which has a flexible array member. However, if implemented by
1333 giving this union a member of type 'struct sdata', the union
1334 could not be the last (flexible) member of 'struct sblock',
1335 because C99 prohibits a flexible array member from having a type
1336 that is itself a flexible array. So, comment this member out here,
1337 but remember that the option's there when using this union. */
1342 /* When STRING is null. */
1345 struct Lisp_String
*string
;
1350 #define SDATA_NBYTES(S) (S)->n.nbytes
1351 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1353 #endif /* not GC_CHECK_STRING_BYTES */
1355 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1357 /* Structure describing a block of memory which is sub-allocated to
1358 obtain string data memory for strings. Blocks for small strings
1359 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1360 as large as needed. */
1365 struct sblock
*next
;
1367 /* Pointer to the next free sdata block. This points past the end
1368 of the sblock if there isn't any space left in this block. */
1372 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1375 /* Number of Lisp strings in a string_block structure. The 1020 is
1376 1024 minus malloc overhead. */
1378 #define STRING_BLOCK_SIZE \
1379 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1381 /* Structure describing a block from which Lisp_String structures
1386 /* Place `strings' first, to preserve alignment. */
1387 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1388 struct string_block
*next
;
1391 /* Head and tail of the list of sblock structures holding Lisp string
1392 data. We always allocate from current_sblock. The NEXT pointers
1393 in the sblock structures go from oldest_sblock to current_sblock. */
1395 static struct sblock
*oldest_sblock
, *current_sblock
;
1397 /* List of sblocks for large strings. */
1399 static struct sblock
*large_sblocks
;
1401 /* List of string_block structures. */
1403 static struct string_block
*string_blocks
;
1405 /* Free-list of Lisp_Strings. */
1407 static struct Lisp_String
*string_free_list
;
1409 /* Number of live and free Lisp_Strings. */
1411 static EMACS_INT total_strings
, total_free_strings
;
1413 /* Number of bytes used by live strings. */
1415 static EMACS_INT total_string_bytes
;
1417 /* Given a pointer to a Lisp_String S which is on the free-list
1418 string_free_list, return a pointer to its successor in the
1421 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1423 /* Return a pointer to the sdata structure belonging to Lisp string S.
1424 S must be live, i.e. S->data must not be null. S->data is actually
1425 a pointer to the `u.data' member of its sdata structure; the
1426 structure starts at a constant offset in front of that. */
1428 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1431 #ifdef GC_CHECK_STRING_OVERRUN
1433 /* We check for overrun in string data blocks by appending a small
1434 "cookie" after each allocated string data block, and check for the
1435 presence of this cookie during GC. */
1437 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1438 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1439 { '\xde', '\xad', '\xbe', '\xef' };
1442 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1445 /* Value is the size of an sdata structure large enough to hold NBYTES
1446 bytes of string data. The value returned includes a terminating
1447 NUL byte, the size of the sdata structure, and padding. */
1449 #ifdef GC_CHECK_STRING_BYTES
1451 #define SDATA_SIZE(NBYTES) \
1452 ((SDATA_DATA_OFFSET \
1454 + sizeof (ptrdiff_t) - 1) \
1455 & ~(sizeof (ptrdiff_t) - 1))
1457 #else /* not GC_CHECK_STRING_BYTES */
1459 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1460 less than the size of that member. The 'max' is not needed when
1461 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1462 alignment code reserves enough space. */
1464 #define SDATA_SIZE(NBYTES) \
1465 ((SDATA_DATA_OFFSET \
1466 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1468 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1470 + sizeof (ptrdiff_t) - 1) \
1471 & ~(sizeof (ptrdiff_t) - 1))
1473 #endif /* not GC_CHECK_STRING_BYTES */
1475 /* Extra bytes to allocate for each string. */
1477 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1479 /* Exact bound on the number of bytes in a string, not counting the
1480 terminating null. A string cannot contain more bytes than
1481 STRING_BYTES_BOUND, nor can it be so long that the size_t
1482 arithmetic in allocate_string_data would overflow while it is
1483 calculating a value to be passed to malloc. */
1484 static ptrdiff_t const STRING_BYTES_MAX
=
1485 min (STRING_BYTES_BOUND
,
1486 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1488 - offsetof (struct sblock
, data
)
1489 - SDATA_DATA_OFFSET
)
1490 & ~(sizeof (EMACS_INT
) - 1)));
1492 /* Initialize string allocation. Called from init_alloc_once. */
1497 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1498 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1502 #ifdef GC_CHECK_STRING_BYTES
1504 static int check_string_bytes_count
;
1506 /* Like STRING_BYTES, but with debugging check. Can be
1507 called during GC, so pay attention to the mark bit. */
1510 string_bytes (struct Lisp_String
*s
)
1513 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1515 if (!PURE_POINTER_P (s
)
1517 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1522 /* Check validity of Lisp strings' string_bytes member in B. */
1525 check_sblock (struct sblock
*b
)
1527 sdata
*from
, *end
, *from_end
;
1531 for (from
= b
->data
; from
< end
; from
= from_end
)
1533 /* Compute the next FROM here because copying below may
1534 overwrite data we need to compute it. */
1537 /* Check that the string size recorded in the string is the
1538 same as the one recorded in the sdata structure. */
1539 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1540 : SDATA_NBYTES (from
));
1541 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1546 /* Check validity of Lisp strings' string_bytes member. ALL_P
1547 means check all strings, otherwise check only most
1548 recently allocated strings. Used for hunting a bug. */
1551 check_string_bytes (bool all_p
)
1557 for (b
= large_sblocks
; b
; b
= b
->next
)
1559 struct Lisp_String
*s
= b
->data
[0].string
;
1564 for (b
= oldest_sblock
; b
; b
= b
->next
)
1567 else if (current_sblock
)
1568 check_sblock (current_sblock
);
1571 #else /* not GC_CHECK_STRING_BYTES */
1573 #define check_string_bytes(all) ((void) 0)
1575 #endif /* GC_CHECK_STRING_BYTES */
1577 #ifdef GC_CHECK_STRING_FREE_LIST
1579 /* Walk through the string free list looking for bogus next pointers.
1580 This may catch buffer overrun from a previous string. */
1583 check_string_free_list (void)
1585 struct Lisp_String
*s
;
1587 /* Pop a Lisp_String off the free-list. */
1588 s
= string_free_list
;
1591 if ((uintptr_t) s
< 1024)
1593 s
= NEXT_FREE_LISP_STRING (s
);
1597 #define check_string_free_list()
1600 /* Return a new Lisp_String. */
1602 static struct Lisp_String
*
1603 allocate_string (void)
1605 struct Lisp_String
*s
;
1609 /* If the free-list is empty, allocate a new string_block, and
1610 add all the Lisp_Strings in it to the free-list. */
1611 if (string_free_list
== NULL
)
1613 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1616 b
->next
= string_blocks
;
1619 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1622 /* Every string on a free list should have NULL data pointer. */
1624 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1625 string_free_list
= s
;
1628 total_free_strings
+= STRING_BLOCK_SIZE
;
1631 check_string_free_list ();
1633 /* Pop a Lisp_String off the free-list. */
1634 s
= string_free_list
;
1635 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1637 MALLOC_UNBLOCK_INPUT
;
1639 --total_free_strings
;
1642 consing_since_gc
+= sizeof *s
;
1644 #ifdef GC_CHECK_STRING_BYTES
1645 if (!noninteractive
)
1647 if (++check_string_bytes_count
== 200)
1649 check_string_bytes_count
= 0;
1650 check_string_bytes (1);
1653 check_string_bytes (0);
1655 #endif /* GC_CHECK_STRING_BYTES */
1661 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1662 plus a NUL byte at the end. Allocate an sdata structure for S, and
1663 set S->data to its `u.data' member. Store a NUL byte at the end of
1664 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1665 S->data if it was initially non-null. */
1668 allocate_string_data (struct Lisp_String
*s
,
1669 EMACS_INT nchars
, EMACS_INT nbytes
)
1671 sdata
*data
, *old_data
;
1673 ptrdiff_t needed
, old_nbytes
;
1675 if (STRING_BYTES_MAX
< nbytes
)
1678 /* Determine the number of bytes needed to store NBYTES bytes
1680 needed
= SDATA_SIZE (nbytes
);
1683 old_data
= SDATA_OF_STRING (s
);
1684 old_nbytes
= STRING_BYTES (s
);
1691 if (nbytes
> LARGE_STRING_BYTES
)
1693 size_t size
= offsetof (struct sblock
, data
) + needed
;
1695 #ifdef DOUG_LEA_MALLOC
1696 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1697 because mapped region contents are not preserved in
1700 In case you think of allowing it in a dumped Emacs at the
1701 cost of not being able to re-dump, there's another reason:
1702 mmap'ed data typically have an address towards the top of the
1703 address space, which won't fit into an EMACS_INT (at least on
1704 32-bit systems with the current tagging scheme). --fx */
1705 mallopt (M_MMAP_MAX
, 0);
1708 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1710 #ifdef DOUG_LEA_MALLOC
1711 /* Back to a reasonable maximum of mmap'ed areas. */
1712 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1715 b
->next_free
= b
->data
;
1716 b
->data
[0].string
= NULL
;
1717 b
->next
= large_sblocks
;
1720 else if (current_sblock
== NULL
1721 || (((char *) current_sblock
+ SBLOCK_SIZE
1722 - (char *) current_sblock
->next_free
)
1723 < (needed
+ GC_STRING_EXTRA
)))
1725 /* Not enough room in the current sblock. */
1726 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1727 b
->next_free
= b
->data
;
1728 b
->data
[0].string
= NULL
;
1732 current_sblock
->next
= b
;
1740 data
= b
->next_free
;
1741 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1743 MALLOC_UNBLOCK_INPUT
;
1746 s
->data
= SDATA_DATA (data
);
1747 #ifdef GC_CHECK_STRING_BYTES
1748 SDATA_NBYTES (data
) = nbytes
;
1751 s
->size_byte
= nbytes
;
1752 s
->data
[nbytes
] = '\0';
1753 #ifdef GC_CHECK_STRING_OVERRUN
1754 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1755 GC_STRING_OVERRUN_COOKIE_SIZE
);
1758 /* Note that Faset may call to this function when S has already data
1759 assigned. In this case, mark data as free by setting it's string
1760 back-pointer to null, and record the size of the data in it. */
1763 SDATA_NBYTES (old_data
) = old_nbytes
;
1764 old_data
->string
= NULL
;
1767 consing_since_gc
+= needed
;
1771 /* Sweep and compact strings. */
1774 sweep_strings (void)
1776 struct string_block
*b
, *next
;
1777 struct string_block
*live_blocks
= NULL
;
1779 string_free_list
= NULL
;
1780 total_strings
= total_free_strings
= 0;
1781 total_string_bytes
= 0;
1783 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1784 for (b
= string_blocks
; b
; b
= next
)
1787 struct Lisp_String
*free_list_before
= string_free_list
;
1791 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1793 struct Lisp_String
*s
= b
->strings
+ i
;
1797 /* String was not on free-list before. */
1798 if (STRING_MARKED_P (s
))
1800 /* String is live; unmark it and its intervals. */
1803 /* Do not use string_(set|get)_intervals here. */
1804 s
->intervals
= balance_intervals (s
->intervals
);
1807 total_string_bytes
+= STRING_BYTES (s
);
1811 /* String is dead. Put it on the free-list. */
1812 sdata
*data
= SDATA_OF_STRING (s
);
1814 /* Save the size of S in its sdata so that we know
1815 how large that is. Reset the sdata's string
1816 back-pointer so that we know it's free. */
1817 #ifdef GC_CHECK_STRING_BYTES
1818 if (string_bytes (s
) != SDATA_NBYTES (data
))
1821 data
->n
.nbytes
= STRING_BYTES (s
);
1823 data
->string
= NULL
;
1825 /* Reset the strings's `data' member so that we
1829 /* Put the string on the free-list. */
1830 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1831 string_free_list
= s
;
1837 /* S was on the free-list before. Put it there again. */
1838 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1839 string_free_list
= s
;
1844 /* Free blocks that contain free Lisp_Strings only, except
1845 the first two of them. */
1846 if (nfree
== STRING_BLOCK_SIZE
1847 && total_free_strings
> STRING_BLOCK_SIZE
)
1850 string_free_list
= free_list_before
;
1854 total_free_strings
+= nfree
;
1855 b
->next
= live_blocks
;
1860 check_string_free_list ();
1862 string_blocks
= live_blocks
;
1863 free_large_strings ();
1864 compact_small_strings ();
1866 check_string_free_list ();
1870 /* Free dead large strings. */
1873 free_large_strings (void)
1875 struct sblock
*b
, *next
;
1876 struct sblock
*live_blocks
= NULL
;
1878 for (b
= large_sblocks
; b
; b
= next
)
1882 if (b
->data
[0].string
== NULL
)
1886 b
->next
= live_blocks
;
1891 large_sblocks
= live_blocks
;
1895 /* Compact data of small strings. Free sblocks that don't contain
1896 data of live strings after compaction. */
1899 compact_small_strings (void)
1901 struct sblock
*b
, *tb
, *next
;
1902 sdata
*from
, *to
, *end
, *tb_end
;
1903 sdata
*to_end
, *from_end
;
1905 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1906 to, and TB_END is the end of TB. */
1908 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1911 /* Step through the blocks from the oldest to the youngest. We
1912 expect that old blocks will stabilize over time, so that less
1913 copying will happen this way. */
1914 for (b
= oldest_sblock
; b
; b
= b
->next
)
1917 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1919 for (from
= b
->data
; from
< end
; from
= from_end
)
1921 /* Compute the next FROM here because copying below may
1922 overwrite data we need to compute it. */
1924 struct Lisp_String
*s
= from
->string
;
1926 #ifdef GC_CHECK_STRING_BYTES
1927 /* Check that the string size recorded in the string is the
1928 same as the one recorded in the sdata structure. */
1929 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1931 #endif /* GC_CHECK_STRING_BYTES */
1933 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1934 eassert (nbytes
<= LARGE_STRING_BYTES
);
1936 nbytes
= SDATA_SIZE (nbytes
);
1937 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1939 #ifdef GC_CHECK_STRING_OVERRUN
1940 if (memcmp (string_overrun_cookie
,
1941 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1942 GC_STRING_OVERRUN_COOKIE_SIZE
))
1946 /* Non-NULL S means it's alive. Copy its data. */
1949 /* If TB is full, proceed with the next sblock. */
1950 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1951 if (to_end
> tb_end
)
1955 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1957 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1960 /* Copy, and update the string's `data' pointer. */
1963 eassert (tb
!= b
|| to
< from
);
1964 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1965 to
->string
->data
= SDATA_DATA (to
);
1968 /* Advance past the sdata we copied to. */
1974 /* The rest of the sblocks following TB don't contain live data, so
1975 we can free them. */
1976 for (b
= tb
->next
; b
; b
= next
)
1984 current_sblock
= tb
;
1988 string_overflow (void)
1990 error ("Maximum string size exceeded");
1993 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1994 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1995 LENGTH must be an integer.
1996 INIT must be an integer that represents a character. */)
1997 (Lisp_Object length
, Lisp_Object init
)
1999 register Lisp_Object val
;
2003 CHECK_NATNUM (length
);
2004 CHECK_CHARACTER (init
);
2006 c
= XFASTINT (init
);
2007 if (ASCII_CHAR_P (c
))
2009 nbytes
= XINT (length
);
2010 val
= make_uninit_string (nbytes
);
2011 memset (SDATA (val
), c
, nbytes
);
2012 SDATA (val
)[nbytes
] = 0;
2016 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2017 ptrdiff_t len
= CHAR_STRING (c
, str
);
2018 EMACS_INT string_len
= XINT (length
);
2019 unsigned char *p
, *beg
, *end
;
2021 if (string_len
> STRING_BYTES_MAX
/ len
)
2023 nbytes
= len
* string_len
;
2024 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2025 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2027 /* First time we just copy `str' to the data of `val'. */
2029 memcpy (p
, str
, len
);
2032 /* Next time we copy largest possible chunk from
2033 initialized to uninitialized part of `val'. */
2034 len
= min (p
- beg
, end
- p
);
2035 memcpy (p
, beg
, len
);
2044 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2048 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2050 EMACS_INT nbits
= bool_vector_size (a
);
2053 unsigned char *data
= bool_vector_uchar_data (a
);
2054 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2055 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2056 int last_mask
= ~ (~0 << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2057 memset (data
, pattern
, nbytes
- 1);
2058 data
[nbytes
- 1] = pattern
& last_mask
;
2063 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2066 make_uninit_bool_vector (EMACS_INT nbits
)
2069 EMACS_INT words
= bool_vector_words (nbits
);
2070 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2071 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2074 struct Lisp_Bool_Vector
*p
2075 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2076 XSETVECTOR (val
, p
);
2077 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2080 /* Clear padding at the end. */
2082 p
->data
[words
- 1] = 0;
2087 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2088 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2089 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2090 (Lisp_Object length
, Lisp_Object init
)
2094 CHECK_NATNUM (length
);
2095 val
= make_uninit_bool_vector (XFASTINT (length
));
2096 return bool_vector_fill (val
, init
);
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 /* Sometimes a vector's contents are merely a pointer internally used
2610 in vector allocation code. Usually you don't want to touch this. */
2612 static struct Lisp_Vector
*
2613 next_vector (struct Lisp_Vector
*v
)
2615 return XUNTAG (v
->contents
[0], 0);
2619 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2621 v
->contents
[0] = make_lisp_ptr (p
, 0);
2624 /* This value is balanced well enough to avoid too much internal overhead
2625 for the most common cases; it's not required to be a power of two, but
2626 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2628 #define VECTOR_BLOCK_SIZE 4096
2632 /* Alignment of struct Lisp_Vector objects. */
2633 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2634 USE_LSB_TAG
? GCALIGNMENT
: 1),
2636 /* Vector size requests are a multiple of this. */
2637 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2640 /* Verify assumptions described above. */
2641 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2642 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2644 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2645 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2646 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2647 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2649 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2651 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2653 /* Size of the minimal vector allocated from block. */
2655 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2657 /* Size of the largest vector allocated from block. */
2659 #define VBLOCK_BYTES_MAX \
2660 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2662 /* We maintain one free list for each possible block-allocated
2663 vector size, and this is the number of free lists we have. */
2665 #define VECTOR_MAX_FREE_LIST_INDEX \
2666 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2668 /* Common shortcut to advance vector pointer over a block data. */
2670 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2672 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2674 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2676 /* Common shortcut to setup vector on a free list. */
2678 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2680 (tmp) = ((nbytes - header_size) / word_size); \
2681 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2682 eassert ((nbytes) % roundup_size == 0); \
2683 (tmp) = VINDEX (nbytes); \
2684 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2685 set_next_vector (v, vector_free_lists[tmp]); \
2686 vector_free_lists[tmp] = (v); \
2687 total_free_vector_slots += (nbytes) / word_size; \
2690 /* This internal type is used to maintain the list of large vectors
2691 which are allocated at their own, e.g. outside of vector blocks.
2693 struct large_vector itself cannot contain a struct Lisp_Vector, as
2694 the latter contains a flexible array member and C99 does not allow
2695 such structs to be nested. Instead, each struct large_vector
2696 object LV is followed by a struct Lisp_Vector, which is at offset
2697 large_vector_offset from LV, and whose address is therefore
2698 large_vector_vec (&LV). */
2702 struct large_vector
*next
;
2707 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2710 static struct Lisp_Vector
*
2711 large_vector_vec (struct large_vector
*p
)
2713 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
2716 /* This internal type is used to maintain an underlying storage
2717 for small vectors. */
2721 char data
[VECTOR_BLOCK_BYTES
];
2722 struct vector_block
*next
;
2725 /* Chain of vector blocks. */
2727 static struct vector_block
*vector_blocks
;
2729 /* Vector free lists, where NTH item points to a chain of free
2730 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2732 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2734 /* Singly-linked list of large vectors. */
2736 static struct large_vector
*large_vectors
;
2738 /* The only vector with 0 slots, allocated from pure space. */
2740 Lisp_Object zero_vector
;
2742 /* Number of live vectors. */
2744 static EMACS_INT total_vectors
;
2746 /* Total size of live and free vectors, in Lisp_Object units. */
2748 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2750 /* Get a new vector block. */
2752 static struct vector_block
*
2753 allocate_vector_block (void)
2755 struct vector_block
*block
= xmalloc (sizeof *block
);
2757 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2758 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2759 MEM_TYPE_VECTOR_BLOCK
);
2762 block
->next
= vector_blocks
;
2763 vector_blocks
= block
;
2767 /* Called once to initialize vector allocation. */
2772 zero_vector
= make_pure_vector (0);
2775 /* Allocate vector from a vector block. */
2777 static struct Lisp_Vector
*
2778 allocate_vector_from_block (size_t nbytes
)
2780 struct Lisp_Vector
*vector
;
2781 struct vector_block
*block
;
2782 size_t index
, restbytes
;
2784 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2785 eassert (nbytes
% roundup_size
== 0);
2787 /* First, try to allocate from a free list
2788 containing vectors of the requested size. */
2789 index
= VINDEX (nbytes
);
2790 if (vector_free_lists
[index
])
2792 vector
= vector_free_lists
[index
];
2793 vector_free_lists
[index
] = next_vector (vector
);
2794 total_free_vector_slots
-= nbytes
/ word_size
;
2798 /* Next, check free lists containing larger vectors. Since
2799 we will split the result, we should have remaining space
2800 large enough to use for one-slot vector at least. */
2801 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2802 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2803 if (vector_free_lists
[index
])
2805 /* This vector is larger than requested. */
2806 vector
= vector_free_lists
[index
];
2807 vector_free_lists
[index
] = next_vector (vector
);
2808 total_free_vector_slots
-= nbytes
/ word_size
;
2810 /* Excess bytes are used for the smaller vector,
2811 which should be set on an appropriate free list. */
2812 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2813 eassert (restbytes
% roundup_size
== 0);
2814 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2818 /* Finally, need a new vector block. */
2819 block
= allocate_vector_block ();
2821 /* New vector will be at the beginning of this block. */
2822 vector
= (struct Lisp_Vector
*) block
->data
;
2824 /* If the rest of space from this block is large enough
2825 for one-slot vector at least, set up it on a free list. */
2826 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2827 if (restbytes
>= VBLOCK_BYTES_MIN
)
2829 eassert (restbytes
% roundup_size
== 0);
2830 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2835 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2837 #define VECTOR_IN_BLOCK(vector, block) \
2838 ((char *) (vector) <= (block)->data \
2839 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2841 /* Return the memory footprint of V in bytes. */
2844 vector_nbytes (struct Lisp_Vector
*v
)
2846 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2849 if (size
& PSEUDOVECTOR_FLAG
)
2851 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2853 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
2854 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
2855 * sizeof (bits_word
));
2856 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
2857 verify (header_size
<= bool_header_size
);
2858 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
2861 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
2862 + ((size
& PSEUDOVECTOR_REST_MASK
)
2863 >> PSEUDOVECTOR_SIZE_BITS
));
2867 return vroundup (header_size
+ word_size
* nwords
);
2870 /* Release extra resources still in use by VECTOR, which may be any
2871 vector-like object. For now, this is used just to free data in
2875 cleanup_vector (struct Lisp_Vector
*vector
)
2877 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
))
2879 ptrdiff_t size
= vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
2880 Lisp_Object obj
= make_lisp_ptr (vector
, Lisp_Vectorlike
);
2882 if (size
== FONT_OBJECT_MAX
)
2883 font_close_object (obj
);
2885 else if (size
== FONT_ENTITY_MAX
)
2887 struct font_entity
*entity
= (struct font_entity
*) vector
;
2888 if (entity
->driver
&& entity
->driver
->free_entity
)
2889 entity
->driver
->free_entity (obj
);
2891 #endif /* HAVE_NS */
2895 /* Reclaim space used by unmarked vectors. */
2898 sweep_vectors (void)
2900 struct vector_block
*block
, **bprev
= &vector_blocks
;
2901 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2902 struct Lisp_Vector
*vector
, *next
;
2904 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2905 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2907 /* Looking through vector blocks. */
2909 for (block
= vector_blocks
; block
; block
= *bprev
)
2911 bool free_this_block
= 0;
2914 for (vector
= (struct Lisp_Vector
*) block
->data
;
2915 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2917 if (VECTOR_MARKED_P (vector
))
2919 VECTOR_UNMARK (vector
);
2921 nbytes
= vector_nbytes (vector
);
2922 total_vector_slots
+= nbytes
/ word_size
;
2923 next
= ADVANCE (vector
, nbytes
);
2927 ptrdiff_t total_bytes
;
2929 cleanup_vector (vector
);
2930 nbytes
= vector_nbytes (vector
);
2931 total_bytes
= nbytes
;
2932 next
= ADVANCE (vector
, nbytes
);
2934 /* While NEXT is not marked, try to coalesce with VECTOR,
2935 thus making VECTOR of the largest possible size. */
2937 while (VECTOR_IN_BLOCK (next
, block
))
2939 if (VECTOR_MARKED_P (next
))
2941 cleanup_vector (next
);
2942 nbytes
= vector_nbytes (next
);
2943 total_bytes
+= nbytes
;
2944 next
= ADVANCE (next
, nbytes
);
2947 eassert (total_bytes
% roundup_size
== 0);
2949 if (vector
== (struct Lisp_Vector
*) block
->data
2950 && !VECTOR_IN_BLOCK (next
, block
))
2951 /* This block should be freed because all of it's
2952 space was coalesced into the only free vector. */
2953 free_this_block
= 1;
2957 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2962 if (free_this_block
)
2964 *bprev
= block
->next
;
2965 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2966 mem_delete (mem_find (block
->data
));
2971 bprev
= &block
->next
;
2974 /* Sweep large vectors. */
2976 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2978 vector
= large_vector_vec (lv
);
2979 if (VECTOR_MARKED_P (vector
))
2981 VECTOR_UNMARK (vector
);
2983 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2985 /* All non-bool pseudovectors are small enough to be allocated
2986 from vector blocks. This code should be redesigned if some
2987 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2988 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2989 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
2993 += header_size
/ word_size
+ vector
->header
.size
;
3004 /* Value is a pointer to a newly allocated Lisp_Vector structure
3005 with room for LEN Lisp_Objects. */
3007 static struct Lisp_Vector
*
3008 allocate_vectorlike (ptrdiff_t len
)
3010 struct Lisp_Vector
*p
;
3015 p
= XVECTOR (zero_vector
);
3018 size_t nbytes
= header_size
+ len
* word_size
;
3020 #ifdef DOUG_LEA_MALLOC
3021 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
3022 because mapped region contents are not preserved in
3024 mallopt (M_MMAP_MAX
, 0);
3027 if (nbytes
<= VBLOCK_BYTES_MAX
)
3028 p
= allocate_vector_from_block (vroundup (nbytes
));
3031 struct large_vector
*lv
3032 = lisp_malloc ((large_vector_offset
+ header_size
3034 MEM_TYPE_VECTORLIKE
);
3035 lv
->next
= large_vectors
;
3037 p
= large_vector_vec (lv
);
3040 #ifdef DOUG_LEA_MALLOC
3041 /* Back to a reasonable maximum of mmap'ed areas. */
3042 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3045 consing_since_gc
+= nbytes
;
3046 vector_cells_consed
+= len
;
3049 MALLOC_UNBLOCK_INPUT
;
3055 /* Allocate a vector with LEN slots. */
3057 struct Lisp_Vector
*
3058 allocate_vector (EMACS_INT len
)
3060 struct Lisp_Vector
*v
;
3061 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3063 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3064 memory_full (SIZE_MAX
);
3065 v
= allocate_vectorlike (len
);
3066 v
->header
.size
= len
;
3071 /* Allocate other vector-like structures. */
3073 struct Lisp_Vector
*
3074 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3076 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3079 /* Catch bogus values. */
3080 eassert (tag
<= PVEC_FONT
);
3081 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3082 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3084 /* Only the first lisplen slots will be traced normally by the GC. */
3085 for (i
= 0; i
< lisplen
; ++i
)
3086 v
->contents
[i
] = Qnil
;
3088 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3093 allocate_buffer (void)
3095 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3097 BUFFER_PVEC_INIT (b
);
3098 /* Put B on the chain of all buffers including killed ones. */
3099 b
->next
= all_buffers
;
3101 /* Note that the rest fields of B are not initialized. */
3105 struct Lisp_Hash_Table
*
3106 allocate_hash_table (void)
3108 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3112 allocate_window (void)
3116 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3117 /* Users assumes that non-Lisp data is zeroed. */
3118 memset (&w
->current_matrix
, 0,
3119 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3124 allocate_terminal (void)
3128 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3129 /* Users assumes that non-Lisp data is zeroed. */
3130 memset (&t
->next_terminal
, 0,
3131 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3136 allocate_frame (void)
3140 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3141 /* Users assumes that non-Lisp data is zeroed. */
3142 memset (&f
->face_cache
, 0,
3143 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3147 struct Lisp_Process
*
3148 allocate_process (void)
3150 struct Lisp_Process
*p
;
3152 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3153 /* Users assumes that non-Lisp data is zeroed. */
3155 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3159 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3160 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3161 See also the function `vector'. */)
3162 (register Lisp_Object length
, Lisp_Object init
)
3165 register ptrdiff_t sizei
;
3166 register ptrdiff_t i
;
3167 register struct Lisp_Vector
*p
;
3169 CHECK_NATNUM (length
);
3171 p
= allocate_vector (XFASTINT (length
));
3172 sizei
= XFASTINT (length
);
3173 for (i
= 0; i
< sizei
; i
++)
3174 p
->contents
[i
] = init
;
3176 XSETVECTOR (vector
, p
);
3181 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3182 doc
: /* Return a newly created vector with specified arguments as elements.
3183 Any number of arguments, even zero arguments, are allowed.
3184 usage: (vector &rest OBJECTS) */)
3185 (ptrdiff_t nargs
, Lisp_Object
*args
)
3188 register Lisp_Object val
= make_uninit_vector (nargs
);
3189 register struct Lisp_Vector
*p
= XVECTOR (val
);
3191 for (i
= 0; i
< nargs
; i
++)
3192 p
->contents
[i
] = args
[i
];
3197 make_byte_code (struct Lisp_Vector
*v
)
3199 /* Don't allow the global zero_vector to become a byte code object. */
3200 eassert(0 < v
->header
.size
);
3201 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3202 && STRING_MULTIBYTE (v
->contents
[1]))
3203 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3204 earlier because they produced a raw 8-bit string for byte-code
3205 and now such a byte-code string is loaded as multibyte while
3206 raw 8-bit characters converted to multibyte form. Thus, now we
3207 must convert them back to the original unibyte form. */
3208 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3209 XSETPVECTYPE (v
, PVEC_COMPILED
);
3212 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3213 doc
: /* Create a byte-code object with specified arguments as elements.
3214 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3215 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3216 and (optional) INTERACTIVE-SPEC.
3217 The first four arguments are required; at most six have any
3219 The ARGLIST can be either like the one of `lambda', in which case the arguments
3220 will be dynamically bound before executing the byte code, or it can be an
3221 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3222 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3223 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3224 argument to catch the left-over arguments. If such an integer is used, the
3225 arguments will not be dynamically bound but will be instead pushed on the
3226 stack before executing the byte-code.
3227 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3228 (ptrdiff_t nargs
, Lisp_Object
*args
)
3231 register Lisp_Object val
= make_uninit_vector (nargs
);
3232 register struct Lisp_Vector
*p
= XVECTOR (val
);
3234 /* We used to purecopy everything here, if purify-flag was set. This worked
3235 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3236 dangerous, since make-byte-code is used during execution to build
3237 closures, so any closure built during the preload phase would end up
3238 copied into pure space, including its free variables, which is sometimes
3239 just wasteful and other times plainly wrong (e.g. those free vars may want
3242 for (i
= 0; i
< nargs
; i
++)
3243 p
->contents
[i
] = args
[i
];
3245 XSETCOMPILED (val
, p
);
3251 /***********************************************************************
3253 ***********************************************************************/
3255 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3256 of the required alignment if LSB tags are used. */
3258 union aligned_Lisp_Symbol
3260 struct Lisp_Symbol s
;
3262 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3267 /* Each symbol_block is just under 1020 bytes long, since malloc
3268 really allocates in units of powers of two and uses 4 bytes for its
3271 #define SYMBOL_BLOCK_SIZE \
3272 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3276 /* Place `symbols' first, to preserve alignment. */
3277 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3278 struct symbol_block
*next
;
3281 /* Current symbol block and index of first unused Lisp_Symbol
3284 static struct symbol_block
*symbol_block
;
3285 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3287 /* List of free symbols. */
3289 static struct Lisp_Symbol
*symbol_free_list
;
3292 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3294 XSYMBOL (sym
)->name
= name
;
3297 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3298 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3299 Its value is void, and its function definition and property list are nil. */)
3302 register Lisp_Object val
;
3303 register struct Lisp_Symbol
*p
;
3305 CHECK_STRING (name
);
3309 if (symbol_free_list
)
3311 XSETSYMBOL (val
, symbol_free_list
);
3312 symbol_free_list
= symbol_free_list
->next
;
3316 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3318 struct symbol_block
*new
3319 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3320 new->next
= symbol_block
;
3322 symbol_block_index
= 0;
3323 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3325 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3326 symbol_block_index
++;
3329 MALLOC_UNBLOCK_INPUT
;
3332 set_symbol_name (val
, name
);
3333 set_symbol_plist (val
, Qnil
);
3334 p
->redirect
= SYMBOL_PLAINVAL
;
3335 SET_SYMBOL_VAL (p
, Qunbound
);
3336 set_symbol_function (val
, Qnil
);
3337 set_symbol_next (val
, NULL
);
3339 p
->interned
= SYMBOL_UNINTERNED
;
3341 p
->declared_special
= 0;
3342 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3344 total_free_symbols
--;
3350 /***********************************************************************
3351 Marker (Misc) Allocation
3352 ***********************************************************************/
3354 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3355 the required alignment when LSB tags are used. */
3357 union aligned_Lisp_Misc
3361 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3366 /* Allocation of markers and other objects that share that structure.
3367 Works like allocation of conses. */
3369 #define MARKER_BLOCK_SIZE \
3370 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3374 /* Place `markers' first, to preserve alignment. */
3375 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3376 struct marker_block
*next
;
3379 static struct marker_block
*marker_block
;
3380 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3382 static union Lisp_Misc
*marker_free_list
;
3384 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3387 allocate_misc (enum Lisp_Misc_Type type
)
3393 if (marker_free_list
)
3395 XSETMISC (val
, marker_free_list
);
3396 marker_free_list
= marker_free_list
->u_free
.chain
;
3400 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3402 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3403 new->next
= marker_block
;
3405 marker_block_index
= 0;
3406 total_free_markers
+= MARKER_BLOCK_SIZE
;
3408 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3409 marker_block_index
++;
3412 MALLOC_UNBLOCK_INPUT
;
3414 --total_free_markers
;
3415 consing_since_gc
+= sizeof (union Lisp_Misc
);
3416 misc_objects_consed
++;
3417 XMISCANY (val
)->type
= type
;
3418 XMISCANY (val
)->gcmarkbit
= 0;
3422 /* Free a Lisp_Misc object. */
3425 free_misc (Lisp_Object misc
)
3427 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3428 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3429 marker_free_list
= XMISC (misc
);
3430 consing_since_gc
-= sizeof (union Lisp_Misc
);
3431 total_free_markers
++;
3434 /* Verify properties of Lisp_Save_Value's representation
3435 that are assumed here and elsewhere. */
3437 verify (SAVE_UNUSED
== 0);
3438 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3442 /* Return Lisp_Save_Value objects for the various combinations
3443 that callers need. */
3446 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3448 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3449 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3450 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3451 p
->data
[0].integer
= a
;
3452 p
->data
[1].integer
= b
;
3453 p
->data
[2].integer
= c
;
3458 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3461 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3462 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3463 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3464 p
->data
[0].object
= a
;
3465 p
->data
[1].object
= b
;
3466 p
->data
[2].object
= c
;
3467 p
->data
[3].object
= d
;
3472 make_save_ptr (void *a
)
3474 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3475 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3476 p
->save_type
= SAVE_POINTER
;
3477 p
->data
[0].pointer
= a
;
3482 make_save_ptr_int (void *a
, ptrdiff_t b
)
3484 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3485 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3486 p
->save_type
= SAVE_TYPE_PTR_INT
;
3487 p
->data
[0].pointer
= a
;
3488 p
->data
[1].integer
= b
;
3492 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3494 make_save_ptr_ptr (void *a
, void *b
)
3496 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3497 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3498 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3499 p
->data
[0].pointer
= a
;
3500 p
->data
[1].pointer
= b
;
3506 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3508 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3509 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3510 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3511 p
->data
[0].funcpointer
= a
;
3512 p
->data
[1].pointer
= b
;
3513 p
->data
[2].object
= c
;
3517 /* Return a Lisp_Save_Value object that represents an array A
3518 of N Lisp objects. */
3521 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3523 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3524 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3525 p
->save_type
= SAVE_TYPE_MEMORY
;
3526 p
->data
[0].pointer
= a
;
3527 p
->data
[1].integer
= n
;
3531 /* Free a Lisp_Save_Value object. Do not use this function
3532 if SAVE contains pointer other than returned by xmalloc. */
3535 free_save_value (Lisp_Object save
)
3537 xfree (XSAVE_POINTER (save
, 0));
3541 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3544 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3546 register Lisp_Object overlay
;
3548 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3549 OVERLAY_START (overlay
) = start
;
3550 OVERLAY_END (overlay
) = end
;
3551 set_overlay_plist (overlay
, plist
);
3552 XOVERLAY (overlay
)->next
= NULL
;
3556 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3557 doc
: /* Return a newly allocated marker which does not point at any place. */)
3560 register Lisp_Object val
;
3561 register struct Lisp_Marker
*p
;
3563 val
= allocate_misc (Lisp_Misc_Marker
);
3569 p
->insertion_type
= 0;
3570 p
->need_adjustment
= 0;
3574 /* Return a newly allocated marker which points into BUF
3575 at character position CHARPOS and byte position BYTEPOS. */
3578 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3581 struct Lisp_Marker
*m
;
3583 /* No dead buffers here. */
3584 eassert (BUFFER_LIVE_P (buf
));
3586 /* Every character is at least one byte. */
3587 eassert (charpos
<= bytepos
);
3589 obj
= allocate_misc (Lisp_Misc_Marker
);
3592 m
->charpos
= charpos
;
3593 m
->bytepos
= bytepos
;
3594 m
->insertion_type
= 0;
3595 m
->need_adjustment
= 0;
3596 m
->next
= BUF_MARKERS (buf
);
3597 BUF_MARKERS (buf
) = m
;
3601 /* Put MARKER back on the free list after using it temporarily. */
3604 free_marker (Lisp_Object marker
)
3606 unchain_marker (XMARKER (marker
));
3611 /* Return a newly created vector or string with specified arguments as
3612 elements. If all the arguments are characters that can fit
3613 in a string of events, make a string; otherwise, make a vector.
3615 Any number of arguments, even zero arguments, are allowed. */
3618 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3622 for (i
= 0; i
< nargs
; i
++)
3623 /* The things that fit in a string
3624 are characters that are in 0...127,
3625 after discarding the meta bit and all the bits above it. */
3626 if (!INTEGERP (args
[i
])
3627 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3628 return Fvector (nargs
, args
);
3630 /* Since the loop exited, we know that all the things in it are
3631 characters, so we can make a string. */
3635 result
= Fmake_string (make_number (nargs
), make_number (0));
3636 for (i
= 0; i
< nargs
; i
++)
3638 SSET (result
, i
, XINT (args
[i
]));
3639 /* Move the meta bit to the right place for a string char. */
3640 if (XINT (args
[i
]) & CHAR_META
)
3641 SSET (result
, i
, SREF (result
, i
) | 0x80);
3650 /************************************************************************
3651 Memory Full Handling
3652 ************************************************************************/
3655 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3656 there may have been size_t overflow so that malloc was never
3657 called, or perhaps malloc was invoked successfully but the
3658 resulting pointer had problems fitting into a tagged EMACS_INT. In
3659 either case this counts as memory being full even though malloc did
3663 memory_full (size_t nbytes
)
3665 /* Do not go into hysterics merely because a large request failed. */
3666 bool enough_free_memory
= 0;
3667 if (SPARE_MEMORY
< nbytes
)
3672 p
= malloc (SPARE_MEMORY
);
3676 enough_free_memory
= 1;
3678 MALLOC_UNBLOCK_INPUT
;
3681 if (! enough_free_memory
)
3687 memory_full_cons_threshold
= sizeof (struct cons_block
);
3689 /* The first time we get here, free the spare memory. */
3690 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3691 if (spare_memory
[i
])
3694 free (spare_memory
[i
]);
3695 else if (i
>= 1 && i
<= 4)
3696 lisp_align_free (spare_memory
[i
]);
3698 lisp_free (spare_memory
[i
]);
3699 spare_memory
[i
] = 0;
3703 /* This used to call error, but if we've run out of memory, we could
3704 get infinite recursion trying to build the string. */
3705 xsignal (Qnil
, Vmemory_signal_data
);
3708 /* If we released our reserve (due to running out of memory),
3709 and we have a fair amount free once again,
3710 try to set aside another reserve in case we run out once more.
3712 This is called when a relocatable block is freed in ralloc.c,
3713 and also directly from this file, in case we're not using ralloc.c. */
3716 refill_memory_reserve (void)
3718 #ifndef SYSTEM_MALLOC
3719 if (spare_memory
[0] == 0)
3720 spare_memory
[0] = malloc (SPARE_MEMORY
);
3721 if (spare_memory
[1] == 0)
3722 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3724 if (spare_memory
[2] == 0)
3725 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3727 if (spare_memory
[3] == 0)
3728 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3730 if (spare_memory
[4] == 0)
3731 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3733 if (spare_memory
[5] == 0)
3734 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3736 if (spare_memory
[6] == 0)
3737 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3739 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3740 Vmemory_full
= Qnil
;
3744 /************************************************************************
3746 ************************************************************************/
3748 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3750 /* Conservative C stack marking requires a method to identify possibly
3751 live Lisp objects given a pointer value. We do this by keeping
3752 track of blocks of Lisp data that are allocated in a red-black tree
3753 (see also the comment of mem_node which is the type of nodes in
3754 that tree). Function lisp_malloc adds information for an allocated
3755 block to the red-black tree with calls to mem_insert, and function
3756 lisp_free removes it with mem_delete. Functions live_string_p etc
3757 call mem_find to lookup information about a given pointer in the
3758 tree, and use that to determine if the pointer points to a Lisp
3761 /* Initialize this part of alloc.c. */
3766 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3767 mem_z
.parent
= NULL
;
3768 mem_z
.color
= MEM_BLACK
;
3769 mem_z
.start
= mem_z
.end
= NULL
;
3774 /* Value is a pointer to the mem_node containing START. Value is
3775 MEM_NIL if there is no node in the tree containing START. */
3777 static struct mem_node
*
3778 mem_find (void *start
)
3782 if (start
< min_heap_address
|| start
> max_heap_address
)
3785 /* Make the search always successful to speed up the loop below. */
3786 mem_z
.start
= start
;
3787 mem_z
.end
= (char *) start
+ 1;
3790 while (start
< p
->start
|| start
>= p
->end
)
3791 p
= start
< p
->start
? p
->left
: p
->right
;
3796 /* Insert a new node into the tree for a block of memory with start
3797 address START, end address END, and type TYPE. Value is a
3798 pointer to the node that was inserted. */
3800 static struct mem_node
*
3801 mem_insert (void *start
, void *end
, enum mem_type type
)
3803 struct mem_node
*c
, *parent
, *x
;
3805 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3806 min_heap_address
= start
;
3807 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3808 max_heap_address
= end
;
3810 /* See where in the tree a node for START belongs. In this
3811 particular application, it shouldn't happen that a node is already
3812 present. For debugging purposes, let's check that. */
3816 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3818 while (c
!= MEM_NIL
)
3820 if (start
>= c
->start
&& start
< c
->end
)
3823 c
= start
< c
->start
? c
->left
: c
->right
;
3826 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3828 while (c
!= MEM_NIL
)
3831 c
= start
< c
->start
? c
->left
: c
->right
;
3834 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3836 /* Create a new node. */
3837 #ifdef GC_MALLOC_CHECK
3838 x
= malloc (sizeof *x
);
3842 x
= xmalloc (sizeof *x
);
3848 x
->left
= x
->right
= MEM_NIL
;
3851 /* Insert it as child of PARENT or install it as root. */
3854 if (start
< parent
->start
)
3862 /* Re-establish red-black tree properties. */
3863 mem_insert_fixup (x
);
3869 /* Re-establish the red-black properties of the tree, and thereby
3870 balance the tree, after node X has been inserted; X is always red. */
3873 mem_insert_fixup (struct mem_node
*x
)
3875 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3877 /* X is red and its parent is red. This is a violation of
3878 red-black tree property #3. */
3880 if (x
->parent
== x
->parent
->parent
->left
)
3882 /* We're on the left side of our grandparent, and Y is our
3884 struct mem_node
*y
= x
->parent
->parent
->right
;
3886 if (y
->color
== MEM_RED
)
3888 /* Uncle and parent are red but should be black because
3889 X is red. Change the colors accordingly and proceed
3890 with the grandparent. */
3891 x
->parent
->color
= MEM_BLACK
;
3892 y
->color
= MEM_BLACK
;
3893 x
->parent
->parent
->color
= MEM_RED
;
3894 x
= x
->parent
->parent
;
3898 /* Parent and uncle have different colors; parent is
3899 red, uncle is black. */
3900 if (x
== x
->parent
->right
)
3903 mem_rotate_left (x
);
3906 x
->parent
->color
= MEM_BLACK
;
3907 x
->parent
->parent
->color
= MEM_RED
;
3908 mem_rotate_right (x
->parent
->parent
);
3913 /* This is the symmetrical case of above. */
3914 struct mem_node
*y
= x
->parent
->parent
->left
;
3916 if (y
->color
== MEM_RED
)
3918 x
->parent
->color
= MEM_BLACK
;
3919 y
->color
= MEM_BLACK
;
3920 x
->parent
->parent
->color
= MEM_RED
;
3921 x
= x
->parent
->parent
;
3925 if (x
== x
->parent
->left
)
3928 mem_rotate_right (x
);
3931 x
->parent
->color
= MEM_BLACK
;
3932 x
->parent
->parent
->color
= MEM_RED
;
3933 mem_rotate_left (x
->parent
->parent
);
3938 /* The root may have been changed to red due to the algorithm. Set
3939 it to black so that property #5 is satisfied. */
3940 mem_root
->color
= MEM_BLACK
;
3951 mem_rotate_left (struct mem_node
*x
)
3955 /* Turn y's left sub-tree into x's right sub-tree. */
3958 if (y
->left
!= MEM_NIL
)
3959 y
->left
->parent
= x
;
3961 /* Y's parent was x's parent. */
3963 y
->parent
= x
->parent
;
3965 /* Get the parent to point to y instead of x. */
3968 if (x
== x
->parent
->left
)
3969 x
->parent
->left
= y
;
3971 x
->parent
->right
= y
;
3976 /* Put x on y's left. */
3990 mem_rotate_right (struct mem_node
*x
)
3992 struct mem_node
*y
= x
->left
;
3995 if (y
->right
!= MEM_NIL
)
3996 y
->right
->parent
= x
;
3999 y
->parent
= x
->parent
;
4002 if (x
== x
->parent
->right
)
4003 x
->parent
->right
= y
;
4005 x
->parent
->left
= y
;
4016 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4019 mem_delete (struct mem_node
*z
)
4021 struct mem_node
*x
, *y
;
4023 if (!z
|| z
== MEM_NIL
)
4026 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4031 while (y
->left
!= MEM_NIL
)
4035 if (y
->left
!= MEM_NIL
)
4040 x
->parent
= y
->parent
;
4043 if (y
== y
->parent
->left
)
4044 y
->parent
->left
= x
;
4046 y
->parent
->right
= x
;
4053 z
->start
= y
->start
;
4058 if (y
->color
== MEM_BLACK
)
4059 mem_delete_fixup (x
);
4061 #ifdef GC_MALLOC_CHECK
4069 /* Re-establish the red-black properties of the tree, after a
4073 mem_delete_fixup (struct mem_node
*x
)
4075 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4077 if (x
== x
->parent
->left
)
4079 struct mem_node
*w
= x
->parent
->right
;
4081 if (w
->color
== MEM_RED
)
4083 w
->color
= MEM_BLACK
;
4084 x
->parent
->color
= MEM_RED
;
4085 mem_rotate_left (x
->parent
);
4086 w
= x
->parent
->right
;
4089 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4096 if (w
->right
->color
== MEM_BLACK
)
4098 w
->left
->color
= MEM_BLACK
;
4100 mem_rotate_right (w
);
4101 w
= x
->parent
->right
;
4103 w
->color
= x
->parent
->color
;
4104 x
->parent
->color
= MEM_BLACK
;
4105 w
->right
->color
= MEM_BLACK
;
4106 mem_rotate_left (x
->parent
);
4112 struct mem_node
*w
= x
->parent
->left
;
4114 if (w
->color
== MEM_RED
)
4116 w
->color
= MEM_BLACK
;
4117 x
->parent
->color
= MEM_RED
;
4118 mem_rotate_right (x
->parent
);
4119 w
= x
->parent
->left
;
4122 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4129 if (w
->left
->color
== MEM_BLACK
)
4131 w
->right
->color
= MEM_BLACK
;
4133 mem_rotate_left (w
);
4134 w
= x
->parent
->left
;
4137 w
->color
= x
->parent
->color
;
4138 x
->parent
->color
= MEM_BLACK
;
4139 w
->left
->color
= MEM_BLACK
;
4140 mem_rotate_right (x
->parent
);
4146 x
->color
= MEM_BLACK
;
4150 /* Value is non-zero if P is a pointer to a live Lisp string on
4151 the heap. M is a pointer to the mem_block for P. */
4154 live_string_p (struct mem_node
*m
, void *p
)
4156 if (m
->type
== MEM_TYPE_STRING
)
4158 struct string_block
*b
= m
->start
;
4159 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4161 /* P must point to the start of a Lisp_String structure, and it
4162 must not be on the free-list. */
4164 && offset
% sizeof b
->strings
[0] == 0
4165 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4166 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4173 /* Value is non-zero if P is a pointer to a live Lisp cons on
4174 the heap. M is a pointer to the mem_block for P. */
4177 live_cons_p (struct mem_node
*m
, void *p
)
4179 if (m
->type
== MEM_TYPE_CONS
)
4181 struct cons_block
*b
= m
->start
;
4182 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4184 /* P must point to the start of a Lisp_Cons, not be
4185 one of the unused cells in the current cons block,
4186 and not be on the free-list. */
4188 && offset
% sizeof b
->conses
[0] == 0
4189 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4191 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4192 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4199 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4200 the heap. M is a pointer to the mem_block for P. */
4203 live_symbol_p (struct mem_node
*m
, void *p
)
4205 if (m
->type
== MEM_TYPE_SYMBOL
)
4207 struct symbol_block
*b
= m
->start
;
4208 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4210 /* P must point to the start of a Lisp_Symbol, not be
4211 one of the unused cells in the current symbol block,
4212 and not be on the free-list. */
4214 && offset
% sizeof b
->symbols
[0] == 0
4215 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4216 && (b
!= symbol_block
4217 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4218 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4225 /* Value is non-zero if P is a pointer to a live Lisp float on
4226 the heap. M is a pointer to the mem_block for P. */
4229 live_float_p (struct mem_node
*m
, void *p
)
4231 if (m
->type
== MEM_TYPE_FLOAT
)
4233 struct float_block
*b
= m
->start
;
4234 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4236 /* P must point to the start of a Lisp_Float and not be
4237 one of the unused cells in the current float block. */
4239 && offset
% sizeof b
->floats
[0] == 0
4240 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4241 && (b
!= float_block
4242 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4249 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4250 the heap. M is a pointer to the mem_block for P. */
4253 live_misc_p (struct mem_node
*m
, void *p
)
4255 if (m
->type
== MEM_TYPE_MISC
)
4257 struct marker_block
*b
= m
->start
;
4258 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4260 /* P must point to the start of a Lisp_Misc, not be
4261 one of the unused cells in the current misc block,
4262 and not be on the free-list. */
4264 && offset
% sizeof b
->markers
[0] == 0
4265 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4266 && (b
!= marker_block
4267 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4268 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4275 /* Value is non-zero if P is a pointer to a live vector-like object.
4276 M is a pointer to the mem_block for P. */
4279 live_vector_p (struct mem_node
*m
, void *p
)
4281 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4283 /* This memory node corresponds to a vector block. */
4284 struct vector_block
*block
= m
->start
;
4285 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4287 /* P is in the block's allocation range. Scan the block
4288 up to P and see whether P points to the start of some
4289 vector which is not on a free list. FIXME: check whether
4290 some allocation patterns (probably a lot of short vectors)
4291 may cause a substantial overhead of this loop. */
4292 while (VECTOR_IN_BLOCK (vector
, block
)
4293 && vector
<= (struct Lisp_Vector
*) p
)
4295 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4298 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4301 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4302 /* This memory node corresponds to a large vector. */
4308 /* Value is non-zero if P is a pointer to a live buffer. M is a
4309 pointer to the mem_block for P. */
4312 live_buffer_p (struct mem_node
*m
, void *p
)
4314 /* P must point to the start of the block, and the buffer
4315 must not have been killed. */
4316 return (m
->type
== MEM_TYPE_BUFFER
4318 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4321 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4325 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4327 /* Currently not used, but may be called from gdb. */
4329 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4331 /* Array of objects that are kept alive because the C stack contains
4332 a pattern that looks like a reference to them. */
4334 #define MAX_ZOMBIES 10
4335 static Lisp_Object zombies
[MAX_ZOMBIES
];
4337 /* Number of zombie objects. */
4339 static EMACS_INT nzombies
;
4341 /* Number of garbage collections. */
4343 static EMACS_INT ngcs
;
4345 /* Average percentage of zombies per collection. */
4347 static double avg_zombies
;
4349 /* Max. number of live and zombie objects. */
4351 static EMACS_INT max_live
, max_zombies
;
4353 /* Average number of live objects per GC. */
4355 static double avg_live
;
4357 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4358 doc
: /* Show information about live and zombie objects. */)
4361 Lisp_Object args
[8], zombie_list
= Qnil
;
4363 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4364 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4365 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4366 args
[1] = make_number (ngcs
);
4367 args
[2] = make_float (avg_live
);
4368 args
[3] = make_float (avg_zombies
);
4369 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4370 args
[5] = make_number (max_live
);
4371 args
[6] = make_number (max_zombies
);
4372 args
[7] = zombie_list
;
4373 return Fmessage (8, args
);
4376 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4379 /* Mark OBJ if we can prove it's a Lisp_Object. */
4382 mark_maybe_object (Lisp_Object obj
)
4389 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4395 po
= (void *) XPNTR (obj
);
4402 switch (XTYPE (obj
))
4405 mark_p
= (live_string_p (m
, po
)
4406 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4410 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4414 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4418 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4421 case Lisp_Vectorlike
:
4422 /* Note: can't check BUFFERP before we know it's a
4423 buffer because checking that dereferences the pointer
4424 PO which might point anywhere. */
4425 if (live_vector_p (m
, po
))
4426 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4427 else if (live_buffer_p (m
, po
))
4428 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4432 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4441 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4442 if (nzombies
< MAX_ZOMBIES
)
4443 zombies
[nzombies
] = obj
;
4452 /* If P points to Lisp data, mark that as live if it isn't already
4456 mark_maybe_pointer (void *p
)
4462 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4465 /* Quickly rule out some values which can't point to Lisp data.
4466 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4467 Otherwise, assume that Lisp data is aligned on even addresses. */
4468 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4474 Lisp_Object obj
= Qnil
;
4478 case MEM_TYPE_NON_LISP
:
4479 case MEM_TYPE_SPARE
:
4480 /* Nothing to do; not a pointer to Lisp memory. */
4483 case MEM_TYPE_BUFFER
:
4484 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4485 XSETVECTOR (obj
, p
);
4489 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4493 case MEM_TYPE_STRING
:
4494 if (live_string_p (m
, p
)
4495 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4496 XSETSTRING (obj
, p
);
4500 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4504 case MEM_TYPE_SYMBOL
:
4505 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4506 XSETSYMBOL (obj
, p
);
4509 case MEM_TYPE_FLOAT
:
4510 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4514 case MEM_TYPE_VECTORLIKE
:
4515 case MEM_TYPE_VECTOR_BLOCK
:
4516 if (live_vector_p (m
, p
))
4519 XSETVECTOR (tem
, p
);
4520 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4535 /* Alignment of pointer values. Use alignof, as it sometimes returns
4536 a smaller alignment than GCC's __alignof__ and mark_memory might
4537 miss objects if __alignof__ were used. */
4538 #define GC_POINTER_ALIGNMENT alignof (void *)
4540 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4541 not suffice, which is the typical case. A host where a Lisp_Object is
4542 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4543 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4544 suffice to widen it to to a Lisp_Object and check it that way. */
4545 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4546 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4547 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4548 nor mark_maybe_object can follow the pointers. This should not occur on
4549 any practical porting target. */
4550 # error "MSB type bits straddle pointer-word boundaries"
4552 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4553 pointer words that hold pointers ORed with type bits. */
4554 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4556 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4557 words that hold unmodified pointers. */
4558 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4561 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4562 or END+OFFSET..START. */
4565 mark_memory (void *start
, void *end
)
4566 #if defined (__clang__) && defined (__has_feature)
4567 #if __has_feature(address_sanitizer)
4568 /* Do not allow -faddress-sanitizer to check this function, since it
4569 crosses the function stack boundary, and thus would yield many
4571 __attribute__((no_address_safety_analysis
))
4578 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4582 /* Make START the pointer to the start of the memory region,
4583 if it isn't already. */
4591 /* Mark Lisp data pointed to. This is necessary because, in some
4592 situations, the C compiler optimizes Lisp objects away, so that
4593 only a pointer to them remains. Example:
4595 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4598 Lisp_Object obj = build_string ("test");
4599 struct Lisp_String *s = XSTRING (obj);
4600 Fgarbage_collect ();
4601 fprintf (stderr, "test `%s'\n", s->data);
4605 Here, `obj' isn't really used, and the compiler optimizes it
4606 away. The only reference to the life string is through the
4609 for (pp
= start
; (void *) pp
< end
; pp
++)
4610 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4612 void *p
= *(void **) ((char *) pp
+ i
);
4613 mark_maybe_pointer (p
);
4614 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4615 mark_maybe_object (XIL ((intptr_t) p
));
4619 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4621 static bool setjmp_tested_p
;
4622 static int longjmps_done
;
4624 #define SETJMP_WILL_LIKELY_WORK "\
4626 Emacs garbage collector has been changed to use conservative stack\n\
4627 marking. Emacs has determined that the method it uses to do the\n\
4628 marking will likely work on your system, but this isn't sure.\n\
4630 If you are a system-programmer, or can get the help of a local wizard\n\
4631 who is, please take a look at the function mark_stack in alloc.c, and\n\
4632 verify that the methods used are appropriate for your system.\n\
4634 Please mail the result to <emacs-devel@gnu.org>.\n\
4637 #define SETJMP_WILL_NOT_WORK "\
4639 Emacs garbage collector has been changed to use conservative stack\n\
4640 marking. Emacs has determined that the default method it uses to do the\n\
4641 marking will not work on your system. We will need a system-dependent\n\
4642 solution for your system.\n\
4644 Please take a look at the function mark_stack in alloc.c, and\n\
4645 try to find a way to make it work on your system.\n\
4647 Note that you may get false negatives, depending on the compiler.\n\
4648 In particular, you need to use -O with GCC for this test.\n\
4650 Please mail the result to <emacs-devel@gnu.org>.\n\
4654 /* Perform a quick check if it looks like setjmp saves registers in a
4655 jmp_buf. Print a message to stderr saying so. When this test
4656 succeeds, this is _not_ a proof that setjmp is sufficient for
4657 conservative stack marking. Only the sources or a disassembly
4667 /* Arrange for X to be put in a register. */
4673 if (longjmps_done
== 1)
4675 /* Came here after the longjmp at the end of the function.
4677 If x == 1, the longjmp has restored the register to its
4678 value before the setjmp, and we can hope that setjmp
4679 saves all such registers in the jmp_buf, although that
4682 For other values of X, either something really strange is
4683 taking place, or the setjmp just didn't save the register. */
4686 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4689 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4696 if (longjmps_done
== 1)
4697 sys_longjmp (jbuf
, 1);
4700 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4703 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4705 /* Abort if anything GCPRO'd doesn't survive the GC. */
4713 for (p
= gcprolist
; p
; p
= p
->next
)
4714 for (i
= 0; i
< p
->nvars
; ++i
)
4715 if (!survives_gc_p (p
->var
[i
]))
4716 /* FIXME: It's not necessarily a bug. It might just be that the
4717 GCPRO is unnecessary or should release the object sooner. */
4721 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4728 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4729 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4731 fprintf (stderr
, " %d = ", i
);
4732 debug_print (zombies
[i
]);
4736 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4739 /* Mark live Lisp objects on the C stack.
4741 There are several system-dependent problems to consider when
4742 porting this to new architectures:
4746 We have to mark Lisp objects in CPU registers that can hold local
4747 variables or are used to pass parameters.
4749 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4750 something that either saves relevant registers on the stack, or
4751 calls mark_maybe_object passing it each register's contents.
4753 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4754 implementation assumes that calling setjmp saves registers we need
4755 to see in a jmp_buf which itself lies on the stack. This doesn't
4756 have to be true! It must be verified for each system, possibly
4757 by taking a look at the source code of setjmp.
4759 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4760 can use it as a machine independent method to store all registers
4761 to the stack. In this case the macros described in the previous
4762 two paragraphs are not used.
4766 Architectures differ in the way their processor stack is organized.
4767 For example, the stack might look like this
4770 | Lisp_Object | size = 4
4772 | something else | size = 2
4774 | Lisp_Object | size = 4
4778 In such a case, not every Lisp_Object will be aligned equally. To
4779 find all Lisp_Object on the stack it won't be sufficient to walk
4780 the stack in steps of 4 bytes. Instead, two passes will be
4781 necessary, one starting at the start of the stack, and a second
4782 pass starting at the start of the stack + 2. Likewise, if the
4783 minimal alignment of Lisp_Objects on the stack is 1, four passes
4784 would be necessary, each one starting with one byte more offset
4785 from the stack start. */
4792 #ifdef HAVE___BUILTIN_UNWIND_INIT
4793 /* Force callee-saved registers and register windows onto the stack.
4794 This is the preferred method if available, obviating the need for
4795 machine dependent methods. */
4796 __builtin_unwind_init ();
4798 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4799 #ifndef GC_SAVE_REGISTERS_ON_STACK
4800 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4801 union aligned_jmpbuf
{
4805 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4807 /* This trick flushes the register windows so that all the state of
4808 the process is contained in the stack. */
4809 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4810 needed on ia64 too. See mach_dep.c, where it also says inline
4811 assembler doesn't work with relevant proprietary compilers. */
4813 #if defined (__sparc64__) && defined (__FreeBSD__)
4814 /* FreeBSD does not have a ta 3 handler. */
4821 /* Save registers that we need to see on the stack. We need to see
4822 registers used to hold register variables and registers used to
4824 #ifdef GC_SAVE_REGISTERS_ON_STACK
4825 GC_SAVE_REGISTERS_ON_STACK (end
);
4826 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4828 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4829 setjmp will definitely work, test it
4830 and print a message with the result
4832 if (!setjmp_tested_p
)
4834 setjmp_tested_p
= 1;
4837 #endif /* GC_SETJMP_WORKS */
4840 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4841 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4842 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4844 /* This assumes that the stack is a contiguous region in memory. If
4845 that's not the case, something has to be done here to iterate
4846 over the stack segments. */
4847 mark_memory (stack_base
, end
);
4849 /* Allow for marking a secondary stack, like the register stack on the
4851 #ifdef GC_MARK_SECONDARY_STACK
4852 GC_MARK_SECONDARY_STACK ();
4855 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4860 #else /* GC_MARK_STACK == 0 */
4862 #define mark_maybe_object(obj) emacs_abort ()
4864 #endif /* GC_MARK_STACK != 0 */
4867 /* Determine whether it is safe to access memory at address P. */
4869 valid_pointer_p (void *p
)
4872 return w32_valid_pointer_p (p
, 16);
4876 /* Obviously, we cannot just access it (we would SEGV trying), so we
4877 trick the o/s to tell us whether p is a valid pointer.
4878 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4879 not validate p in that case. */
4881 if (emacs_pipe (fd
) == 0)
4883 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4884 emacs_close (fd
[1]);
4885 emacs_close (fd
[0]);
4893 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4894 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4895 cannot validate OBJ. This function can be quite slow, so its primary
4896 use is the manual debugging. The only exception is print_object, where
4897 we use it to check whether the memory referenced by the pointer of
4898 Lisp_Save_Value object contains valid objects. */
4901 valid_lisp_object_p (Lisp_Object obj
)
4911 p
= (void *) XPNTR (obj
);
4912 if (PURE_POINTER_P (p
))
4915 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4919 return valid_pointer_p (p
);
4926 int valid
= valid_pointer_p (p
);
4938 case MEM_TYPE_NON_LISP
:
4939 case MEM_TYPE_SPARE
:
4942 case MEM_TYPE_BUFFER
:
4943 return live_buffer_p (m
, p
) ? 1 : 2;
4946 return live_cons_p (m
, p
);
4948 case MEM_TYPE_STRING
:
4949 return live_string_p (m
, p
);
4952 return live_misc_p (m
, p
);
4954 case MEM_TYPE_SYMBOL
:
4955 return live_symbol_p (m
, p
);
4957 case MEM_TYPE_FLOAT
:
4958 return live_float_p (m
, p
);
4960 case MEM_TYPE_VECTORLIKE
:
4961 case MEM_TYPE_VECTOR_BLOCK
:
4962 return live_vector_p (m
, p
);
4975 /***********************************************************************
4976 Pure Storage Management
4977 ***********************************************************************/
4979 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4980 pointer to it. TYPE is the Lisp type for which the memory is
4981 allocated. TYPE < 0 means it's not used for a Lisp object. */
4984 pure_alloc (size_t size
, int type
)
4988 size_t alignment
= GCALIGNMENT
;
4990 size_t alignment
= alignof (EMACS_INT
);
4992 /* Give Lisp_Floats an extra alignment. */
4993 if (type
== Lisp_Float
)
4994 alignment
= alignof (struct Lisp_Float
);
5000 /* Allocate space for a Lisp object from the beginning of the free
5001 space with taking account of alignment. */
5002 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
5003 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5007 /* Allocate space for a non-Lisp object from the end of the free
5009 pure_bytes_used_non_lisp
+= size
;
5010 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5012 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5014 if (pure_bytes_used
<= pure_size
)
5017 /* Don't allocate a large amount here,
5018 because it might get mmap'd and then its address
5019 might not be usable. */
5020 purebeg
= xmalloc (10000);
5022 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5023 pure_bytes_used
= 0;
5024 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5029 /* Print a warning if PURESIZE is too small. */
5032 check_pure_size (void)
5034 if (pure_bytes_used_before_overflow
)
5035 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5037 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5041 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5042 the non-Lisp data pool of the pure storage, and return its start
5043 address. Return NULL if not found. */
5046 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5049 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5050 const unsigned char *p
;
5053 if (pure_bytes_used_non_lisp
<= nbytes
)
5056 /* Set up the Boyer-Moore table. */
5058 for (i
= 0; i
< 256; i
++)
5061 p
= (const unsigned char *) data
;
5063 bm_skip
[*p
++] = skip
;
5065 last_char_skip
= bm_skip
['\0'];
5067 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5068 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5070 /* See the comments in the function `boyer_moore' (search.c) for the
5071 use of `infinity'. */
5072 infinity
= pure_bytes_used_non_lisp
+ 1;
5073 bm_skip
['\0'] = infinity
;
5075 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5079 /* Check the last character (== '\0'). */
5082 start
+= bm_skip
[*(p
+ start
)];
5084 while (start
<= start_max
);
5086 if (start
< infinity
)
5087 /* Couldn't find the last character. */
5090 /* No less than `infinity' means we could find the last
5091 character at `p[start - infinity]'. */
5094 /* Check the remaining characters. */
5095 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5097 return non_lisp_beg
+ start
;
5099 start
+= last_char_skip
;
5101 while (start
<= start_max
);
5107 /* Return a string allocated in pure space. DATA is a buffer holding
5108 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5109 means make the result string multibyte.
5111 Must get an error if pure storage is full, since if it cannot hold
5112 a large string it may be able to hold conses that point to that
5113 string; then the string is not protected from gc. */
5116 make_pure_string (const char *data
,
5117 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5120 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5121 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5122 if (s
->data
== NULL
)
5124 s
->data
= pure_alloc (nbytes
+ 1, -1);
5125 memcpy (s
->data
, data
, nbytes
);
5126 s
->data
[nbytes
] = '\0';
5129 s
->size_byte
= multibyte
? nbytes
: -1;
5130 s
->intervals
= NULL
;
5131 XSETSTRING (string
, s
);
5135 /* Return a string allocated in pure space. Do not
5136 allocate the string data, just point to DATA. */
5139 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5142 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5145 s
->data
= (unsigned char *) data
;
5146 s
->intervals
= NULL
;
5147 XSETSTRING (string
, s
);
5151 /* Return a cons allocated from pure space. Give it pure copies
5152 of CAR as car and CDR as cdr. */
5155 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5158 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5160 XSETCAR (new, Fpurecopy (car
));
5161 XSETCDR (new, Fpurecopy (cdr
));
5166 /* Value is a float object with value NUM allocated from pure space. */
5169 make_pure_float (double num
)
5172 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5174 XFLOAT_INIT (new, num
);
5179 /* Return a vector with room for LEN Lisp_Objects allocated from
5183 make_pure_vector (ptrdiff_t len
)
5186 size_t size
= header_size
+ len
* word_size
;
5187 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5188 XSETVECTOR (new, p
);
5189 XVECTOR (new)->header
.size
= len
;
5194 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5195 doc
: /* Make a copy of object OBJ in pure storage.
5196 Recursively copies contents of vectors and cons cells.
5197 Does not copy symbols. Copies strings without text properties. */)
5198 (register Lisp_Object obj
)
5200 if (NILP (Vpurify_flag
))
5203 if (PURE_POINTER_P (XPNTR (obj
)))
5206 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5208 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5214 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5215 else if (FLOATP (obj
))
5216 obj
= make_pure_float (XFLOAT_DATA (obj
));
5217 else if (STRINGP (obj
))
5218 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5220 STRING_MULTIBYTE (obj
));
5221 else if (COMPILEDP (obj
) || VECTORP (obj
))
5223 register struct Lisp_Vector
*vec
;
5224 register ptrdiff_t i
;
5228 if (size
& PSEUDOVECTOR_FLAG
)
5229 size
&= PSEUDOVECTOR_SIZE_MASK
;
5230 vec
= XVECTOR (make_pure_vector (size
));
5231 for (i
= 0; i
< size
; i
++)
5232 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5233 if (COMPILEDP (obj
))
5235 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5236 XSETCOMPILED (obj
, vec
);
5239 XSETVECTOR (obj
, vec
);
5241 else if (MARKERP (obj
))
5242 error ("Attempt to copy a marker to pure storage");
5244 /* Not purified, don't hash-cons. */
5247 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5248 Fputhash (obj
, obj
, Vpurify_flag
);
5255 /***********************************************************************
5257 ***********************************************************************/
5259 /* Put an entry in staticvec, pointing at the variable with address
5263 staticpro (Lisp_Object
*varaddress
)
5265 if (staticidx
>= NSTATICS
)
5266 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5267 staticvec
[staticidx
++] = varaddress
;
5271 /***********************************************************************
5273 ***********************************************************************/
5275 /* Temporarily prevent garbage collection. */
5278 inhibit_garbage_collection (void)
5280 ptrdiff_t count
= SPECPDL_INDEX ();
5282 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5286 /* Used to avoid possible overflows when
5287 converting from C to Lisp integers. */
5290 bounded_number (EMACS_INT number
)
5292 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5295 /* Calculate total bytes of live objects. */
5298 total_bytes_of_live_objects (void)
5301 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5302 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5303 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5304 tot
+= total_string_bytes
;
5305 tot
+= total_vector_slots
* word_size
;
5306 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5307 tot
+= total_intervals
* sizeof (struct interval
);
5308 tot
+= total_strings
* sizeof (struct Lisp_String
);
5312 #ifdef HAVE_WINDOW_SYSTEM
5314 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5315 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5318 compact_font_cache_entry (Lisp_Object entry
)
5320 Lisp_Object tail
, *prev
= &entry
;
5322 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5325 Lisp_Object obj
= XCAR (tail
);
5327 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5328 if (CONSP (obj
) && FONT_SPEC_P (XCAR (obj
))
5329 && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj
)))
5330 && VECTORP (XCDR (obj
)))
5332 ptrdiff_t i
, size
= ASIZE (XCDR (obj
)) & ~ARRAY_MARK_FLAG
;
5334 /* If font-spec is not marked, most likely all font-entities
5335 are not marked too. But we must be sure that nothing is
5336 marked within OBJ before we really drop it. */
5337 for (i
= 0; i
< size
; i
++)
5338 if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj
), i
))))
5345 *prev
= XCDR (tail
);
5347 prev
= xcdr_addr (tail
);
5352 /* Compact font caches on all terminals and mark
5353 everything which is still here after compaction. */
5356 compact_font_caches (void)
5360 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5362 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5368 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5369 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5371 mark_object (cache
);
5375 #else /* not HAVE_WINDOW_SYSTEM */
5377 #define compact_font_caches() (void)(0)
5379 #endif /* HAVE_WINDOW_SYSTEM */
5381 /* Remove (MARKER . DATA) entries with unmarked MARKER
5382 from buffer undo LIST and return changed list. */
5385 compact_undo_list (Lisp_Object list
)
5387 Lisp_Object tail
, *prev
= &list
;
5389 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5391 if (CONSP (XCAR (tail
))
5392 && MARKERP (XCAR (XCAR (tail
)))
5393 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5394 *prev
= XCDR (tail
);
5396 prev
= xcdr_addr (tail
);
5401 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5402 doc
: /* Reclaim storage for Lisp objects no longer needed.
5403 Garbage collection happens automatically if you cons more than
5404 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5405 `garbage-collect' normally returns a list with info on amount of space in use,
5406 where each entry has the form (NAME SIZE USED FREE), where:
5407 - NAME is a symbol describing the kind of objects this entry represents,
5408 - SIZE is the number of bytes used by each one,
5409 - USED is the number of those objects that were found live in the heap,
5410 - FREE is the number of those objects that are not live but that Emacs
5411 keeps around for future allocations (maybe because it does not know how
5412 to return them to the OS).
5413 However, if there was overflow in pure space, `garbage-collect'
5414 returns nil, because real GC can't be done.
5415 See Info node `(elisp)Garbage Collection'. */)
5418 struct buffer
*nextb
;
5419 char stack_top_variable
;
5422 ptrdiff_t count
= SPECPDL_INDEX ();
5423 struct timespec start
;
5424 Lisp_Object retval
= Qnil
;
5425 size_t tot_before
= 0;
5430 /* Can't GC if pure storage overflowed because we can't determine
5431 if something is a pure object or not. */
5432 if (pure_bytes_used_before_overflow
)
5435 /* Record this function, so it appears on the profiler's backtraces. */
5436 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5440 /* Don't keep undo information around forever.
5441 Do this early on, so it is no problem if the user quits. */
5442 FOR_EACH_BUFFER (nextb
)
5443 compact_buffer (nextb
);
5445 if (profiler_memory_running
)
5446 tot_before
= total_bytes_of_live_objects ();
5448 start
= current_timespec ();
5450 /* In case user calls debug_print during GC,
5451 don't let that cause a recursive GC. */
5452 consing_since_gc
= 0;
5454 /* Save what's currently displayed in the echo area. */
5455 message_p
= push_message ();
5456 record_unwind_protect_void (pop_message_unwind
);
5458 /* Save a copy of the contents of the stack, for debugging. */
5459 #if MAX_SAVE_STACK > 0
5460 if (NILP (Vpurify_flag
))
5463 ptrdiff_t stack_size
;
5464 if (&stack_top_variable
< stack_bottom
)
5466 stack
= &stack_top_variable
;
5467 stack_size
= stack_bottom
- &stack_top_variable
;
5471 stack
= stack_bottom
;
5472 stack_size
= &stack_top_variable
- stack_bottom
;
5474 if (stack_size
<= MAX_SAVE_STACK
)
5476 if (stack_copy_size
< stack_size
)
5478 stack_copy
= xrealloc (stack_copy
, stack_size
);
5479 stack_copy_size
= stack_size
;
5481 memcpy (stack_copy
, stack
, stack_size
);
5484 #endif /* MAX_SAVE_STACK > 0 */
5486 if (garbage_collection_messages
)
5487 message1_nolog ("Garbage collecting...");
5491 shrink_regexp_cache ();
5495 /* Mark all the special slots that serve as the roots of accessibility. */
5497 mark_buffer (&buffer_defaults
);
5498 mark_buffer (&buffer_local_symbols
);
5500 for (i
= 0; i
< staticidx
; i
++)
5501 mark_object (*staticvec
[i
]);
5511 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5512 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5516 register struct gcpro
*tail
;
5517 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5518 for (i
= 0; i
< tail
->nvars
; i
++)
5519 mark_object (tail
->var
[i
]);
5524 struct handler
*handler
;
5525 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5527 mark_object (handler
->tag_or_ch
);
5528 mark_object (handler
->val
);
5531 #ifdef HAVE_WINDOW_SYSTEM
5532 mark_fringe_data ();
5535 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5539 /* Everything is now marked, except for the data in font caches
5540 and undo lists. They're compacted by removing an items which
5541 aren't reachable otherwise. */
5543 compact_font_caches ();
5545 FOR_EACH_BUFFER (nextb
)
5547 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5548 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5549 /* Now that we have stripped the elements that need not be
5550 in the undo_list any more, we can finally mark the list. */
5551 mark_object (BVAR (nextb
, undo_list
));
5556 /* Clear the mark bits that we set in certain root slots. */
5558 unmark_byte_stack ();
5559 VECTOR_UNMARK (&buffer_defaults
);
5560 VECTOR_UNMARK (&buffer_local_symbols
);
5562 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5572 consing_since_gc
= 0;
5573 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5574 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5576 gc_relative_threshold
= 0;
5577 if (FLOATP (Vgc_cons_percentage
))
5578 { /* Set gc_cons_combined_threshold. */
5579 double tot
= total_bytes_of_live_objects ();
5581 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5584 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5585 gc_relative_threshold
= tot
;
5587 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5591 if (garbage_collection_messages
)
5593 if (message_p
|| minibuf_level
> 0)
5596 message1_nolog ("Garbage collecting...done");
5599 unbind_to (count
, Qnil
);
5601 Lisp_Object total
[11];
5602 int total_size
= 10;
5604 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5605 bounded_number (total_conses
),
5606 bounded_number (total_free_conses
));
5608 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5609 bounded_number (total_symbols
),
5610 bounded_number (total_free_symbols
));
5612 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5613 bounded_number (total_markers
),
5614 bounded_number (total_free_markers
));
5616 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5617 bounded_number (total_strings
),
5618 bounded_number (total_free_strings
));
5620 total
[4] = list3 (Qstring_bytes
, make_number (1),
5621 bounded_number (total_string_bytes
));
5623 total
[5] = list3 (Qvectors
,
5624 make_number (header_size
+ sizeof (Lisp_Object
)),
5625 bounded_number (total_vectors
));
5627 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5628 bounded_number (total_vector_slots
),
5629 bounded_number (total_free_vector_slots
));
5631 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5632 bounded_number (total_floats
),
5633 bounded_number (total_free_floats
));
5635 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5636 bounded_number (total_intervals
),
5637 bounded_number (total_free_intervals
));
5639 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5640 bounded_number (total_buffers
));
5642 #ifdef DOUG_LEA_MALLOC
5644 total
[10] = list4 (Qheap
, make_number (1024),
5645 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5646 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5648 retval
= Flist (total_size
, total
);
5651 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5653 /* Compute average percentage of zombies. */
5655 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5656 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5658 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5659 max_live
= max (nlive
, max_live
);
5660 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5661 max_zombies
= max (nzombies
, max_zombies
);
5666 if (!NILP (Vpost_gc_hook
))
5668 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5669 safe_run_hooks (Qpost_gc_hook
);
5670 unbind_to (gc_count
, Qnil
);
5673 /* Accumulate statistics. */
5674 if (FLOATP (Vgc_elapsed
))
5676 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5677 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5678 + timespectod (since_start
));
5683 /* Collect profiling data. */
5684 if (profiler_memory_running
)
5687 size_t tot_after
= total_bytes_of_live_objects ();
5688 if (tot_before
> tot_after
)
5689 swept
= tot_before
- tot_after
;
5690 malloc_probe (swept
);
5697 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5698 only interesting objects referenced from glyphs are strings. */
5701 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5703 struct glyph_row
*row
= matrix
->rows
;
5704 struct glyph_row
*end
= row
+ matrix
->nrows
;
5706 for (; row
< end
; ++row
)
5710 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5712 struct glyph
*glyph
= row
->glyphs
[area
];
5713 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5715 for (; glyph
< end_glyph
; ++glyph
)
5716 if (STRINGP (glyph
->object
)
5717 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5718 mark_object (glyph
->object
);
5723 /* Mark reference to a Lisp_Object.
5724 If the object referred to has not been seen yet, recursively mark
5725 all the references contained in it. */
5727 #define LAST_MARKED_SIZE 500
5728 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5729 static int last_marked_index
;
5731 /* For debugging--call abort when we cdr down this many
5732 links of a list, in mark_object. In debugging,
5733 the call to abort will hit a breakpoint.
5734 Normally this is zero and the check never goes off. */
5735 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5738 mark_vectorlike (struct Lisp_Vector
*ptr
)
5740 ptrdiff_t size
= ptr
->header
.size
;
5743 eassert (!VECTOR_MARKED_P (ptr
));
5744 VECTOR_MARK (ptr
); /* Else mark it. */
5745 if (size
& PSEUDOVECTOR_FLAG
)
5746 size
&= PSEUDOVECTOR_SIZE_MASK
;
5748 /* Note that this size is not the memory-footprint size, but only
5749 the number of Lisp_Object fields that we should trace.
5750 The distinction is used e.g. by Lisp_Process which places extra
5751 non-Lisp_Object fields at the end of the structure... */
5752 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5753 mark_object (ptr
->contents
[i
]);
5756 /* Like mark_vectorlike but optimized for char-tables (and
5757 sub-char-tables) assuming that the contents are mostly integers or
5761 mark_char_table (struct Lisp_Vector
*ptr
)
5763 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5766 eassert (!VECTOR_MARKED_P (ptr
));
5768 for (i
= 0; i
< size
; i
++)
5770 Lisp_Object val
= ptr
->contents
[i
];
5772 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5774 if (SUB_CHAR_TABLE_P (val
))
5776 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5777 mark_char_table (XVECTOR (val
));
5784 /* Mark the chain of overlays starting at PTR. */
5787 mark_overlay (struct Lisp_Overlay
*ptr
)
5789 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5792 mark_object (ptr
->start
);
5793 mark_object (ptr
->end
);
5794 mark_object (ptr
->plist
);
5798 /* Mark Lisp_Objects and special pointers in BUFFER. */
5801 mark_buffer (struct buffer
*buffer
)
5803 /* This is handled much like other pseudovectors... */
5804 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5806 /* ...but there are some buffer-specific things. */
5808 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5810 /* For now, we just don't mark the undo_list. It's done later in
5811 a special way just before the sweep phase, and after stripping
5812 some of its elements that are not needed any more. */
5814 mark_overlay (buffer
->overlays_before
);
5815 mark_overlay (buffer
->overlays_after
);
5817 /* If this is an indirect buffer, mark its base buffer. */
5818 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5819 mark_buffer (buffer
->base_buffer
);
5822 /* Mark Lisp faces in the face cache C. */
5825 mark_face_cache (struct face_cache
*c
)
5830 for (i
= 0; i
< c
->used
; ++i
)
5832 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5836 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
5837 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
5839 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5840 mark_object (face
->lface
[j
]);
5846 /* Remove killed buffers or items whose car is a killed buffer from
5847 LIST, and mark other items. Return changed LIST, which is marked. */
5850 mark_discard_killed_buffers (Lisp_Object list
)
5852 Lisp_Object tail
, *prev
= &list
;
5854 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5857 Lisp_Object tem
= XCAR (tail
);
5860 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5861 *prev
= XCDR (tail
);
5864 CONS_MARK (XCONS (tail
));
5865 mark_object (XCAR (tail
));
5866 prev
= xcdr_addr (tail
);
5873 /* Determine type of generic Lisp_Object and mark it accordingly. */
5876 mark_object (Lisp_Object arg
)
5878 register Lisp_Object obj
= arg
;
5879 #ifdef GC_CHECK_MARKED_OBJECTS
5883 ptrdiff_t cdr_count
= 0;
5887 if (PURE_POINTER_P (XPNTR (obj
)))
5890 last_marked
[last_marked_index
++] = obj
;
5891 if (last_marked_index
== LAST_MARKED_SIZE
)
5892 last_marked_index
= 0;
5894 /* Perform some sanity checks on the objects marked here. Abort if
5895 we encounter an object we know is bogus. This increases GC time
5896 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5897 #ifdef GC_CHECK_MARKED_OBJECTS
5899 po
= (void *) XPNTR (obj
);
5901 /* Check that the object pointed to by PO is known to be a Lisp
5902 structure allocated from the heap. */
5903 #define CHECK_ALLOCATED() \
5905 m = mem_find (po); \
5910 /* Check that the object pointed to by PO is live, using predicate
5912 #define CHECK_LIVE(LIVEP) \
5914 if (!LIVEP (m, po)) \
5918 /* Check both of the above conditions. */
5919 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5921 CHECK_ALLOCATED (); \
5922 CHECK_LIVE (LIVEP); \
5925 #else /* not GC_CHECK_MARKED_OBJECTS */
5927 #define CHECK_LIVE(LIVEP) (void) 0
5928 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5930 #endif /* not GC_CHECK_MARKED_OBJECTS */
5932 switch (XTYPE (obj
))
5936 register struct Lisp_String
*ptr
= XSTRING (obj
);
5937 if (STRING_MARKED_P (ptr
))
5939 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5941 MARK_INTERVAL_TREE (ptr
->intervals
);
5942 #ifdef GC_CHECK_STRING_BYTES
5943 /* Check that the string size recorded in the string is the
5944 same as the one recorded in the sdata structure. */
5946 #endif /* GC_CHECK_STRING_BYTES */
5950 case Lisp_Vectorlike
:
5952 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5953 register ptrdiff_t pvectype
;
5955 if (VECTOR_MARKED_P (ptr
))
5958 #ifdef GC_CHECK_MARKED_OBJECTS
5960 if (m
== MEM_NIL
&& !SUBRP (obj
))
5962 #endif /* GC_CHECK_MARKED_OBJECTS */
5964 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5965 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5966 >> PSEUDOVECTOR_AREA_BITS
);
5968 pvectype
= PVEC_NORMAL_VECTOR
;
5970 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5971 CHECK_LIVE (live_vector_p
);
5976 #ifdef GC_CHECK_MARKED_OBJECTS
5985 #endif /* GC_CHECK_MARKED_OBJECTS */
5986 mark_buffer ((struct buffer
*) ptr
);
5990 { /* We could treat this just like a vector, but it is better
5991 to save the COMPILED_CONSTANTS element for last and avoid
5993 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5997 for (i
= 0; i
< size
; i
++)
5998 if (i
!= COMPILED_CONSTANTS
)
5999 mark_object (ptr
->contents
[i
]);
6000 if (size
> COMPILED_CONSTANTS
)
6002 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
6010 struct frame
*f
= (struct frame
*) ptr
;
6012 mark_vectorlike (ptr
);
6013 mark_face_cache (f
->face_cache
);
6014 #ifdef HAVE_WINDOW_SYSTEM
6015 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6017 struct font
*font
= FRAME_FONT (f
);
6019 if (font
&& !VECTOR_MARKED_P (font
))
6020 mark_vectorlike ((struct Lisp_Vector
*) font
);
6028 struct window
*w
= (struct window
*) ptr
;
6030 mark_vectorlike (ptr
);
6032 /* Mark glyph matrices, if any. Marking window
6033 matrices is sufficient because frame matrices
6034 use the same glyph memory. */
6035 if (w
->current_matrix
)
6037 mark_glyph_matrix (w
->current_matrix
);
6038 mark_glyph_matrix (w
->desired_matrix
);
6041 /* Filter out killed buffers from both buffer lists
6042 in attempt to help GC to reclaim killed buffers faster.
6043 We can do it elsewhere for live windows, but this is the
6044 best place to do it for dead windows. */
6046 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6048 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6052 case PVEC_HASH_TABLE
:
6054 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6056 mark_vectorlike (ptr
);
6057 mark_object (h
->test
.name
);
6058 mark_object (h
->test
.user_hash_function
);
6059 mark_object (h
->test
.user_cmp_function
);
6060 /* If hash table is not weak, mark all keys and values.
6061 For weak tables, mark only the vector. */
6063 mark_object (h
->key_and_value
);
6065 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6069 case PVEC_CHAR_TABLE
:
6070 mark_char_table (ptr
);
6073 case PVEC_BOOL_VECTOR
:
6074 /* No Lisp_Objects to mark in a bool vector. */
6085 mark_vectorlike (ptr
);
6092 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6093 struct Lisp_Symbol
*ptrx
;
6097 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6099 mark_object (ptr
->function
);
6100 mark_object (ptr
->plist
);
6101 switch (ptr
->redirect
)
6103 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6104 case SYMBOL_VARALIAS
:
6107 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6111 case SYMBOL_LOCALIZED
:
6113 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6114 Lisp_Object where
= blv
->where
;
6115 /* If the value is set up for a killed buffer or deleted
6116 frame, restore it's global binding. If the value is
6117 forwarded to a C variable, either it's not a Lisp_Object
6118 var, or it's staticpro'd already. */
6119 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6120 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6121 swap_in_global_binding (ptr
);
6122 mark_object (blv
->where
);
6123 mark_object (blv
->valcell
);
6124 mark_object (blv
->defcell
);
6127 case SYMBOL_FORWARDED
:
6128 /* If the value is forwarded to a buffer or keyboard field,
6129 these are marked when we see the corresponding object.
6130 And if it's forwarded to a C variable, either it's not
6131 a Lisp_Object var, or it's staticpro'd already. */
6133 default: emacs_abort ();
6135 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6136 MARK_STRING (XSTRING (ptr
->name
));
6137 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6142 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6143 XSETSYMBOL (obj
, ptrx
);
6150 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6152 if (XMISCANY (obj
)->gcmarkbit
)
6155 switch (XMISCTYPE (obj
))
6157 case Lisp_Misc_Marker
:
6158 /* DO NOT mark thru the marker's chain.
6159 The buffer's markers chain does not preserve markers from gc;
6160 instead, markers are removed from the chain when freed by gc. */
6161 XMISCANY (obj
)->gcmarkbit
= 1;
6164 case Lisp_Misc_Save_Value
:
6165 XMISCANY (obj
)->gcmarkbit
= 1;
6167 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6168 /* If `save_type' is zero, `data[0].pointer' is the address
6169 of a memory area containing `data[1].integer' potential
6171 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6173 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6175 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6176 mark_maybe_object (*p
);
6180 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6182 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6183 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6184 mark_object (ptr
->data
[i
].object
);
6189 case Lisp_Misc_Overlay
:
6190 mark_overlay (XOVERLAY (obj
));
6200 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6201 if (CONS_MARKED_P (ptr
))
6203 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6205 /* If the cdr is nil, avoid recursion for the car. */
6206 if (EQ (ptr
->u
.cdr
, Qnil
))
6212 mark_object (ptr
->car
);
6215 if (cdr_count
== mark_object_loop_halt
)
6221 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6222 FLOAT_MARK (XFLOAT (obj
));
6233 #undef CHECK_ALLOCATED
6234 #undef CHECK_ALLOCATED_AND_LIVE
6236 /* Mark the Lisp pointers in the terminal objects.
6237 Called by Fgarbage_collect. */
6240 mark_terminals (void)
6243 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6245 eassert (t
->name
!= NULL
);
6246 #ifdef HAVE_WINDOW_SYSTEM
6247 /* If a terminal object is reachable from a stacpro'ed object,
6248 it might have been marked already. Make sure the image cache
6250 mark_image_cache (t
->image_cache
);
6251 #endif /* HAVE_WINDOW_SYSTEM */
6252 if (!VECTOR_MARKED_P (t
))
6253 mark_vectorlike ((struct Lisp_Vector
*)t
);
6259 /* Value is non-zero if OBJ will survive the current GC because it's
6260 either marked or does not need to be marked to survive. */
6263 survives_gc_p (Lisp_Object obj
)
6267 switch (XTYPE (obj
))
6274 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6278 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6282 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6285 case Lisp_Vectorlike
:
6286 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6290 survives_p
= CONS_MARKED_P (XCONS (obj
));
6294 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6301 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6306 /* Sweep: find all structures not marked, and free them. */
6311 /* Remove or mark entries in weak hash tables.
6312 This must be done before any object is unmarked. */
6313 sweep_weak_hash_tables ();
6316 check_string_bytes (!noninteractive
);
6318 /* Put all unmarked conses on free list. */
6320 register struct cons_block
*cblk
;
6321 struct cons_block
**cprev
= &cons_block
;
6322 register int lim
= cons_block_index
;
6323 EMACS_INT num_free
= 0, num_used
= 0;
6327 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6331 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6333 /* Scan the mark bits an int at a time. */
6334 for (i
= 0; i
< ilim
; i
++)
6336 if (cblk
->gcmarkbits
[i
] == -1)
6338 /* Fast path - all cons cells for this int are marked. */
6339 cblk
->gcmarkbits
[i
] = 0;
6340 num_used
+= BITS_PER_INT
;
6344 /* Some cons cells for this int are not marked.
6345 Find which ones, and free them. */
6346 int start
, pos
, stop
;
6348 start
= i
* BITS_PER_INT
;
6350 if (stop
> BITS_PER_INT
)
6351 stop
= BITS_PER_INT
;
6354 for (pos
= start
; pos
< stop
; pos
++)
6356 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6359 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6360 cons_free_list
= &cblk
->conses
[pos
];
6362 cons_free_list
->car
= Vdead
;
6368 CONS_UNMARK (&cblk
->conses
[pos
]);
6374 lim
= CONS_BLOCK_SIZE
;
6375 /* If this block contains only free conses and we have already
6376 seen more than two blocks worth of free conses then deallocate
6378 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6380 *cprev
= cblk
->next
;
6381 /* Unhook from the free list. */
6382 cons_free_list
= cblk
->conses
[0].u
.chain
;
6383 lisp_align_free (cblk
);
6387 num_free
+= this_free
;
6388 cprev
= &cblk
->next
;
6391 total_conses
= num_used
;
6392 total_free_conses
= num_free
;
6395 /* Put all unmarked floats on free list. */
6397 register struct float_block
*fblk
;
6398 struct float_block
**fprev
= &float_block
;
6399 register int lim
= float_block_index
;
6400 EMACS_INT num_free
= 0, num_used
= 0;
6402 float_free_list
= 0;
6404 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6408 for (i
= 0; i
< lim
; i
++)
6409 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6412 fblk
->floats
[i
].u
.chain
= float_free_list
;
6413 float_free_list
= &fblk
->floats
[i
];
6418 FLOAT_UNMARK (&fblk
->floats
[i
]);
6420 lim
= FLOAT_BLOCK_SIZE
;
6421 /* If this block contains only free floats and we have already
6422 seen more than two blocks worth of free floats then deallocate
6424 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6426 *fprev
= fblk
->next
;
6427 /* Unhook from the free list. */
6428 float_free_list
= fblk
->floats
[0].u
.chain
;
6429 lisp_align_free (fblk
);
6433 num_free
+= this_free
;
6434 fprev
= &fblk
->next
;
6437 total_floats
= num_used
;
6438 total_free_floats
= num_free
;
6441 /* Put all unmarked intervals on free list. */
6443 register struct interval_block
*iblk
;
6444 struct interval_block
**iprev
= &interval_block
;
6445 register int lim
= interval_block_index
;
6446 EMACS_INT num_free
= 0, num_used
= 0;
6448 interval_free_list
= 0;
6450 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6455 for (i
= 0; i
< lim
; i
++)
6457 if (!iblk
->intervals
[i
].gcmarkbit
)
6459 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6460 interval_free_list
= &iblk
->intervals
[i
];
6466 iblk
->intervals
[i
].gcmarkbit
= 0;
6469 lim
= INTERVAL_BLOCK_SIZE
;
6470 /* If this block contains only free intervals and we have already
6471 seen more than two blocks worth of free intervals then
6472 deallocate this block. */
6473 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6475 *iprev
= iblk
->next
;
6476 /* Unhook from the free list. */
6477 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6482 num_free
+= this_free
;
6483 iprev
= &iblk
->next
;
6486 total_intervals
= num_used
;
6487 total_free_intervals
= num_free
;
6490 /* Put all unmarked symbols on free list. */
6492 register struct symbol_block
*sblk
;
6493 struct symbol_block
**sprev
= &symbol_block
;
6494 register int lim
= symbol_block_index
;
6495 EMACS_INT num_free
= 0, num_used
= 0;
6497 symbol_free_list
= NULL
;
6499 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6502 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6503 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6505 for (; sym
< end
; ++sym
)
6507 /* Check if the symbol was created during loadup. In such a case
6508 it might be pointed to by pure bytecode which we don't trace,
6509 so we conservatively assume that it is live. */
6510 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6512 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6514 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6515 xfree (SYMBOL_BLV (&sym
->s
));
6516 sym
->s
.next
= symbol_free_list
;
6517 symbol_free_list
= &sym
->s
;
6519 symbol_free_list
->function
= Vdead
;
6527 eassert (!STRING_MARKED_P (XSTRING (sym
->s
.name
)));
6528 sym
->s
.gcmarkbit
= 0;
6532 lim
= SYMBOL_BLOCK_SIZE
;
6533 /* If this block contains only free symbols and we have already
6534 seen more than two blocks worth of free symbols then deallocate
6536 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6538 *sprev
= sblk
->next
;
6539 /* Unhook from the free list. */
6540 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6545 num_free
+= this_free
;
6546 sprev
= &sblk
->next
;
6549 total_symbols
= num_used
;
6550 total_free_symbols
= num_free
;
6553 /* Put all unmarked misc's on free list.
6554 For a marker, first unchain it from the buffer it points into. */
6556 register struct marker_block
*mblk
;
6557 struct marker_block
**mprev
= &marker_block
;
6558 register int lim
= marker_block_index
;
6559 EMACS_INT num_free
= 0, num_used
= 0;
6561 marker_free_list
= 0;
6563 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6568 for (i
= 0; i
< lim
; i
++)
6570 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6572 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6573 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6574 /* Set the type of the freed object to Lisp_Misc_Free.
6575 We could leave the type alone, since nobody checks it,
6576 but this might catch bugs faster. */
6577 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6578 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6579 marker_free_list
= &mblk
->markers
[i
].m
;
6585 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6588 lim
= MARKER_BLOCK_SIZE
;
6589 /* If this block contains only free markers and we have already
6590 seen more than two blocks worth of free markers then deallocate
6592 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6594 *mprev
= mblk
->next
;
6595 /* Unhook from the free list. */
6596 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6601 num_free
+= this_free
;
6602 mprev
= &mblk
->next
;
6606 total_markers
= num_used
;
6607 total_free_markers
= num_free
;
6610 /* Free all unmarked buffers */
6612 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6615 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6616 if (!VECTOR_MARKED_P (buffer
))
6618 *bprev
= buffer
->next
;
6623 VECTOR_UNMARK (buffer
);
6624 /* Do not use buffer_(set|get)_intervals here. */
6625 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6627 bprev
= &buffer
->next
;
6632 check_string_bytes (!noninteractive
);
6638 /* Debugging aids. */
6640 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6641 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6642 This may be helpful in debugging Emacs's memory usage.
6643 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6649 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
6652 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6658 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6659 doc
: /* Return a list of counters that measure how much consing there has been.
6660 Each of these counters increments for a certain kind of object.
6661 The counters wrap around from the largest positive integer to zero.
6662 Garbage collection does not decrease them.
6663 The elements of the value are as follows:
6664 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6665 All are in units of 1 = one object consed
6666 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6668 MISCS include overlays, markers, and some internal types.
6669 Frames, windows, buffers, and subprocesses count as vectors
6670 (but the contents of a buffer's text do not count here). */)
6673 return listn (CONSTYPE_HEAP
, 8,
6674 bounded_number (cons_cells_consed
),
6675 bounded_number (floats_consed
),
6676 bounded_number (vector_cells_consed
),
6677 bounded_number (symbols_consed
),
6678 bounded_number (string_chars_consed
),
6679 bounded_number (misc_objects_consed
),
6680 bounded_number (intervals_consed
),
6681 bounded_number (strings_consed
));
6684 /* Find at most FIND_MAX symbols which have OBJ as their value or
6685 function. This is used in gdbinit's `xwhichsymbols' command. */
6688 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6690 struct symbol_block
*sblk
;
6691 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6692 Lisp_Object found
= Qnil
;
6696 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6698 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6701 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6703 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6707 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6710 XSETSYMBOL (tem
, sym
);
6711 val
= find_symbol_value (tem
);
6713 || EQ (sym
->function
, obj
)
6714 || (!NILP (sym
->function
)
6715 && COMPILEDP (sym
->function
)
6716 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6719 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6721 found
= Fcons (tem
, found
);
6722 if (--find_max
== 0)
6730 unbind_to (gc_count
, Qnil
);
6734 #ifdef ENABLE_CHECKING
6736 bool suppress_checking
;
6739 die (const char *msg
, const char *file
, int line
)
6741 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6743 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6747 /* Initialization. */
6750 init_alloc_once (void)
6752 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6754 pure_size
= PURESIZE
;
6756 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6758 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6761 #ifdef DOUG_LEA_MALLOC
6762 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6763 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6764 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6769 refill_memory_reserve ();
6770 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6777 byte_stack_list
= 0;
6779 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6780 setjmp_tested_p
= longjmps_done
= 0;
6783 Vgc_elapsed
= make_float (0.0);
6787 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
6792 syms_of_alloc (void)
6794 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6795 doc
: /* Number of bytes of consing between garbage collections.
6796 Garbage collection can happen automatically once this many bytes have been
6797 allocated since the last garbage collection. All data types count.
6799 Garbage collection happens automatically only when `eval' is called.
6801 By binding this temporarily to a large number, you can effectively
6802 prevent garbage collection during a part of the program.
6803 See also `gc-cons-percentage'. */);
6805 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6806 doc
: /* Portion of the heap used for allocation.
6807 Garbage collection can happen automatically once this portion of the heap
6808 has been allocated since the last garbage collection.
6809 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6810 Vgc_cons_percentage
= make_float (0.1);
6812 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6813 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6815 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6816 doc
: /* Number of cons cells that have been consed so far. */);
6818 DEFVAR_INT ("floats-consed", floats_consed
,
6819 doc
: /* Number of floats that have been consed so far. */);
6821 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6822 doc
: /* Number of vector cells that have been consed so far. */);
6824 DEFVAR_INT ("symbols-consed", symbols_consed
,
6825 doc
: /* Number of symbols that have been consed so far. */);
6827 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6828 doc
: /* Number of string characters that have been consed so far. */);
6830 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6831 doc
: /* Number of miscellaneous objects that have been consed so far.
6832 These include markers and overlays, plus certain objects not visible
6835 DEFVAR_INT ("intervals-consed", intervals_consed
,
6836 doc
: /* Number of intervals that have been consed so far. */);
6838 DEFVAR_INT ("strings-consed", strings_consed
,
6839 doc
: /* Number of strings that have been consed so far. */);
6841 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6842 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6843 This means that certain objects should be allocated in shared (pure) space.
6844 It can also be set to a hash-table, in which case this table is used to
6845 do hash-consing of the objects allocated to pure space. */);
6847 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6848 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6849 garbage_collection_messages
= 0;
6851 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6852 doc
: /* Hook run after garbage collection has finished. */);
6853 Vpost_gc_hook
= Qnil
;
6854 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6856 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6857 doc
: /* Precomputed `signal' argument for memory-full error. */);
6858 /* We build this in advance because if we wait until we need it, we might
6859 not be able to allocate the memory to hold it. */
6861 = listn (CONSTYPE_PURE
, 2, Qerror
,
6862 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6864 DEFVAR_LISP ("memory-full", Vmemory_full
,
6865 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6866 Vmemory_full
= Qnil
;
6868 DEFSYM (Qconses
, "conses");
6869 DEFSYM (Qsymbols
, "symbols");
6870 DEFSYM (Qmiscs
, "miscs");
6871 DEFSYM (Qstrings
, "strings");
6872 DEFSYM (Qvectors
, "vectors");
6873 DEFSYM (Qfloats
, "floats");
6874 DEFSYM (Qintervals
, "intervals");
6875 DEFSYM (Qbuffers
, "buffers");
6876 DEFSYM (Qstring_bytes
, "string-bytes");
6877 DEFSYM (Qvector_slots
, "vector-slots");
6878 DEFSYM (Qheap
, "heap");
6879 DEFSYM (Qautomatic_gc
, "Automatic GC");
6881 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6882 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6884 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6885 doc
: /* Accumulated time elapsed in garbage collections.
6886 The time is in seconds as a floating point value. */);
6887 DEFVAR_INT ("gcs-done", gcs_done
,
6888 doc
: /* Accumulated number of garbage collections done. */);
6893 defsubr (&Smake_byte_code
);
6894 defsubr (&Smake_list
);
6895 defsubr (&Smake_vector
);
6896 defsubr (&Smake_string
);
6897 defsubr (&Smake_bool_vector
);
6898 defsubr (&Smake_symbol
);
6899 defsubr (&Smake_marker
);
6900 defsubr (&Spurecopy
);
6901 defsubr (&Sgarbage_collect
);
6902 defsubr (&Smemory_limit
);
6903 defsubr (&Smemory_use_counts
);
6905 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6906 defsubr (&Sgc_status
);
6910 /* When compiled with GCC, GDB might say "No enum type named
6911 pvec_type" if we don't have at least one symbol with that type, and
6912 then xbacktrace could fail. Similarly for the other enums and
6913 their values. Some non-GCC compilers don't like these constructs. */
6917 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6918 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6919 enum char_bits char_bits
;
6920 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6921 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6922 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6923 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6924 enum Lisp_Bits Lisp_Bits
;
6925 enum Lisp_Compiled Lisp_Compiled
;
6926 enum maxargs maxargs
;
6927 enum MAX_ALLOCA MAX_ALLOCA
;
6928 enum More_Lisp_Bits More_Lisp_Bits
;
6929 enum pvec_type pvec_type
;
6930 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6931 #endif /* __GNUC__ */