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. */
48 #if (defined ENABLE_CHECKING \
49 && defined HAVE_VALGRIND_VALGRIND_H \
50 && !defined USE_VALGRIND)
51 # define USE_VALGRIND 1
55 #include <valgrind/valgrind.h>
56 #include <valgrind/memcheck.h>
57 static bool valgrind_p
;
60 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
61 Doable only if GC_MARK_STACK. */
63 # undef GC_CHECK_MARKED_OBJECTS
66 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
67 memory. Can do this only if using gmalloc.c and if not checking
70 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
71 || defined GC_CHECK_MARKED_OBJECTS)
72 #undef GC_MALLOC_CHECK
83 #include "w32heap.h" /* for sbrk */
86 #ifdef DOUG_LEA_MALLOC
90 /* Specify maximum number of areas to mmap. It would be nice to use a
91 value that explicitly means "no limit". */
93 #define MMAP_MAX_AREAS 100000000
95 #endif /* not DOUG_LEA_MALLOC */
97 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
98 to a struct Lisp_String. */
100 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
101 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
102 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
104 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
105 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
106 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
108 /* Default value of gc_cons_threshold (see below). */
110 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
112 /* Global variables. */
113 struct emacs_globals globals
;
115 /* Number of bytes of consing done since the last gc. */
117 EMACS_INT consing_since_gc
;
119 /* Similar minimum, computed from Vgc_cons_percentage. */
121 EMACS_INT gc_relative_threshold
;
123 /* Minimum number of bytes of consing since GC before next GC,
124 when memory is full. */
126 EMACS_INT memory_full_cons_threshold
;
128 /* True during GC. */
132 /* True means abort if try to GC.
133 This is for code which is written on the assumption that
134 no GC will happen, so as to verify that assumption. */
138 /* Number of live and free conses etc. */
140 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
141 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
142 static EMACS_INT total_free_floats
, total_floats
;
144 /* Points to memory space allocated as "spare", to be freed if we run
145 out of memory. We keep one large block, four cons-blocks, and
146 two string blocks. */
148 static char *spare_memory
[7];
150 /* Amount of spare memory to keep in large reserve block, or to see
151 whether this much is available when malloc fails on a larger request. */
153 #define SPARE_MEMORY (1 << 14)
155 /* Initialize it to a nonzero value to force it into data space
156 (rather than bss space). That way unexec will remap it into text
157 space (pure), on some systems. We have not implemented the
158 remapping on more recent systems because this is less important
159 nowadays than in the days of small memories and timesharing. */
161 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
162 #define PUREBEG (char *) pure
164 /* Pointer to the pure area, and its size. */
166 static char *purebeg
;
167 static ptrdiff_t pure_size
;
169 /* Number of bytes of pure storage used before pure storage overflowed.
170 If this is non-zero, this implies that an overflow occurred. */
172 static ptrdiff_t pure_bytes_used_before_overflow
;
174 /* True if P points into pure space. */
176 #define PURE_POINTER_P(P) \
177 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
179 /* Index in pure at which next pure Lisp object will be allocated.. */
181 static ptrdiff_t pure_bytes_used_lisp
;
183 /* Number of bytes allocated for non-Lisp objects in pure storage. */
185 static ptrdiff_t pure_bytes_used_non_lisp
;
187 /* If nonzero, this is a warning delivered by malloc and not yet
190 const char *pending_malloc_warning
;
192 /* Maximum amount of C stack to save when a GC happens. */
194 #ifndef MAX_SAVE_STACK
195 #define MAX_SAVE_STACK 16000
198 /* Buffer in which we save a copy of the C stack at each GC. */
200 #if MAX_SAVE_STACK > 0
201 static char *stack_copy
;
202 static ptrdiff_t stack_copy_size
;
205 static Lisp_Object Qconses
;
206 static Lisp_Object Qsymbols
;
207 static Lisp_Object Qmiscs
;
208 static Lisp_Object Qstrings
;
209 static Lisp_Object Qvectors
;
210 static Lisp_Object Qfloats
;
211 static Lisp_Object Qintervals
;
212 static Lisp_Object Qbuffers
;
213 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
214 static Lisp_Object Qgc_cons_threshold
;
215 Lisp_Object Qautomatic_gc
;
216 Lisp_Object Qchar_table_extra_slots
;
218 /* Hook run after GC has finished. */
220 static Lisp_Object Qpost_gc_hook
;
222 static void mark_terminals (void);
223 static void gc_sweep (void);
224 static Lisp_Object
make_pure_vector (ptrdiff_t);
225 static void mark_buffer (struct buffer
*);
227 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
228 static void refill_memory_reserve (void);
230 static void compact_small_strings (void);
231 static void free_large_strings (void);
232 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
234 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
235 what memory allocated via lisp_malloc and lisp_align_malloc is intended
236 for what purpose. This enumeration specifies the type of memory. */
247 /* Since all non-bool pseudovectors are small enough to be
248 allocated from vector blocks, this memory type denotes
249 large regular vectors and large bool pseudovectors. */
251 /* Special type to denote vector blocks. */
252 MEM_TYPE_VECTOR_BLOCK
,
253 /* Special type to denote reserved memory. */
257 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
259 /* A unique object in pure space used to make some Lisp objects
260 on free lists recognizable in O(1). */
262 static Lisp_Object Vdead
;
263 #define DEADP(x) EQ (x, Vdead)
265 #ifdef GC_MALLOC_CHECK
267 enum mem_type allocated_mem_type
;
269 #endif /* GC_MALLOC_CHECK */
271 /* A node in the red-black tree describing allocated memory containing
272 Lisp data. Each such block is recorded with its start and end
273 address when it is allocated, and removed from the tree when it
276 A red-black tree is a balanced binary tree with the following
279 1. Every node is either red or black.
280 2. Every leaf is black.
281 3. If a node is red, then both of its children are black.
282 4. Every simple path from a node to a descendant leaf contains
283 the same number of black nodes.
284 5. The root is always black.
286 When nodes are inserted into the tree, or deleted from the tree,
287 the tree is "fixed" so that these properties are always true.
289 A red-black tree with N internal nodes has height at most 2
290 log(N+1). Searches, insertions and deletions are done in O(log N).
291 Please see a text book about data structures for a detailed
292 description of red-black trees. Any book worth its salt should
297 /* Children of this node. These pointers are never NULL. When there
298 is no child, the value is MEM_NIL, which points to a dummy node. */
299 struct mem_node
*left
, *right
;
301 /* The parent of this node. In the root node, this is NULL. */
302 struct mem_node
*parent
;
304 /* Start and end of allocated region. */
308 enum {MEM_BLACK
, MEM_RED
} color
;
314 /* Base address of stack. Set in main. */
316 Lisp_Object
*stack_base
;
318 /* Root of the tree describing allocated Lisp memory. */
320 static struct mem_node
*mem_root
;
322 /* Lowest and highest known address in the heap. */
324 static void *min_heap_address
, *max_heap_address
;
326 /* Sentinel node of the tree. */
328 static struct mem_node mem_z
;
329 #define MEM_NIL &mem_z
331 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
332 static void mem_insert_fixup (struct mem_node
*);
333 static void mem_rotate_left (struct mem_node
*);
334 static void mem_rotate_right (struct mem_node
*);
335 static void mem_delete (struct mem_node
*);
336 static void mem_delete_fixup (struct mem_node
*);
337 static struct mem_node
*mem_find (void *);
339 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
345 /* Recording what needs to be marked for gc. */
347 struct gcpro
*gcprolist
;
349 /* Addresses of staticpro'd variables. Initialize it to a nonzero
350 value; otherwise some compilers put it into BSS. */
352 enum { NSTATICS
= 2048 };
353 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
355 /* Index of next unused slot in staticvec. */
357 static int staticidx
;
359 static void *pure_alloc (size_t, int);
362 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
363 ALIGNMENT must be a power of 2. */
365 #define ALIGN(ptr, ALIGNMENT) \
366 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
367 & ~ ((ALIGNMENT) - 1)))
370 XFLOAT_INIT (Lisp_Object f
, double n
)
372 XFLOAT (f
)->u
.data
= n
;
376 /************************************************************************
378 ************************************************************************/
380 /* Function malloc calls this if it finds we are near exhausting storage. */
383 malloc_warning (const char *str
)
385 pending_malloc_warning
= str
;
389 /* Display an already-pending malloc warning. */
392 display_malloc_warning (void)
394 call3 (intern ("display-warning"),
396 build_string (pending_malloc_warning
),
397 intern ("emergency"));
398 pending_malloc_warning
= 0;
401 /* Called if we can't allocate relocatable space for a buffer. */
404 buffer_memory_full (ptrdiff_t nbytes
)
406 /* If buffers use the relocating allocator, no need to free
407 spare_memory, because we may have plenty of malloc space left
408 that we could get, and if we don't, the malloc that fails will
409 itself cause spare_memory to be freed. If buffers don't use the
410 relocating allocator, treat this like any other failing
414 memory_full (nbytes
);
416 /* This used to call error, but if we've run out of memory, we could
417 get infinite recursion trying to build the string. */
418 xsignal (Qnil
, Vmemory_signal_data
);
422 /* A common multiple of the positive integers A and B. Ideally this
423 would be the least common multiple, but there's no way to do that
424 as a constant expression in C, so do the best that we can easily do. */
425 #define COMMON_MULTIPLE(a, b) \
426 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
428 #ifndef XMALLOC_OVERRUN_CHECK
429 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
432 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
435 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
436 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
437 block size in little-endian order. The trailer consists of
438 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
440 The header is used to detect whether this block has been allocated
441 through these functions, as some low-level libc functions may
442 bypass the malloc hooks. */
444 #define XMALLOC_OVERRUN_CHECK_SIZE 16
445 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
446 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
448 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
449 hold a size_t value and (2) the header size is a multiple of the
450 alignment that Emacs needs for C types and for USE_LSB_TAG. */
451 #define XMALLOC_BASE_ALIGNMENT \
452 alignof (union { long double d; intmax_t i; void *p; })
455 # define XMALLOC_HEADER_ALIGNMENT \
456 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
458 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
460 #define XMALLOC_OVERRUN_SIZE_SIZE \
461 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
462 + XMALLOC_HEADER_ALIGNMENT - 1) \
463 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
464 - XMALLOC_OVERRUN_CHECK_SIZE)
466 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
467 { '\x9a', '\x9b', '\xae', '\xaf',
468 '\xbf', '\xbe', '\xce', '\xcf',
469 '\xea', '\xeb', '\xec', '\xed',
470 '\xdf', '\xde', '\x9c', '\x9d' };
472 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
473 { '\xaa', '\xab', '\xac', '\xad',
474 '\xba', '\xbb', '\xbc', '\xbd',
475 '\xca', '\xcb', '\xcc', '\xcd',
476 '\xda', '\xdb', '\xdc', '\xdd' };
478 /* Insert and extract the block size in the header. */
481 xmalloc_put_size (unsigned char *ptr
, size_t size
)
484 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
486 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
492 xmalloc_get_size (unsigned char *ptr
)
496 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
497 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
506 /* Like malloc, but wraps allocated block with header and trailer. */
509 overrun_check_malloc (size_t size
)
511 register unsigned char *val
;
512 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
515 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
518 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
519 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
520 xmalloc_put_size (val
, size
);
521 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
522 XMALLOC_OVERRUN_CHECK_SIZE
);
528 /* Like realloc, but checks old block for overrun, and wraps new block
529 with header and trailer. */
532 overrun_check_realloc (void *block
, size_t size
)
534 register unsigned char *val
= (unsigned char *) block
;
535 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
539 && memcmp (xmalloc_overrun_check_header
,
540 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
541 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
543 size_t osize
= xmalloc_get_size (val
);
544 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
545 XMALLOC_OVERRUN_CHECK_SIZE
))
547 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
548 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
549 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
552 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
556 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
557 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
558 xmalloc_put_size (val
, size
);
559 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
560 XMALLOC_OVERRUN_CHECK_SIZE
);
565 /* Like free, but checks block for overrun. */
568 overrun_check_free (void *block
)
570 unsigned char *val
= (unsigned char *) block
;
573 && memcmp (xmalloc_overrun_check_header
,
574 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
575 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
577 size_t osize
= xmalloc_get_size (val
);
578 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
579 XMALLOC_OVERRUN_CHECK_SIZE
))
581 #ifdef XMALLOC_CLEAR_FREE_MEMORY
582 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
583 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
585 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
586 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
587 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
597 #define malloc overrun_check_malloc
598 #define realloc overrun_check_realloc
599 #define free overrun_check_free
602 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
603 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
604 If that variable is set, block input while in one of Emacs's memory
605 allocation functions. There should be no need for this debugging
606 option, since signal handlers do not allocate memory, but Emacs
607 formerly allocated memory in signal handlers and this compile-time
608 option remains as a way to help debug the issue should it rear its
610 #ifdef XMALLOC_BLOCK_INPUT_CHECK
611 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
613 malloc_block_input (void)
615 if (block_input_in_memory_allocators
)
619 malloc_unblock_input (void)
621 if (block_input_in_memory_allocators
)
624 # define MALLOC_BLOCK_INPUT malloc_block_input ()
625 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
627 # define MALLOC_BLOCK_INPUT ((void) 0)
628 # define MALLOC_UNBLOCK_INPUT ((void) 0)
631 #define MALLOC_PROBE(size) \
633 if (profiler_memory_running) \
634 malloc_probe (size); \
638 /* Like malloc but check for no memory and block interrupt input.. */
641 xmalloc (size_t size
)
647 MALLOC_UNBLOCK_INPUT
;
655 /* Like the above, but zeroes out the memory just allocated. */
658 xzalloc (size_t size
)
664 MALLOC_UNBLOCK_INPUT
;
668 memset (val
, 0, size
);
673 /* Like realloc but check for no memory and block interrupt input.. */
676 xrealloc (void *block
, size_t size
)
681 /* We must call malloc explicitly when BLOCK is 0, since some
682 reallocs don't do this. */
686 val
= realloc (block
, size
);
687 MALLOC_UNBLOCK_INPUT
;
696 /* Like free but block interrupt input. */
705 MALLOC_UNBLOCK_INPUT
;
706 /* We don't call refill_memory_reserve here
707 because in practice the call in r_alloc_free seems to suffice. */
711 /* Other parts of Emacs pass large int values to allocator functions
712 expecting ptrdiff_t. This is portable in practice, but check it to
714 verify (INT_MAX
<= PTRDIFF_MAX
);
717 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
718 Signal an error on memory exhaustion, and block interrupt input. */
721 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
723 eassert (0 <= nitems
&& 0 < item_size
);
724 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
725 memory_full (SIZE_MAX
);
726 return xmalloc (nitems
* item_size
);
730 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
731 Signal an error on memory exhaustion, and block interrupt input. */
734 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
736 eassert (0 <= nitems
&& 0 < item_size
);
737 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
738 memory_full (SIZE_MAX
);
739 return xrealloc (pa
, nitems
* item_size
);
743 /* Grow PA, which points to an array of *NITEMS items, and return the
744 location of the reallocated array, updating *NITEMS to reflect its
745 new size. The new array will contain at least NITEMS_INCR_MIN more
746 items, but will not contain more than NITEMS_MAX items total.
747 ITEM_SIZE is the size of each item, in bytes.
749 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
750 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
753 If PA is null, then allocate a new array instead of reallocating
756 Block interrupt input as needed. If memory exhaustion occurs, set
757 *NITEMS to zero if PA is null, and signal an error (i.e., do not
760 Thus, to grow an array A without saving its old contents, do
761 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
762 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
763 and signals an error, and later this code is reexecuted and
764 attempts to free A. */
767 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
768 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
770 /* The approximate size to use for initial small allocation
771 requests. This is the largest "small" request for the GNU C
773 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
775 /* If the array is tiny, grow it to about (but no greater than)
776 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
777 ptrdiff_t n
= *nitems
;
778 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
779 ptrdiff_t half_again
= n
>> 1;
780 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
782 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
783 NITEMS_MAX, and what the C language can represent safely. */
784 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
785 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
786 ? nitems_max
: C_language_max
);
787 ptrdiff_t nitems_incr_max
= n_max
- n
;
788 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
790 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
793 if (nitems_incr_max
< incr
)
794 memory_full (SIZE_MAX
);
796 pa
= xrealloc (pa
, n
* item_size
);
802 /* Like strdup, but uses xmalloc. */
805 xstrdup (const char *s
)
809 size
= strlen (s
) + 1;
810 return memcpy (xmalloc (size
), s
, size
);
813 /* Like above, but duplicates Lisp string to C string. */
816 xlispstrdup (Lisp_Object string
)
818 ptrdiff_t size
= SBYTES (string
) + 1;
819 return memcpy (xmalloc (size
), SSDATA (string
), size
);
822 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
823 argument is a const pointer. */
826 xputenv (char const *string
)
828 if (putenv ((char *) string
) != 0)
832 /* Return a newly allocated memory block of SIZE bytes, remembering
833 to free it when unwinding. */
835 record_xmalloc (size_t size
)
837 void *p
= xmalloc (size
);
838 record_unwind_protect_ptr (xfree
, p
);
843 /* Like malloc but used for allocating Lisp data. NBYTES is the
844 number of bytes to allocate, TYPE describes the intended use of the
845 allocated memory block (for strings, for conses, ...). */
848 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
852 lisp_malloc (size_t nbytes
, enum mem_type type
)
858 #ifdef GC_MALLOC_CHECK
859 allocated_mem_type
= type
;
862 val
= malloc (nbytes
);
865 /* If the memory just allocated cannot be addressed thru a Lisp
866 object's pointer, and it needs to be,
867 that's equivalent to running out of memory. */
868 if (val
&& type
!= MEM_TYPE_NON_LISP
)
871 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
872 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
874 lisp_malloc_loser
= val
;
881 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
882 if (val
&& type
!= MEM_TYPE_NON_LISP
)
883 mem_insert (val
, (char *) val
+ nbytes
, type
);
886 MALLOC_UNBLOCK_INPUT
;
888 memory_full (nbytes
);
889 MALLOC_PROBE (nbytes
);
893 /* Free BLOCK. This must be called to free memory allocated with a
894 call to lisp_malloc. */
897 lisp_free (void *block
)
901 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
902 mem_delete (mem_find (block
));
904 MALLOC_UNBLOCK_INPUT
;
907 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
909 /* The entry point is lisp_align_malloc which returns blocks of at most
910 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
912 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
913 #define USE_POSIX_MEMALIGN 1
916 /* BLOCK_ALIGN has to be a power of 2. */
917 #define BLOCK_ALIGN (1 << 10)
919 /* Padding to leave at the end of a malloc'd block. This is to give
920 malloc a chance to minimize the amount of memory wasted to alignment.
921 It should be tuned to the particular malloc library used.
922 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
923 posix_memalign on the other hand would ideally prefer a value of 4
924 because otherwise, there's 1020 bytes wasted between each ablocks.
925 In Emacs, testing shows that those 1020 can most of the time be
926 efficiently used by malloc to place other objects, so a value of 0 can
927 still preferable unless you have a lot of aligned blocks and virtually
929 #define BLOCK_PADDING 0
930 #define BLOCK_BYTES \
931 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
933 /* Internal data structures and constants. */
935 #define ABLOCKS_SIZE 16
937 /* An aligned block of memory. */
942 char payload
[BLOCK_BYTES
];
943 struct ablock
*next_free
;
945 /* `abase' is the aligned base of the ablocks. */
946 /* It is overloaded to hold the virtual `busy' field that counts
947 the number of used ablock in the parent ablocks.
948 The first ablock has the `busy' field, the others have the `abase'
949 field. To tell the difference, we assume that pointers will have
950 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
951 is used to tell whether the real base of the parent ablocks is `abase'
952 (if not, the word before the first ablock holds a pointer to the
954 struct ablocks
*abase
;
955 /* The padding of all but the last ablock is unused. The padding of
956 the last ablock in an ablocks is not allocated. */
958 char padding
[BLOCK_PADDING
];
962 /* A bunch of consecutive aligned blocks. */
965 struct ablock blocks
[ABLOCKS_SIZE
];
968 /* Size of the block requested from malloc or posix_memalign. */
969 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
971 #define ABLOCK_ABASE(block) \
972 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
973 ? (struct ablocks *)(block) \
976 /* Virtual `busy' field. */
977 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
979 /* Pointer to the (not necessarily aligned) malloc block. */
980 #ifdef USE_POSIX_MEMALIGN
981 #define ABLOCKS_BASE(abase) (abase)
983 #define ABLOCKS_BASE(abase) \
984 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
987 /* The list of free ablock. */
988 static struct ablock
*free_ablock
;
990 /* Allocate an aligned block of nbytes.
991 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
992 smaller or equal to BLOCK_BYTES. */
994 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
997 struct ablocks
*abase
;
999 eassert (nbytes
<= BLOCK_BYTES
);
1003 #ifdef GC_MALLOC_CHECK
1004 allocated_mem_type
= type
;
1010 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1012 #ifdef DOUG_LEA_MALLOC
1013 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1014 because mapped region contents are not preserved in
1016 mallopt (M_MMAP_MAX
, 0);
1019 #ifdef USE_POSIX_MEMALIGN
1021 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1027 base
= malloc (ABLOCKS_BYTES
);
1028 abase
= ALIGN (base
, BLOCK_ALIGN
);
1033 MALLOC_UNBLOCK_INPUT
;
1034 memory_full (ABLOCKS_BYTES
);
1037 aligned
= (base
== abase
);
1039 ((void **) abase
)[-1] = base
;
1041 #ifdef DOUG_LEA_MALLOC
1042 /* Back to a reasonable maximum of mmap'ed areas. */
1043 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1047 /* If the memory just allocated cannot be addressed thru a Lisp
1048 object's pointer, and it needs to be, that's equivalent to
1049 running out of memory. */
1050 if (type
!= MEM_TYPE_NON_LISP
)
1053 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1054 XSETCONS (tem
, end
);
1055 if ((char *) XCONS (tem
) != end
)
1057 lisp_malloc_loser
= base
;
1059 MALLOC_UNBLOCK_INPUT
;
1060 memory_full (SIZE_MAX
);
1065 /* Initialize the blocks and put them on the free list.
1066 If `base' was not properly aligned, we can't use the last block. */
1067 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1069 abase
->blocks
[i
].abase
= abase
;
1070 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1071 free_ablock
= &abase
->blocks
[i
];
1073 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1075 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1076 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1077 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1078 eassert (ABLOCKS_BASE (abase
) == base
);
1079 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1082 abase
= ABLOCK_ABASE (free_ablock
);
1083 ABLOCKS_BUSY (abase
) =
1084 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1086 free_ablock
= free_ablock
->x
.next_free
;
1088 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1089 if (type
!= MEM_TYPE_NON_LISP
)
1090 mem_insert (val
, (char *) val
+ nbytes
, type
);
1093 MALLOC_UNBLOCK_INPUT
;
1095 MALLOC_PROBE (nbytes
);
1097 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1102 lisp_align_free (void *block
)
1104 struct ablock
*ablock
= block
;
1105 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1108 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1109 mem_delete (mem_find (block
));
1111 /* Put on free list. */
1112 ablock
->x
.next_free
= free_ablock
;
1113 free_ablock
= ablock
;
1114 /* Update busy count. */
1115 ABLOCKS_BUSY (abase
)
1116 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1118 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1119 { /* All the blocks are free. */
1120 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1121 struct ablock
**tem
= &free_ablock
;
1122 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1126 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1129 *tem
= (*tem
)->x
.next_free
;
1132 tem
= &(*tem
)->x
.next_free
;
1134 eassert ((aligned
& 1) == aligned
);
1135 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1136 #ifdef USE_POSIX_MEMALIGN
1137 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1139 free (ABLOCKS_BASE (abase
));
1141 MALLOC_UNBLOCK_INPUT
;
1145 /***********************************************************************
1147 ***********************************************************************/
1149 /* Number of intervals allocated in an interval_block structure.
1150 The 1020 is 1024 minus malloc overhead. */
1152 #define INTERVAL_BLOCK_SIZE \
1153 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1155 /* Intervals are allocated in chunks in the form of an interval_block
1158 struct interval_block
1160 /* Place `intervals' first, to preserve alignment. */
1161 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1162 struct interval_block
*next
;
1165 /* Current interval block. Its `next' pointer points to older
1168 static struct interval_block
*interval_block
;
1170 /* Index in interval_block above of the next unused interval
1173 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1175 /* Number of free and live intervals. */
1177 static EMACS_INT total_free_intervals
, total_intervals
;
1179 /* List of free intervals. */
1181 static INTERVAL interval_free_list
;
1183 /* Return a new interval. */
1186 make_interval (void)
1192 if (interval_free_list
)
1194 val
= interval_free_list
;
1195 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1199 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1201 struct interval_block
*newi
1202 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1204 newi
->next
= interval_block
;
1205 interval_block
= newi
;
1206 interval_block_index
= 0;
1207 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1209 val
= &interval_block
->intervals
[interval_block_index
++];
1212 MALLOC_UNBLOCK_INPUT
;
1214 consing_since_gc
+= sizeof (struct interval
);
1216 total_free_intervals
--;
1217 RESET_INTERVAL (val
);
1223 /* Mark Lisp objects in interval I. */
1226 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1228 /* Intervals should never be shared. So, if extra internal checking is
1229 enabled, GC aborts if it seems to have visited an interval twice. */
1230 eassert (!i
->gcmarkbit
);
1232 mark_object (i
->plist
);
1235 /* Mark the interval tree rooted in I. */
1237 #define MARK_INTERVAL_TREE(i) \
1239 if (i && !i->gcmarkbit) \
1240 traverse_intervals_noorder (i, mark_interval, Qnil); \
1243 /***********************************************************************
1245 ***********************************************************************/
1247 /* Lisp_Strings are allocated in string_block structures. When a new
1248 string_block is allocated, all the Lisp_Strings it contains are
1249 added to a free-list string_free_list. When a new Lisp_String is
1250 needed, it is taken from that list. During the sweep phase of GC,
1251 string_blocks that are entirely free are freed, except two which
1254 String data is allocated from sblock structures. Strings larger
1255 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1256 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1258 Sblocks consist internally of sdata structures, one for each
1259 Lisp_String. The sdata structure points to the Lisp_String it
1260 belongs to. The Lisp_String points back to the `u.data' member of
1261 its sdata structure.
1263 When a Lisp_String is freed during GC, it is put back on
1264 string_free_list, and its `data' member and its sdata's `string'
1265 pointer is set to null. The size of the string is recorded in the
1266 `n.nbytes' member of the sdata. So, sdata structures that are no
1267 longer used, can be easily recognized, and it's easy to compact the
1268 sblocks of small strings which we do in compact_small_strings. */
1270 /* Size in bytes of an sblock structure used for small strings. This
1271 is 8192 minus malloc overhead. */
1273 #define SBLOCK_SIZE 8188
1275 /* Strings larger than this are considered large strings. String data
1276 for large strings is allocated from individual sblocks. */
1278 #define LARGE_STRING_BYTES 1024
1280 /* Struct or union describing string memory sub-allocated from an sblock.
1281 This is where the contents of Lisp strings are stored. */
1283 #ifdef GC_CHECK_STRING_BYTES
1287 /* Back-pointer to the string this sdata belongs to. If null, this
1288 structure is free, and the NBYTES member of the union below
1289 contains the string's byte size (the same value that STRING_BYTES
1290 would return if STRING were non-null). If non-null, STRING_BYTES
1291 (STRING) is the size of the data, and DATA contains the string's
1293 struct Lisp_String
*string
;
1296 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1299 #define SDATA_NBYTES(S) (S)->nbytes
1300 #define SDATA_DATA(S) (S)->data
1301 #define SDATA_SELECTOR(member) member
1307 struct Lisp_String
*string
;
1309 /* When STRING is non-null. */
1312 struct Lisp_String
*string
;
1313 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1316 /* When STRING is null. */
1319 struct Lisp_String
*string
;
1324 #define SDATA_NBYTES(S) (S)->n.nbytes
1325 #define SDATA_DATA(S) (S)->u.data
1326 #define SDATA_SELECTOR(member) u.member
1328 #endif /* not GC_CHECK_STRING_BYTES */
1330 #define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1333 /* Structure describing a block of memory which is sub-allocated to
1334 obtain string data memory for strings. Blocks for small strings
1335 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1336 as large as needed. */
1341 struct sblock
*next
;
1343 /* Pointer to the next free sdata block. This points past the end
1344 of the sblock if there isn't any space left in this block. */
1347 /* Start of data. */
1351 /* Number of Lisp strings in a string_block structure. The 1020 is
1352 1024 minus malloc overhead. */
1354 #define STRING_BLOCK_SIZE \
1355 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1357 /* Structure describing a block from which Lisp_String structures
1362 /* Place `strings' first, to preserve alignment. */
1363 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1364 struct string_block
*next
;
1367 /* Head and tail of the list of sblock structures holding Lisp string
1368 data. We always allocate from current_sblock. The NEXT pointers
1369 in the sblock structures go from oldest_sblock to current_sblock. */
1371 static struct sblock
*oldest_sblock
, *current_sblock
;
1373 /* List of sblocks for large strings. */
1375 static struct sblock
*large_sblocks
;
1377 /* List of string_block structures. */
1379 static struct string_block
*string_blocks
;
1381 /* Free-list of Lisp_Strings. */
1383 static struct Lisp_String
*string_free_list
;
1385 /* Number of live and free Lisp_Strings. */
1387 static EMACS_INT total_strings
, total_free_strings
;
1389 /* Number of bytes used by live strings. */
1391 static EMACS_INT total_string_bytes
;
1393 /* Given a pointer to a Lisp_String S which is on the free-list
1394 string_free_list, return a pointer to its successor in the
1397 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1399 /* Return a pointer to the sdata structure belonging to Lisp string S.
1400 S must be live, i.e. S->data must not be null. S->data is actually
1401 a pointer to the `u.data' member of its sdata structure; the
1402 structure starts at a constant offset in front of that. */
1404 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1407 #ifdef GC_CHECK_STRING_OVERRUN
1409 /* We check for overrun in string data blocks by appending a small
1410 "cookie" after each allocated string data block, and check for the
1411 presence of this cookie during GC. */
1413 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1414 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1415 { '\xde', '\xad', '\xbe', '\xef' };
1418 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1421 /* Value is the size of an sdata structure large enough to hold NBYTES
1422 bytes of string data. The value returned includes a terminating
1423 NUL byte, the size of the sdata structure, and padding. */
1425 #ifdef GC_CHECK_STRING_BYTES
1427 #define SDATA_SIZE(NBYTES) \
1428 ((SDATA_DATA_OFFSET \
1430 + sizeof (ptrdiff_t) - 1) \
1431 & ~(sizeof (ptrdiff_t) - 1))
1433 #else /* not GC_CHECK_STRING_BYTES */
1435 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1436 less than the size of that member. The 'max' is not needed when
1437 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1438 alignment code reserves enough space. */
1440 #define SDATA_SIZE(NBYTES) \
1441 ((SDATA_DATA_OFFSET \
1442 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1444 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1446 + sizeof (ptrdiff_t) - 1) \
1447 & ~(sizeof (ptrdiff_t) - 1))
1449 #endif /* not GC_CHECK_STRING_BYTES */
1451 /* Extra bytes to allocate for each string. */
1453 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1455 /* Exact bound on the number of bytes in a string, not counting the
1456 terminating null. A string cannot contain more bytes than
1457 STRING_BYTES_BOUND, nor can it be so long that the size_t
1458 arithmetic in allocate_string_data would overflow while it is
1459 calculating a value to be passed to malloc. */
1460 static ptrdiff_t const STRING_BYTES_MAX
=
1461 min (STRING_BYTES_BOUND
,
1462 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1464 - offsetof (struct sblock
, first_data
)
1465 - SDATA_DATA_OFFSET
)
1466 & ~(sizeof (EMACS_INT
) - 1)));
1468 /* Initialize string allocation. Called from init_alloc_once. */
1473 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1474 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1478 #ifdef GC_CHECK_STRING_BYTES
1480 static int check_string_bytes_count
;
1482 /* Like STRING_BYTES, but with debugging check. Can be
1483 called during GC, so pay attention to the mark bit. */
1486 string_bytes (struct Lisp_String
*s
)
1489 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1491 if (!PURE_POINTER_P (s
)
1493 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1498 /* Check validity of Lisp strings' string_bytes member in B. */
1501 check_sblock (struct sblock
*b
)
1503 sdata
*from
, *end
, *from_end
;
1507 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1509 /* Compute the next FROM here because copying below may
1510 overwrite data we need to compute it. */
1513 /* Check that the string size recorded in the string is the
1514 same as the one recorded in the sdata structure. */
1515 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1516 : SDATA_NBYTES (from
));
1517 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1522 /* Check validity of Lisp strings' string_bytes member. ALL_P
1523 means check all strings, otherwise check only most
1524 recently allocated strings. Used for hunting a bug. */
1527 check_string_bytes (bool all_p
)
1533 for (b
= large_sblocks
; b
; b
= b
->next
)
1535 struct Lisp_String
*s
= b
->first_data
.string
;
1540 for (b
= oldest_sblock
; b
; b
= b
->next
)
1543 else if (current_sblock
)
1544 check_sblock (current_sblock
);
1547 #else /* not GC_CHECK_STRING_BYTES */
1549 #define check_string_bytes(all) ((void) 0)
1551 #endif /* GC_CHECK_STRING_BYTES */
1553 #ifdef GC_CHECK_STRING_FREE_LIST
1555 /* Walk through the string free list looking for bogus next pointers.
1556 This may catch buffer overrun from a previous string. */
1559 check_string_free_list (void)
1561 struct Lisp_String
*s
;
1563 /* Pop a Lisp_String off the free-list. */
1564 s
= string_free_list
;
1567 if ((uintptr_t) s
< 1024)
1569 s
= NEXT_FREE_LISP_STRING (s
);
1573 #define check_string_free_list()
1576 /* Return a new Lisp_String. */
1578 static struct Lisp_String
*
1579 allocate_string (void)
1581 struct Lisp_String
*s
;
1585 /* If the free-list is empty, allocate a new string_block, and
1586 add all the Lisp_Strings in it to the free-list. */
1587 if (string_free_list
== NULL
)
1589 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1592 b
->next
= string_blocks
;
1595 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1598 /* Every string on a free list should have NULL data pointer. */
1600 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1601 string_free_list
= s
;
1604 total_free_strings
+= STRING_BLOCK_SIZE
;
1607 check_string_free_list ();
1609 /* Pop a Lisp_String off the free-list. */
1610 s
= string_free_list
;
1611 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1613 MALLOC_UNBLOCK_INPUT
;
1615 --total_free_strings
;
1618 consing_since_gc
+= sizeof *s
;
1620 #ifdef GC_CHECK_STRING_BYTES
1621 if (!noninteractive
)
1623 if (++check_string_bytes_count
== 200)
1625 check_string_bytes_count
= 0;
1626 check_string_bytes (1);
1629 check_string_bytes (0);
1631 #endif /* GC_CHECK_STRING_BYTES */
1637 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1638 plus a NUL byte at the end. Allocate an sdata structure for S, and
1639 set S->data to its `u.data' member. Store a NUL byte at the end of
1640 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1641 S->data if it was initially non-null. */
1644 allocate_string_data (struct Lisp_String
*s
,
1645 EMACS_INT nchars
, EMACS_INT nbytes
)
1647 sdata
*data
, *old_data
;
1649 ptrdiff_t needed
, old_nbytes
;
1651 if (STRING_BYTES_MAX
< nbytes
)
1654 /* Determine the number of bytes needed to store NBYTES bytes
1656 needed
= SDATA_SIZE (nbytes
);
1659 old_data
= SDATA_OF_STRING (s
);
1660 old_nbytes
= STRING_BYTES (s
);
1667 if (nbytes
> LARGE_STRING_BYTES
)
1669 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1671 #ifdef DOUG_LEA_MALLOC
1672 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1673 because mapped region contents are not preserved in
1676 In case you think of allowing it in a dumped Emacs at the
1677 cost of not being able to re-dump, there's another reason:
1678 mmap'ed data typically have an address towards the top of the
1679 address space, which won't fit into an EMACS_INT (at least on
1680 32-bit systems with the current tagging scheme). --fx */
1681 mallopt (M_MMAP_MAX
, 0);
1684 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1686 #ifdef DOUG_LEA_MALLOC
1687 /* Back to a reasonable maximum of mmap'ed areas. */
1688 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1691 b
->next_free
= &b
->first_data
;
1692 b
->first_data
.string
= NULL
;
1693 b
->next
= large_sblocks
;
1696 else if (current_sblock
== NULL
1697 || (((char *) current_sblock
+ SBLOCK_SIZE
1698 - (char *) current_sblock
->next_free
)
1699 < (needed
+ GC_STRING_EXTRA
)))
1701 /* Not enough room in the current sblock. */
1702 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1703 b
->next_free
= &b
->first_data
;
1704 b
->first_data
.string
= NULL
;
1708 current_sblock
->next
= b
;
1716 data
= b
->next_free
;
1717 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1719 MALLOC_UNBLOCK_INPUT
;
1722 s
->data
= SDATA_DATA (data
);
1723 #ifdef GC_CHECK_STRING_BYTES
1724 SDATA_NBYTES (data
) = nbytes
;
1727 s
->size_byte
= nbytes
;
1728 s
->data
[nbytes
] = '\0';
1729 #ifdef GC_CHECK_STRING_OVERRUN
1730 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1731 GC_STRING_OVERRUN_COOKIE_SIZE
);
1734 /* Note that Faset may call to this function when S has already data
1735 assigned. In this case, mark data as free by setting it's string
1736 back-pointer to null, and record the size of the data in it. */
1739 SDATA_NBYTES (old_data
) = old_nbytes
;
1740 old_data
->string
= NULL
;
1743 consing_since_gc
+= needed
;
1747 /* Sweep and compact strings. */
1750 sweep_strings (void)
1752 struct string_block
*b
, *next
;
1753 struct string_block
*live_blocks
= NULL
;
1755 string_free_list
= NULL
;
1756 total_strings
= total_free_strings
= 0;
1757 total_string_bytes
= 0;
1759 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1760 for (b
= string_blocks
; b
; b
= next
)
1763 struct Lisp_String
*free_list_before
= string_free_list
;
1767 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1769 struct Lisp_String
*s
= b
->strings
+ i
;
1773 /* String was not on free-list before. */
1774 if (STRING_MARKED_P (s
))
1776 /* String is live; unmark it and its intervals. */
1779 /* Do not use string_(set|get)_intervals here. */
1780 s
->intervals
= balance_intervals (s
->intervals
);
1783 total_string_bytes
+= STRING_BYTES (s
);
1787 /* String is dead. Put it on the free-list. */
1788 sdata
*data
= SDATA_OF_STRING (s
);
1790 /* Save the size of S in its sdata so that we know
1791 how large that is. Reset the sdata's string
1792 back-pointer so that we know it's free. */
1793 #ifdef GC_CHECK_STRING_BYTES
1794 if (string_bytes (s
) != SDATA_NBYTES (data
))
1797 data
->n
.nbytes
= STRING_BYTES (s
);
1799 data
->string
= NULL
;
1801 /* Reset the strings's `data' member so that we
1805 /* Put the string on the free-list. */
1806 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1807 string_free_list
= s
;
1813 /* S was on the free-list before. Put it there again. */
1814 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1815 string_free_list
= s
;
1820 /* Free blocks that contain free Lisp_Strings only, except
1821 the first two of them. */
1822 if (nfree
== STRING_BLOCK_SIZE
1823 && total_free_strings
> STRING_BLOCK_SIZE
)
1826 string_free_list
= free_list_before
;
1830 total_free_strings
+= nfree
;
1831 b
->next
= live_blocks
;
1836 check_string_free_list ();
1838 string_blocks
= live_blocks
;
1839 free_large_strings ();
1840 compact_small_strings ();
1842 check_string_free_list ();
1846 /* Free dead large strings. */
1849 free_large_strings (void)
1851 struct sblock
*b
, *next
;
1852 struct sblock
*live_blocks
= NULL
;
1854 for (b
= large_sblocks
; b
; b
= next
)
1858 if (b
->first_data
.string
== NULL
)
1862 b
->next
= live_blocks
;
1867 large_sblocks
= live_blocks
;
1871 /* Compact data of small strings. Free sblocks that don't contain
1872 data of live strings after compaction. */
1875 compact_small_strings (void)
1877 struct sblock
*b
, *tb
, *next
;
1878 sdata
*from
, *to
, *end
, *tb_end
;
1879 sdata
*to_end
, *from_end
;
1881 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1882 to, and TB_END is the end of TB. */
1884 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1885 to
= &tb
->first_data
;
1887 /* Step through the blocks from the oldest to the youngest. We
1888 expect that old blocks will stabilize over time, so that less
1889 copying will happen this way. */
1890 for (b
= oldest_sblock
; b
; b
= b
->next
)
1893 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1895 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1897 /* Compute the next FROM here because copying below may
1898 overwrite data we need to compute it. */
1900 struct Lisp_String
*s
= from
->string
;
1902 #ifdef GC_CHECK_STRING_BYTES
1903 /* Check that the string size recorded in the string is the
1904 same as the one recorded in the sdata structure. */
1905 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1907 #endif /* GC_CHECK_STRING_BYTES */
1909 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1910 eassert (nbytes
<= LARGE_STRING_BYTES
);
1912 nbytes
= SDATA_SIZE (nbytes
);
1913 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1915 #ifdef GC_CHECK_STRING_OVERRUN
1916 if (memcmp (string_overrun_cookie
,
1917 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1918 GC_STRING_OVERRUN_COOKIE_SIZE
))
1922 /* Non-NULL S means it's alive. Copy its data. */
1925 /* If TB is full, proceed with the next sblock. */
1926 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1927 if (to_end
> tb_end
)
1931 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1932 to
= &tb
->first_data
;
1933 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1936 /* Copy, and update the string's `data' pointer. */
1939 eassert (tb
!= b
|| to
< from
);
1940 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1941 to
->string
->data
= SDATA_DATA (to
);
1944 /* Advance past the sdata we copied to. */
1950 /* The rest of the sblocks following TB don't contain live data, so
1951 we can free them. */
1952 for (b
= tb
->next
; b
; b
= next
)
1960 current_sblock
= tb
;
1964 string_overflow (void)
1966 error ("Maximum string size exceeded");
1969 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1970 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1971 LENGTH must be an integer.
1972 INIT must be an integer that represents a character. */)
1973 (Lisp_Object length
, Lisp_Object init
)
1975 register Lisp_Object val
;
1979 CHECK_NATNUM (length
);
1980 CHECK_CHARACTER (init
);
1982 c
= XFASTINT (init
);
1983 if (ASCII_CHAR_P (c
))
1985 nbytes
= XINT (length
);
1986 val
= make_uninit_string (nbytes
);
1987 memset (SDATA (val
), c
, nbytes
);
1988 SDATA (val
)[nbytes
] = 0;
1992 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1993 ptrdiff_t len
= CHAR_STRING (c
, str
);
1994 EMACS_INT string_len
= XINT (length
);
1995 unsigned char *p
, *beg
, *end
;
1997 if (string_len
> STRING_BYTES_MAX
/ len
)
1999 nbytes
= len
* string_len
;
2000 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2001 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2003 /* First time we just copy `str' to the data of `val'. */
2005 memcpy (p
, str
, len
);
2008 /* Next time we copy largest possible chunk from
2009 initialized to uninitialized part of `val'. */
2010 len
= min (p
- beg
, end
- p
);
2011 memcpy (p
, beg
, len
);
2020 verify (sizeof (size_t) * CHAR_BIT
== BITS_PER_BITS_WORD
);
2021 verify ((BITS_PER_BITS_WORD
& (BITS_PER_BITS_WORD
- 1)) == 0);
2024 bool_vector_payload_bytes (ptrdiff_t nr_bits
,
2025 ptrdiff_t *exact_needed_bytes_out
)
2027 ptrdiff_t exact_needed_bytes
;
2028 ptrdiff_t needed_bytes
;
2030 eassume (nr_bits
>= 0);
2032 exact_needed_bytes
= ROUNDUP ((size_t) nr_bits
, CHAR_BIT
) / CHAR_BIT
;
2033 needed_bytes
= ROUNDUP ((size_t) nr_bits
, BITS_PER_BITS_WORD
) / CHAR_BIT
;
2035 if (needed_bytes
== 0)
2037 /* Always allocate at least one machine word of payload so that
2038 bool-vector operations in data.c don't need a special case
2039 for empty vectors. */
2040 needed_bytes
= sizeof (bits_word
);
2043 if (exact_needed_bytes_out
!= NULL
)
2044 *exact_needed_bytes_out
= exact_needed_bytes
;
2046 return needed_bytes
;
2049 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2050 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2051 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2052 (Lisp_Object length
, Lisp_Object init
)
2054 register Lisp_Object val
;
2055 struct Lisp_Bool_Vector
*p
;
2056 ptrdiff_t exact_payload_bytes
;
2057 ptrdiff_t total_payload_bytes
;
2058 ptrdiff_t needed_elements
;
2060 CHECK_NATNUM (length
);
2061 if (PTRDIFF_MAX
< XFASTINT (length
))
2062 memory_full (SIZE_MAX
);
2064 total_payload_bytes
= bool_vector_payload_bytes
2065 (XFASTINT (length
), &exact_payload_bytes
);
2067 eassume (exact_payload_bytes
<= total_payload_bytes
);
2068 eassume (0 <= exact_payload_bytes
);
2070 needed_elements
= ROUNDUP ((size_t) ((bool_header_size
- header_size
)
2071 + total_payload_bytes
),
2072 word_size
) / word_size
;
2074 p
= (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2075 XSETVECTOR (val
, p
);
2076 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2078 p
->size
= XFASTINT (length
);
2079 if (exact_payload_bytes
)
2081 memset (p
->data
, ! NILP (init
) ? -1 : 0, exact_payload_bytes
);
2083 /* Clear any extraneous bits in the last byte. */
2084 p
->data
[exact_payload_bytes
- 1]
2085 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2088 /* Clear padding at the end. */
2089 memset (p
->data
+ exact_payload_bytes
,
2091 total_payload_bytes
- exact_payload_bytes
);
2097 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2098 of characters from the contents. This string may be unibyte or
2099 multibyte, depending on the contents. */
2102 make_string (const char *contents
, ptrdiff_t nbytes
)
2104 register Lisp_Object val
;
2105 ptrdiff_t nchars
, multibyte_nbytes
;
2107 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2108 &nchars
, &multibyte_nbytes
);
2109 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2110 /* CONTENTS contains no multibyte sequences or contains an invalid
2111 multibyte sequence. We must make unibyte string. */
2112 val
= make_unibyte_string (contents
, nbytes
);
2114 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2119 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2122 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2124 register Lisp_Object val
;
2125 val
= make_uninit_string (length
);
2126 memcpy (SDATA (val
), contents
, length
);
2131 /* Make a multibyte string from NCHARS characters occupying NBYTES
2132 bytes at CONTENTS. */
2135 make_multibyte_string (const char *contents
,
2136 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2138 register Lisp_Object val
;
2139 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2140 memcpy (SDATA (val
), contents
, nbytes
);
2145 /* Make a string from NCHARS characters occupying NBYTES bytes at
2146 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2149 make_string_from_bytes (const char *contents
,
2150 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2152 register Lisp_Object val
;
2153 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2154 memcpy (SDATA (val
), contents
, nbytes
);
2155 if (SBYTES (val
) == SCHARS (val
))
2156 STRING_SET_UNIBYTE (val
);
2161 /* Make a string from NCHARS characters occupying NBYTES bytes at
2162 CONTENTS. The argument MULTIBYTE controls whether to label the
2163 string as multibyte. If NCHARS is negative, it counts the number of
2164 characters by itself. */
2167 make_specified_string (const char *contents
,
2168 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2175 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2180 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2181 memcpy (SDATA (val
), contents
, nbytes
);
2183 STRING_SET_UNIBYTE (val
);
2188 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2189 occupying LENGTH bytes. */
2192 make_uninit_string (EMACS_INT length
)
2197 return empty_unibyte_string
;
2198 val
= make_uninit_multibyte_string (length
, length
);
2199 STRING_SET_UNIBYTE (val
);
2204 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2205 which occupy NBYTES bytes. */
2208 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2211 struct Lisp_String
*s
;
2216 return empty_multibyte_string
;
2218 s
= allocate_string ();
2219 s
->intervals
= NULL
;
2220 allocate_string_data (s
, nchars
, nbytes
);
2221 XSETSTRING (string
, s
);
2222 string_chars_consed
+= nbytes
;
2226 /* Print arguments to BUF according to a FORMAT, then return
2227 a Lisp_String initialized with the data from BUF. */
2230 make_formatted_string (char *buf
, const char *format
, ...)
2235 va_start (ap
, format
);
2236 length
= vsprintf (buf
, format
, ap
);
2238 return make_string (buf
, length
);
2242 /***********************************************************************
2244 ***********************************************************************/
2246 /* We store float cells inside of float_blocks, allocating a new
2247 float_block with malloc whenever necessary. Float cells reclaimed
2248 by GC are put on a free list to be reallocated before allocating
2249 any new float cells from the latest float_block. */
2251 #define FLOAT_BLOCK_SIZE \
2252 (((BLOCK_BYTES - sizeof (struct float_block *) \
2253 /* The compiler might add padding at the end. */ \
2254 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2255 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2257 #define GETMARKBIT(block,n) \
2258 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2259 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2262 #define SETMARKBIT(block,n) \
2263 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2264 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2266 #define UNSETMARKBIT(block,n) \
2267 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2268 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2270 #define FLOAT_BLOCK(fptr) \
2271 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2273 #define FLOAT_INDEX(fptr) \
2274 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2278 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2279 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2280 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2281 struct float_block
*next
;
2284 #define FLOAT_MARKED_P(fptr) \
2285 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2287 #define FLOAT_MARK(fptr) \
2288 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2290 #define FLOAT_UNMARK(fptr) \
2291 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2293 /* Current float_block. */
2295 static struct float_block
*float_block
;
2297 /* Index of first unused Lisp_Float in the current float_block. */
2299 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2301 /* Free-list of Lisp_Floats. */
2303 static struct Lisp_Float
*float_free_list
;
2305 /* Return a new float object with value FLOAT_VALUE. */
2308 make_float (double float_value
)
2310 register Lisp_Object val
;
2314 if (float_free_list
)
2316 /* We use the data field for chaining the free list
2317 so that we won't use the same field that has the mark bit. */
2318 XSETFLOAT (val
, float_free_list
);
2319 float_free_list
= float_free_list
->u
.chain
;
2323 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2325 struct float_block
*new
2326 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2327 new->next
= float_block
;
2328 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2330 float_block_index
= 0;
2331 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2333 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2334 float_block_index
++;
2337 MALLOC_UNBLOCK_INPUT
;
2339 XFLOAT_INIT (val
, float_value
);
2340 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2341 consing_since_gc
+= sizeof (struct Lisp_Float
);
2343 total_free_floats
--;
2349 /***********************************************************************
2351 ***********************************************************************/
2353 /* We store cons cells inside of cons_blocks, allocating a new
2354 cons_block with malloc whenever necessary. Cons cells reclaimed by
2355 GC are put on a free list to be reallocated before allocating
2356 any new cons cells from the latest cons_block. */
2358 #define CONS_BLOCK_SIZE \
2359 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2360 /* The compiler might add padding at the end. */ \
2361 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2362 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2364 #define CONS_BLOCK(fptr) \
2365 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2367 #define CONS_INDEX(fptr) \
2368 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2372 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2373 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2374 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2375 struct cons_block
*next
;
2378 #define CONS_MARKED_P(fptr) \
2379 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2381 #define CONS_MARK(fptr) \
2382 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2384 #define CONS_UNMARK(fptr) \
2385 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2387 /* Current cons_block. */
2389 static struct cons_block
*cons_block
;
2391 /* Index of first unused Lisp_Cons in the current block. */
2393 static int cons_block_index
= CONS_BLOCK_SIZE
;
2395 /* Free-list of Lisp_Cons structures. */
2397 static struct Lisp_Cons
*cons_free_list
;
2399 /* Explicitly free a cons cell by putting it on the free-list. */
2402 free_cons (struct Lisp_Cons
*ptr
)
2404 ptr
->u
.chain
= cons_free_list
;
2408 cons_free_list
= ptr
;
2409 consing_since_gc
-= sizeof *ptr
;
2410 total_free_conses
++;
2413 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2414 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2415 (Lisp_Object car
, Lisp_Object cdr
)
2417 register Lisp_Object val
;
2423 /* We use the cdr for chaining the free list
2424 so that we won't use the same field that has the mark bit. */
2425 XSETCONS (val
, cons_free_list
);
2426 cons_free_list
= cons_free_list
->u
.chain
;
2430 if (cons_block_index
== CONS_BLOCK_SIZE
)
2432 struct cons_block
*new
2433 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2434 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2435 new->next
= cons_block
;
2437 cons_block_index
= 0;
2438 total_free_conses
+= CONS_BLOCK_SIZE
;
2440 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2444 MALLOC_UNBLOCK_INPUT
;
2448 eassert (!CONS_MARKED_P (XCONS (val
)));
2449 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2450 total_free_conses
--;
2451 cons_cells_consed
++;
2455 #ifdef GC_CHECK_CONS_LIST
2456 /* Get an error now if there's any junk in the cons free list. */
2458 check_cons_list (void)
2460 struct Lisp_Cons
*tail
= cons_free_list
;
2463 tail
= tail
->u
.chain
;
2467 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2470 list1 (Lisp_Object arg1
)
2472 return Fcons (arg1
, Qnil
);
2476 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2478 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2483 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2485 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2490 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2492 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2497 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2499 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2500 Fcons (arg5
, Qnil
)))));
2503 /* Make a list of COUNT Lisp_Objects, where ARG is the
2504 first one. Allocate conses from pure space if TYPE
2505 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2508 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2512 Lisp_Object val
, *objp
;
2514 /* Change to SAFE_ALLOCA if you hit this eassert. */
2515 eassert (count
<= MAX_ALLOCA
/ word_size
);
2517 objp
= alloca (count
* word_size
);
2520 for (i
= 1; i
< count
; i
++)
2521 objp
[i
] = va_arg (ap
, Lisp_Object
);
2524 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2526 if (type
== CONSTYPE_PURE
)
2527 val
= pure_cons (objp
[i
], val
);
2528 else if (type
== CONSTYPE_HEAP
)
2529 val
= Fcons (objp
[i
], val
);
2536 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2537 doc
: /* Return a newly created list with specified arguments as elements.
2538 Any number of arguments, even zero arguments, are allowed.
2539 usage: (list &rest OBJECTS) */)
2540 (ptrdiff_t nargs
, Lisp_Object
*args
)
2542 register Lisp_Object val
;
2548 val
= Fcons (args
[nargs
], val
);
2554 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2555 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2556 (register Lisp_Object length
, Lisp_Object init
)
2558 register Lisp_Object val
;
2559 register EMACS_INT size
;
2561 CHECK_NATNUM (length
);
2562 size
= XFASTINT (length
);
2567 val
= Fcons (init
, val
);
2572 val
= Fcons (init
, val
);
2577 val
= Fcons (init
, val
);
2582 val
= Fcons (init
, val
);
2587 val
= Fcons (init
, val
);
2602 /***********************************************************************
2604 ***********************************************************************/
2606 /* This value is balanced well enough to avoid too much internal overhead
2607 for the most common cases; it's not required to be a power of two, but
2608 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2610 #define VECTOR_BLOCK_SIZE 4096
2612 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2615 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2618 /* Verify assumptions described above. */
2619 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2620 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2622 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2623 #define vroundup_ct(x) ROUNDUP ((size_t) (x), roundup_size)
2624 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2625 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2627 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2629 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2631 /* Size of the minimal vector allocated from block. */
2633 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2635 /* Size of the largest vector allocated from block. */
2637 #define VBLOCK_BYTES_MAX \
2638 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2640 /* We maintain one free list for each possible block-allocated
2641 vector size, and this is the number of free lists we have. */
2643 #define VECTOR_MAX_FREE_LIST_INDEX \
2644 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2646 /* Common shortcut to advance vector pointer over a block data. */
2648 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2650 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2652 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2654 /* Common shortcut to setup vector on a free list. */
2656 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2658 (tmp) = ((nbytes - header_size) / word_size); \
2659 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2660 eassert ((nbytes) % roundup_size == 0); \
2661 (tmp) = VINDEX (nbytes); \
2662 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2663 v->u.next = vector_free_lists[tmp]; \
2664 vector_free_lists[tmp] = (v); \
2665 total_free_vector_slots += (nbytes) / word_size; \
2668 /* This internal type is used to maintain the list of large vectors
2669 which are allocated at their own, e.g. outside of vector blocks. */
2674 struct large_vector
*vector
;
2676 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2677 unsigned char c
[vroundup_ct (sizeof (struct large_vector
*))];
2680 struct Lisp_Vector v
;
2683 /* This internal type is used to maintain an underlying storage
2684 for small vectors. */
2688 char data
[VECTOR_BLOCK_BYTES
];
2689 struct vector_block
*next
;
2692 /* Chain of vector blocks. */
2694 static struct vector_block
*vector_blocks
;
2696 /* Vector free lists, where NTH item points to a chain of free
2697 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2699 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2701 /* Singly-linked list of large vectors. */
2703 static struct large_vector
*large_vectors
;
2705 /* The only vector with 0 slots, allocated from pure space. */
2707 Lisp_Object zero_vector
;
2709 /* Number of live vectors. */
2711 static EMACS_INT total_vectors
;
2713 /* Total size of live and free vectors, in Lisp_Object units. */
2715 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2717 /* Get a new vector block. */
2719 static struct vector_block
*
2720 allocate_vector_block (void)
2722 struct vector_block
*block
= xmalloc (sizeof *block
);
2724 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2725 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2726 MEM_TYPE_VECTOR_BLOCK
);
2729 block
->next
= vector_blocks
;
2730 vector_blocks
= block
;
2734 /* Called once to initialize vector allocation. */
2739 zero_vector
= make_pure_vector (0);
2742 /* Allocate vector from a vector block. */
2744 static struct Lisp_Vector
*
2745 allocate_vector_from_block (size_t nbytes
)
2747 struct Lisp_Vector
*vector
;
2748 struct vector_block
*block
;
2749 size_t index
, restbytes
;
2751 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2752 eassert (nbytes
% roundup_size
== 0);
2754 /* First, try to allocate from a free list
2755 containing vectors of the requested size. */
2756 index
= VINDEX (nbytes
);
2757 if (vector_free_lists
[index
])
2759 vector
= vector_free_lists
[index
];
2760 vector_free_lists
[index
] = vector
->u
.next
;
2761 total_free_vector_slots
-= nbytes
/ word_size
;
2765 /* Next, check free lists containing larger vectors. Since
2766 we will split the result, we should have remaining space
2767 large enough to use for one-slot vector at least. */
2768 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2769 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2770 if (vector_free_lists
[index
])
2772 /* This vector is larger than requested. */
2773 vector
= vector_free_lists
[index
];
2774 vector_free_lists
[index
] = vector
->u
.next
;
2775 total_free_vector_slots
-= nbytes
/ word_size
;
2777 /* Excess bytes are used for the smaller vector,
2778 which should be set on an appropriate free list. */
2779 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2780 eassert (restbytes
% roundup_size
== 0);
2781 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2785 /* Finally, need a new vector block. */
2786 block
= allocate_vector_block ();
2788 /* New vector will be at the beginning of this block. */
2789 vector
= (struct Lisp_Vector
*) block
->data
;
2791 /* If the rest of space from this block is large enough
2792 for one-slot vector at least, set up it on a free list. */
2793 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2794 if (restbytes
>= VBLOCK_BYTES_MIN
)
2796 eassert (restbytes
% roundup_size
== 0);
2797 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2802 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2804 #define VECTOR_IN_BLOCK(vector, block) \
2805 ((char *) (vector) <= (block)->data \
2806 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2808 /* Return the memory footprint of V in bytes. */
2811 vector_nbytes (struct Lisp_Vector
*v
)
2813 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2815 if (size
& PSEUDOVECTOR_FLAG
)
2817 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2819 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
2820 ptrdiff_t payload_bytes
=
2821 bool_vector_payload_bytes (bv
->size
, NULL
);
2823 eassume (payload_bytes
>= 0);
2824 size
= bool_header_size
+ ROUNDUP (payload_bytes
, word_size
);
2828 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2829 + ((size
& PSEUDOVECTOR_REST_MASK
)
2830 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2833 size
= header_size
+ size
* word_size
;
2834 return vroundup (size
);
2837 /* Reclaim space used by unmarked vectors. */
2840 sweep_vectors (void)
2842 struct vector_block
*block
, **bprev
= &vector_blocks
;
2843 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2844 struct Lisp_Vector
*vector
, *next
;
2846 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2847 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2849 /* Looking through vector blocks. */
2851 for (block
= vector_blocks
; block
; block
= *bprev
)
2853 bool free_this_block
= 0;
2856 for (vector
= (struct Lisp_Vector
*) block
->data
;
2857 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2859 if (VECTOR_MARKED_P (vector
))
2861 VECTOR_UNMARK (vector
);
2863 nbytes
= vector_nbytes (vector
);
2864 total_vector_slots
+= nbytes
/ word_size
;
2865 next
= ADVANCE (vector
, nbytes
);
2869 ptrdiff_t total_bytes
;
2871 nbytes
= vector_nbytes (vector
);
2872 total_bytes
= nbytes
;
2873 next
= ADVANCE (vector
, nbytes
);
2875 /* While NEXT is not marked, try to coalesce with VECTOR,
2876 thus making VECTOR of the largest possible size. */
2878 while (VECTOR_IN_BLOCK (next
, block
))
2880 if (VECTOR_MARKED_P (next
))
2882 nbytes
= vector_nbytes (next
);
2883 total_bytes
+= nbytes
;
2884 next
= ADVANCE (next
, nbytes
);
2887 eassert (total_bytes
% roundup_size
== 0);
2889 if (vector
== (struct Lisp_Vector
*) block
->data
2890 && !VECTOR_IN_BLOCK (next
, block
))
2891 /* This block should be freed because all of it's
2892 space was coalesced into the only free vector. */
2893 free_this_block
= 1;
2897 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2902 if (free_this_block
)
2904 *bprev
= block
->next
;
2905 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2906 mem_delete (mem_find (block
->data
));
2911 bprev
= &block
->next
;
2914 /* Sweep large vectors. */
2916 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2919 if (VECTOR_MARKED_P (vector
))
2921 VECTOR_UNMARK (vector
);
2923 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2925 /* All non-bool pseudovectors are small enough to be allocated
2926 from vector blocks. This code should be redesigned if some
2927 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2928 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2929 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
2933 += header_size
/ word_size
+ vector
->header
.size
;
2934 lvprev
= &lv
->next
.vector
;
2938 *lvprev
= lv
->next
.vector
;
2944 /* Value is a pointer to a newly allocated Lisp_Vector structure
2945 with room for LEN Lisp_Objects. */
2947 static struct Lisp_Vector
*
2948 allocate_vectorlike (ptrdiff_t len
)
2950 struct Lisp_Vector
*p
;
2955 p
= XVECTOR (zero_vector
);
2958 size_t nbytes
= header_size
+ len
* word_size
;
2960 #ifdef DOUG_LEA_MALLOC
2961 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2962 because mapped region contents are not preserved in
2964 mallopt (M_MMAP_MAX
, 0);
2967 if (nbytes
<= VBLOCK_BYTES_MAX
)
2968 p
= allocate_vector_from_block (vroundup (nbytes
));
2971 struct large_vector
*lv
2972 = lisp_malloc ((offsetof (struct large_vector
, v
.u
.contents
)
2974 MEM_TYPE_VECTORLIKE
);
2975 lv
->next
.vector
= large_vectors
;
2980 #ifdef DOUG_LEA_MALLOC
2981 /* Back to a reasonable maximum of mmap'ed areas. */
2982 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2985 consing_since_gc
+= nbytes
;
2986 vector_cells_consed
+= len
;
2989 MALLOC_UNBLOCK_INPUT
;
2995 /* Allocate a vector with LEN slots. */
2997 struct Lisp_Vector
*
2998 allocate_vector (EMACS_INT len
)
3000 struct Lisp_Vector
*v
;
3001 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3003 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3004 memory_full (SIZE_MAX
);
3005 v
= allocate_vectorlike (len
);
3006 v
->header
.size
= len
;
3011 /* Allocate other vector-like structures. */
3013 struct Lisp_Vector
*
3014 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3016 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3019 /* Catch bogus values. */
3020 eassert (tag
<= PVEC_FONT
);
3021 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3022 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3024 /* Only the first lisplen slots will be traced normally by the GC. */
3025 for (i
= 0; i
< lisplen
; ++i
)
3026 v
->u
.contents
[i
] = Qnil
;
3028 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3033 allocate_buffer (void)
3035 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3037 BUFFER_PVEC_INIT (b
);
3038 /* Put B on the chain of all buffers including killed ones. */
3039 b
->next
= all_buffers
;
3041 /* Note that the rest fields of B are not initialized. */
3045 struct Lisp_Hash_Table
*
3046 allocate_hash_table (void)
3048 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3052 allocate_window (void)
3056 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3057 /* Users assumes that non-Lisp data is zeroed. */
3058 memset (&w
->current_matrix
, 0,
3059 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3064 allocate_terminal (void)
3068 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3069 /* Users assumes that non-Lisp data is zeroed. */
3070 memset (&t
->next_terminal
, 0,
3071 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3076 allocate_frame (void)
3080 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3081 /* Users assumes that non-Lisp data is zeroed. */
3082 memset (&f
->face_cache
, 0,
3083 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3087 struct Lisp_Process
*
3088 allocate_process (void)
3090 struct Lisp_Process
*p
;
3092 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3093 /* Users assumes that non-Lisp data is zeroed. */
3095 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3099 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3100 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3101 See also the function `vector'. */)
3102 (register Lisp_Object length
, Lisp_Object init
)
3105 register ptrdiff_t sizei
;
3106 register ptrdiff_t i
;
3107 register struct Lisp_Vector
*p
;
3109 CHECK_NATNUM (length
);
3111 p
= allocate_vector (XFASTINT (length
));
3112 sizei
= XFASTINT (length
);
3113 for (i
= 0; i
< sizei
; i
++)
3114 p
->u
.contents
[i
] = init
;
3116 XSETVECTOR (vector
, p
);
3121 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3122 doc
: /* Return a newly created vector with specified arguments as elements.
3123 Any number of arguments, even zero arguments, are allowed.
3124 usage: (vector &rest OBJECTS) */)
3125 (ptrdiff_t nargs
, Lisp_Object
*args
)
3128 register Lisp_Object val
= make_uninit_vector (nargs
);
3129 register struct Lisp_Vector
*p
= XVECTOR (val
);
3131 for (i
= 0; i
< nargs
; i
++)
3132 p
->u
.contents
[i
] = args
[i
];
3137 make_byte_code (struct Lisp_Vector
*v
)
3139 /* Don't allow the global zero_vector to become a byte code object. */
3140 eassert(0 < v
->header
.size
);
3141 if (v
->header
.size
> 1 && STRINGP (v
->u
.contents
[1])
3142 && STRING_MULTIBYTE (v
->u
.contents
[1]))
3143 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3144 earlier because they produced a raw 8-bit string for byte-code
3145 and now such a byte-code string is loaded as multibyte while
3146 raw 8-bit characters converted to multibyte form. Thus, now we
3147 must convert them back to the original unibyte form. */
3148 v
->u
.contents
[1] = Fstring_as_unibyte (v
->u
.contents
[1]);
3149 XSETPVECTYPE (v
, PVEC_COMPILED
);
3152 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3153 doc
: /* Create a byte-code object with specified arguments as elements.
3154 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3155 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3156 and (optional) INTERACTIVE-SPEC.
3157 The first four arguments are required; at most six have any
3159 The ARGLIST can be either like the one of `lambda', in which case the arguments
3160 will be dynamically bound before executing the byte code, or it can be an
3161 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3162 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3163 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3164 argument to catch the left-over arguments. If such an integer is used, the
3165 arguments will not be dynamically bound but will be instead pushed on the
3166 stack before executing the byte-code.
3167 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3168 (ptrdiff_t nargs
, Lisp_Object
*args
)
3171 register Lisp_Object val
= make_uninit_vector (nargs
);
3172 register struct Lisp_Vector
*p
= XVECTOR (val
);
3174 /* We used to purecopy everything here, if purify-flag was set. This worked
3175 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3176 dangerous, since make-byte-code is used during execution to build
3177 closures, so any closure built during the preload phase would end up
3178 copied into pure space, including its free variables, which is sometimes
3179 just wasteful and other times plainly wrong (e.g. those free vars may want
3182 for (i
= 0; i
< nargs
; i
++)
3183 p
->u
.contents
[i
] = args
[i
];
3185 XSETCOMPILED (val
, p
);
3191 /***********************************************************************
3193 ***********************************************************************/
3195 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3196 of the required alignment if LSB tags are used. */
3198 union aligned_Lisp_Symbol
3200 struct Lisp_Symbol s
;
3202 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3207 /* Each symbol_block is just under 1020 bytes long, since malloc
3208 really allocates in units of powers of two and uses 4 bytes for its
3211 #define SYMBOL_BLOCK_SIZE \
3212 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3216 /* Place `symbols' first, to preserve alignment. */
3217 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3218 struct symbol_block
*next
;
3221 /* Current symbol block and index of first unused Lisp_Symbol
3224 static struct symbol_block
*symbol_block
;
3225 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3227 /* List of free symbols. */
3229 static struct Lisp_Symbol
*symbol_free_list
;
3232 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3234 XSYMBOL (sym
)->name
= name
;
3237 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3238 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3239 Its value is void, and its function definition and property list are nil. */)
3242 register Lisp_Object val
;
3243 register struct Lisp_Symbol
*p
;
3245 CHECK_STRING (name
);
3249 if (symbol_free_list
)
3251 XSETSYMBOL (val
, symbol_free_list
);
3252 symbol_free_list
= symbol_free_list
->next
;
3256 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3258 struct symbol_block
*new
3259 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3260 new->next
= symbol_block
;
3262 symbol_block_index
= 0;
3263 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3265 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3266 symbol_block_index
++;
3269 MALLOC_UNBLOCK_INPUT
;
3272 set_symbol_name (val
, name
);
3273 set_symbol_plist (val
, Qnil
);
3274 p
->redirect
= SYMBOL_PLAINVAL
;
3275 SET_SYMBOL_VAL (p
, Qunbound
);
3276 set_symbol_function (val
, Qnil
);
3277 set_symbol_next (val
, NULL
);
3279 p
->interned
= SYMBOL_UNINTERNED
;
3281 p
->declared_special
= 0;
3282 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3284 total_free_symbols
--;
3290 /***********************************************************************
3291 Marker (Misc) Allocation
3292 ***********************************************************************/
3294 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3295 the required alignment when LSB tags are used. */
3297 union aligned_Lisp_Misc
3301 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3306 /* Allocation of markers and other objects that share that structure.
3307 Works like allocation of conses. */
3309 #define MARKER_BLOCK_SIZE \
3310 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3314 /* Place `markers' first, to preserve alignment. */
3315 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3316 struct marker_block
*next
;
3319 static struct marker_block
*marker_block
;
3320 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3322 static union Lisp_Misc
*marker_free_list
;
3324 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3327 allocate_misc (enum Lisp_Misc_Type type
)
3333 if (marker_free_list
)
3335 XSETMISC (val
, marker_free_list
);
3336 marker_free_list
= marker_free_list
->u_free
.chain
;
3340 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3342 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3343 new->next
= marker_block
;
3345 marker_block_index
= 0;
3346 total_free_markers
+= MARKER_BLOCK_SIZE
;
3348 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3349 marker_block_index
++;
3352 MALLOC_UNBLOCK_INPUT
;
3354 --total_free_markers
;
3355 consing_since_gc
+= sizeof (union Lisp_Misc
);
3356 misc_objects_consed
++;
3357 XMISCANY (val
)->type
= type
;
3358 XMISCANY (val
)->gcmarkbit
= 0;
3362 /* Free a Lisp_Misc object. */
3365 free_misc (Lisp_Object misc
)
3367 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3368 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3369 marker_free_list
= XMISC (misc
);
3370 consing_since_gc
-= sizeof (union Lisp_Misc
);
3371 total_free_markers
++;
3374 /* Verify properties of Lisp_Save_Value's representation
3375 that are assumed here and elsewhere. */
3377 verify (SAVE_UNUSED
== 0);
3378 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3382 /* Return Lisp_Save_Value objects for the various combinations
3383 that callers need. */
3386 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3388 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3389 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3390 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3391 p
->data
[0].integer
= a
;
3392 p
->data
[1].integer
= b
;
3393 p
->data
[2].integer
= c
;
3398 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3401 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3402 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3403 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3404 p
->data
[0].object
= a
;
3405 p
->data
[1].object
= b
;
3406 p
->data
[2].object
= c
;
3407 p
->data
[3].object
= d
;
3412 make_save_ptr (void *a
)
3414 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3415 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3416 p
->save_type
= SAVE_POINTER
;
3417 p
->data
[0].pointer
= a
;
3422 make_save_ptr_int (void *a
, ptrdiff_t b
)
3424 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3425 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3426 p
->save_type
= SAVE_TYPE_PTR_INT
;
3427 p
->data
[0].pointer
= a
;
3428 p
->data
[1].integer
= b
;
3432 #if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3434 make_save_ptr_ptr (void *a
, void *b
)
3436 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3437 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3438 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3439 p
->data
[0].pointer
= a
;
3440 p
->data
[1].pointer
= b
;
3446 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object 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_FUNCPTR_PTR_OBJ
;
3451 p
->data
[0].funcpointer
= a
;
3452 p
->data
[1].pointer
= b
;
3453 p
->data
[2].object
= c
;
3457 /* Return a Lisp_Save_Value object that represents an array A
3458 of N Lisp objects. */
3461 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3463 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3464 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3465 p
->save_type
= SAVE_TYPE_MEMORY
;
3466 p
->data
[0].pointer
= a
;
3467 p
->data
[1].integer
= n
;
3471 /* Free a Lisp_Save_Value object. Do not use this function
3472 if SAVE contains pointer other than returned by xmalloc. */
3475 free_save_value (Lisp_Object save
)
3477 xfree (XSAVE_POINTER (save
, 0));
3481 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3484 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3486 register Lisp_Object overlay
;
3488 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3489 OVERLAY_START (overlay
) = start
;
3490 OVERLAY_END (overlay
) = end
;
3491 set_overlay_plist (overlay
, plist
);
3492 XOVERLAY (overlay
)->next
= NULL
;
3496 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3497 doc
: /* Return a newly allocated marker which does not point at any place. */)
3500 register Lisp_Object val
;
3501 register struct Lisp_Marker
*p
;
3503 val
= allocate_misc (Lisp_Misc_Marker
);
3509 p
->insertion_type
= 0;
3510 p
->need_adjustment
= 0;
3514 /* Return a newly allocated marker which points into BUF
3515 at character position CHARPOS and byte position BYTEPOS. */
3518 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3521 struct Lisp_Marker
*m
;
3523 /* No dead buffers here. */
3524 eassert (BUFFER_LIVE_P (buf
));
3526 /* Every character is at least one byte. */
3527 eassert (charpos
<= bytepos
);
3529 obj
= allocate_misc (Lisp_Misc_Marker
);
3532 m
->charpos
= charpos
;
3533 m
->bytepos
= bytepos
;
3534 m
->insertion_type
= 0;
3535 m
->need_adjustment
= 0;
3536 m
->next
= BUF_MARKERS (buf
);
3537 BUF_MARKERS (buf
) = m
;
3541 /* Put MARKER back on the free list after using it temporarily. */
3544 free_marker (Lisp_Object marker
)
3546 unchain_marker (XMARKER (marker
));
3551 /* Return a newly created vector or string with specified arguments as
3552 elements. If all the arguments are characters that can fit
3553 in a string of events, make a string; otherwise, make a vector.
3555 Any number of arguments, even zero arguments, are allowed. */
3558 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3562 for (i
= 0; i
< nargs
; i
++)
3563 /* The things that fit in a string
3564 are characters that are in 0...127,
3565 after discarding the meta bit and all the bits above it. */
3566 if (!INTEGERP (args
[i
])
3567 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3568 return Fvector (nargs
, args
);
3570 /* Since the loop exited, we know that all the things in it are
3571 characters, so we can make a string. */
3575 result
= Fmake_string (make_number (nargs
), make_number (0));
3576 for (i
= 0; i
< nargs
; i
++)
3578 SSET (result
, i
, XINT (args
[i
]));
3579 /* Move the meta bit to the right place for a string char. */
3580 if (XINT (args
[i
]) & CHAR_META
)
3581 SSET (result
, i
, SREF (result
, i
) | 0x80);
3590 /************************************************************************
3591 Memory Full Handling
3592 ************************************************************************/
3595 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3596 there may have been size_t overflow so that malloc was never
3597 called, or perhaps malloc was invoked successfully but the
3598 resulting pointer had problems fitting into a tagged EMACS_INT. In
3599 either case this counts as memory being full even though malloc did
3603 memory_full (size_t nbytes
)
3605 /* Do not go into hysterics merely because a large request failed. */
3606 bool enough_free_memory
= 0;
3607 if (SPARE_MEMORY
< nbytes
)
3612 p
= malloc (SPARE_MEMORY
);
3616 enough_free_memory
= 1;
3618 MALLOC_UNBLOCK_INPUT
;
3621 if (! enough_free_memory
)
3627 memory_full_cons_threshold
= sizeof (struct cons_block
);
3629 /* The first time we get here, free the spare memory. */
3630 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3631 if (spare_memory
[i
])
3634 free (spare_memory
[i
]);
3635 else if (i
>= 1 && i
<= 4)
3636 lisp_align_free (spare_memory
[i
]);
3638 lisp_free (spare_memory
[i
]);
3639 spare_memory
[i
] = 0;
3643 /* This used to call error, but if we've run out of memory, we could
3644 get infinite recursion trying to build the string. */
3645 xsignal (Qnil
, Vmemory_signal_data
);
3648 /* If we released our reserve (due to running out of memory),
3649 and we have a fair amount free once again,
3650 try to set aside another reserve in case we run out once more.
3652 This is called when a relocatable block is freed in ralloc.c,
3653 and also directly from this file, in case we're not using ralloc.c. */
3656 refill_memory_reserve (void)
3658 #ifndef SYSTEM_MALLOC
3659 if (spare_memory
[0] == 0)
3660 spare_memory
[0] = malloc (SPARE_MEMORY
);
3661 if (spare_memory
[1] == 0)
3662 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3664 if (spare_memory
[2] == 0)
3665 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3667 if (spare_memory
[3] == 0)
3668 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3670 if (spare_memory
[4] == 0)
3671 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3673 if (spare_memory
[5] == 0)
3674 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3676 if (spare_memory
[6] == 0)
3677 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3679 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3680 Vmemory_full
= Qnil
;
3684 /************************************************************************
3686 ************************************************************************/
3688 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3690 /* Conservative C stack marking requires a method to identify possibly
3691 live Lisp objects given a pointer value. We do this by keeping
3692 track of blocks of Lisp data that are allocated in a red-black tree
3693 (see also the comment of mem_node which is the type of nodes in
3694 that tree). Function lisp_malloc adds information for an allocated
3695 block to the red-black tree with calls to mem_insert, and function
3696 lisp_free removes it with mem_delete. Functions live_string_p etc
3697 call mem_find to lookup information about a given pointer in the
3698 tree, and use that to determine if the pointer points to a Lisp
3701 /* Initialize this part of alloc.c. */
3706 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3707 mem_z
.parent
= NULL
;
3708 mem_z
.color
= MEM_BLACK
;
3709 mem_z
.start
= mem_z
.end
= NULL
;
3714 /* Value is a pointer to the mem_node containing START. Value is
3715 MEM_NIL if there is no node in the tree containing START. */
3717 static struct mem_node
*
3718 mem_find (void *start
)
3722 if (start
< min_heap_address
|| start
> max_heap_address
)
3725 /* Make the search always successful to speed up the loop below. */
3726 mem_z
.start
= start
;
3727 mem_z
.end
= (char *) start
+ 1;
3730 while (start
< p
->start
|| start
>= p
->end
)
3731 p
= start
< p
->start
? p
->left
: p
->right
;
3736 /* Insert a new node into the tree for a block of memory with start
3737 address START, end address END, and type TYPE. Value is a
3738 pointer to the node that was inserted. */
3740 static struct mem_node
*
3741 mem_insert (void *start
, void *end
, enum mem_type type
)
3743 struct mem_node
*c
, *parent
, *x
;
3745 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3746 min_heap_address
= start
;
3747 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3748 max_heap_address
= end
;
3750 /* See where in the tree a node for START belongs. In this
3751 particular application, it shouldn't happen that a node is already
3752 present. For debugging purposes, let's check that. */
3756 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3758 while (c
!= MEM_NIL
)
3760 if (start
>= c
->start
&& start
< c
->end
)
3763 c
= start
< c
->start
? c
->left
: c
->right
;
3766 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3768 while (c
!= MEM_NIL
)
3771 c
= start
< c
->start
? c
->left
: c
->right
;
3774 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3776 /* Create a new node. */
3777 #ifdef GC_MALLOC_CHECK
3778 x
= malloc (sizeof *x
);
3782 x
= xmalloc (sizeof *x
);
3788 x
->left
= x
->right
= MEM_NIL
;
3791 /* Insert it as child of PARENT or install it as root. */
3794 if (start
< parent
->start
)
3802 /* Re-establish red-black tree properties. */
3803 mem_insert_fixup (x
);
3809 /* Re-establish the red-black properties of the tree, and thereby
3810 balance the tree, after node X has been inserted; X is always red. */
3813 mem_insert_fixup (struct mem_node
*x
)
3815 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3817 /* X is red and its parent is red. This is a violation of
3818 red-black tree property #3. */
3820 if (x
->parent
== x
->parent
->parent
->left
)
3822 /* We're on the left side of our grandparent, and Y is our
3824 struct mem_node
*y
= x
->parent
->parent
->right
;
3826 if (y
->color
== MEM_RED
)
3828 /* Uncle and parent are red but should be black because
3829 X is red. Change the colors accordingly and proceed
3830 with the grandparent. */
3831 x
->parent
->color
= MEM_BLACK
;
3832 y
->color
= MEM_BLACK
;
3833 x
->parent
->parent
->color
= MEM_RED
;
3834 x
= x
->parent
->parent
;
3838 /* Parent and uncle have different colors; parent is
3839 red, uncle is black. */
3840 if (x
== x
->parent
->right
)
3843 mem_rotate_left (x
);
3846 x
->parent
->color
= MEM_BLACK
;
3847 x
->parent
->parent
->color
= MEM_RED
;
3848 mem_rotate_right (x
->parent
->parent
);
3853 /* This is the symmetrical case of above. */
3854 struct mem_node
*y
= x
->parent
->parent
->left
;
3856 if (y
->color
== MEM_RED
)
3858 x
->parent
->color
= MEM_BLACK
;
3859 y
->color
= MEM_BLACK
;
3860 x
->parent
->parent
->color
= MEM_RED
;
3861 x
= x
->parent
->parent
;
3865 if (x
== x
->parent
->left
)
3868 mem_rotate_right (x
);
3871 x
->parent
->color
= MEM_BLACK
;
3872 x
->parent
->parent
->color
= MEM_RED
;
3873 mem_rotate_left (x
->parent
->parent
);
3878 /* The root may have been changed to red due to the algorithm. Set
3879 it to black so that property #5 is satisfied. */
3880 mem_root
->color
= MEM_BLACK
;
3891 mem_rotate_left (struct mem_node
*x
)
3895 /* Turn y's left sub-tree into x's right sub-tree. */
3898 if (y
->left
!= MEM_NIL
)
3899 y
->left
->parent
= x
;
3901 /* Y's parent was x's parent. */
3903 y
->parent
= x
->parent
;
3905 /* Get the parent to point to y instead of x. */
3908 if (x
== x
->parent
->left
)
3909 x
->parent
->left
= y
;
3911 x
->parent
->right
= y
;
3916 /* Put x on y's left. */
3930 mem_rotate_right (struct mem_node
*x
)
3932 struct mem_node
*y
= x
->left
;
3935 if (y
->right
!= MEM_NIL
)
3936 y
->right
->parent
= x
;
3939 y
->parent
= x
->parent
;
3942 if (x
== x
->parent
->right
)
3943 x
->parent
->right
= y
;
3945 x
->parent
->left
= y
;
3956 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3959 mem_delete (struct mem_node
*z
)
3961 struct mem_node
*x
, *y
;
3963 if (!z
|| z
== MEM_NIL
)
3966 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3971 while (y
->left
!= MEM_NIL
)
3975 if (y
->left
!= MEM_NIL
)
3980 x
->parent
= y
->parent
;
3983 if (y
== y
->parent
->left
)
3984 y
->parent
->left
= x
;
3986 y
->parent
->right
= x
;
3993 z
->start
= y
->start
;
3998 if (y
->color
== MEM_BLACK
)
3999 mem_delete_fixup (x
);
4001 #ifdef GC_MALLOC_CHECK
4009 /* Re-establish the red-black properties of the tree, after a
4013 mem_delete_fixup (struct mem_node
*x
)
4015 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4017 if (x
== x
->parent
->left
)
4019 struct mem_node
*w
= x
->parent
->right
;
4021 if (w
->color
== MEM_RED
)
4023 w
->color
= MEM_BLACK
;
4024 x
->parent
->color
= MEM_RED
;
4025 mem_rotate_left (x
->parent
);
4026 w
= x
->parent
->right
;
4029 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4036 if (w
->right
->color
== MEM_BLACK
)
4038 w
->left
->color
= MEM_BLACK
;
4040 mem_rotate_right (w
);
4041 w
= x
->parent
->right
;
4043 w
->color
= x
->parent
->color
;
4044 x
->parent
->color
= MEM_BLACK
;
4045 w
->right
->color
= MEM_BLACK
;
4046 mem_rotate_left (x
->parent
);
4052 struct mem_node
*w
= x
->parent
->left
;
4054 if (w
->color
== MEM_RED
)
4056 w
->color
= MEM_BLACK
;
4057 x
->parent
->color
= MEM_RED
;
4058 mem_rotate_right (x
->parent
);
4059 w
= x
->parent
->left
;
4062 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4069 if (w
->left
->color
== MEM_BLACK
)
4071 w
->right
->color
= MEM_BLACK
;
4073 mem_rotate_left (w
);
4074 w
= x
->parent
->left
;
4077 w
->color
= x
->parent
->color
;
4078 x
->parent
->color
= MEM_BLACK
;
4079 w
->left
->color
= MEM_BLACK
;
4080 mem_rotate_right (x
->parent
);
4086 x
->color
= MEM_BLACK
;
4090 /* Value is non-zero if P is a pointer to a live Lisp string on
4091 the heap. M is a pointer to the mem_block for P. */
4094 live_string_p (struct mem_node
*m
, void *p
)
4096 if (m
->type
== MEM_TYPE_STRING
)
4098 struct string_block
*b
= m
->start
;
4099 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4101 /* P must point to the start of a Lisp_String structure, and it
4102 must not be on the free-list. */
4104 && offset
% sizeof b
->strings
[0] == 0
4105 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4106 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4113 /* Value is non-zero if P is a pointer to a live Lisp cons on
4114 the heap. M is a pointer to the mem_block for P. */
4117 live_cons_p (struct mem_node
*m
, void *p
)
4119 if (m
->type
== MEM_TYPE_CONS
)
4121 struct cons_block
*b
= m
->start
;
4122 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4124 /* P must point to the start of a Lisp_Cons, not be
4125 one of the unused cells in the current cons block,
4126 and not be on the free-list. */
4128 && offset
% sizeof b
->conses
[0] == 0
4129 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4131 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4132 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4139 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4140 the heap. M is a pointer to the mem_block for P. */
4143 live_symbol_p (struct mem_node
*m
, void *p
)
4145 if (m
->type
== MEM_TYPE_SYMBOL
)
4147 struct symbol_block
*b
= m
->start
;
4148 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4150 /* P must point to the start of a Lisp_Symbol, not be
4151 one of the unused cells in the current symbol block,
4152 and not be on the free-list. */
4154 && offset
% sizeof b
->symbols
[0] == 0
4155 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4156 && (b
!= symbol_block
4157 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4158 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4165 /* Value is non-zero if P is a pointer to a live Lisp float on
4166 the heap. M is a pointer to the mem_block for P. */
4169 live_float_p (struct mem_node
*m
, void *p
)
4171 if (m
->type
== MEM_TYPE_FLOAT
)
4173 struct float_block
*b
= m
->start
;
4174 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4176 /* P must point to the start of a Lisp_Float and not be
4177 one of the unused cells in the current float block. */
4179 && offset
% sizeof b
->floats
[0] == 0
4180 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4181 && (b
!= float_block
4182 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4189 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4190 the heap. M is a pointer to the mem_block for P. */
4193 live_misc_p (struct mem_node
*m
, void *p
)
4195 if (m
->type
== MEM_TYPE_MISC
)
4197 struct marker_block
*b
= m
->start
;
4198 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4200 /* P must point to the start of a Lisp_Misc, not be
4201 one of the unused cells in the current misc block,
4202 and not be on the free-list. */
4204 && offset
% sizeof b
->markers
[0] == 0
4205 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4206 && (b
!= marker_block
4207 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4208 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4215 /* Value is non-zero if P is a pointer to a live vector-like object.
4216 M is a pointer to the mem_block for P. */
4219 live_vector_p (struct mem_node
*m
, void *p
)
4221 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4223 /* This memory node corresponds to a vector block. */
4224 struct vector_block
*block
= m
->start
;
4225 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4227 /* P is in the block's allocation range. Scan the block
4228 up to P and see whether P points to the start of some
4229 vector which is not on a free list. FIXME: check whether
4230 some allocation patterns (probably a lot of short vectors)
4231 may cause a substantial overhead of this loop. */
4232 while (VECTOR_IN_BLOCK (vector
, block
)
4233 && vector
<= (struct Lisp_Vector
*) p
)
4235 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4238 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4241 else if (m
->type
== MEM_TYPE_VECTORLIKE
4242 && (char *) p
== ((char *) m
->start
4243 + offsetof (struct large_vector
, v
)))
4244 /* This memory node corresponds to a large vector. */
4250 /* Value is non-zero if P is a pointer to a live buffer. M is a
4251 pointer to the mem_block for P. */
4254 live_buffer_p (struct mem_node
*m
, void *p
)
4256 /* P must point to the start of the block, and the buffer
4257 must not have been killed. */
4258 return (m
->type
== MEM_TYPE_BUFFER
4260 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4263 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4267 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4269 /* Currently not used, but may be called from gdb. */
4271 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4273 /* Array of objects that are kept alive because the C stack contains
4274 a pattern that looks like a reference to them . */
4276 #define MAX_ZOMBIES 10
4277 static Lisp_Object zombies
[MAX_ZOMBIES
];
4279 /* Number of zombie objects. */
4281 static EMACS_INT nzombies
;
4283 /* Number of garbage collections. */
4285 static EMACS_INT ngcs
;
4287 /* Average percentage of zombies per collection. */
4289 static double avg_zombies
;
4291 /* Max. number of live and zombie objects. */
4293 static EMACS_INT max_live
, max_zombies
;
4295 /* Average number of live objects per GC. */
4297 static double avg_live
;
4299 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4300 doc
: /* Show information about live and zombie objects. */)
4303 Lisp_Object args
[8], zombie_list
= Qnil
;
4305 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4306 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4307 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4308 args
[1] = make_number (ngcs
);
4309 args
[2] = make_float (avg_live
);
4310 args
[3] = make_float (avg_zombies
);
4311 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4312 args
[5] = make_number (max_live
);
4313 args
[6] = make_number (max_zombies
);
4314 args
[7] = zombie_list
;
4315 return Fmessage (8, args
);
4318 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4321 /* Mark OBJ if we can prove it's a Lisp_Object. */
4324 mark_maybe_object (Lisp_Object obj
)
4331 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4337 po
= (void *) XPNTR (obj
);
4344 switch (XTYPE (obj
))
4347 mark_p
= (live_string_p (m
, po
)
4348 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4352 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4356 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4360 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4363 case Lisp_Vectorlike
:
4364 /* Note: can't check BUFFERP before we know it's a
4365 buffer because checking that dereferences the pointer
4366 PO which might point anywhere. */
4367 if (live_vector_p (m
, po
))
4368 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4369 else if (live_buffer_p (m
, po
))
4370 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4374 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4383 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4384 if (nzombies
< MAX_ZOMBIES
)
4385 zombies
[nzombies
] = obj
;
4394 /* If P points to Lisp data, mark that as live if it isn't already
4398 mark_maybe_pointer (void *p
)
4404 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4407 /* Quickly rule out some values which can't point to Lisp data.
4408 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4409 Otherwise, assume that Lisp data is aligned on even addresses. */
4410 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4416 Lisp_Object obj
= Qnil
;
4420 case MEM_TYPE_NON_LISP
:
4421 case MEM_TYPE_SPARE
:
4422 /* Nothing to do; not a pointer to Lisp memory. */
4425 case MEM_TYPE_BUFFER
:
4426 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4427 XSETVECTOR (obj
, p
);
4431 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4435 case MEM_TYPE_STRING
:
4436 if (live_string_p (m
, p
)
4437 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4438 XSETSTRING (obj
, p
);
4442 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4446 case MEM_TYPE_SYMBOL
:
4447 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4448 XSETSYMBOL (obj
, p
);
4451 case MEM_TYPE_FLOAT
:
4452 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4456 case MEM_TYPE_VECTORLIKE
:
4457 case MEM_TYPE_VECTOR_BLOCK
:
4458 if (live_vector_p (m
, p
))
4461 XSETVECTOR (tem
, p
);
4462 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4477 /* Alignment of pointer values. Use alignof, as it sometimes returns
4478 a smaller alignment than GCC's __alignof__ and mark_memory might
4479 miss objects if __alignof__ were used. */
4480 #define GC_POINTER_ALIGNMENT alignof (void *)
4482 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4483 not suffice, which is the typical case. A host where a Lisp_Object is
4484 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4485 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4486 suffice to widen it to to a Lisp_Object and check it that way. */
4487 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4488 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4489 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4490 nor mark_maybe_object can follow the pointers. This should not occur on
4491 any practical porting target. */
4492 # error "MSB type bits straddle pointer-word boundaries"
4494 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4495 pointer words that hold pointers ORed with type bits. */
4496 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4498 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4499 words that hold unmodified pointers. */
4500 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4503 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4504 or END+OFFSET..START. */
4507 mark_memory (void *start
, void *end
)
4508 #if defined (__clang__) && defined (__has_feature)
4509 #if __has_feature(address_sanitizer)
4510 /* Do not allow -faddress-sanitizer to check this function, since it
4511 crosses the function stack boundary, and thus would yield many
4513 __attribute__((no_address_safety_analysis
))
4520 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4524 /* Make START the pointer to the start of the memory region,
4525 if it isn't already. */
4533 /* Mark Lisp data pointed to. This is necessary because, in some
4534 situations, the C compiler optimizes Lisp objects away, so that
4535 only a pointer to them remains. Example:
4537 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4540 Lisp_Object obj = build_string ("test");
4541 struct Lisp_String *s = XSTRING (obj);
4542 Fgarbage_collect ();
4543 fprintf (stderr, "test `%s'\n", s->data);
4547 Here, `obj' isn't really used, and the compiler optimizes it
4548 away. The only reference to the life string is through the
4551 for (pp
= start
; (void *) pp
< end
; pp
++)
4552 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4554 void *p
= *(void **) ((char *) pp
+ i
);
4555 mark_maybe_pointer (p
);
4556 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4557 mark_maybe_object (XIL ((intptr_t) p
));
4561 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4563 static bool setjmp_tested_p
;
4564 static int longjmps_done
;
4566 #define SETJMP_WILL_LIKELY_WORK "\
4568 Emacs garbage collector has been changed to use conservative stack\n\
4569 marking. Emacs has determined that the method it uses to do the\n\
4570 marking will likely work on your system, but this isn't sure.\n\
4572 If you are a system-programmer, or can get the help of a local wizard\n\
4573 who is, please take a look at the function mark_stack in alloc.c, and\n\
4574 verify that the methods used are appropriate for your system.\n\
4576 Please mail the result to <emacs-devel@gnu.org>.\n\
4579 #define SETJMP_WILL_NOT_WORK "\
4581 Emacs garbage collector has been changed to use conservative stack\n\
4582 marking. Emacs has determined that the default method it uses to do the\n\
4583 marking will not work on your system. We will need a system-dependent\n\
4584 solution for your system.\n\
4586 Please take a look at the function mark_stack in alloc.c, and\n\
4587 try to find a way to make it work on your system.\n\
4589 Note that you may get false negatives, depending on the compiler.\n\
4590 In particular, you need to use -O with GCC for this test.\n\
4592 Please mail the result to <emacs-devel@gnu.org>.\n\
4596 /* Perform a quick check if it looks like setjmp saves registers in a
4597 jmp_buf. Print a message to stderr saying so. When this test
4598 succeeds, this is _not_ a proof that setjmp is sufficient for
4599 conservative stack marking. Only the sources or a disassembly
4609 /* Arrange for X to be put in a register. */
4615 if (longjmps_done
== 1)
4617 /* Came here after the longjmp at the end of the function.
4619 If x == 1, the longjmp has restored the register to its
4620 value before the setjmp, and we can hope that setjmp
4621 saves all such registers in the jmp_buf, although that
4624 For other values of X, either something really strange is
4625 taking place, or the setjmp just didn't save the register. */
4628 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4631 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4638 if (longjmps_done
== 1)
4639 sys_longjmp (jbuf
, 1);
4642 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4645 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4647 /* Abort if anything GCPRO'd doesn't survive the GC. */
4655 for (p
= gcprolist
; p
; p
= p
->next
)
4656 for (i
= 0; i
< p
->nvars
; ++i
)
4657 if (!survives_gc_p (p
->var
[i
]))
4658 /* FIXME: It's not necessarily a bug. It might just be that the
4659 GCPRO is unnecessary or should release the object sooner. */
4663 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4670 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4671 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4673 fprintf (stderr
, " %d = ", i
);
4674 debug_print (zombies
[i
]);
4678 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4681 /* Mark live Lisp objects on the C stack.
4683 There are several system-dependent problems to consider when
4684 porting this to new architectures:
4688 We have to mark Lisp objects in CPU registers that can hold local
4689 variables or are used to pass parameters.
4691 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4692 something that either saves relevant registers on the stack, or
4693 calls mark_maybe_object passing it each register's contents.
4695 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4696 implementation assumes that calling setjmp saves registers we need
4697 to see in a jmp_buf which itself lies on the stack. This doesn't
4698 have to be true! It must be verified for each system, possibly
4699 by taking a look at the source code of setjmp.
4701 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4702 can use it as a machine independent method to store all registers
4703 to the stack. In this case the macros described in the previous
4704 two paragraphs are not used.
4708 Architectures differ in the way their processor stack is organized.
4709 For example, the stack might look like this
4712 | Lisp_Object | size = 4
4714 | something else | size = 2
4716 | Lisp_Object | size = 4
4720 In such a case, not every Lisp_Object will be aligned equally. To
4721 find all Lisp_Object on the stack it won't be sufficient to walk
4722 the stack in steps of 4 bytes. Instead, two passes will be
4723 necessary, one starting at the start of the stack, and a second
4724 pass starting at the start of the stack + 2. Likewise, if the
4725 minimal alignment of Lisp_Objects on the stack is 1, four passes
4726 would be necessary, each one starting with one byte more offset
4727 from the stack start. */
4734 #ifdef HAVE___BUILTIN_UNWIND_INIT
4735 /* Force callee-saved registers and register windows onto the stack.
4736 This is the preferred method if available, obviating the need for
4737 machine dependent methods. */
4738 __builtin_unwind_init ();
4740 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4741 #ifndef GC_SAVE_REGISTERS_ON_STACK
4742 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4743 union aligned_jmpbuf
{
4747 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4749 /* This trick flushes the register windows so that all the state of
4750 the process is contained in the stack. */
4751 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4752 needed on ia64 too. See mach_dep.c, where it also says inline
4753 assembler doesn't work with relevant proprietary compilers. */
4755 #if defined (__sparc64__) && defined (__FreeBSD__)
4756 /* FreeBSD does not have a ta 3 handler. */
4763 /* Save registers that we need to see on the stack. We need to see
4764 registers used to hold register variables and registers used to
4766 #ifdef GC_SAVE_REGISTERS_ON_STACK
4767 GC_SAVE_REGISTERS_ON_STACK (end
);
4768 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4770 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4771 setjmp will definitely work, test it
4772 and print a message with the result
4774 if (!setjmp_tested_p
)
4776 setjmp_tested_p
= 1;
4779 #endif /* GC_SETJMP_WORKS */
4782 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4783 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4784 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4786 /* This assumes that the stack is a contiguous region in memory. If
4787 that's not the case, something has to be done here to iterate
4788 over the stack segments. */
4789 mark_memory (stack_base
, end
);
4791 /* Allow for marking a secondary stack, like the register stack on the
4793 #ifdef GC_MARK_SECONDARY_STACK
4794 GC_MARK_SECONDARY_STACK ();
4797 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4802 #else /* GC_MARK_STACK == 0 */
4804 #define mark_maybe_object(obj) emacs_abort ()
4806 #endif /* GC_MARK_STACK != 0 */
4809 /* Determine whether it is safe to access memory at address P. */
4811 valid_pointer_p (void *p
)
4814 return w32_valid_pointer_p (p
, 16);
4818 /* Obviously, we cannot just access it (we would SEGV trying), so we
4819 trick the o/s to tell us whether p is a valid pointer.
4820 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4821 not validate p in that case. */
4823 if (emacs_pipe (fd
) == 0)
4825 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4826 emacs_close (fd
[1]);
4827 emacs_close (fd
[0]);
4835 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4836 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4837 cannot validate OBJ. This function can be quite slow, so its primary
4838 use is the manual debugging. The only exception is print_object, where
4839 we use it to check whether the memory referenced by the pointer of
4840 Lisp_Save_Value object contains valid objects. */
4843 valid_lisp_object_p (Lisp_Object obj
)
4853 p
= (void *) XPNTR (obj
);
4854 if (PURE_POINTER_P (p
))
4857 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4861 return valid_pointer_p (p
);
4868 int valid
= valid_pointer_p (p
);
4880 case MEM_TYPE_NON_LISP
:
4881 case MEM_TYPE_SPARE
:
4884 case MEM_TYPE_BUFFER
:
4885 return live_buffer_p (m
, p
) ? 1 : 2;
4888 return live_cons_p (m
, p
);
4890 case MEM_TYPE_STRING
:
4891 return live_string_p (m
, p
);
4894 return live_misc_p (m
, p
);
4896 case MEM_TYPE_SYMBOL
:
4897 return live_symbol_p (m
, p
);
4899 case MEM_TYPE_FLOAT
:
4900 return live_float_p (m
, p
);
4902 case MEM_TYPE_VECTORLIKE
:
4903 case MEM_TYPE_VECTOR_BLOCK
:
4904 return live_vector_p (m
, p
);
4917 /***********************************************************************
4918 Pure Storage Management
4919 ***********************************************************************/
4921 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4922 pointer to it. TYPE is the Lisp type for which the memory is
4923 allocated. TYPE < 0 means it's not used for a Lisp object. */
4926 pure_alloc (size_t size
, int type
)
4930 size_t alignment
= GCALIGNMENT
;
4932 size_t alignment
= alignof (EMACS_INT
);
4934 /* Give Lisp_Floats an extra alignment. */
4935 if (type
== Lisp_Float
)
4936 alignment
= alignof (struct Lisp_Float
);
4942 /* Allocate space for a Lisp object from the beginning of the free
4943 space with taking account of alignment. */
4944 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4945 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4949 /* Allocate space for a non-Lisp object from the end of the free
4951 pure_bytes_used_non_lisp
+= size
;
4952 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4954 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4956 if (pure_bytes_used
<= pure_size
)
4959 /* Don't allocate a large amount here,
4960 because it might get mmap'd and then its address
4961 might not be usable. */
4962 purebeg
= xmalloc (10000);
4964 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4965 pure_bytes_used
= 0;
4966 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4971 /* Print a warning if PURESIZE is too small. */
4974 check_pure_size (void)
4976 if (pure_bytes_used_before_overflow
)
4977 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4979 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4983 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4984 the non-Lisp data pool of the pure storage, and return its start
4985 address. Return NULL if not found. */
4988 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4991 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4992 const unsigned char *p
;
4995 if (pure_bytes_used_non_lisp
<= nbytes
)
4998 /* Set up the Boyer-Moore table. */
5000 for (i
= 0; i
< 256; i
++)
5003 p
= (const unsigned char *) data
;
5005 bm_skip
[*p
++] = skip
;
5007 last_char_skip
= bm_skip
['\0'];
5009 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5010 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5012 /* See the comments in the function `boyer_moore' (search.c) for the
5013 use of `infinity'. */
5014 infinity
= pure_bytes_used_non_lisp
+ 1;
5015 bm_skip
['\0'] = infinity
;
5017 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5021 /* Check the last character (== '\0'). */
5024 start
+= bm_skip
[*(p
+ start
)];
5026 while (start
<= start_max
);
5028 if (start
< infinity
)
5029 /* Couldn't find the last character. */
5032 /* No less than `infinity' means we could find the last
5033 character at `p[start - infinity]'. */
5036 /* Check the remaining characters. */
5037 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5039 return non_lisp_beg
+ start
;
5041 start
+= last_char_skip
;
5043 while (start
<= start_max
);
5049 /* Return a string allocated in pure space. DATA is a buffer holding
5050 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5051 means make the result string multibyte.
5053 Must get an error if pure storage is full, since if it cannot hold
5054 a large string it may be able to hold conses that point to that
5055 string; then the string is not protected from gc. */
5058 make_pure_string (const char *data
,
5059 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5062 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5063 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5064 if (s
->data
== NULL
)
5066 s
->data
= pure_alloc (nbytes
+ 1, -1);
5067 memcpy (s
->data
, data
, nbytes
);
5068 s
->data
[nbytes
] = '\0';
5071 s
->size_byte
= multibyte
? nbytes
: -1;
5072 s
->intervals
= NULL
;
5073 XSETSTRING (string
, s
);
5077 /* Return a string allocated in pure space. Do not
5078 allocate the string data, just point to DATA. */
5081 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5084 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5087 s
->data
= (unsigned char *) data
;
5088 s
->intervals
= NULL
;
5089 XSETSTRING (string
, s
);
5093 /* Return a cons allocated from pure space. Give it pure copies
5094 of CAR as car and CDR as cdr. */
5097 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5100 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5102 XSETCAR (new, Fpurecopy (car
));
5103 XSETCDR (new, Fpurecopy (cdr
));
5108 /* Value is a float object with value NUM allocated from pure space. */
5111 make_pure_float (double num
)
5114 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5116 XFLOAT_INIT (new, num
);
5121 /* Return a vector with room for LEN Lisp_Objects allocated from
5125 make_pure_vector (ptrdiff_t len
)
5128 size_t size
= header_size
+ len
* word_size
;
5129 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5130 XSETVECTOR (new, p
);
5131 XVECTOR (new)->header
.size
= len
;
5136 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5137 doc
: /* Make a copy of object OBJ in pure storage.
5138 Recursively copies contents of vectors and cons cells.
5139 Does not copy symbols. Copies strings without text properties. */)
5140 (register Lisp_Object obj
)
5142 if (NILP (Vpurify_flag
))
5145 if (PURE_POINTER_P (XPNTR (obj
)))
5148 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5150 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5156 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5157 else if (FLOATP (obj
))
5158 obj
= make_pure_float (XFLOAT_DATA (obj
));
5159 else if (STRINGP (obj
))
5160 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5162 STRING_MULTIBYTE (obj
));
5163 else if (COMPILEDP (obj
) || VECTORP (obj
))
5165 register struct Lisp_Vector
*vec
;
5166 register ptrdiff_t i
;
5170 if (size
& PSEUDOVECTOR_FLAG
)
5171 size
&= PSEUDOVECTOR_SIZE_MASK
;
5172 vec
= XVECTOR (make_pure_vector (size
));
5173 for (i
= 0; i
< size
; i
++)
5174 vec
->u
.contents
[i
] = Fpurecopy (AREF (obj
, i
));
5175 if (COMPILEDP (obj
))
5177 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5178 XSETCOMPILED (obj
, vec
);
5181 XSETVECTOR (obj
, vec
);
5183 else if (MARKERP (obj
))
5184 error ("Attempt to copy a marker to pure storage");
5186 /* Not purified, don't hash-cons. */
5189 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5190 Fputhash (obj
, obj
, Vpurify_flag
);
5197 /***********************************************************************
5199 ***********************************************************************/
5201 /* Put an entry in staticvec, pointing at the variable with address
5205 staticpro (Lisp_Object
*varaddress
)
5207 if (staticidx
>= NSTATICS
)
5208 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5209 staticvec
[staticidx
++] = varaddress
;
5213 /***********************************************************************
5215 ***********************************************************************/
5217 /* Temporarily prevent garbage collection. */
5220 inhibit_garbage_collection (void)
5222 ptrdiff_t count
= SPECPDL_INDEX ();
5224 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5228 /* Used to avoid possible overflows when
5229 converting from C to Lisp integers. */
5232 bounded_number (EMACS_INT number
)
5234 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5237 /* Calculate total bytes of live objects. */
5240 total_bytes_of_live_objects (void)
5243 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5244 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5245 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5246 tot
+= total_string_bytes
;
5247 tot
+= total_vector_slots
* word_size
;
5248 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5249 tot
+= total_intervals
* sizeof (struct interval
);
5250 tot
+= total_strings
* sizeof (struct Lisp_String
);
5254 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5255 doc
: /* Reclaim storage for Lisp objects no longer needed.
5256 Garbage collection happens automatically if you cons more than
5257 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5258 `garbage-collect' normally returns a list with info on amount of space in use,
5259 where each entry has the form (NAME SIZE USED FREE), where:
5260 - NAME is a symbol describing the kind of objects this entry represents,
5261 - SIZE is the number of bytes used by each one,
5262 - USED is the number of those objects that were found live in the heap,
5263 - FREE is the number of those objects that are not live but that Emacs
5264 keeps around for future allocations (maybe because it does not know how
5265 to return them to the OS).
5266 However, if there was overflow in pure space, `garbage-collect'
5267 returns nil, because real GC can't be done.
5268 See Info node `(elisp)Garbage Collection'. */)
5271 struct buffer
*nextb
;
5272 char stack_top_variable
;
5275 ptrdiff_t count
= SPECPDL_INDEX ();
5276 struct timespec start
;
5277 Lisp_Object retval
= Qnil
;
5278 size_t tot_before
= 0;
5283 /* Can't GC if pure storage overflowed because we can't determine
5284 if something is a pure object or not. */
5285 if (pure_bytes_used_before_overflow
)
5288 /* Record this function, so it appears on the profiler's backtraces. */
5289 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5293 /* Don't keep undo information around forever.
5294 Do this early on, so it is no problem if the user quits. */
5295 FOR_EACH_BUFFER (nextb
)
5296 compact_buffer (nextb
);
5298 if (profiler_memory_running
)
5299 tot_before
= total_bytes_of_live_objects ();
5301 start
= current_timespec ();
5303 /* In case user calls debug_print during GC,
5304 don't let that cause a recursive GC. */
5305 consing_since_gc
= 0;
5307 /* Save what's currently displayed in the echo area. */
5308 message_p
= push_message ();
5309 record_unwind_protect_void (pop_message_unwind
);
5311 /* Save a copy of the contents of the stack, for debugging. */
5312 #if MAX_SAVE_STACK > 0
5313 if (NILP (Vpurify_flag
))
5316 ptrdiff_t stack_size
;
5317 if (&stack_top_variable
< stack_bottom
)
5319 stack
= &stack_top_variable
;
5320 stack_size
= stack_bottom
- &stack_top_variable
;
5324 stack
= stack_bottom
;
5325 stack_size
= &stack_top_variable
- stack_bottom
;
5327 if (stack_size
<= MAX_SAVE_STACK
)
5329 if (stack_copy_size
< stack_size
)
5331 stack_copy
= xrealloc (stack_copy
, stack_size
);
5332 stack_copy_size
= stack_size
;
5334 memcpy (stack_copy
, stack
, stack_size
);
5337 #endif /* MAX_SAVE_STACK > 0 */
5339 if (garbage_collection_messages
)
5340 message1_nolog ("Garbage collecting...");
5344 shrink_regexp_cache ();
5348 /* Mark all the special slots that serve as the roots of accessibility. */
5350 mark_buffer (&buffer_defaults
);
5351 mark_buffer (&buffer_local_symbols
);
5353 for (i
= 0; i
< staticidx
; i
++)
5354 mark_object (*staticvec
[i
]);
5364 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5365 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5369 register struct gcpro
*tail
;
5370 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5371 for (i
= 0; i
< tail
->nvars
; i
++)
5372 mark_object (tail
->var
[i
]);
5377 struct handler
*handler
;
5378 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5380 mark_object (handler
->tag_or_ch
);
5381 mark_object (handler
->val
);
5384 #ifdef HAVE_WINDOW_SYSTEM
5385 mark_fringe_data ();
5388 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5392 /* Everything is now marked, except for the things that require special
5393 finalization, i.e. the undo_list.
5394 Look thru every buffer's undo list
5395 for elements that update markers that were not marked,
5397 FOR_EACH_BUFFER (nextb
)
5399 /* If a buffer's undo list is Qt, that means that undo is
5400 turned off in that buffer. Calling truncate_undo_list on
5401 Qt tends to return NULL, which effectively turns undo back on.
5402 So don't call truncate_undo_list if undo_list is Qt. */
5403 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5405 Lisp_Object tail
, prev
;
5406 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5408 while (CONSP (tail
))
5410 if (CONSP (XCAR (tail
))
5411 && MARKERP (XCAR (XCAR (tail
)))
5412 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5415 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5419 XSETCDR (prev
, tail
);
5429 /* Now that we have stripped the elements that need not be in the
5430 undo_list any more, we can finally mark the list. */
5431 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5436 /* Clear the mark bits that we set in certain root slots. */
5438 unmark_byte_stack ();
5439 VECTOR_UNMARK (&buffer_defaults
);
5440 VECTOR_UNMARK (&buffer_local_symbols
);
5442 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5452 consing_since_gc
= 0;
5453 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5454 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5456 gc_relative_threshold
= 0;
5457 if (FLOATP (Vgc_cons_percentage
))
5458 { /* Set gc_cons_combined_threshold. */
5459 double tot
= total_bytes_of_live_objects ();
5461 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5464 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5465 gc_relative_threshold
= tot
;
5467 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5471 if (garbage_collection_messages
)
5473 if (message_p
|| minibuf_level
> 0)
5476 message1_nolog ("Garbage collecting...done");
5479 unbind_to (count
, Qnil
);
5481 Lisp_Object total
[11];
5482 int total_size
= 10;
5484 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5485 bounded_number (total_conses
),
5486 bounded_number (total_free_conses
));
5488 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5489 bounded_number (total_symbols
),
5490 bounded_number (total_free_symbols
));
5492 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5493 bounded_number (total_markers
),
5494 bounded_number (total_free_markers
));
5496 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5497 bounded_number (total_strings
),
5498 bounded_number (total_free_strings
));
5500 total
[4] = list3 (Qstring_bytes
, make_number (1),
5501 bounded_number (total_string_bytes
));
5503 total
[5] = list3 (Qvectors
,
5504 make_number (header_size
+ sizeof (Lisp_Object
)),
5505 bounded_number (total_vectors
));
5507 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5508 bounded_number (total_vector_slots
),
5509 bounded_number (total_free_vector_slots
));
5511 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5512 bounded_number (total_floats
),
5513 bounded_number (total_free_floats
));
5515 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5516 bounded_number (total_intervals
),
5517 bounded_number (total_free_intervals
));
5519 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5520 bounded_number (total_buffers
));
5522 #ifdef DOUG_LEA_MALLOC
5524 total
[10] = list4 (Qheap
, make_number (1024),
5525 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5526 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5528 retval
= Flist (total_size
, total
);
5531 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5533 /* Compute average percentage of zombies. */
5535 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5536 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5538 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5539 max_live
= max (nlive
, max_live
);
5540 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5541 max_zombies
= max (nzombies
, max_zombies
);
5546 if (!NILP (Vpost_gc_hook
))
5548 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5549 safe_run_hooks (Qpost_gc_hook
);
5550 unbind_to (gc_count
, Qnil
);
5553 /* Accumulate statistics. */
5554 if (FLOATP (Vgc_elapsed
))
5556 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5557 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5558 + timespectod (since_start
));
5563 /* Collect profiling data. */
5564 if (profiler_memory_running
)
5567 size_t tot_after
= total_bytes_of_live_objects ();
5568 if (tot_before
> tot_after
)
5569 swept
= tot_before
- tot_after
;
5570 malloc_probe (swept
);
5577 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5578 only interesting objects referenced from glyphs are strings. */
5581 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5583 struct glyph_row
*row
= matrix
->rows
;
5584 struct glyph_row
*end
= row
+ matrix
->nrows
;
5586 for (; row
< end
; ++row
)
5590 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5592 struct glyph
*glyph
= row
->glyphs
[area
];
5593 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5595 for (; glyph
< end_glyph
; ++glyph
)
5596 if (STRINGP (glyph
->object
)
5597 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5598 mark_object (glyph
->object
);
5604 /* Mark Lisp faces in the face cache C. */
5607 mark_face_cache (struct face_cache
*c
)
5612 for (i
= 0; i
< c
->used
; ++i
)
5614 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5618 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5619 mark_object (face
->lface
[j
]);
5627 /* Mark reference to a Lisp_Object.
5628 If the object referred to has not been seen yet, recursively mark
5629 all the references contained in it. */
5631 #define LAST_MARKED_SIZE 500
5632 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5633 static int last_marked_index
;
5635 /* For debugging--call abort when we cdr down this many
5636 links of a list, in mark_object. In debugging,
5637 the call to abort will hit a breakpoint.
5638 Normally this is zero and the check never goes off. */
5639 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5642 mark_vectorlike (struct Lisp_Vector
*ptr
)
5644 ptrdiff_t size
= ptr
->header
.size
;
5647 eassert (!VECTOR_MARKED_P (ptr
));
5648 VECTOR_MARK (ptr
); /* Else mark it. */
5649 if (size
& PSEUDOVECTOR_FLAG
)
5650 size
&= PSEUDOVECTOR_SIZE_MASK
;
5652 /* Note that this size is not the memory-footprint size, but only
5653 the number of Lisp_Object fields that we should trace.
5654 The distinction is used e.g. by Lisp_Process which places extra
5655 non-Lisp_Object fields at the end of the structure... */
5656 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5657 mark_object (ptr
->u
.contents
[i
]);
5660 /* Like mark_vectorlike but optimized for char-tables (and
5661 sub-char-tables) assuming that the contents are mostly integers or
5665 mark_char_table (struct Lisp_Vector
*ptr
)
5667 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5670 eassert (!VECTOR_MARKED_P (ptr
));
5672 for (i
= 0; i
< size
; i
++)
5674 Lisp_Object val
= ptr
->u
.contents
[i
];
5676 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5678 if (SUB_CHAR_TABLE_P (val
))
5680 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5681 mark_char_table (XVECTOR (val
));
5688 /* Mark the chain of overlays starting at PTR. */
5691 mark_overlay (struct Lisp_Overlay
*ptr
)
5693 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5696 mark_object (ptr
->start
);
5697 mark_object (ptr
->end
);
5698 mark_object (ptr
->plist
);
5702 /* Mark Lisp_Objects and special pointers in BUFFER. */
5705 mark_buffer (struct buffer
*buffer
)
5707 /* This is handled much like other pseudovectors... */
5708 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5710 /* ...but there are some buffer-specific things. */
5712 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5714 /* For now, we just don't mark the undo_list. It's done later in
5715 a special way just before the sweep phase, and after stripping
5716 some of its elements that are not needed any more. */
5718 mark_overlay (buffer
->overlays_before
);
5719 mark_overlay (buffer
->overlays_after
);
5721 /* If this is an indirect buffer, mark its base buffer. */
5722 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5723 mark_buffer (buffer
->base_buffer
);
5726 /* Remove killed buffers or items whose car is a killed buffer from
5727 LIST, and mark other items. Return changed LIST, which is marked. */
5730 mark_discard_killed_buffers (Lisp_Object list
)
5732 Lisp_Object tail
, *prev
= &list
;
5734 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5737 Lisp_Object tem
= XCAR (tail
);
5740 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5741 *prev
= XCDR (tail
);
5744 CONS_MARK (XCONS (tail
));
5745 mark_object (XCAR (tail
));
5746 prev
= xcdr_addr (tail
);
5753 /* Determine type of generic Lisp_Object and mark it accordingly. */
5756 mark_object (Lisp_Object arg
)
5758 register Lisp_Object obj
= arg
;
5759 #ifdef GC_CHECK_MARKED_OBJECTS
5763 ptrdiff_t cdr_count
= 0;
5767 if (PURE_POINTER_P (XPNTR (obj
)))
5770 last_marked
[last_marked_index
++] = obj
;
5771 if (last_marked_index
== LAST_MARKED_SIZE
)
5772 last_marked_index
= 0;
5774 /* Perform some sanity checks on the objects marked here. Abort if
5775 we encounter an object we know is bogus. This increases GC time
5776 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5777 #ifdef GC_CHECK_MARKED_OBJECTS
5779 po
= (void *) XPNTR (obj
);
5781 /* Check that the object pointed to by PO is known to be a Lisp
5782 structure allocated from the heap. */
5783 #define CHECK_ALLOCATED() \
5785 m = mem_find (po); \
5790 /* Check that the object pointed to by PO is live, using predicate
5792 #define CHECK_LIVE(LIVEP) \
5794 if (!LIVEP (m, po)) \
5798 /* Check both of the above conditions. */
5799 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5801 CHECK_ALLOCATED (); \
5802 CHECK_LIVE (LIVEP); \
5805 #else /* not GC_CHECK_MARKED_OBJECTS */
5807 #define CHECK_LIVE(LIVEP) (void) 0
5808 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5810 #endif /* not GC_CHECK_MARKED_OBJECTS */
5812 switch (XTYPE (obj
))
5816 register struct Lisp_String
*ptr
= XSTRING (obj
);
5817 if (STRING_MARKED_P (ptr
))
5819 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5821 MARK_INTERVAL_TREE (ptr
->intervals
);
5822 #ifdef GC_CHECK_STRING_BYTES
5823 /* Check that the string size recorded in the string is the
5824 same as the one recorded in the sdata structure. */
5826 #endif /* GC_CHECK_STRING_BYTES */
5830 case Lisp_Vectorlike
:
5832 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5833 register ptrdiff_t pvectype
;
5835 if (VECTOR_MARKED_P (ptr
))
5838 #ifdef GC_CHECK_MARKED_OBJECTS
5840 if (m
== MEM_NIL
&& !SUBRP (obj
))
5842 #endif /* GC_CHECK_MARKED_OBJECTS */
5844 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5845 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5846 >> PSEUDOVECTOR_AREA_BITS
);
5848 pvectype
= PVEC_NORMAL_VECTOR
;
5850 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5851 CHECK_LIVE (live_vector_p
);
5856 #ifdef GC_CHECK_MARKED_OBJECTS
5865 #endif /* GC_CHECK_MARKED_OBJECTS */
5866 mark_buffer ((struct buffer
*) ptr
);
5870 { /* We could treat this just like a vector, but it is better
5871 to save the COMPILED_CONSTANTS element for last and avoid
5873 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5877 for (i
= 0; i
< size
; i
++)
5878 if (i
!= COMPILED_CONSTANTS
)
5879 mark_object (ptr
->u
.contents
[i
]);
5880 if (size
> COMPILED_CONSTANTS
)
5882 obj
= ptr
->u
.contents
[COMPILED_CONSTANTS
];
5889 mark_vectorlike (ptr
);
5890 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5895 struct window
*w
= (struct window
*) ptr
;
5897 mark_vectorlike (ptr
);
5899 /* Mark glyph matrices, if any. Marking window
5900 matrices is sufficient because frame matrices
5901 use the same glyph memory. */
5902 if (w
->current_matrix
)
5904 mark_glyph_matrix (w
->current_matrix
);
5905 mark_glyph_matrix (w
->desired_matrix
);
5908 /* Filter out killed buffers from both buffer lists
5909 in attempt to help GC to reclaim killed buffers faster.
5910 We can do it elsewhere for live windows, but this is the
5911 best place to do it for dead windows. */
5913 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5915 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5919 case PVEC_HASH_TABLE
:
5921 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5923 mark_vectorlike (ptr
);
5924 mark_object (h
->test
.name
);
5925 mark_object (h
->test
.user_hash_function
);
5926 mark_object (h
->test
.user_cmp_function
);
5927 /* If hash table is not weak, mark all keys and values.
5928 For weak tables, mark only the vector. */
5930 mark_object (h
->key_and_value
);
5932 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5936 case PVEC_CHAR_TABLE
:
5937 mark_char_table (ptr
);
5940 case PVEC_BOOL_VECTOR
:
5941 /* No Lisp_Objects to mark in a bool vector. */
5952 mark_vectorlike (ptr
);
5959 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5960 struct Lisp_Symbol
*ptrx
;
5964 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5966 mark_object (ptr
->function
);
5967 mark_object (ptr
->plist
);
5968 switch (ptr
->redirect
)
5970 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5971 case SYMBOL_VARALIAS
:
5974 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5978 case SYMBOL_LOCALIZED
:
5980 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5981 Lisp_Object where
= blv
->where
;
5982 /* If the value is set up for a killed buffer or deleted
5983 frame, restore it's global binding. If the value is
5984 forwarded to a C variable, either it's not a Lisp_Object
5985 var, or it's staticpro'd already. */
5986 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5987 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5988 swap_in_global_binding (ptr
);
5989 mark_object (blv
->where
);
5990 mark_object (blv
->valcell
);
5991 mark_object (blv
->defcell
);
5994 case SYMBOL_FORWARDED
:
5995 /* If the value is forwarded to a buffer or keyboard field,
5996 these are marked when we see the corresponding object.
5997 And if it's forwarded to a C variable, either it's not
5998 a Lisp_Object var, or it's staticpro'd already. */
6000 default: emacs_abort ();
6002 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6003 MARK_STRING (XSTRING (ptr
->name
));
6004 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6009 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6010 XSETSYMBOL (obj
, ptrx
);
6017 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6019 if (XMISCANY (obj
)->gcmarkbit
)
6022 switch (XMISCTYPE (obj
))
6024 case Lisp_Misc_Marker
:
6025 /* DO NOT mark thru the marker's chain.
6026 The buffer's markers chain does not preserve markers from gc;
6027 instead, markers are removed from the chain when freed by gc. */
6028 XMISCANY (obj
)->gcmarkbit
= 1;
6031 case Lisp_Misc_Save_Value
:
6032 XMISCANY (obj
)->gcmarkbit
= 1;
6034 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6035 /* If `save_type' is zero, `data[0].pointer' is the address
6036 of a memory area containing `data[1].integer' potential
6038 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6040 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6042 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6043 mark_maybe_object (*p
);
6047 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6049 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6050 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6051 mark_object (ptr
->data
[i
].object
);
6056 case Lisp_Misc_Overlay
:
6057 mark_overlay (XOVERLAY (obj
));
6067 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6068 if (CONS_MARKED_P (ptr
))
6070 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6072 /* If the cdr is nil, avoid recursion for the car. */
6073 if (EQ (ptr
->u
.cdr
, Qnil
))
6079 mark_object (ptr
->car
);
6082 if (cdr_count
== mark_object_loop_halt
)
6088 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6089 FLOAT_MARK (XFLOAT (obj
));
6100 #undef CHECK_ALLOCATED
6101 #undef CHECK_ALLOCATED_AND_LIVE
6103 /* Mark the Lisp pointers in the terminal objects.
6104 Called by Fgarbage_collect. */
6107 mark_terminals (void)
6110 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6112 eassert (t
->name
!= NULL
);
6113 #ifdef HAVE_WINDOW_SYSTEM
6114 /* If a terminal object is reachable from a stacpro'ed object,
6115 it might have been marked already. Make sure the image cache
6117 mark_image_cache (t
->image_cache
);
6118 #endif /* HAVE_WINDOW_SYSTEM */
6119 if (!VECTOR_MARKED_P (t
))
6120 mark_vectorlike ((struct Lisp_Vector
*)t
);
6126 /* Value is non-zero if OBJ will survive the current GC because it's
6127 either marked or does not need to be marked to survive. */
6130 survives_gc_p (Lisp_Object obj
)
6134 switch (XTYPE (obj
))
6141 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6145 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6149 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6152 case Lisp_Vectorlike
:
6153 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6157 survives_p
= CONS_MARKED_P (XCONS (obj
));
6161 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6168 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6173 /* Sweep: find all structures not marked, and free them. */
6178 /* Remove or mark entries in weak hash tables.
6179 This must be done before any object is unmarked. */
6180 sweep_weak_hash_tables ();
6183 check_string_bytes (!noninteractive
);
6185 /* Put all unmarked conses on free list */
6187 register struct cons_block
*cblk
;
6188 struct cons_block
**cprev
= &cons_block
;
6189 register int lim
= cons_block_index
;
6190 EMACS_INT num_free
= 0, num_used
= 0;
6194 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6198 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6200 /* Scan the mark bits an int at a time. */
6201 for (i
= 0; i
< ilim
; i
++)
6203 if (cblk
->gcmarkbits
[i
] == -1)
6205 /* Fast path - all cons cells for this int are marked. */
6206 cblk
->gcmarkbits
[i
] = 0;
6207 num_used
+= BITS_PER_INT
;
6211 /* Some cons cells for this int are not marked.
6212 Find which ones, and free them. */
6213 int start
, pos
, stop
;
6215 start
= i
* BITS_PER_INT
;
6217 if (stop
> BITS_PER_INT
)
6218 stop
= BITS_PER_INT
;
6221 for (pos
= start
; pos
< stop
; pos
++)
6223 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6226 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6227 cons_free_list
= &cblk
->conses
[pos
];
6229 cons_free_list
->car
= Vdead
;
6235 CONS_UNMARK (&cblk
->conses
[pos
]);
6241 lim
= CONS_BLOCK_SIZE
;
6242 /* If this block contains only free conses and we have already
6243 seen more than two blocks worth of free conses then deallocate
6245 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6247 *cprev
= cblk
->next
;
6248 /* Unhook from the free list. */
6249 cons_free_list
= cblk
->conses
[0].u
.chain
;
6250 lisp_align_free (cblk
);
6254 num_free
+= this_free
;
6255 cprev
= &cblk
->next
;
6258 total_conses
= num_used
;
6259 total_free_conses
= num_free
;
6262 /* Put all unmarked floats on free list */
6264 register struct float_block
*fblk
;
6265 struct float_block
**fprev
= &float_block
;
6266 register int lim
= float_block_index
;
6267 EMACS_INT num_free
= 0, num_used
= 0;
6269 float_free_list
= 0;
6271 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6275 for (i
= 0; i
< lim
; i
++)
6276 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6279 fblk
->floats
[i
].u
.chain
= float_free_list
;
6280 float_free_list
= &fblk
->floats
[i
];
6285 FLOAT_UNMARK (&fblk
->floats
[i
]);
6287 lim
= FLOAT_BLOCK_SIZE
;
6288 /* If this block contains only free floats and we have already
6289 seen more than two blocks worth of free floats then deallocate
6291 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6293 *fprev
= fblk
->next
;
6294 /* Unhook from the free list. */
6295 float_free_list
= fblk
->floats
[0].u
.chain
;
6296 lisp_align_free (fblk
);
6300 num_free
+= this_free
;
6301 fprev
= &fblk
->next
;
6304 total_floats
= num_used
;
6305 total_free_floats
= num_free
;
6308 /* Put all unmarked intervals on free list */
6310 register struct interval_block
*iblk
;
6311 struct interval_block
**iprev
= &interval_block
;
6312 register int lim
= interval_block_index
;
6313 EMACS_INT num_free
= 0, num_used
= 0;
6315 interval_free_list
= 0;
6317 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6322 for (i
= 0; i
< lim
; i
++)
6324 if (!iblk
->intervals
[i
].gcmarkbit
)
6326 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6327 interval_free_list
= &iblk
->intervals
[i
];
6333 iblk
->intervals
[i
].gcmarkbit
= 0;
6336 lim
= INTERVAL_BLOCK_SIZE
;
6337 /* If this block contains only free intervals and we have already
6338 seen more than two blocks worth of free intervals then
6339 deallocate this block. */
6340 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6342 *iprev
= iblk
->next
;
6343 /* Unhook from the free list. */
6344 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6349 num_free
+= this_free
;
6350 iprev
= &iblk
->next
;
6353 total_intervals
= num_used
;
6354 total_free_intervals
= num_free
;
6357 /* Put all unmarked symbols on free list */
6359 register struct symbol_block
*sblk
;
6360 struct symbol_block
**sprev
= &symbol_block
;
6361 register int lim
= symbol_block_index
;
6362 EMACS_INT num_free
= 0, num_used
= 0;
6364 symbol_free_list
= NULL
;
6366 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6369 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6370 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6372 for (; sym
< end
; ++sym
)
6374 /* Check if the symbol was created during loadup. In such a case
6375 it might be pointed to by pure bytecode which we don't trace,
6376 so we conservatively assume that it is live. */
6377 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6379 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6381 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6382 xfree (SYMBOL_BLV (&sym
->s
));
6383 sym
->s
.next
= symbol_free_list
;
6384 symbol_free_list
= &sym
->s
;
6386 symbol_free_list
->function
= Vdead
;
6394 UNMARK_STRING (XSTRING (sym
->s
.name
));
6395 sym
->s
.gcmarkbit
= 0;
6399 lim
= SYMBOL_BLOCK_SIZE
;
6400 /* If this block contains only free symbols and we have already
6401 seen more than two blocks worth of free symbols then deallocate
6403 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6405 *sprev
= sblk
->next
;
6406 /* Unhook from the free list. */
6407 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6412 num_free
+= this_free
;
6413 sprev
= &sblk
->next
;
6416 total_symbols
= num_used
;
6417 total_free_symbols
= num_free
;
6420 /* Put all unmarked misc's on free list.
6421 For a marker, first unchain it from the buffer it points into. */
6423 register struct marker_block
*mblk
;
6424 struct marker_block
**mprev
= &marker_block
;
6425 register int lim
= marker_block_index
;
6426 EMACS_INT num_free
= 0, num_used
= 0;
6428 marker_free_list
= 0;
6430 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6435 for (i
= 0; i
< lim
; i
++)
6437 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6439 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6440 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6441 /* Set the type of the freed object to Lisp_Misc_Free.
6442 We could leave the type alone, since nobody checks it,
6443 but this might catch bugs faster. */
6444 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6445 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6446 marker_free_list
= &mblk
->markers
[i
].m
;
6452 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6455 lim
= MARKER_BLOCK_SIZE
;
6456 /* If this block contains only free markers and we have already
6457 seen more than two blocks worth of free markers then deallocate
6459 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6461 *mprev
= mblk
->next
;
6462 /* Unhook from the free list. */
6463 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6468 num_free
+= this_free
;
6469 mprev
= &mblk
->next
;
6473 total_markers
= num_used
;
6474 total_free_markers
= num_free
;
6477 /* Free all unmarked buffers */
6479 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6482 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6483 if (!VECTOR_MARKED_P (buffer
))
6485 *bprev
= buffer
->next
;
6490 VECTOR_UNMARK (buffer
);
6491 /* Do not use buffer_(set|get)_intervals here. */
6492 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6494 bprev
= &buffer
->next
;
6499 check_string_bytes (!noninteractive
);
6505 /* Debugging aids. */
6507 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6508 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6509 This may be helpful in debugging Emacs's memory usage.
6510 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6515 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6520 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6521 doc
: /* Return a list of counters that measure how much consing there has been.
6522 Each of these counters increments for a certain kind of object.
6523 The counters wrap around from the largest positive integer to zero.
6524 Garbage collection does not decrease them.
6525 The elements of the value are as follows:
6526 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6527 All are in units of 1 = one object consed
6528 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6530 MISCS include overlays, markers, and some internal types.
6531 Frames, windows, buffers, and subprocesses count as vectors
6532 (but the contents of a buffer's text do not count here). */)
6535 return listn (CONSTYPE_HEAP
, 8,
6536 bounded_number (cons_cells_consed
),
6537 bounded_number (floats_consed
),
6538 bounded_number (vector_cells_consed
),
6539 bounded_number (symbols_consed
),
6540 bounded_number (string_chars_consed
),
6541 bounded_number (misc_objects_consed
),
6542 bounded_number (intervals_consed
),
6543 bounded_number (strings_consed
));
6546 /* Find at most FIND_MAX symbols which have OBJ as their value or
6547 function. This is used in gdbinit's `xwhichsymbols' command. */
6550 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6552 struct symbol_block
*sblk
;
6553 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6554 Lisp_Object found
= Qnil
;
6558 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6560 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6563 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6565 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6569 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6572 XSETSYMBOL (tem
, sym
);
6573 val
= find_symbol_value (tem
);
6575 || EQ (sym
->function
, obj
)
6576 || (!NILP (sym
->function
)
6577 && COMPILEDP (sym
->function
)
6578 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6581 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6583 found
= Fcons (tem
, found
);
6584 if (--find_max
== 0)
6592 unbind_to (gc_count
, Qnil
);
6596 #ifdef ENABLE_CHECKING
6598 bool suppress_checking
;
6601 die (const char *msg
, const char *file
, int line
)
6603 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6605 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6609 /* Initialization. */
6612 init_alloc_once (void)
6614 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6616 pure_size
= PURESIZE
;
6618 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6620 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6623 #ifdef DOUG_LEA_MALLOC
6624 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6625 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6626 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6631 refill_memory_reserve ();
6632 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6639 byte_stack_list
= 0;
6641 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6642 setjmp_tested_p
= longjmps_done
= 0;
6645 Vgc_elapsed
= make_float (0.0);
6649 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
6654 syms_of_alloc (void)
6656 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6657 doc
: /* Number of bytes of consing between garbage collections.
6658 Garbage collection can happen automatically once this many bytes have been
6659 allocated since the last garbage collection. All data types count.
6661 Garbage collection happens automatically only when `eval' is called.
6663 By binding this temporarily to a large number, you can effectively
6664 prevent garbage collection during a part of the program.
6665 See also `gc-cons-percentage'. */);
6667 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6668 doc
: /* Portion of the heap used for allocation.
6669 Garbage collection can happen automatically once this portion of the heap
6670 has been allocated since the last garbage collection.
6671 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6672 Vgc_cons_percentage
= make_float (0.1);
6674 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6675 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6677 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6678 doc
: /* Number of cons cells that have been consed so far. */);
6680 DEFVAR_INT ("floats-consed", floats_consed
,
6681 doc
: /* Number of floats that have been consed so far. */);
6683 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6684 doc
: /* Number of vector cells that have been consed so far. */);
6686 DEFVAR_INT ("symbols-consed", symbols_consed
,
6687 doc
: /* Number of symbols that have been consed so far. */);
6689 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6690 doc
: /* Number of string characters that have been consed so far. */);
6692 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6693 doc
: /* Number of miscellaneous objects that have been consed so far.
6694 These include markers and overlays, plus certain objects not visible
6697 DEFVAR_INT ("intervals-consed", intervals_consed
,
6698 doc
: /* Number of intervals that have been consed so far. */);
6700 DEFVAR_INT ("strings-consed", strings_consed
,
6701 doc
: /* Number of strings that have been consed so far. */);
6703 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6704 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6705 This means that certain objects should be allocated in shared (pure) space.
6706 It can also be set to a hash-table, in which case this table is used to
6707 do hash-consing of the objects allocated to pure space. */);
6709 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6710 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6711 garbage_collection_messages
= 0;
6713 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6714 doc
: /* Hook run after garbage collection has finished. */);
6715 Vpost_gc_hook
= Qnil
;
6716 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6718 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6719 doc
: /* Precomputed `signal' argument for memory-full error. */);
6720 /* We build this in advance because if we wait until we need it, we might
6721 not be able to allocate the memory to hold it. */
6723 = listn (CONSTYPE_PURE
, 2, Qerror
,
6724 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6726 DEFVAR_LISP ("memory-full", Vmemory_full
,
6727 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6728 Vmemory_full
= Qnil
;
6730 DEFSYM (Qconses
, "conses");
6731 DEFSYM (Qsymbols
, "symbols");
6732 DEFSYM (Qmiscs
, "miscs");
6733 DEFSYM (Qstrings
, "strings");
6734 DEFSYM (Qvectors
, "vectors");
6735 DEFSYM (Qfloats
, "floats");
6736 DEFSYM (Qintervals
, "intervals");
6737 DEFSYM (Qbuffers
, "buffers");
6738 DEFSYM (Qstring_bytes
, "string-bytes");
6739 DEFSYM (Qvector_slots
, "vector-slots");
6740 DEFSYM (Qheap
, "heap");
6741 DEFSYM (Qautomatic_gc
, "Automatic GC");
6743 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6744 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6746 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6747 doc
: /* Accumulated time elapsed in garbage collections.
6748 The time is in seconds as a floating point value. */);
6749 DEFVAR_INT ("gcs-done", gcs_done
,
6750 doc
: /* Accumulated number of garbage collections done. */);
6755 defsubr (&Smake_byte_code
);
6756 defsubr (&Smake_list
);
6757 defsubr (&Smake_vector
);
6758 defsubr (&Smake_string
);
6759 defsubr (&Smake_bool_vector
);
6760 defsubr (&Smake_symbol
);
6761 defsubr (&Smake_marker
);
6762 defsubr (&Spurecopy
);
6763 defsubr (&Sgarbage_collect
);
6764 defsubr (&Smemory_limit
);
6765 defsubr (&Smemory_use_counts
);
6767 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6768 defsubr (&Sgc_status
);
6772 /* When compiled with GCC, GDB might say "No enum type named
6773 pvec_type" if we don't have at least one symbol with that type, and
6774 then xbacktrace could fail. Similarly for the other enums and
6775 their values. Some non-GCC compilers don't like these constructs. */
6779 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6780 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6781 enum char_bits char_bits
;
6782 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6783 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6784 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6785 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6786 enum Lisp_Bits Lisp_Bits
;
6787 enum Lisp_Compiled Lisp_Compiled
;
6788 enum maxargs maxargs
;
6789 enum MAX_ALLOCA MAX_ALLOCA
;
6790 enum More_Lisp_Bits More_Lisp_Bits
;
6791 enum pvec_type pvec_type
;
6792 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6793 #endif /* __GNUC__ */