1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #define LISP_INLINE EXTERN_INLINE
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
38 #include "intervals.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
53 # undef GC_CHECK_MARKED_OBJECTS
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
73 #include "w32heap.h" /* for sbrk */
76 #ifdef DOUG_LEA_MALLOC
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #endif /* not DOUG_LEA_MALLOC */
87 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
88 to a struct Lisp_String. */
90 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
91 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
92 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
94 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
95 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
96 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
98 /* Default value of gc_cons_threshold (see below). */
100 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
102 /* Global variables. */
103 struct emacs_globals globals
;
105 /* Number of bytes of consing done since the last gc. */
107 EMACS_INT consing_since_gc
;
109 /* Similar minimum, computed from Vgc_cons_percentage. */
111 EMACS_INT gc_relative_threshold
;
113 /* Minimum number of bytes of consing since GC before next GC,
114 when memory is full. */
116 EMACS_INT memory_full_cons_threshold
;
118 /* True during GC. */
122 /* True means abort if try to GC.
123 This is for code which is written on the assumption that
124 no GC will happen, so as to verify that assumption. */
128 /* Number of live and free conses etc. */
130 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
131 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
132 static EMACS_INT total_free_floats
, total_floats
;
134 /* Points to memory space allocated as "spare", to be freed if we run
135 out of memory. We keep one large block, four cons-blocks, and
136 two string blocks. */
138 static char *spare_memory
[7];
140 /* Amount of spare memory to keep in large reserve block, or to see
141 whether this much is available when malloc fails on a larger request. */
143 #define SPARE_MEMORY (1 << 14)
145 /* Initialize it to a nonzero value to force it into data space
146 (rather than bss space). That way unexec will remap it into text
147 space (pure), on some systems. We have not implemented the
148 remapping on more recent systems because this is less important
149 nowadays than in the days of small memories and timesharing. */
151 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
152 #define PUREBEG (char *) pure
154 /* Pointer to the pure area, and its size. */
156 static char *purebeg
;
157 static ptrdiff_t pure_size
;
159 /* Number of bytes of pure storage used before pure storage overflowed.
160 If this is non-zero, this implies that an overflow occurred. */
162 static ptrdiff_t pure_bytes_used_before_overflow
;
164 /* True if P points into pure space. */
166 #define PURE_POINTER_P(P) \
167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
169 /* Index in pure at which next pure Lisp object will be allocated.. */
171 static ptrdiff_t pure_bytes_used_lisp
;
173 /* Number of bytes allocated for non-Lisp objects in pure storage. */
175 static ptrdiff_t pure_bytes_used_non_lisp
;
177 /* If nonzero, this is a warning delivered by malloc and not yet
180 const char *pending_malloc_warning
;
182 /* Maximum amount of C stack to save when a GC happens. */
184 #ifndef MAX_SAVE_STACK
185 #define MAX_SAVE_STACK 16000
188 /* Buffer in which we save a copy of the C stack at each GC. */
190 #if MAX_SAVE_STACK > 0
191 static char *stack_copy
;
192 static ptrdiff_t stack_copy_size
;
195 static Lisp_Object Qconses
;
196 static Lisp_Object Qsymbols
;
197 static Lisp_Object Qmiscs
;
198 static Lisp_Object Qstrings
;
199 static Lisp_Object Qvectors
;
200 static Lisp_Object Qfloats
;
201 static Lisp_Object Qintervals
;
202 static Lisp_Object Qbuffers
;
203 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
204 static Lisp_Object Qgc_cons_threshold
;
205 Lisp_Object Qautomatic_gc
;
206 Lisp_Object Qchar_table_extra_slots
;
208 /* Hook run after GC has finished. */
210 static Lisp_Object Qpost_gc_hook
;
212 static void mark_terminals (void);
213 static void gc_sweep (void);
214 static Lisp_Object
make_pure_vector (ptrdiff_t);
215 static void mark_buffer (struct buffer
*);
217 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
218 static void refill_memory_reserve (void);
220 static void compact_small_strings (void);
221 static void free_large_strings (void);
222 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
224 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
225 what memory allocated via lisp_malloc and lisp_align_malloc is intended
226 for what purpose. This enumeration specifies the type of memory. */
237 /* Since all non-bool pseudovectors are small enough to be
238 allocated from vector blocks, this memory type denotes
239 large regular vectors and large bool pseudovectors. */
241 /* Special type to denote vector blocks. */
242 MEM_TYPE_VECTOR_BLOCK
,
243 /* Special type to denote reserved memory. */
247 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
249 /* A unique object in pure space used to make some Lisp objects
250 on free lists recognizable in O(1). */
252 static Lisp_Object Vdead
;
253 #define DEADP(x) EQ (x, Vdead)
255 #ifdef GC_MALLOC_CHECK
257 enum mem_type allocated_mem_type
;
259 #endif /* GC_MALLOC_CHECK */
261 /* A node in the red-black tree describing allocated memory containing
262 Lisp data. Each such block is recorded with its start and end
263 address when it is allocated, and removed from the tree when it
266 A red-black tree is a balanced binary tree with the following
269 1. Every node is either red or black.
270 2. Every leaf is black.
271 3. If a node is red, then both of its children are black.
272 4. Every simple path from a node to a descendant leaf contains
273 the same number of black nodes.
274 5. The root is always black.
276 When nodes are inserted into the tree, or deleted from the tree,
277 the tree is "fixed" so that these properties are always true.
279 A red-black tree with N internal nodes has height at most 2
280 log(N+1). Searches, insertions and deletions are done in O(log N).
281 Please see a text book about data structures for a detailed
282 description of red-black trees. Any book worth its salt should
287 /* Children of this node. These pointers are never NULL. When there
288 is no child, the value is MEM_NIL, which points to a dummy node. */
289 struct mem_node
*left
, *right
;
291 /* The parent of this node. In the root node, this is NULL. */
292 struct mem_node
*parent
;
294 /* Start and end of allocated region. */
298 enum {MEM_BLACK
, MEM_RED
} color
;
304 /* Root of the tree describing allocated Lisp memory. */
306 static struct mem_node
*mem_root
;
308 /* Lowest and highest known address in the heap. */
310 static void *min_heap_address
, *max_heap_address
;
312 /* Sentinel node of the tree. */
314 static struct mem_node mem_z
;
315 #define MEM_NIL &mem_z
317 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
318 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
319 static void mem_insert_fixup (struct mem_node
*);
320 static void mem_rotate_left (struct mem_node
*);
321 static void mem_rotate_right (struct mem_node
*);
322 static void mem_delete (struct mem_node
*);
323 static void mem_delete_fixup (struct mem_node
*);
324 static struct mem_node
*mem_find (void *);
327 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
333 /* Addresses of staticpro'd variables. Initialize it to a nonzero
334 value; otherwise some compilers put it into BSS. */
336 enum { NSTATICS
= 2048 };
337 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
339 /* Index of next unused slot in staticvec. */
341 static int staticidx
;
343 static void *pure_alloc (size_t, int);
346 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
347 ALIGNMENT must be a power of 2. */
349 #define ALIGN(ptr, ALIGNMENT) \
350 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
351 & ~ ((ALIGNMENT) - 1)))
354 XFLOAT_INIT (Lisp_Object f
, double n
)
356 XFLOAT (f
)->u
.data
= n
;
360 /************************************************************************
362 ************************************************************************/
364 /* Function malloc calls this if it finds we are near exhausting storage. */
367 malloc_warning (const char *str
)
369 pending_malloc_warning
= str
;
373 /* Display an already-pending malloc warning. */
376 display_malloc_warning (void)
378 call3 (intern ("display-warning"),
380 build_string (pending_malloc_warning
),
381 intern ("emergency"));
382 pending_malloc_warning
= 0;
385 /* Called if we can't allocate relocatable space for a buffer. */
388 buffer_memory_full (ptrdiff_t nbytes
)
390 /* If buffers use the relocating allocator, no need to free
391 spare_memory, because we may have plenty of malloc space left
392 that we could get, and if we don't, the malloc that fails will
393 itself cause spare_memory to be freed. If buffers don't use the
394 relocating allocator, treat this like any other failing
398 memory_full (nbytes
);
400 /* This used to call error, but if we've run out of memory, we could
401 get infinite recursion trying to build the string. */
402 xsignal (Qnil
, Vmemory_signal_data
);
406 /* A common multiple of the positive integers A and B. Ideally this
407 would be the least common multiple, but there's no way to do that
408 as a constant expression in C, so do the best that we can easily do. */
409 #define COMMON_MULTIPLE(a, b) \
410 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
412 #ifndef XMALLOC_OVERRUN_CHECK
413 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
416 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
419 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
420 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
421 block size in little-endian order. The trailer consists of
422 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
424 The header is used to detect whether this block has been allocated
425 through these functions, as some low-level libc functions may
426 bypass the malloc hooks. */
428 #define XMALLOC_OVERRUN_CHECK_SIZE 16
429 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
430 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
432 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
433 hold a size_t value and (2) the header size is a multiple of the
434 alignment that Emacs needs for C types and for USE_LSB_TAG. */
435 #define XMALLOC_BASE_ALIGNMENT \
436 alignof (union { long double d; intmax_t i; void *p; })
439 # define XMALLOC_HEADER_ALIGNMENT \
440 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
442 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
444 #define XMALLOC_OVERRUN_SIZE_SIZE \
445 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
446 + XMALLOC_HEADER_ALIGNMENT - 1) \
447 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
448 - XMALLOC_OVERRUN_CHECK_SIZE)
450 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
451 { '\x9a', '\x9b', '\xae', '\xaf',
452 '\xbf', '\xbe', '\xce', '\xcf',
453 '\xea', '\xeb', '\xec', '\xed',
454 '\xdf', '\xde', '\x9c', '\x9d' };
456 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
457 { '\xaa', '\xab', '\xac', '\xad',
458 '\xba', '\xbb', '\xbc', '\xbd',
459 '\xca', '\xcb', '\xcc', '\xcd',
460 '\xda', '\xdb', '\xdc', '\xdd' };
462 /* Insert and extract the block size in the header. */
465 xmalloc_put_size (unsigned char *ptr
, size_t size
)
468 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
470 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
476 xmalloc_get_size (unsigned char *ptr
)
480 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
481 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
490 /* Like malloc, but wraps allocated block with header and trailer. */
493 overrun_check_malloc (size_t size
)
495 register unsigned char *val
;
496 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
499 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
502 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
503 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
504 xmalloc_put_size (val
, size
);
505 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
506 XMALLOC_OVERRUN_CHECK_SIZE
);
512 /* Like realloc, but checks old block for overrun, and wraps new block
513 with header and trailer. */
516 overrun_check_realloc (void *block
, size_t size
)
518 register unsigned char *val
= (unsigned char *) block
;
519 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
523 && memcmp (xmalloc_overrun_check_header
,
524 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
525 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
527 size_t osize
= xmalloc_get_size (val
);
528 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
529 XMALLOC_OVERRUN_CHECK_SIZE
))
531 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
532 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
533 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
536 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
540 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
541 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
542 xmalloc_put_size (val
, size
);
543 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
544 XMALLOC_OVERRUN_CHECK_SIZE
);
549 /* Like free, but checks block for overrun. */
552 overrun_check_free (void *block
)
554 unsigned char *val
= (unsigned char *) block
;
557 && memcmp (xmalloc_overrun_check_header
,
558 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
559 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
561 size_t osize
= xmalloc_get_size (val
);
562 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
563 XMALLOC_OVERRUN_CHECK_SIZE
))
565 #ifdef XMALLOC_CLEAR_FREE_MEMORY
566 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
567 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
569 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
570 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
571 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
581 #define malloc overrun_check_malloc
582 #define realloc overrun_check_realloc
583 #define free overrun_check_free
586 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
587 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
588 If that variable is set, block input while in one of Emacs's memory
589 allocation functions. There should be no need for this debugging
590 option, since signal handlers do not allocate memory, but Emacs
591 formerly allocated memory in signal handlers and this compile-time
592 option remains as a way to help debug the issue should it rear its
594 #ifdef XMALLOC_BLOCK_INPUT_CHECK
595 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
597 malloc_block_input (void)
599 if (block_input_in_memory_allocators
)
603 malloc_unblock_input (void)
605 if (block_input_in_memory_allocators
)
608 # define MALLOC_BLOCK_INPUT malloc_block_input ()
609 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
611 # define MALLOC_BLOCK_INPUT ((void) 0)
612 # define MALLOC_UNBLOCK_INPUT ((void) 0)
615 #define MALLOC_PROBE(size) \
617 if (profiler_memory_running) \
618 malloc_probe (size); \
622 /* Like malloc but check for no memory and block interrupt input.. */
625 xmalloc (size_t size
)
631 MALLOC_UNBLOCK_INPUT
;
639 /* Like the above, but zeroes out the memory just allocated. */
642 xzalloc (size_t size
)
648 MALLOC_UNBLOCK_INPUT
;
652 memset (val
, 0, size
);
657 /* Like realloc but check for no memory and block interrupt input.. */
660 xrealloc (void *block
, size_t size
)
665 /* We must call malloc explicitly when BLOCK is 0, since some
666 reallocs don't do this. */
670 val
= realloc (block
, size
);
671 MALLOC_UNBLOCK_INPUT
;
680 /* Like free but block interrupt input. */
689 MALLOC_UNBLOCK_INPUT
;
690 /* We don't call refill_memory_reserve here
691 because in practice the call in r_alloc_free seems to suffice. */
695 /* Other parts of Emacs pass large int values to allocator functions
696 expecting ptrdiff_t. This is portable in practice, but check it to
698 verify (INT_MAX
<= PTRDIFF_MAX
);
701 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
702 Signal an error on memory exhaustion, and block interrupt input. */
705 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
707 eassert (0 <= nitems
&& 0 < item_size
);
708 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
709 memory_full (SIZE_MAX
);
710 return xmalloc (nitems
* item_size
);
714 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
715 Signal an error on memory exhaustion, and block interrupt input. */
718 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
720 eassert (0 <= nitems
&& 0 < item_size
);
721 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
722 memory_full (SIZE_MAX
);
723 return xrealloc (pa
, nitems
* item_size
);
727 /* Grow PA, which points to an array of *NITEMS items, and return the
728 location of the reallocated array, updating *NITEMS to reflect its
729 new size. The new array will contain at least NITEMS_INCR_MIN more
730 items, but will not contain more than NITEMS_MAX items total.
731 ITEM_SIZE is the size of each item, in bytes.
733 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
734 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
737 If PA is null, then allocate a new array instead of reallocating
740 Block interrupt input as needed. If memory exhaustion occurs, set
741 *NITEMS to zero if PA is null, and signal an error (i.e., do not
744 Thus, to grow an array A without saving its old contents, do
745 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
746 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
747 and signals an error, and later this code is reexecuted and
748 attempts to free A. */
751 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
752 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
754 /* The approximate size to use for initial small allocation
755 requests. This is the largest "small" request for the GNU C
757 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
759 /* If the array is tiny, grow it to about (but no greater than)
760 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
761 ptrdiff_t n
= *nitems
;
762 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
763 ptrdiff_t half_again
= n
>> 1;
764 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
766 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
767 NITEMS_MAX, and what the C language can represent safely. */
768 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
769 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
770 ? nitems_max
: C_language_max
);
771 ptrdiff_t nitems_incr_max
= n_max
- n
;
772 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
774 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
777 if (nitems_incr_max
< incr
)
778 memory_full (SIZE_MAX
);
780 pa
= xrealloc (pa
, n
* item_size
);
786 /* Like strdup, but uses xmalloc. */
789 xstrdup (const char *s
)
793 size
= strlen (s
) + 1;
794 return memcpy (xmalloc (size
), s
, size
);
797 /* Like above, but duplicates Lisp string to C string. */
800 xlispstrdup (Lisp_Object string
)
802 ptrdiff_t size
= SBYTES (string
) + 1;
803 return memcpy (xmalloc (size
), SSDATA (string
), size
);
806 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
807 argument is a const pointer. */
810 xputenv (char const *string
)
812 if (putenv ((char *) string
) != 0)
816 /* Return a newly allocated memory block of SIZE bytes, remembering
817 to free it when unwinding. */
819 record_xmalloc (size_t size
)
821 void *p
= xmalloc (size
);
822 record_unwind_protect_ptr (xfree
, p
);
827 /* Like malloc but used for allocating Lisp data. NBYTES is the
828 number of bytes to allocate, TYPE describes the intended use of the
829 allocated memory block (for strings, for conses, ...). */
832 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
836 lisp_malloc (size_t nbytes
, enum mem_type type
)
842 #ifdef GC_MALLOC_CHECK
843 allocated_mem_type
= type
;
846 val
= malloc (nbytes
);
849 /* If the memory just allocated cannot be addressed thru a Lisp
850 object's pointer, and it needs to be,
851 that's equivalent to running out of memory. */
852 if (val
&& type
!= MEM_TYPE_NON_LISP
)
855 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
856 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
858 lisp_malloc_loser
= val
;
865 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
866 if (val
&& type
!= MEM_TYPE_NON_LISP
)
867 mem_insert (val
, (char *) val
+ nbytes
, type
);
870 MALLOC_UNBLOCK_INPUT
;
872 memory_full (nbytes
);
873 MALLOC_PROBE (nbytes
);
877 /* Free BLOCK. This must be called to free memory allocated with a
878 call to lisp_malloc. */
881 lisp_free (void *block
)
885 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
886 mem_delete (mem_find (block
));
888 MALLOC_UNBLOCK_INPUT
;
891 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
893 /* The entry point is lisp_align_malloc which returns blocks of at most
894 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
896 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
897 #define USE_POSIX_MEMALIGN 1
900 /* BLOCK_ALIGN has to be a power of 2. */
901 #define BLOCK_ALIGN (1 << 10)
903 /* Padding to leave at the end of a malloc'd block. This is to give
904 malloc a chance to minimize the amount of memory wasted to alignment.
905 It should be tuned to the particular malloc library used.
906 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
907 posix_memalign on the other hand would ideally prefer a value of 4
908 because otherwise, there's 1020 bytes wasted between each ablocks.
909 In Emacs, testing shows that those 1020 can most of the time be
910 efficiently used by malloc to place other objects, so a value of 0 can
911 still preferable unless you have a lot of aligned blocks and virtually
913 #define BLOCK_PADDING 0
914 #define BLOCK_BYTES \
915 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
917 /* Internal data structures and constants. */
919 #define ABLOCKS_SIZE 16
921 /* An aligned block of memory. */
926 char payload
[BLOCK_BYTES
];
927 struct ablock
*next_free
;
929 /* `abase' is the aligned base of the ablocks. */
930 /* It is overloaded to hold the virtual `busy' field that counts
931 the number of used ablock in the parent ablocks.
932 The first ablock has the `busy' field, the others have the `abase'
933 field. To tell the difference, we assume that pointers will have
934 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
935 is used to tell whether the real base of the parent ablocks is `abase'
936 (if not, the word before the first ablock holds a pointer to the
938 struct ablocks
*abase
;
939 /* The padding of all but the last ablock is unused. The padding of
940 the last ablock in an ablocks is not allocated. */
942 char padding
[BLOCK_PADDING
];
946 /* A bunch of consecutive aligned blocks. */
949 struct ablock blocks
[ABLOCKS_SIZE
];
952 /* Size of the block requested from malloc or posix_memalign. */
953 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
955 #define ABLOCK_ABASE(block) \
956 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
957 ? (struct ablocks *)(block) \
960 /* Virtual `busy' field. */
961 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
963 /* Pointer to the (not necessarily aligned) malloc block. */
964 #ifdef USE_POSIX_MEMALIGN
965 #define ABLOCKS_BASE(abase) (abase)
967 #define ABLOCKS_BASE(abase) \
968 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
971 /* The list of free ablock. */
972 static struct ablock
*free_ablock
;
974 /* Allocate an aligned block of nbytes.
975 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
976 smaller or equal to BLOCK_BYTES. */
978 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
981 struct ablocks
*abase
;
983 eassert (nbytes
<= BLOCK_BYTES
);
987 #ifdef GC_MALLOC_CHECK
988 allocated_mem_type
= type
;
994 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
996 #ifdef DOUG_LEA_MALLOC
997 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
998 because mapped region contents are not preserved in
1000 mallopt (M_MMAP_MAX
, 0);
1003 #ifdef USE_POSIX_MEMALIGN
1005 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1011 base
= malloc (ABLOCKS_BYTES
);
1012 abase
= ALIGN (base
, BLOCK_ALIGN
);
1017 MALLOC_UNBLOCK_INPUT
;
1018 memory_full (ABLOCKS_BYTES
);
1021 aligned
= (base
== abase
);
1023 ((void**)abase
)[-1] = base
;
1025 #ifdef DOUG_LEA_MALLOC
1026 /* Back to a reasonable maximum of mmap'ed areas. */
1027 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1031 /* If the memory just allocated cannot be addressed thru a Lisp
1032 object's pointer, and it needs to be, that's equivalent to
1033 running out of memory. */
1034 if (type
!= MEM_TYPE_NON_LISP
)
1037 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1038 XSETCONS (tem
, end
);
1039 if ((char *) XCONS (tem
) != end
)
1041 lisp_malloc_loser
= base
;
1043 MALLOC_UNBLOCK_INPUT
;
1044 memory_full (SIZE_MAX
);
1049 /* Initialize the blocks and put them on the free list.
1050 If `base' was not properly aligned, we can't use the last block. */
1051 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1053 abase
->blocks
[i
].abase
= abase
;
1054 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1055 free_ablock
= &abase
->blocks
[i
];
1057 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1059 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1060 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1061 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1062 eassert (ABLOCKS_BASE (abase
) == base
);
1063 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1066 abase
= ABLOCK_ABASE (free_ablock
);
1067 ABLOCKS_BUSY (abase
) =
1068 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1070 free_ablock
= free_ablock
->x
.next_free
;
1072 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1073 if (type
!= MEM_TYPE_NON_LISP
)
1074 mem_insert (val
, (char *) val
+ nbytes
, type
);
1077 MALLOC_UNBLOCK_INPUT
;
1079 MALLOC_PROBE (nbytes
);
1081 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1086 lisp_align_free (void *block
)
1088 struct ablock
*ablock
= block
;
1089 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1092 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1093 mem_delete (mem_find (block
));
1095 /* Put on free list. */
1096 ablock
->x
.next_free
= free_ablock
;
1097 free_ablock
= ablock
;
1098 /* Update busy count. */
1099 ABLOCKS_BUSY (abase
)
1100 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1102 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1103 { /* All the blocks are free. */
1104 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1105 struct ablock
**tem
= &free_ablock
;
1106 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1110 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1113 *tem
= (*tem
)->x
.next_free
;
1116 tem
= &(*tem
)->x
.next_free
;
1118 eassert ((aligned
& 1) == aligned
);
1119 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1120 #ifdef USE_POSIX_MEMALIGN
1121 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1123 free (ABLOCKS_BASE (abase
));
1125 MALLOC_UNBLOCK_INPUT
;
1129 /***********************************************************************
1131 ***********************************************************************/
1133 /* Number of intervals allocated in an interval_block structure.
1134 The 1020 is 1024 minus malloc overhead. */
1136 #define INTERVAL_BLOCK_SIZE \
1137 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1139 /* Intervals are allocated in chunks in the form of an interval_block
1142 struct interval_block
1144 /* Place `intervals' first, to preserve alignment. */
1145 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1146 struct interval_block
*next
;
1149 /* Current interval block. Its `next' pointer points to older
1152 static struct interval_block
*interval_block
;
1154 /* Index in interval_block above of the next unused interval
1157 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1159 /* Number of free and live intervals. */
1161 static EMACS_INT total_free_intervals
, total_intervals
;
1163 /* List of free intervals. */
1165 static INTERVAL interval_free_list
;
1167 /* Return a new interval. */
1170 make_interval (void)
1176 if (interval_free_list
)
1178 val
= interval_free_list
;
1179 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1183 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1185 struct interval_block
*newi
1186 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1188 newi
->next
= interval_block
;
1189 interval_block
= newi
;
1190 interval_block_index
= 0;
1191 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1193 val
= &interval_block
->intervals
[interval_block_index
++];
1196 MALLOC_UNBLOCK_INPUT
;
1198 consing_since_gc
+= sizeof (struct interval
);
1200 total_free_intervals
--;
1201 RESET_INTERVAL (val
);
1207 /* Mark Lisp objects in interval I. */
1210 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1212 /* Intervals should never be shared. So, if extra internal checking is
1213 enabled, GC aborts if it seems to have visited an interval twice. */
1214 eassert (!i
->gcmarkbit
);
1216 mark_object (i
->plist
);
1219 /* Mark the interval tree rooted in I. */
1221 #define MARK_INTERVAL_TREE(i) \
1223 if (i && !i->gcmarkbit) \
1224 traverse_intervals_noorder (i, mark_interval, Qnil); \
1227 /***********************************************************************
1229 ***********************************************************************/
1231 /* Lisp_Strings are allocated in string_block structures. When a new
1232 string_block is allocated, all the Lisp_Strings it contains are
1233 added to a free-list string_free_list. When a new Lisp_String is
1234 needed, it is taken from that list. During the sweep phase of GC,
1235 string_blocks that are entirely free are freed, except two which
1238 String data is allocated from sblock structures. Strings larger
1239 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1240 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1242 Sblocks consist internally of sdata structures, one for each
1243 Lisp_String. The sdata structure points to the Lisp_String it
1244 belongs to. The Lisp_String points back to the `u.data' member of
1245 its sdata structure.
1247 When a Lisp_String is freed during GC, it is put back on
1248 string_free_list, and its `data' member and its sdata's `string'
1249 pointer is set to null. The size of the string is recorded in the
1250 `n.nbytes' member of the sdata. So, sdata structures that are no
1251 longer used, can be easily recognized, and it's easy to compact the
1252 sblocks of small strings which we do in compact_small_strings. */
1254 /* Size in bytes of an sblock structure used for small strings. This
1255 is 8192 minus malloc overhead. */
1257 #define SBLOCK_SIZE 8188
1259 /* Strings larger than this are considered large strings. String data
1260 for large strings is allocated from individual sblocks. */
1262 #define LARGE_STRING_BYTES 1024
1264 /* Struct or union describing string memory sub-allocated from an sblock.
1265 This is where the contents of Lisp strings are stored. */
1267 #ifdef GC_CHECK_STRING_BYTES
1271 /* Back-pointer to the string this sdata belongs to. If null, this
1272 structure is free, and the NBYTES member of the union below
1273 contains the string's byte size (the same value that STRING_BYTES
1274 would return if STRING were non-null). If non-null, STRING_BYTES
1275 (STRING) is the size of the data, and DATA contains the string's
1277 struct Lisp_String
*string
;
1280 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1283 #define SDATA_NBYTES(S) (S)->nbytes
1284 #define SDATA_DATA(S) (S)->data
1285 #define SDATA_SELECTOR(member) member
1291 struct Lisp_String
*string
;
1293 /* When STRING is non-null. */
1296 struct Lisp_String
*string
;
1297 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1300 /* When STRING is null. */
1303 struct Lisp_String
*string
;
1308 #define SDATA_NBYTES(S) (S)->n.nbytes
1309 #define SDATA_DATA(S) (S)->u.data
1310 #define SDATA_SELECTOR(member) u.member
1312 #endif /* not GC_CHECK_STRING_BYTES */
1314 #define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1317 /* Structure describing a block of memory which is sub-allocated to
1318 obtain string data memory for strings. Blocks for small strings
1319 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1320 as large as needed. */
1325 struct sblock
*next
;
1327 /* Pointer to the next free sdata block. This points past the end
1328 of the sblock if there isn't any space left in this block. */
1331 /* Start of data. */
1335 /* Number of Lisp strings in a string_block structure. The 1020 is
1336 1024 minus malloc overhead. */
1338 #define STRING_BLOCK_SIZE \
1339 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1341 /* Structure describing a block from which Lisp_String structures
1346 /* Place `strings' first, to preserve alignment. */
1347 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1348 struct string_block
*next
;
1351 /* Head and tail of the list of sblock structures holding Lisp string
1352 data. We always allocate from current_sblock. The NEXT pointers
1353 in the sblock structures go from oldest_sblock to current_sblock. */
1355 static struct sblock
*oldest_sblock
, *current_sblock
;
1357 /* List of sblocks for large strings. */
1359 static struct sblock
*large_sblocks
;
1361 /* List of string_block structures. */
1363 static struct string_block
*string_blocks
;
1365 /* Free-list of Lisp_Strings. */
1367 static struct Lisp_String
*string_free_list
;
1369 /* Number of live and free Lisp_Strings. */
1371 static EMACS_INT total_strings
, total_free_strings
;
1373 /* Number of bytes used by live strings. */
1375 static EMACS_INT total_string_bytes
;
1377 /* Given a pointer to a Lisp_String S which is on the free-list
1378 string_free_list, return a pointer to its successor in the
1381 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1383 /* Return a pointer to the sdata structure belonging to Lisp string S.
1384 S must be live, i.e. S->data must not be null. S->data is actually
1385 a pointer to the `u.data' member of its sdata structure; the
1386 structure starts at a constant offset in front of that. */
1388 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1391 #ifdef GC_CHECK_STRING_OVERRUN
1393 /* We check for overrun in string data blocks by appending a small
1394 "cookie" after each allocated string data block, and check for the
1395 presence of this cookie during GC. */
1397 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1398 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1399 { '\xde', '\xad', '\xbe', '\xef' };
1402 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1405 /* Value is the size of an sdata structure large enough to hold NBYTES
1406 bytes of string data. The value returned includes a terminating
1407 NUL byte, the size of the sdata structure, and padding. */
1409 #ifdef GC_CHECK_STRING_BYTES
1411 #define SDATA_SIZE(NBYTES) \
1412 ((SDATA_DATA_OFFSET \
1414 + sizeof (ptrdiff_t) - 1) \
1415 & ~(sizeof (ptrdiff_t) - 1))
1417 #else /* not GC_CHECK_STRING_BYTES */
1419 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1420 less than the size of that member. The 'max' is not needed when
1421 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1422 alignment code reserves enough space. */
1424 #define SDATA_SIZE(NBYTES) \
1425 ((SDATA_DATA_OFFSET \
1426 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1428 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1430 + sizeof (ptrdiff_t) - 1) \
1431 & ~(sizeof (ptrdiff_t) - 1))
1433 #endif /* not GC_CHECK_STRING_BYTES */
1435 /* Extra bytes to allocate for each string. */
1437 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1439 /* Exact bound on the number of bytes in a string, not counting the
1440 terminating null. A string cannot contain more bytes than
1441 STRING_BYTES_BOUND, nor can it be so long that the size_t
1442 arithmetic in allocate_string_data would overflow while it is
1443 calculating a value to be passed to malloc. */
1444 static ptrdiff_t const STRING_BYTES_MAX
=
1445 min (STRING_BYTES_BOUND
,
1446 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1448 - offsetof (struct sblock
, first_data
)
1449 - SDATA_DATA_OFFSET
)
1450 & ~(sizeof (EMACS_INT
) - 1)));
1452 /* Initialize string allocation. Called from init_alloc_once. */
1457 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1458 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1462 #ifdef GC_CHECK_STRING_BYTES
1464 static int check_string_bytes_count
;
1466 /* Like STRING_BYTES, but with debugging check. Can be
1467 called during GC, so pay attention to the mark bit. */
1470 string_bytes (struct Lisp_String
*s
)
1473 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1475 if (!PURE_POINTER_P (s
)
1477 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1482 /* Check validity of Lisp strings' string_bytes member in B. */
1485 check_sblock (struct sblock
*b
)
1487 sdata
*from
, *end
, *from_end
;
1491 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1493 /* Compute the next FROM here because copying below may
1494 overwrite data we need to compute it. */
1497 /* Check that the string size recorded in the string is the
1498 same as the one recorded in the sdata structure. */
1499 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1500 : SDATA_NBYTES (from
));
1501 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1506 /* Check validity of Lisp strings' string_bytes member. ALL_P
1507 means check all strings, otherwise check only most
1508 recently allocated strings. Used for hunting a bug. */
1511 check_string_bytes (bool all_p
)
1517 for (b
= large_sblocks
; b
; b
= b
->next
)
1519 struct Lisp_String
*s
= b
->first_data
.string
;
1524 for (b
= oldest_sblock
; b
; b
= b
->next
)
1527 else if (current_sblock
)
1528 check_sblock (current_sblock
);
1531 #else /* not GC_CHECK_STRING_BYTES */
1533 #define check_string_bytes(all) ((void) 0)
1535 #endif /* GC_CHECK_STRING_BYTES */
1537 #ifdef GC_CHECK_STRING_FREE_LIST
1539 /* Walk through the string free list looking for bogus next pointers.
1540 This may catch buffer overrun from a previous string. */
1543 check_string_free_list (void)
1545 struct Lisp_String
*s
;
1547 /* Pop a Lisp_String off the free-list. */
1548 s
= string_free_list
;
1551 if ((uintptr_t) s
< 1024)
1553 s
= NEXT_FREE_LISP_STRING (s
);
1557 #define check_string_free_list()
1560 /* Return a new Lisp_String. */
1562 static struct Lisp_String
*
1563 allocate_string (void)
1565 struct Lisp_String
*s
;
1569 /* If the free-list is empty, allocate a new string_block, and
1570 add all the Lisp_Strings in it to the free-list. */
1571 if (string_free_list
== NULL
)
1573 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1576 b
->next
= string_blocks
;
1579 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1582 /* Every string on a free list should have NULL data pointer. */
1584 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1585 string_free_list
= s
;
1588 total_free_strings
+= STRING_BLOCK_SIZE
;
1591 check_string_free_list ();
1593 /* Pop a Lisp_String off the free-list. */
1594 s
= string_free_list
;
1595 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1597 MALLOC_UNBLOCK_INPUT
;
1599 --total_free_strings
;
1602 consing_since_gc
+= sizeof *s
;
1604 #ifdef GC_CHECK_STRING_BYTES
1605 if (!noninteractive
)
1607 if (++check_string_bytes_count
== 200)
1609 check_string_bytes_count
= 0;
1610 check_string_bytes (1);
1613 check_string_bytes (0);
1615 #endif /* GC_CHECK_STRING_BYTES */
1621 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1622 plus a NUL byte at the end. Allocate an sdata structure for S, and
1623 set S->data to its `u.data' member. Store a NUL byte at the end of
1624 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1625 S->data if it was initially non-null. */
1628 allocate_string_data (struct Lisp_String
*s
,
1629 EMACS_INT nchars
, EMACS_INT nbytes
)
1631 sdata
*data
, *old_data
;
1633 ptrdiff_t needed
, old_nbytes
;
1635 if (STRING_BYTES_MAX
< nbytes
)
1638 /* Determine the number of bytes needed to store NBYTES bytes
1640 needed
= SDATA_SIZE (nbytes
);
1643 old_data
= SDATA_OF_STRING (s
);
1644 old_nbytes
= STRING_BYTES (s
);
1651 if (nbytes
> LARGE_STRING_BYTES
)
1653 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1655 #ifdef DOUG_LEA_MALLOC
1656 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1657 because mapped region contents are not preserved in
1660 In case you think of allowing it in a dumped Emacs at the
1661 cost of not being able to re-dump, there's another reason:
1662 mmap'ed data typically have an address towards the top of the
1663 address space, which won't fit into an EMACS_INT (at least on
1664 32-bit systems with the current tagging scheme). --fx */
1665 mallopt (M_MMAP_MAX
, 0);
1668 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1670 #ifdef DOUG_LEA_MALLOC
1671 /* Back to a reasonable maximum of mmap'ed areas. */
1672 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1675 b
->next_free
= &b
->first_data
;
1676 b
->first_data
.string
= NULL
;
1677 b
->next
= large_sblocks
;
1680 else if (current_sblock
== NULL
1681 || (((char *) current_sblock
+ SBLOCK_SIZE
1682 - (char *) current_sblock
->next_free
)
1683 < (needed
+ GC_STRING_EXTRA
)))
1685 /* Not enough room in the current sblock. */
1686 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1687 b
->next_free
= &b
->first_data
;
1688 b
->first_data
.string
= NULL
;
1692 current_sblock
->next
= b
;
1700 data
= b
->next_free
;
1701 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1703 MALLOC_UNBLOCK_INPUT
;
1706 s
->data
= SDATA_DATA (data
);
1707 #ifdef GC_CHECK_STRING_BYTES
1708 SDATA_NBYTES (data
) = nbytes
;
1711 s
->size_byte
= nbytes
;
1712 s
->data
[nbytes
] = '\0';
1713 #ifdef GC_CHECK_STRING_OVERRUN
1714 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1715 GC_STRING_OVERRUN_COOKIE_SIZE
);
1718 /* Note that Faset may call to this function when S has already data
1719 assigned. In this case, mark data as free by setting it's string
1720 back-pointer to null, and record the size of the data in it. */
1723 SDATA_NBYTES (old_data
) = old_nbytes
;
1724 old_data
->string
= NULL
;
1727 consing_since_gc
+= needed
;
1731 /* Sweep and compact strings. */
1734 sweep_strings (void)
1736 struct string_block
*b
, *next
;
1737 struct string_block
*live_blocks
= NULL
;
1739 string_free_list
= NULL
;
1740 total_strings
= total_free_strings
= 0;
1741 total_string_bytes
= 0;
1743 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1744 for (b
= string_blocks
; b
; b
= next
)
1747 struct Lisp_String
*free_list_before
= string_free_list
;
1751 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1753 struct Lisp_String
*s
= b
->strings
+ i
;
1757 /* String was not on free-list before. */
1758 if (STRING_MARKED_P (s
))
1760 /* String is live; unmark it and its intervals. */
1763 /* Do not use string_(set|get)_intervals here. */
1764 s
->intervals
= balance_intervals (s
->intervals
);
1767 total_string_bytes
+= STRING_BYTES (s
);
1771 /* String is dead. Put it on the free-list. */
1772 sdata
*data
= SDATA_OF_STRING (s
);
1774 /* Save the size of S in its sdata so that we know
1775 how large that is. Reset the sdata's string
1776 back-pointer so that we know it's free. */
1777 #ifdef GC_CHECK_STRING_BYTES
1778 if (string_bytes (s
) != SDATA_NBYTES (data
))
1781 data
->n
.nbytes
= STRING_BYTES (s
);
1783 data
->string
= NULL
;
1785 /* Reset the strings's `data' member so that we
1789 /* Put the string on the free-list. */
1790 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1791 string_free_list
= s
;
1797 /* S was on the free-list before. Put it there again. */
1798 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1799 string_free_list
= s
;
1804 /* Free blocks that contain free Lisp_Strings only, except
1805 the first two of them. */
1806 if (nfree
== STRING_BLOCK_SIZE
1807 && total_free_strings
> STRING_BLOCK_SIZE
)
1810 string_free_list
= free_list_before
;
1814 total_free_strings
+= nfree
;
1815 b
->next
= live_blocks
;
1820 check_string_free_list ();
1822 string_blocks
= live_blocks
;
1823 free_large_strings ();
1824 compact_small_strings ();
1826 check_string_free_list ();
1830 /* Free dead large strings. */
1833 free_large_strings (void)
1835 struct sblock
*b
, *next
;
1836 struct sblock
*live_blocks
= NULL
;
1838 for (b
= large_sblocks
; b
; b
= next
)
1842 if (b
->first_data
.string
== NULL
)
1846 b
->next
= live_blocks
;
1851 large_sblocks
= live_blocks
;
1855 /* Compact data of small strings. Free sblocks that don't contain
1856 data of live strings after compaction. */
1859 compact_small_strings (void)
1861 struct sblock
*b
, *tb
, *next
;
1862 sdata
*from
, *to
, *end
, *tb_end
;
1863 sdata
*to_end
, *from_end
;
1865 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1866 to, and TB_END is the end of TB. */
1868 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1869 to
= &tb
->first_data
;
1871 /* Step through the blocks from the oldest to the youngest. We
1872 expect that old blocks will stabilize over time, so that less
1873 copying will happen this way. */
1874 for (b
= oldest_sblock
; b
; b
= b
->next
)
1877 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1879 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1881 /* Compute the next FROM here because copying below may
1882 overwrite data we need to compute it. */
1884 struct Lisp_String
*s
= from
->string
;
1886 #ifdef GC_CHECK_STRING_BYTES
1887 /* Check that the string size recorded in the string is the
1888 same as the one recorded in the sdata structure. */
1889 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1891 #endif /* GC_CHECK_STRING_BYTES */
1893 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1894 eassert (nbytes
<= LARGE_STRING_BYTES
);
1896 nbytes
= SDATA_SIZE (nbytes
);
1897 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1899 #ifdef GC_CHECK_STRING_OVERRUN
1900 if (memcmp (string_overrun_cookie
,
1901 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1902 GC_STRING_OVERRUN_COOKIE_SIZE
))
1906 /* Non-NULL S means it's alive. Copy its data. */
1909 /* If TB is full, proceed with the next sblock. */
1910 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1911 if (to_end
> tb_end
)
1915 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1916 to
= &tb
->first_data
;
1917 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1920 /* Copy, and update the string's `data' pointer. */
1923 eassert (tb
!= b
|| to
< from
);
1924 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1925 to
->string
->data
= SDATA_DATA (to
);
1928 /* Advance past the sdata we copied to. */
1934 /* The rest of the sblocks following TB don't contain live data, so
1935 we can free them. */
1936 for (b
= tb
->next
; b
; b
= next
)
1944 current_sblock
= tb
;
1948 string_overflow (void)
1950 error ("Maximum string size exceeded");
1953 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1954 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1955 LENGTH must be an integer.
1956 INIT must be an integer that represents a character. */)
1957 (Lisp_Object length
, Lisp_Object init
)
1959 register Lisp_Object val
;
1960 register unsigned char *p
, *end
;
1964 CHECK_NATNUM (length
);
1965 CHECK_CHARACTER (init
);
1967 c
= XFASTINT (init
);
1968 if (ASCII_CHAR_P (c
))
1970 nbytes
= XINT (length
);
1971 val
= make_uninit_string (nbytes
);
1973 end
= p
+ SCHARS (val
);
1979 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1980 int len
= CHAR_STRING (c
, str
);
1981 EMACS_INT string_len
= XINT (length
);
1983 if (string_len
> STRING_BYTES_MAX
/ len
)
1985 nbytes
= len
* string_len
;
1986 val
= make_uninit_multibyte_string (string_len
, nbytes
);
1991 memcpy (p
, str
, len
);
2001 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2002 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2003 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2004 (Lisp_Object length
, Lisp_Object init
)
2006 register Lisp_Object val
;
2007 struct Lisp_Bool_Vector
*p
;
2008 ptrdiff_t length_in_chars
;
2009 EMACS_INT length_in_elts
;
2011 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2014 CHECK_NATNUM (length
);
2016 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2018 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2020 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2022 /* No Lisp_Object to trace in there. */
2023 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2025 p
= XBOOL_VECTOR (val
);
2026 p
->size
= XFASTINT (length
);
2028 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2029 / BOOL_VECTOR_BITS_PER_CHAR
);
2030 if (length_in_chars
)
2032 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2034 /* Clear any extraneous bits in the last byte. */
2035 p
->data
[length_in_chars
- 1]
2036 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2043 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2044 of characters from the contents. This string may be unibyte or
2045 multibyte, depending on the contents. */
2048 make_string (const char *contents
, ptrdiff_t nbytes
)
2050 register Lisp_Object val
;
2051 ptrdiff_t nchars
, multibyte_nbytes
;
2053 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2054 &nchars
, &multibyte_nbytes
);
2055 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2056 /* CONTENTS contains no multibyte sequences or contains an invalid
2057 multibyte sequence. We must make unibyte string. */
2058 val
= make_unibyte_string (contents
, nbytes
);
2060 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2065 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2068 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2070 register Lisp_Object val
;
2071 val
= make_uninit_string (length
);
2072 memcpy (SDATA (val
), contents
, length
);
2077 /* Make a multibyte string from NCHARS characters occupying NBYTES
2078 bytes at CONTENTS. */
2081 make_multibyte_string (const char *contents
,
2082 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2084 register Lisp_Object val
;
2085 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2086 memcpy (SDATA (val
), contents
, nbytes
);
2091 /* Make a string from NCHARS characters occupying NBYTES bytes at
2092 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2095 make_string_from_bytes (const char *contents
,
2096 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2098 register Lisp_Object val
;
2099 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2100 memcpy (SDATA (val
), contents
, nbytes
);
2101 if (SBYTES (val
) == SCHARS (val
))
2102 STRING_SET_UNIBYTE (val
);
2107 /* Make a string from NCHARS characters occupying NBYTES bytes at
2108 CONTENTS. The argument MULTIBYTE controls whether to label the
2109 string as multibyte. If NCHARS is negative, it counts the number of
2110 characters by itself. */
2113 make_specified_string (const char *contents
,
2114 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2121 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2126 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2127 memcpy (SDATA (val
), contents
, nbytes
);
2129 STRING_SET_UNIBYTE (val
);
2134 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2135 occupying LENGTH bytes. */
2138 make_uninit_string (EMACS_INT length
)
2143 return empty_unibyte_string
;
2144 val
= make_uninit_multibyte_string (length
, length
);
2145 STRING_SET_UNIBYTE (val
);
2150 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2151 which occupy NBYTES bytes. */
2154 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2157 struct Lisp_String
*s
;
2162 return empty_multibyte_string
;
2164 s
= allocate_string ();
2165 s
->intervals
= NULL
;
2166 allocate_string_data (s
, nchars
, nbytes
);
2167 XSETSTRING (string
, s
);
2168 string_chars_consed
+= nbytes
;
2172 /* Print arguments to BUF according to a FORMAT, then return
2173 a Lisp_String initialized with the data from BUF. */
2176 make_formatted_string (char *buf
, const char *format
, ...)
2181 va_start (ap
, format
);
2182 length
= vsprintf (buf
, format
, ap
);
2184 return make_string (buf
, length
);
2188 /***********************************************************************
2190 ***********************************************************************/
2192 /* We store float cells inside of float_blocks, allocating a new
2193 float_block with malloc whenever necessary. Float cells reclaimed
2194 by GC are put on a free list to be reallocated before allocating
2195 any new float cells from the latest float_block. */
2197 #define FLOAT_BLOCK_SIZE \
2198 (((BLOCK_BYTES - sizeof (struct float_block *) \
2199 /* The compiler might add padding at the end. */ \
2200 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2201 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2203 #define GETMARKBIT(block,n) \
2204 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2205 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2208 #define SETMARKBIT(block,n) \
2209 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2210 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2212 #define UNSETMARKBIT(block,n) \
2213 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2214 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2216 #define FLOAT_BLOCK(fptr) \
2217 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2219 #define FLOAT_INDEX(fptr) \
2220 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2224 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2225 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2226 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2227 struct float_block
*next
;
2230 #define FLOAT_MARKED_P(fptr) \
2231 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2233 #define FLOAT_MARK(fptr) \
2234 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2236 #define FLOAT_UNMARK(fptr) \
2237 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2239 /* Current float_block. */
2241 static struct float_block
*float_block
;
2243 /* Index of first unused Lisp_Float in the current float_block. */
2245 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2247 /* Free-list of Lisp_Floats. */
2249 static struct Lisp_Float
*float_free_list
;
2251 /* Return a new float object with value FLOAT_VALUE. */
2254 make_float (double float_value
)
2256 register Lisp_Object val
;
2260 if (float_free_list
)
2262 /* We use the data field for chaining the free list
2263 so that we won't use the same field that has the mark bit. */
2264 XSETFLOAT (val
, float_free_list
);
2265 float_free_list
= float_free_list
->u
.chain
;
2269 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2271 struct float_block
*new
2272 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2273 new->next
= float_block
;
2274 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2276 float_block_index
= 0;
2277 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2279 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2280 float_block_index
++;
2283 MALLOC_UNBLOCK_INPUT
;
2285 XFLOAT_INIT (val
, float_value
);
2286 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2287 consing_since_gc
+= sizeof (struct Lisp_Float
);
2289 total_free_floats
--;
2295 /***********************************************************************
2297 ***********************************************************************/
2299 /* We store cons cells inside of cons_blocks, allocating a new
2300 cons_block with malloc whenever necessary. Cons cells reclaimed by
2301 GC are put on a free list to be reallocated before allocating
2302 any new cons cells from the latest cons_block. */
2304 #define CONS_BLOCK_SIZE \
2305 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2306 /* The compiler might add padding at the end. */ \
2307 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2308 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2310 #define CONS_BLOCK(fptr) \
2311 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2313 #define CONS_INDEX(fptr) \
2314 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2318 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2319 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2320 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2321 struct cons_block
*next
;
2324 #define CONS_MARKED_P(fptr) \
2325 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2327 #define CONS_MARK(fptr) \
2328 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2330 #define CONS_UNMARK(fptr) \
2331 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2333 /* Current cons_block. */
2335 static struct cons_block
*cons_block
;
2337 /* Index of first unused Lisp_Cons in the current block. */
2339 static int cons_block_index
= CONS_BLOCK_SIZE
;
2341 /* Free-list of Lisp_Cons structures. */
2343 static struct Lisp_Cons
*cons_free_list
;
2345 /* Explicitly free a cons cell by putting it on the free-list. */
2348 free_cons (struct Lisp_Cons
*ptr
)
2350 ptr
->u
.chain
= cons_free_list
;
2354 cons_free_list
= ptr
;
2355 consing_since_gc
-= sizeof *ptr
;
2356 total_free_conses
++;
2359 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2360 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2361 (Lisp_Object car
, Lisp_Object cdr
)
2363 register Lisp_Object val
;
2369 /* We use the cdr for chaining the free list
2370 so that we won't use the same field that has the mark bit. */
2371 XSETCONS (val
, cons_free_list
);
2372 cons_free_list
= cons_free_list
->u
.chain
;
2376 if (cons_block_index
== CONS_BLOCK_SIZE
)
2378 struct cons_block
*new
2379 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2380 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2381 new->next
= cons_block
;
2383 cons_block_index
= 0;
2384 total_free_conses
+= CONS_BLOCK_SIZE
;
2386 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2390 MALLOC_UNBLOCK_INPUT
;
2394 eassert (!CONS_MARKED_P (XCONS (val
)));
2395 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2396 total_free_conses
--;
2397 cons_cells_consed
++;
2401 #ifdef GC_CHECK_CONS_LIST
2402 /* Get an error now if there's any junk in the cons free list. */
2404 check_cons_list (void)
2406 struct Lisp_Cons
*tail
= cons_free_list
;
2409 tail
= tail
->u
.chain
;
2413 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2416 list1 (Lisp_Object arg1
)
2418 return Fcons (arg1
, Qnil
);
2422 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2424 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2429 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2431 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2436 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2438 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2443 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2445 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2446 Fcons (arg5
, Qnil
)))));
2449 /* Make a list of COUNT Lisp_Objects, where ARG is the
2450 first one. Allocate conses from pure space if TYPE
2451 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2454 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2458 Lisp_Object val
, *objp
;
2460 /* Change to SAFE_ALLOCA if you hit this eassert. */
2461 eassert (count
<= MAX_ALLOCA
/ word_size
);
2463 objp
= alloca (count
* word_size
);
2466 for (i
= 1; i
< count
; i
++)
2467 objp
[i
] = va_arg (ap
, Lisp_Object
);
2470 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2472 if (type
== CONSTYPE_PURE
)
2473 val
= pure_cons (objp
[i
], val
);
2474 else if (type
== CONSTYPE_HEAP
)
2475 val
= Fcons (objp
[i
], val
);
2482 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2483 doc
: /* Return a newly created list with specified arguments as elements.
2484 Any number of arguments, even zero arguments, are allowed.
2485 usage: (list &rest OBJECTS) */)
2486 (ptrdiff_t nargs
, Lisp_Object
*args
)
2488 register Lisp_Object val
;
2494 val
= Fcons (args
[nargs
], val
);
2500 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2501 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2502 (register Lisp_Object length
, Lisp_Object init
)
2504 register Lisp_Object val
;
2505 register EMACS_INT size
;
2507 CHECK_NATNUM (length
);
2508 size
= XFASTINT (length
);
2513 val
= Fcons (init
, val
);
2518 val
= Fcons (init
, val
);
2523 val
= Fcons (init
, val
);
2528 val
= Fcons (init
, val
);
2533 val
= Fcons (init
, val
);
2548 /***********************************************************************
2550 ***********************************************************************/
2552 /* This value is balanced well enough to avoid too much internal overhead
2553 for the most common cases; it's not required to be a power of two, but
2554 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2556 #define VECTOR_BLOCK_SIZE 4096
2558 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2561 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2564 /* ROUNDUP_SIZE must be a power of 2. */
2565 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2567 /* Verify assumptions described above. */
2568 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2569 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2571 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2573 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2575 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2577 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2579 /* Size of the minimal vector allocated from block. */
2581 #define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
2583 /* Size of the largest vector allocated from block. */
2585 #define VBLOCK_BYTES_MAX \
2586 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2588 /* We maintain one free list for each possible block-allocated
2589 vector size, and this is the number of free lists we have. */
2591 #define VECTOR_MAX_FREE_LIST_INDEX \
2592 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2594 /* Common shortcut to advance vector pointer over a block data. */
2596 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2598 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2600 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2602 /* Get and set the next field in block-allocated vectorlike objects on
2603 the free list. Doing it this way respects C's aliasing rules.
2604 We could instead make 'contents' a union, but that would mean
2605 changes everywhere that the code uses 'contents'. */
2606 static struct Lisp_Vector
*
2607 next_in_free_list (struct Lisp_Vector
*v
)
2609 intptr_t i
= XLI (v
->contents
[0]);
2610 return (struct Lisp_Vector
*) i
;
2613 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2615 v
->contents
[0] = XIL ((intptr_t) next
);
2618 /* Common shortcut to setup vector on a free list. */
2620 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2622 (tmp) = ((nbytes - header_size) / word_size); \
2623 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2624 eassert ((nbytes) % roundup_size == 0); \
2625 (tmp) = VINDEX (nbytes); \
2626 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2627 set_next_in_free_list (v, vector_free_lists[tmp]); \
2628 vector_free_lists[tmp] = (v); \
2629 total_free_vector_slots += (nbytes) / word_size; \
2632 /* This internal type is used to maintain the list of large vectors
2633 which are allocated at their own, e.g. outside of vector blocks. */
2638 struct large_vector
*vector
;
2640 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2641 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2644 struct Lisp_Vector v
;
2647 /* This internal type is used to maintain an underlying storage
2648 for small vectors. */
2652 char data
[VECTOR_BLOCK_BYTES
];
2653 struct vector_block
*next
;
2656 /* Chain of vector blocks. */
2658 static struct vector_block
*vector_blocks
;
2660 /* Vector free lists, where NTH item points to a chain of free
2661 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2663 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2665 /* Singly-linked list of large vectors. */
2667 static struct large_vector
*large_vectors
;
2669 /* The only vector with 0 slots, allocated from pure space. */
2671 Lisp_Object zero_vector
;
2673 /* Number of live vectors. */
2675 static EMACS_INT total_vectors
;
2677 /* Total size of live and free vectors, in Lisp_Object units. */
2679 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2681 /* Get a new vector block. */
2683 static struct vector_block
*
2684 allocate_vector_block (void)
2686 struct vector_block
*block
= xmalloc (sizeof *block
);
2688 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2689 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2690 MEM_TYPE_VECTOR_BLOCK
);
2693 block
->next
= vector_blocks
;
2694 vector_blocks
= block
;
2698 /* Called once to initialize vector allocation. */
2703 zero_vector
= make_pure_vector (0);
2706 /* Allocate vector from a vector block. */
2708 static struct Lisp_Vector
*
2709 allocate_vector_from_block (size_t nbytes
)
2711 struct Lisp_Vector
*vector
;
2712 struct vector_block
*block
;
2713 size_t index
, restbytes
;
2715 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2716 eassert (nbytes
% roundup_size
== 0);
2718 /* First, try to allocate from a free list
2719 containing vectors of the requested size. */
2720 index
= VINDEX (nbytes
);
2721 if (vector_free_lists
[index
])
2723 vector
= vector_free_lists
[index
];
2724 vector_free_lists
[index
] = next_in_free_list (vector
);
2725 total_free_vector_slots
-= nbytes
/ word_size
;
2729 /* Next, check free lists containing larger vectors. Since
2730 we will split the result, we should have remaining space
2731 large enough to use for one-slot vector at least. */
2732 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2733 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2734 if (vector_free_lists
[index
])
2736 /* This vector is larger than requested. */
2737 vector
= vector_free_lists
[index
];
2738 vector_free_lists
[index
] = next_in_free_list (vector
);
2739 total_free_vector_slots
-= nbytes
/ word_size
;
2741 /* Excess bytes are used for the smaller vector,
2742 which should be set on an appropriate free list. */
2743 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2744 eassert (restbytes
% roundup_size
== 0);
2745 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2749 /* Finally, need a new vector block. */
2750 block
= allocate_vector_block ();
2752 /* New vector will be at the beginning of this block. */
2753 vector
= (struct Lisp_Vector
*) block
->data
;
2755 /* If the rest of space from this block is large enough
2756 for one-slot vector at least, set up it on a free list. */
2757 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2758 if (restbytes
>= VBLOCK_BYTES_MIN
)
2760 eassert (restbytes
% roundup_size
== 0);
2761 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2766 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2768 #define VECTOR_IN_BLOCK(vector, block) \
2769 ((char *) (vector) <= (block)->data \
2770 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2772 /* Return the memory footprint of V in bytes. */
2775 vector_nbytes (struct Lisp_Vector
*v
)
2777 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2779 if (size
& PSEUDOVECTOR_FLAG
)
2781 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2782 size
= (bool_header_size
2783 + (((struct Lisp_Bool_Vector
*) v
)->size
2784 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2785 / BOOL_VECTOR_BITS_PER_CHAR
);
2788 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2789 + ((size
& PSEUDOVECTOR_REST_MASK
)
2790 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2793 size
= header_size
+ size
* word_size
;
2794 return vroundup (size
);
2797 /* Reclaim space used by unmarked vectors. */
2800 sweep_vectors (void)
2802 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2803 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2804 struct Lisp_Vector
*vector
, *next
;
2806 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2807 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2809 /* Looking through vector blocks. */
2811 for (block
= vector_blocks
; block
; block
= *bprev
)
2813 bool free_this_block
= 0;
2816 for (vector
= (struct Lisp_Vector
*) block
->data
;
2817 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2819 if (VECTOR_MARKED_P (vector
))
2821 VECTOR_UNMARK (vector
);
2823 nbytes
= vector_nbytes (vector
);
2824 total_vector_slots
+= nbytes
/ word_size
;
2825 next
= ADVANCE (vector
, nbytes
);
2829 ptrdiff_t total_bytes
;
2831 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_THREAD
))
2832 finalize_one_thread ((struct thread_state
*) vector
);
2833 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_MUTEX
))
2834 finalize_one_mutex ((struct Lisp_Mutex
*) vector
);
2835 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_CONDVAR
))
2836 finalize_one_condvar ((struct Lisp_CondVar
*) vector
);
2838 nbytes
= vector_nbytes (vector
);
2839 total_bytes
= nbytes
;
2840 next
= ADVANCE (vector
, nbytes
);
2842 /* While NEXT is not marked, try to coalesce with VECTOR,
2843 thus making VECTOR of the largest possible size. */
2845 while (VECTOR_IN_BLOCK (next
, block
))
2847 if (VECTOR_MARKED_P (next
))
2849 nbytes
= vector_nbytes (next
);
2850 total_bytes
+= nbytes
;
2851 next
= ADVANCE (next
, nbytes
);
2854 eassert (total_bytes
% roundup_size
== 0);
2856 if (vector
== (struct Lisp_Vector
*) block
->data
2857 && !VECTOR_IN_BLOCK (next
, block
))
2858 /* This block should be freed because all of it's
2859 space was coalesced into the only free vector. */
2860 free_this_block
= 1;
2864 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2869 if (free_this_block
)
2871 *bprev
= block
->next
;
2872 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2873 mem_delete (mem_find (block
->data
));
2878 bprev
= &block
->next
;
2881 /* Sweep large vectors. */
2883 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2886 if (VECTOR_MARKED_P (vector
))
2888 VECTOR_UNMARK (vector
);
2890 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2892 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2894 /* All non-bool pseudovectors are small enough to be allocated
2895 from vector blocks. This code should be redesigned if some
2896 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2897 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2900 += (bool_header_size
2901 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2902 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2906 += header_size
/ word_size
+ vector
->header
.size
;
2907 lvprev
= &lv
->next
.vector
;
2911 *lvprev
= lv
->next
.vector
;
2917 /* Value is a pointer to a newly allocated Lisp_Vector structure
2918 with room for LEN Lisp_Objects. */
2920 static struct Lisp_Vector
*
2921 allocate_vectorlike (ptrdiff_t len
)
2923 struct Lisp_Vector
*p
;
2928 p
= XVECTOR (zero_vector
);
2931 size_t nbytes
= header_size
+ len
* word_size
;
2933 #ifdef DOUG_LEA_MALLOC
2934 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2935 because mapped region contents are not preserved in
2937 mallopt (M_MMAP_MAX
, 0);
2940 if (nbytes
<= VBLOCK_BYTES_MAX
)
2941 p
= allocate_vector_from_block (vroundup (nbytes
));
2944 struct large_vector
*lv
2945 = lisp_malloc ((offsetof (struct large_vector
, v
.contents
)
2947 MEM_TYPE_VECTORLIKE
);
2948 lv
->next
.vector
= large_vectors
;
2953 #ifdef DOUG_LEA_MALLOC
2954 /* Back to a reasonable maximum of mmap'ed areas. */
2955 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2958 consing_since_gc
+= nbytes
;
2959 vector_cells_consed
+= len
;
2962 MALLOC_UNBLOCK_INPUT
;
2968 /* Allocate a vector with LEN slots. */
2970 struct Lisp_Vector
*
2971 allocate_vector (EMACS_INT len
)
2973 struct Lisp_Vector
*v
;
2974 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2976 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2977 memory_full (SIZE_MAX
);
2978 v
= allocate_vectorlike (len
);
2979 v
->header
.size
= len
;
2984 /* Allocate other vector-like structures. */
2986 struct Lisp_Vector
*
2987 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2989 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2992 /* Catch bogus values. */
2993 eassert (tag
<= PVEC_FONT
);
2994 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2995 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2997 /* Only the first lisplen slots will be traced normally by the GC. */
2998 for (i
= 0; i
< lisplen
; ++i
)
2999 v
->contents
[i
] = Qnil
;
3001 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3006 allocate_buffer (void)
3008 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3010 BUFFER_PVEC_INIT (b
);
3011 /* Put B on the chain of all buffers including killed ones. */
3012 b
->next
= all_buffers
;
3014 /* Note that the rest fields of B are not initialized. */
3018 struct Lisp_Hash_Table
*
3019 allocate_hash_table (void)
3021 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3025 allocate_window (void)
3029 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3030 /* Users assumes that non-Lisp data is zeroed. */
3031 memset (&w
->current_matrix
, 0,
3032 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3037 allocate_terminal (void)
3041 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3042 /* Users assumes that non-Lisp data is zeroed. */
3043 memset (&t
->next_terminal
, 0,
3044 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3049 allocate_frame (void)
3053 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3054 /* Users assumes that non-Lisp data is zeroed. */
3055 memset (&f
->face_cache
, 0,
3056 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3060 struct Lisp_Process
*
3061 allocate_process (void)
3063 struct Lisp_Process
*p
;
3065 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3066 /* Users assumes that non-Lisp data is zeroed. */
3068 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3072 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3073 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3074 See also the function `vector'. */)
3075 (register Lisp_Object length
, Lisp_Object init
)
3078 register ptrdiff_t sizei
;
3079 register ptrdiff_t i
;
3080 register struct Lisp_Vector
*p
;
3082 CHECK_NATNUM (length
);
3084 p
= allocate_vector (XFASTINT (length
));
3085 sizei
= XFASTINT (length
);
3086 for (i
= 0; i
< sizei
; i
++)
3087 p
->contents
[i
] = init
;
3089 XSETVECTOR (vector
, p
);
3094 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3095 doc
: /* Return a newly created vector with specified arguments as elements.
3096 Any number of arguments, even zero arguments, are allowed.
3097 usage: (vector &rest OBJECTS) */)
3098 (ptrdiff_t nargs
, Lisp_Object
*args
)
3101 register Lisp_Object val
= make_uninit_vector (nargs
);
3102 register struct Lisp_Vector
*p
= XVECTOR (val
);
3104 for (i
= 0; i
< nargs
; i
++)
3105 p
->contents
[i
] = args
[i
];
3110 make_byte_code (struct Lisp_Vector
*v
)
3112 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3113 && STRING_MULTIBYTE (v
->contents
[1]))
3114 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3115 earlier because they produced a raw 8-bit string for byte-code
3116 and now such a byte-code string is loaded as multibyte while
3117 raw 8-bit characters converted to multibyte form. Thus, now we
3118 must convert them back to the original unibyte form. */
3119 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3120 XSETPVECTYPE (v
, PVEC_COMPILED
);
3123 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3124 doc
: /* Create a byte-code object with specified arguments as elements.
3125 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3126 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3127 and (optional) INTERACTIVE-SPEC.
3128 The first four arguments are required; at most six have any
3130 The ARGLIST can be either like the one of `lambda', in which case the arguments
3131 will be dynamically bound before executing the byte code, or it can be an
3132 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3133 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3134 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3135 argument to catch the left-over arguments. If such an integer is used, the
3136 arguments will not be dynamically bound but will be instead pushed on the
3137 stack before executing the byte-code.
3138 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3139 (ptrdiff_t nargs
, Lisp_Object
*args
)
3142 register Lisp_Object val
= make_uninit_vector (nargs
);
3143 register struct Lisp_Vector
*p
= XVECTOR (val
);
3145 /* We used to purecopy everything here, if purify-flag was set. This worked
3146 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3147 dangerous, since make-byte-code is used during execution to build
3148 closures, so any closure built during the preload phase would end up
3149 copied into pure space, including its free variables, which is sometimes
3150 just wasteful and other times plainly wrong (e.g. those free vars may want
3153 for (i
= 0; i
< nargs
; i
++)
3154 p
->contents
[i
] = args
[i
];
3156 XSETCOMPILED (val
, p
);
3162 /***********************************************************************
3164 ***********************************************************************/
3166 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3167 of the required alignment if LSB tags are used. */
3169 union aligned_Lisp_Symbol
3171 struct Lisp_Symbol s
;
3173 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3178 /* Each symbol_block is just under 1020 bytes long, since malloc
3179 really allocates in units of powers of two and uses 4 bytes for its
3182 #define SYMBOL_BLOCK_SIZE \
3183 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3187 /* Place `symbols' first, to preserve alignment. */
3188 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3189 struct symbol_block
*next
;
3192 /* Current symbol block and index of first unused Lisp_Symbol
3195 static struct symbol_block
*symbol_block
;
3196 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3198 /* List of free symbols. */
3200 static struct Lisp_Symbol
*symbol_free_list
;
3203 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3205 XSYMBOL (sym
)->name
= name
;
3208 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3209 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3210 Its value is void, and its function definition and property list are nil. */)
3213 register Lisp_Object val
;
3214 register struct Lisp_Symbol
*p
;
3216 CHECK_STRING (name
);
3220 if (symbol_free_list
)
3222 XSETSYMBOL (val
, symbol_free_list
);
3223 symbol_free_list
= symbol_free_list
->next
;
3227 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3229 struct symbol_block
*new
3230 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3231 new->next
= symbol_block
;
3233 symbol_block_index
= 0;
3234 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3236 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3237 symbol_block_index
++;
3240 MALLOC_UNBLOCK_INPUT
;
3243 set_symbol_name (val
, name
);
3244 set_symbol_plist (val
, Qnil
);
3245 p
->redirect
= SYMBOL_PLAINVAL
;
3246 SET_SYMBOL_VAL (p
, Qunbound
);
3247 set_symbol_function (val
, Qnil
);
3248 set_symbol_next (val
, NULL
);
3250 p
->interned
= SYMBOL_UNINTERNED
;
3252 p
->declared_special
= 0;
3253 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3255 total_free_symbols
--;
3261 /***********************************************************************
3262 Marker (Misc) Allocation
3263 ***********************************************************************/
3265 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3266 the required alignment when LSB tags are used. */
3268 union aligned_Lisp_Misc
3272 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3277 /* Allocation of markers and other objects that share that structure.
3278 Works like allocation of conses. */
3280 #define MARKER_BLOCK_SIZE \
3281 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3285 /* Place `markers' first, to preserve alignment. */
3286 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3287 struct marker_block
*next
;
3290 static struct marker_block
*marker_block
;
3291 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3293 static union Lisp_Misc
*marker_free_list
;
3295 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3298 allocate_misc (enum Lisp_Misc_Type type
)
3304 if (marker_free_list
)
3306 XSETMISC (val
, marker_free_list
);
3307 marker_free_list
= marker_free_list
->u_free
.chain
;
3311 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3313 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3314 new->next
= marker_block
;
3316 marker_block_index
= 0;
3317 total_free_markers
+= MARKER_BLOCK_SIZE
;
3319 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3320 marker_block_index
++;
3323 MALLOC_UNBLOCK_INPUT
;
3325 --total_free_markers
;
3326 consing_since_gc
+= sizeof (union Lisp_Misc
);
3327 misc_objects_consed
++;
3328 XMISCANY (val
)->type
= type
;
3329 XMISCANY (val
)->gcmarkbit
= 0;
3333 /* Free a Lisp_Misc object. */
3336 free_misc (Lisp_Object misc
)
3338 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3339 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3340 marker_free_list
= XMISC (misc
);
3341 consing_since_gc
-= sizeof (union Lisp_Misc
);
3342 total_free_markers
++;
3345 /* Verify properties of Lisp_Save_Value's representation
3346 that are assumed here and elsewhere. */
3348 verify (SAVE_UNUSED
== 0);
3349 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3353 /* Return Lisp_Save_Value objects for the various combinations
3354 that callers need. */
3357 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3359 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3360 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3361 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3362 p
->data
[0].integer
= a
;
3363 p
->data
[1].integer
= b
;
3364 p
->data
[2].integer
= c
;
3369 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3372 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3373 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3374 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3375 p
->data
[0].object
= a
;
3376 p
->data
[1].object
= b
;
3377 p
->data
[2].object
= c
;
3378 p
->data
[3].object
= d
;
3382 #if defined HAVE_NS || defined HAVE_NTGUI
3384 make_save_ptr (void *a
)
3386 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3387 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3388 p
->save_type
= SAVE_POINTER
;
3389 p
->data
[0].pointer
= a
;
3395 make_save_ptr_int (void *a
, ptrdiff_t b
)
3397 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3398 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3399 p
->save_type
= SAVE_TYPE_PTR_INT
;
3400 p
->data
[0].pointer
= a
;
3401 p
->data
[1].integer
= b
;
3405 #if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3407 make_save_ptr_ptr (void *a
, void *b
)
3409 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3410 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3411 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3412 p
->data
[0].pointer
= a
;
3413 p
->data
[1].pointer
= b
;
3419 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3421 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3422 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3423 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3424 p
->data
[0].funcpointer
= a
;
3425 p
->data
[1].pointer
= b
;
3426 p
->data
[2].object
= c
;
3430 /* Return a Lisp_Save_Value object that represents an array A
3431 of N Lisp objects. */
3434 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
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_MEMORY
;
3439 p
->data
[0].pointer
= a
;
3440 p
->data
[1].integer
= n
;
3444 /* Free a Lisp_Save_Value object. Do not use this function
3445 if SAVE contains pointer other than returned by xmalloc. */
3448 free_save_value (Lisp_Object save
)
3450 xfree (XSAVE_POINTER (save
, 0));
3454 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3457 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3459 register Lisp_Object overlay
;
3461 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3462 OVERLAY_START (overlay
) = start
;
3463 OVERLAY_END (overlay
) = end
;
3464 set_overlay_plist (overlay
, plist
);
3465 XOVERLAY (overlay
)->next
= NULL
;
3469 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3470 doc
: /* Return a newly allocated marker which does not point at any place. */)
3473 register Lisp_Object val
;
3474 register struct Lisp_Marker
*p
;
3476 val
= allocate_misc (Lisp_Misc_Marker
);
3482 p
->insertion_type
= 0;
3486 /* Return a newly allocated marker which points into BUF
3487 at character position CHARPOS and byte position BYTEPOS. */
3490 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3493 struct Lisp_Marker
*m
;
3495 /* No dead buffers here. */
3496 eassert (BUFFER_LIVE_P (buf
));
3498 /* Every character is at least one byte. */
3499 eassert (charpos
<= bytepos
);
3501 obj
= allocate_misc (Lisp_Misc_Marker
);
3504 m
->charpos
= charpos
;
3505 m
->bytepos
= bytepos
;
3506 m
->insertion_type
= 0;
3507 m
->next
= BUF_MARKERS (buf
);
3508 BUF_MARKERS (buf
) = m
;
3512 /* Put MARKER back on the free list after using it temporarily. */
3515 free_marker (Lisp_Object marker
)
3517 unchain_marker (XMARKER (marker
));
3522 /* Return a newly created vector or string with specified arguments as
3523 elements. If all the arguments are characters that can fit
3524 in a string of events, make a string; otherwise, make a vector.
3526 Any number of arguments, even zero arguments, are allowed. */
3529 make_event_array (register int nargs
, Lisp_Object
*args
)
3533 for (i
= 0; i
< nargs
; i
++)
3534 /* The things that fit in a string
3535 are characters that are in 0...127,
3536 after discarding the meta bit and all the bits above it. */
3537 if (!INTEGERP (args
[i
])
3538 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3539 return Fvector (nargs
, args
);
3541 /* Since the loop exited, we know that all the things in it are
3542 characters, so we can make a string. */
3546 result
= Fmake_string (make_number (nargs
), make_number (0));
3547 for (i
= 0; i
< nargs
; i
++)
3549 SSET (result
, i
, XINT (args
[i
]));
3550 /* Move the meta bit to the right place for a string char. */
3551 if (XINT (args
[i
]) & CHAR_META
)
3552 SSET (result
, i
, SREF (result
, i
) | 0x80);
3561 /************************************************************************
3562 Memory Full Handling
3563 ************************************************************************/
3566 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3567 there may have been size_t overflow so that malloc was never
3568 called, or perhaps malloc was invoked successfully but the
3569 resulting pointer had problems fitting into a tagged EMACS_INT. In
3570 either case this counts as memory being full even though malloc did
3574 memory_full (size_t nbytes
)
3576 /* Do not go into hysterics merely because a large request failed. */
3577 bool enough_free_memory
= 0;
3578 if (SPARE_MEMORY
< nbytes
)
3583 p
= malloc (SPARE_MEMORY
);
3587 enough_free_memory
= 1;
3589 MALLOC_UNBLOCK_INPUT
;
3592 if (! enough_free_memory
)
3598 memory_full_cons_threshold
= sizeof (struct cons_block
);
3600 /* The first time we get here, free the spare memory. */
3601 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3602 if (spare_memory
[i
])
3605 free (spare_memory
[i
]);
3606 else if (i
>= 1 && i
<= 4)
3607 lisp_align_free (spare_memory
[i
]);
3609 lisp_free (spare_memory
[i
]);
3610 spare_memory
[i
] = 0;
3614 /* This used to call error, but if we've run out of memory, we could
3615 get infinite recursion trying to build the string. */
3616 xsignal (Qnil
, Vmemory_signal_data
);
3619 /* If we released our reserve (due to running out of memory),
3620 and we have a fair amount free once again,
3621 try to set aside another reserve in case we run out once more.
3623 This is called when a relocatable block is freed in ralloc.c,
3624 and also directly from this file, in case we're not using ralloc.c. */
3627 refill_memory_reserve (void)
3629 #ifndef SYSTEM_MALLOC
3630 if (spare_memory
[0] == 0)
3631 spare_memory
[0] = malloc (SPARE_MEMORY
);
3632 if (spare_memory
[1] == 0)
3633 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3635 if (spare_memory
[2] == 0)
3636 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3638 if (spare_memory
[3] == 0)
3639 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3641 if (spare_memory
[4] == 0)
3642 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3644 if (spare_memory
[5] == 0)
3645 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3647 if (spare_memory
[6] == 0)
3648 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3650 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3651 Vmemory_full
= Qnil
;
3655 /************************************************************************
3657 ************************************************************************/
3659 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3661 /* Conservative C stack marking requires a method to identify possibly
3662 live Lisp objects given a pointer value. We do this by keeping
3663 track of blocks of Lisp data that are allocated in a red-black tree
3664 (see also the comment of mem_node which is the type of nodes in
3665 that tree). Function lisp_malloc adds information for an allocated
3666 block to the red-black tree with calls to mem_insert, and function
3667 lisp_free removes it with mem_delete. Functions live_string_p etc
3668 call mem_find to lookup information about a given pointer in the
3669 tree, and use that to determine if the pointer points to a Lisp
3672 /* Initialize this part of alloc.c. */
3677 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3678 mem_z
.parent
= NULL
;
3679 mem_z
.color
= MEM_BLACK
;
3680 mem_z
.start
= mem_z
.end
= NULL
;
3685 /* Value is a pointer to the mem_node containing START. Value is
3686 MEM_NIL if there is no node in the tree containing START. */
3688 static struct mem_node
*
3689 mem_find (void *start
)
3693 if (start
< min_heap_address
|| start
> max_heap_address
)
3696 /* Make the search always successful to speed up the loop below. */
3697 mem_z
.start
= start
;
3698 mem_z
.end
= (char *) start
+ 1;
3701 while (start
< p
->start
|| start
>= p
->end
)
3702 p
= start
< p
->start
? p
->left
: p
->right
;
3707 /* Insert a new node into the tree for a block of memory with start
3708 address START, end address END, and type TYPE. Value is a
3709 pointer to the node that was inserted. */
3711 static struct mem_node
*
3712 mem_insert (void *start
, void *end
, enum mem_type type
)
3714 struct mem_node
*c
, *parent
, *x
;
3716 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3717 min_heap_address
= start
;
3718 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3719 max_heap_address
= end
;
3721 /* See where in the tree a node for START belongs. In this
3722 particular application, it shouldn't happen that a node is already
3723 present. For debugging purposes, let's check that. */
3727 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3729 while (c
!= MEM_NIL
)
3731 if (start
>= c
->start
&& start
< c
->end
)
3734 c
= start
< c
->start
? c
->left
: c
->right
;
3737 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3739 while (c
!= MEM_NIL
)
3742 c
= start
< c
->start
? c
->left
: c
->right
;
3745 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3747 /* Create a new node. */
3748 #ifdef GC_MALLOC_CHECK
3749 x
= malloc (sizeof *x
);
3753 x
= xmalloc (sizeof *x
);
3759 x
->left
= x
->right
= MEM_NIL
;
3762 /* Insert it as child of PARENT or install it as root. */
3765 if (start
< parent
->start
)
3773 /* Re-establish red-black tree properties. */
3774 mem_insert_fixup (x
);
3780 /* Re-establish the red-black properties of the tree, and thereby
3781 balance the tree, after node X has been inserted; X is always red. */
3784 mem_insert_fixup (struct mem_node
*x
)
3786 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3788 /* X is red and its parent is red. This is a violation of
3789 red-black tree property #3. */
3791 if (x
->parent
== x
->parent
->parent
->left
)
3793 /* We're on the left side of our grandparent, and Y is our
3795 struct mem_node
*y
= x
->parent
->parent
->right
;
3797 if (y
->color
== MEM_RED
)
3799 /* Uncle and parent are red but should be black because
3800 X is red. Change the colors accordingly and proceed
3801 with the grandparent. */
3802 x
->parent
->color
= MEM_BLACK
;
3803 y
->color
= MEM_BLACK
;
3804 x
->parent
->parent
->color
= MEM_RED
;
3805 x
= x
->parent
->parent
;
3809 /* Parent and uncle have different colors; parent is
3810 red, uncle is black. */
3811 if (x
== x
->parent
->right
)
3814 mem_rotate_left (x
);
3817 x
->parent
->color
= MEM_BLACK
;
3818 x
->parent
->parent
->color
= MEM_RED
;
3819 mem_rotate_right (x
->parent
->parent
);
3824 /* This is the symmetrical case of above. */
3825 struct mem_node
*y
= x
->parent
->parent
->left
;
3827 if (y
->color
== MEM_RED
)
3829 x
->parent
->color
= MEM_BLACK
;
3830 y
->color
= MEM_BLACK
;
3831 x
->parent
->parent
->color
= MEM_RED
;
3832 x
= x
->parent
->parent
;
3836 if (x
== x
->parent
->left
)
3839 mem_rotate_right (x
);
3842 x
->parent
->color
= MEM_BLACK
;
3843 x
->parent
->parent
->color
= MEM_RED
;
3844 mem_rotate_left (x
->parent
->parent
);
3849 /* The root may have been changed to red due to the algorithm. Set
3850 it to black so that property #5 is satisfied. */
3851 mem_root
->color
= MEM_BLACK
;
3862 mem_rotate_left (struct mem_node
*x
)
3866 /* Turn y's left sub-tree into x's right sub-tree. */
3869 if (y
->left
!= MEM_NIL
)
3870 y
->left
->parent
= x
;
3872 /* Y's parent was x's parent. */
3874 y
->parent
= x
->parent
;
3876 /* Get the parent to point to y instead of x. */
3879 if (x
== x
->parent
->left
)
3880 x
->parent
->left
= y
;
3882 x
->parent
->right
= y
;
3887 /* Put x on y's left. */
3901 mem_rotate_right (struct mem_node
*x
)
3903 struct mem_node
*y
= x
->left
;
3906 if (y
->right
!= MEM_NIL
)
3907 y
->right
->parent
= x
;
3910 y
->parent
= x
->parent
;
3913 if (x
== x
->parent
->right
)
3914 x
->parent
->right
= y
;
3916 x
->parent
->left
= y
;
3927 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3930 mem_delete (struct mem_node
*z
)
3932 struct mem_node
*x
, *y
;
3934 if (!z
|| z
== MEM_NIL
)
3937 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3942 while (y
->left
!= MEM_NIL
)
3946 if (y
->left
!= MEM_NIL
)
3951 x
->parent
= y
->parent
;
3954 if (y
== y
->parent
->left
)
3955 y
->parent
->left
= x
;
3957 y
->parent
->right
= x
;
3964 z
->start
= y
->start
;
3969 if (y
->color
== MEM_BLACK
)
3970 mem_delete_fixup (x
);
3972 #ifdef GC_MALLOC_CHECK
3980 /* Re-establish the red-black properties of the tree, after a
3984 mem_delete_fixup (struct mem_node
*x
)
3986 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3988 if (x
== x
->parent
->left
)
3990 struct mem_node
*w
= x
->parent
->right
;
3992 if (w
->color
== MEM_RED
)
3994 w
->color
= MEM_BLACK
;
3995 x
->parent
->color
= MEM_RED
;
3996 mem_rotate_left (x
->parent
);
3997 w
= x
->parent
->right
;
4000 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4007 if (w
->right
->color
== MEM_BLACK
)
4009 w
->left
->color
= MEM_BLACK
;
4011 mem_rotate_right (w
);
4012 w
= x
->parent
->right
;
4014 w
->color
= x
->parent
->color
;
4015 x
->parent
->color
= MEM_BLACK
;
4016 w
->right
->color
= MEM_BLACK
;
4017 mem_rotate_left (x
->parent
);
4023 struct mem_node
*w
= x
->parent
->left
;
4025 if (w
->color
== MEM_RED
)
4027 w
->color
= MEM_BLACK
;
4028 x
->parent
->color
= MEM_RED
;
4029 mem_rotate_right (x
->parent
);
4030 w
= x
->parent
->left
;
4033 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4040 if (w
->left
->color
== MEM_BLACK
)
4042 w
->right
->color
= MEM_BLACK
;
4044 mem_rotate_left (w
);
4045 w
= x
->parent
->left
;
4048 w
->color
= x
->parent
->color
;
4049 x
->parent
->color
= MEM_BLACK
;
4050 w
->left
->color
= MEM_BLACK
;
4051 mem_rotate_right (x
->parent
);
4057 x
->color
= MEM_BLACK
;
4061 /* Value is non-zero if P is a pointer to a live Lisp string on
4062 the heap. M is a pointer to the mem_block for P. */
4065 live_string_p (struct mem_node
*m
, void *p
)
4067 if (m
->type
== MEM_TYPE_STRING
)
4069 struct string_block
*b
= m
->start
;
4070 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4072 /* P must point to the start of a Lisp_String structure, and it
4073 must not be on the free-list. */
4075 && offset
% sizeof b
->strings
[0] == 0
4076 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4077 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4084 /* Value is non-zero if P is a pointer to a live Lisp cons on
4085 the heap. M is a pointer to the mem_block for P. */
4088 live_cons_p (struct mem_node
*m
, void *p
)
4090 if (m
->type
== MEM_TYPE_CONS
)
4092 struct cons_block
*b
= m
->start
;
4093 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4095 /* P must point to the start of a Lisp_Cons, not be
4096 one of the unused cells in the current cons block,
4097 and not be on the free-list. */
4099 && offset
% sizeof b
->conses
[0] == 0
4100 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4102 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4103 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4110 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4111 the heap. M is a pointer to the mem_block for P. */
4114 live_symbol_p (struct mem_node
*m
, void *p
)
4116 if (m
->type
== MEM_TYPE_SYMBOL
)
4118 struct symbol_block
*b
= m
->start
;
4119 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4121 /* P must point to the start of a Lisp_Symbol, not be
4122 one of the unused cells in the current symbol block,
4123 and not be on the free-list. */
4125 && offset
% sizeof b
->symbols
[0] == 0
4126 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4127 && (b
!= symbol_block
4128 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4129 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4136 /* Value is non-zero if P is a pointer to a live Lisp float on
4137 the heap. M is a pointer to the mem_block for P. */
4140 live_float_p (struct mem_node
*m
, void *p
)
4142 if (m
->type
== MEM_TYPE_FLOAT
)
4144 struct float_block
*b
= m
->start
;
4145 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4147 /* P must point to the start of a Lisp_Float and not be
4148 one of the unused cells in the current float block. */
4150 && offset
% sizeof b
->floats
[0] == 0
4151 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4152 && (b
!= float_block
4153 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4160 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4161 the heap. M is a pointer to the mem_block for P. */
4164 live_misc_p (struct mem_node
*m
, void *p
)
4166 if (m
->type
== MEM_TYPE_MISC
)
4168 struct marker_block
*b
= m
->start
;
4169 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4171 /* P must point to the start of a Lisp_Misc, not be
4172 one of the unused cells in the current misc block,
4173 and not be on the free-list. */
4175 && offset
% sizeof b
->markers
[0] == 0
4176 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4177 && (b
!= marker_block
4178 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4179 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4186 /* Value is non-zero if P is a pointer to a live vector-like object.
4187 M is a pointer to the mem_block for P. */
4190 live_vector_p (struct mem_node
*m
, void *p
)
4192 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4194 /* This memory node corresponds to a vector block. */
4195 struct vector_block
*block
= m
->start
;
4196 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4198 /* P is in the block's allocation range. Scan the block
4199 up to P and see whether P points to the start of some
4200 vector which is not on a free list. FIXME: check whether
4201 some allocation patterns (probably a lot of short vectors)
4202 may cause a substantial overhead of this loop. */
4203 while (VECTOR_IN_BLOCK (vector
, block
)
4204 && vector
<= (struct Lisp_Vector
*) p
)
4206 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4209 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4212 else if (m
->type
== MEM_TYPE_VECTORLIKE
4213 && (char *) p
== ((char *) m
->start
4214 + offsetof (struct large_vector
, v
)))
4215 /* This memory node corresponds to a large vector. */
4221 /* Value is non-zero if P is a pointer to a live buffer. M is a
4222 pointer to the mem_block for P. */
4225 live_buffer_p (struct mem_node
*m
, void *p
)
4227 /* P must point to the start of the block, and the buffer
4228 must not have been killed. */
4229 return (m
->type
== MEM_TYPE_BUFFER
4231 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4234 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4238 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4240 /* Array of objects that are kept alive because the C stack contains
4241 a pattern that looks like a reference to them . */
4243 #define MAX_ZOMBIES 10
4244 static Lisp_Object zombies
[MAX_ZOMBIES
];
4246 /* Number of zombie objects. */
4248 static EMACS_INT nzombies
;
4250 /* Number of garbage collections. */
4252 static EMACS_INT ngcs
;
4254 /* Average percentage of zombies per collection. */
4256 static double avg_zombies
;
4258 /* Max. number of live and zombie objects. */
4260 static EMACS_INT max_live
, max_zombies
;
4262 /* Average number of live objects per GC. */
4264 static double avg_live
;
4266 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4267 doc
: /* Show information about live and zombie objects. */)
4270 Lisp_Object args
[8], zombie_list
= Qnil
;
4272 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4273 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4274 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4275 args
[1] = make_number (ngcs
);
4276 args
[2] = make_float (avg_live
);
4277 args
[3] = make_float (avg_zombies
);
4278 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4279 args
[5] = make_number (max_live
);
4280 args
[6] = make_number (max_zombies
);
4281 args
[7] = zombie_list
;
4282 return Fmessage (8, args
);
4285 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4288 /* Mark OBJ if we can prove it's a Lisp_Object. */
4291 mark_maybe_object (Lisp_Object obj
)
4299 po
= (void *) XPNTR (obj
);
4306 switch (XTYPE (obj
))
4309 mark_p
= (live_string_p (m
, po
)
4310 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4314 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4318 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4322 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4325 case Lisp_Vectorlike
:
4326 /* Note: can't check BUFFERP before we know it's a
4327 buffer because checking that dereferences the pointer
4328 PO which might point anywhere. */
4329 if (live_vector_p (m
, po
))
4330 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4331 else if (live_buffer_p (m
, po
))
4332 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4336 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4345 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4346 if (nzombies
< MAX_ZOMBIES
)
4347 zombies
[nzombies
] = obj
;
4356 /* If P points to Lisp data, mark that as live if it isn't already
4360 mark_maybe_pointer (void *p
)
4364 /* Quickly rule out some values which can't point to Lisp data.
4365 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4366 Otherwise, assume that Lisp data is aligned on even addresses. */
4367 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4373 Lisp_Object obj
= Qnil
;
4377 case MEM_TYPE_NON_LISP
:
4378 case MEM_TYPE_SPARE
:
4379 /* Nothing to do; not a pointer to Lisp memory. */
4382 case MEM_TYPE_BUFFER
:
4383 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4384 XSETVECTOR (obj
, p
);
4388 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4392 case MEM_TYPE_STRING
:
4393 if (live_string_p (m
, p
)
4394 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4395 XSETSTRING (obj
, p
);
4399 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4403 case MEM_TYPE_SYMBOL
:
4404 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4405 XSETSYMBOL (obj
, p
);
4408 case MEM_TYPE_FLOAT
:
4409 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4413 case MEM_TYPE_VECTORLIKE
:
4414 case MEM_TYPE_VECTOR_BLOCK
:
4415 if (live_vector_p (m
, p
))
4418 XSETVECTOR (tem
, p
);
4419 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4434 /* Alignment of pointer values. Use alignof, as it sometimes returns
4435 a smaller alignment than GCC's __alignof__ and mark_memory might
4436 miss objects if __alignof__ were used. */
4437 #define GC_POINTER_ALIGNMENT alignof (void *)
4439 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4440 not suffice, which is the typical case. A host where a Lisp_Object is
4441 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4442 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4443 suffice to widen it to to a Lisp_Object and check it that way. */
4444 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4445 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4446 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4447 nor mark_maybe_object can follow the pointers. This should not occur on
4448 any practical porting target. */
4449 # error "MSB type bits straddle pointer-word boundaries"
4451 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4452 pointer words that hold pointers ORed with type bits. */
4453 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4455 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4456 words that hold unmodified pointers. */
4457 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4460 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4461 or END+OFFSET..START. */
4464 mark_memory (void *start
, void *end
)
4465 #if defined (__clang__) && defined (__has_feature)
4466 #if __has_feature(address_sanitizer)
4467 /* Do not allow -faddress-sanitizer to check this function, since it
4468 crosses the function stack boundary, and thus would yield many
4470 __attribute__((no_address_safety_analysis
))
4477 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4481 /* Make START the pointer to the start of the memory region,
4482 if it isn't already. */
4490 /* Mark Lisp data pointed to. This is necessary because, in some
4491 situations, the C compiler optimizes Lisp objects away, so that
4492 only a pointer to them remains. Example:
4494 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4497 Lisp_Object obj = build_string ("test");
4498 struct Lisp_String *s = XSTRING (obj);
4499 Fgarbage_collect ();
4500 fprintf (stderr, "test `%s'\n", s->data);
4504 Here, `obj' isn't really used, and the compiler optimizes it
4505 away. The only reference to the life string is through the
4508 for (pp
= start
; (void *) pp
< end
; pp
++)
4509 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4511 void *p
= *(void **) ((char *) pp
+ i
);
4512 mark_maybe_pointer (p
);
4513 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4514 mark_maybe_object (XIL ((intptr_t) p
));
4518 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4520 static bool setjmp_tested_p
;
4521 static int longjmps_done
;
4523 #define SETJMP_WILL_LIKELY_WORK "\
4525 Emacs garbage collector has been changed to use conservative stack\n\
4526 marking. Emacs has determined that the method it uses to do the\n\
4527 marking will likely work on your system, but this isn't sure.\n\
4529 If you are a system-programmer, or can get the help of a local wizard\n\
4530 who is, please take a look at the function mark_stack in alloc.c, and\n\
4531 verify that the methods used are appropriate for your system.\n\
4533 Please mail the result to <emacs-devel@gnu.org>.\n\
4536 #define SETJMP_WILL_NOT_WORK "\
4538 Emacs garbage collector has been changed to use conservative stack\n\
4539 marking. Emacs has determined that the default method it uses to do the\n\
4540 marking will not work on your system. We will need a system-dependent\n\
4541 solution for your system.\n\
4543 Please take a look at the function mark_stack in alloc.c, and\n\
4544 try to find a way to make it work on your system.\n\
4546 Note that you may get false negatives, depending on the compiler.\n\
4547 In particular, you need to use -O with GCC for this test.\n\
4549 Please mail the result to <emacs-devel@gnu.org>.\n\
4553 /* Perform a quick check if it looks like setjmp saves registers in a
4554 jmp_buf. Print a message to stderr saying so. When this test
4555 succeeds, this is _not_ a proof that setjmp is sufficient for
4556 conservative stack marking. Only the sources or a disassembly
4566 /* Arrange for X to be put in a register. */
4572 if (longjmps_done
== 1)
4574 /* Came here after the longjmp at the end of the function.
4576 If x == 1, the longjmp has restored the register to its
4577 value before the setjmp, and we can hope that setjmp
4578 saves all such registers in the jmp_buf, although that
4581 For other values of X, either something really strange is
4582 taking place, or the setjmp just didn't save the register. */
4585 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4588 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4595 if (longjmps_done
== 1)
4596 sys_longjmp (jbuf
, 1);
4599 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4602 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4604 /* Abort if anything GCPRO'd doesn't survive the GC. */
4612 for (p
= gcprolist
; p
; p
= p
->next
)
4613 for (i
= 0; i
< p
->nvars
; ++i
)
4614 if (!survives_gc_p (p
->var
[i
]))
4615 /* FIXME: It's not necessarily a bug. It might just be that the
4616 GCPRO is unnecessary or should release the object sooner. */
4620 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4627 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4628 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4630 fprintf (stderr
, " %d = ", i
);
4631 debug_print (zombies
[i
]);
4635 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4638 /* Mark live Lisp objects on the C stack.
4640 There are several system-dependent problems to consider when
4641 porting this to new architectures:
4645 We have to mark Lisp objects in CPU registers that can hold local
4646 variables or are used to pass parameters.
4648 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4649 something that either saves relevant registers on the stack, or
4650 calls mark_maybe_object passing it each register's contents.
4652 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4653 implementation assumes that calling setjmp saves registers we need
4654 to see in a jmp_buf which itself lies on the stack. This doesn't
4655 have to be true! It must be verified for each system, possibly
4656 by taking a look at the source code of setjmp.
4658 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4659 can use it as a machine independent method to store all registers
4660 to the stack. In this case the macros described in the previous
4661 two paragraphs are not used.
4665 Architectures differ in the way their processor stack is organized.
4666 For example, the stack might look like this
4669 | Lisp_Object | size = 4
4671 | something else | size = 2
4673 | Lisp_Object | size = 4
4677 In such a case, not every Lisp_Object will be aligned equally. To
4678 find all Lisp_Object on the stack it won't be sufficient to walk
4679 the stack in steps of 4 bytes. Instead, two passes will be
4680 necessary, one starting at the start of the stack, and a second
4681 pass starting at the start of the stack + 2. Likewise, if the
4682 minimal alignment of Lisp_Objects on the stack is 1, four passes
4683 would be necessary, each one starting with one byte more offset
4684 from the stack start. */
4687 mark_stack (char *bottom
, char *end
)
4689 /* This assumes that the stack is a contiguous region in memory. If
4690 that's not the case, something has to be done here to iterate
4691 over the stack segments. */
4692 mark_memory (bottom
, end
);
4694 /* Allow for marking a secondary stack, like the register stack on the
4696 #ifdef GC_MARK_SECONDARY_STACK
4697 GC_MARK_SECONDARY_STACK ();
4700 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4706 flush_stack_call_func (void (*func
) (void *arg
), void *arg
)
4709 struct thread_state
*self
= current_thread
;
4711 #ifdef HAVE___BUILTIN_UNWIND_INIT
4712 /* Force callee-saved registers and register windows onto the stack.
4713 This is the preferred method if available, obviating the need for
4714 machine dependent methods. */
4715 __builtin_unwind_init ();
4717 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4718 #ifndef GC_SAVE_REGISTERS_ON_STACK
4719 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4720 union aligned_jmpbuf
{
4724 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_bottom
;
4726 /* This trick flushes the register windows so that all the state of
4727 the process is contained in the stack. */
4728 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4729 needed on ia64 too. See mach_dep.c, where it also says inline
4730 assembler doesn't work with relevant proprietary compilers. */
4732 #if defined (__sparc64__) && defined (__FreeBSD__)
4733 /* FreeBSD does not have a ta 3 handler. */
4740 /* Save registers that we need to see on the stack. We need to see
4741 registers used to hold register variables and registers used to
4743 #ifdef GC_SAVE_REGISTERS_ON_STACK
4744 GC_SAVE_REGISTERS_ON_STACK (end
);
4745 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4747 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4748 setjmp will definitely work, test it
4749 and print a message with the result
4751 if (!setjmp_tested_p
)
4753 setjmp_tested_p
= 1;
4756 #endif /* GC_SETJMP_WORKS */
4759 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4760 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4761 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4763 self
->stack_top
= end
;
4766 eassert (current_thread
== self
);
4769 #endif /* GC_MARK_STACK != 0 */
4772 /* Determine whether it is safe to access memory at address P. */
4774 valid_pointer_p (void *p
)
4777 return w32_valid_pointer_p (p
, 16);
4781 /* Obviously, we cannot just access it (we would SEGV trying), so we
4782 trick the o/s to tell us whether p is a valid pointer.
4783 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4784 not validate p in that case. */
4786 if (emacs_pipe (fd
) == 0)
4788 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4789 emacs_close (fd
[1]);
4790 emacs_close (fd
[0]);
4798 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4799 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4800 cannot validate OBJ. This function can be quite slow, so its primary
4801 use is the manual debugging. The only exception is print_object, where
4802 we use it to check whether the memory referenced by the pointer of
4803 Lisp_Save_Value object contains valid objects. */
4806 valid_lisp_object_p (Lisp_Object obj
)
4816 p
= (void *) XPNTR (obj
);
4817 if (PURE_POINTER_P (p
))
4820 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4824 return valid_pointer_p (p
);
4831 int valid
= valid_pointer_p (p
);
4843 case MEM_TYPE_NON_LISP
:
4844 case MEM_TYPE_SPARE
:
4847 case MEM_TYPE_BUFFER
:
4848 return live_buffer_p (m
, p
) ? 1 : 2;
4851 return live_cons_p (m
, p
);
4853 case MEM_TYPE_STRING
:
4854 return live_string_p (m
, p
);
4857 return live_misc_p (m
, p
);
4859 case MEM_TYPE_SYMBOL
:
4860 return live_symbol_p (m
, p
);
4862 case MEM_TYPE_FLOAT
:
4863 return live_float_p (m
, p
);
4865 case MEM_TYPE_VECTORLIKE
:
4866 case MEM_TYPE_VECTOR_BLOCK
:
4867 return live_vector_p (m
, p
);
4880 /***********************************************************************
4881 Pure Storage Management
4882 ***********************************************************************/
4884 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4885 pointer to it. TYPE is the Lisp type for which the memory is
4886 allocated. TYPE < 0 means it's not used for a Lisp object. */
4889 pure_alloc (size_t size
, int type
)
4893 size_t alignment
= GCALIGNMENT
;
4895 size_t alignment
= alignof (EMACS_INT
);
4897 /* Give Lisp_Floats an extra alignment. */
4898 if (type
== Lisp_Float
)
4899 alignment
= alignof (struct Lisp_Float
);
4905 /* Allocate space for a Lisp object from the beginning of the free
4906 space with taking account of alignment. */
4907 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4908 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4912 /* Allocate space for a non-Lisp object from the end of the free
4914 pure_bytes_used_non_lisp
+= size
;
4915 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4917 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4919 if (pure_bytes_used
<= pure_size
)
4922 /* Don't allocate a large amount here,
4923 because it might get mmap'd and then its address
4924 might not be usable. */
4925 purebeg
= xmalloc (10000);
4927 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4928 pure_bytes_used
= 0;
4929 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4934 /* Print a warning if PURESIZE is too small. */
4937 check_pure_size (void)
4939 if (pure_bytes_used_before_overflow
)
4940 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4942 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4946 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4947 the non-Lisp data pool of the pure storage, and return its start
4948 address. Return NULL if not found. */
4951 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4954 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4955 const unsigned char *p
;
4958 if (pure_bytes_used_non_lisp
<= nbytes
)
4961 /* Set up the Boyer-Moore table. */
4963 for (i
= 0; i
< 256; i
++)
4966 p
= (const unsigned char *) data
;
4968 bm_skip
[*p
++] = skip
;
4970 last_char_skip
= bm_skip
['\0'];
4972 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4973 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4975 /* See the comments in the function `boyer_moore' (search.c) for the
4976 use of `infinity'. */
4977 infinity
= pure_bytes_used_non_lisp
+ 1;
4978 bm_skip
['\0'] = infinity
;
4980 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4984 /* Check the last character (== '\0'). */
4987 start
+= bm_skip
[*(p
+ start
)];
4989 while (start
<= start_max
);
4991 if (start
< infinity
)
4992 /* Couldn't find the last character. */
4995 /* No less than `infinity' means we could find the last
4996 character at `p[start - infinity]'. */
4999 /* Check the remaining characters. */
5000 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5002 return non_lisp_beg
+ start
;
5004 start
+= last_char_skip
;
5006 while (start
<= start_max
);
5012 /* Return a string allocated in pure space. DATA is a buffer holding
5013 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5014 means make the result string multibyte.
5016 Must get an error if pure storage is full, since if it cannot hold
5017 a large string it may be able to hold conses that point to that
5018 string; then the string is not protected from gc. */
5021 make_pure_string (const char *data
,
5022 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5025 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5026 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5027 if (s
->data
== NULL
)
5029 s
->data
= pure_alloc (nbytes
+ 1, -1);
5030 memcpy (s
->data
, data
, nbytes
);
5031 s
->data
[nbytes
] = '\0';
5034 s
->size_byte
= multibyte
? nbytes
: -1;
5035 s
->intervals
= NULL
;
5036 XSETSTRING (string
, s
);
5040 /* Return a string allocated in pure space. Do not
5041 allocate the string data, just point to DATA. */
5044 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5047 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5050 s
->data
= (unsigned char *) data
;
5051 s
->intervals
= NULL
;
5052 XSETSTRING (string
, s
);
5056 /* Return a cons allocated from pure space. Give it pure copies
5057 of CAR as car and CDR as cdr. */
5060 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5063 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5065 XSETCAR (new, Fpurecopy (car
));
5066 XSETCDR (new, Fpurecopy (cdr
));
5071 /* Value is a float object with value NUM allocated from pure space. */
5074 make_pure_float (double num
)
5077 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5079 XFLOAT_INIT (new, num
);
5084 /* Return a vector with room for LEN Lisp_Objects allocated from
5088 make_pure_vector (ptrdiff_t len
)
5091 size_t size
= header_size
+ len
* word_size
;
5092 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5093 XSETVECTOR (new, p
);
5094 XVECTOR (new)->header
.size
= len
;
5099 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5100 doc
: /* Make a copy of object OBJ in pure storage.
5101 Recursively copies contents of vectors and cons cells.
5102 Does not copy symbols. Copies strings without text properties. */)
5103 (register Lisp_Object obj
)
5105 if (NILP (Vpurify_flag
))
5108 if (PURE_POINTER_P (XPNTR (obj
)))
5111 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5113 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5119 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5120 else if (FLOATP (obj
))
5121 obj
= make_pure_float (XFLOAT_DATA (obj
));
5122 else if (STRINGP (obj
))
5123 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5125 STRING_MULTIBYTE (obj
));
5126 else if (COMPILEDP (obj
) || VECTORP (obj
))
5128 register struct Lisp_Vector
*vec
;
5129 register ptrdiff_t i
;
5133 if (size
& PSEUDOVECTOR_FLAG
)
5134 size
&= PSEUDOVECTOR_SIZE_MASK
;
5135 vec
= XVECTOR (make_pure_vector (size
));
5136 for (i
= 0; i
< size
; i
++)
5137 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5138 if (COMPILEDP (obj
))
5140 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5141 XSETCOMPILED (obj
, vec
);
5144 XSETVECTOR (obj
, vec
);
5146 else if (MARKERP (obj
))
5147 error ("Attempt to copy a marker to pure storage");
5149 /* Not purified, don't hash-cons. */
5152 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5153 Fputhash (obj
, obj
, Vpurify_flag
);
5160 /***********************************************************************
5162 ***********************************************************************/
5164 /* Put an entry in staticvec, pointing at the variable with address
5168 staticpro (Lisp_Object
*varaddress
)
5170 if (staticidx
>= NSTATICS
)
5171 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5172 staticvec
[staticidx
++] = varaddress
;
5176 /***********************************************************************
5178 ***********************************************************************/
5180 /* Temporarily prevent garbage collection. */
5183 inhibit_garbage_collection (void)
5185 ptrdiff_t count
= SPECPDL_INDEX ();
5187 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5191 /* Used to avoid possible overflows when
5192 converting from C to Lisp integers. */
5195 bounded_number (EMACS_INT number
)
5197 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5200 /* Calculate total bytes of live objects. */
5203 total_bytes_of_live_objects (void)
5206 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5207 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5208 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5209 tot
+= total_string_bytes
;
5210 tot
+= total_vector_slots
* word_size
;
5211 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5212 tot
+= total_intervals
* sizeof (struct interval
);
5213 tot
+= total_strings
* sizeof (struct Lisp_String
);
5217 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5218 doc
: /* Reclaim storage for Lisp objects no longer needed.
5219 Garbage collection happens automatically if you cons more than
5220 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5221 `garbage-collect' normally returns a list with info on amount of space in use,
5222 where each entry has the form (NAME SIZE USED FREE), where:
5223 - NAME is a symbol describing the kind of objects this entry represents,
5224 - SIZE is the number of bytes used by each one,
5225 - USED is the number of those objects that were found live in the heap,
5226 - FREE is the number of those objects that are not live but that Emacs
5227 keeps around for future allocations (maybe because it does not know how
5228 to return them to the OS).
5229 However, if there was overflow in pure space, `garbage-collect'
5230 returns nil, because real GC can't be done.
5231 See Info node `(elisp)Garbage Collection'. */)
5234 struct buffer
*nextb
;
5235 char stack_top_variable
;
5238 ptrdiff_t count
= SPECPDL_INDEX ();
5240 Lisp_Object retval
= Qnil
;
5241 size_t tot_before
= 0;
5246 /* Can't GC if pure storage overflowed because we can't determine
5247 if something is a pure object or not. */
5248 if (pure_bytes_used_before_overflow
)
5251 /* Record this function, so it appears on the profiler's backtraces. */
5252 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5256 /* Don't keep undo information around forever.
5257 Do this early on, so it is no problem if the user quits. */
5258 FOR_EACH_BUFFER (nextb
)
5259 compact_buffer (nextb
);
5261 if (profiler_memory_running
)
5262 tot_before
= total_bytes_of_live_objects ();
5264 start
= current_emacs_time ();
5266 /* In case user calls debug_print during GC,
5267 don't let that cause a recursive GC. */
5268 consing_since_gc
= 0;
5270 /* Save what's currently displayed in the echo area. */
5271 message_p
= push_message ();
5272 record_unwind_protect_void (pop_message_unwind
);
5274 /* Save a copy of the contents of the stack, for debugging. */
5275 #if MAX_SAVE_STACK > 0
5276 if (NILP (Vpurify_flag
))
5279 ptrdiff_t stack_size
;
5280 if (&stack_top_variable
< stack_bottom
)
5282 stack
= &stack_top_variable
;
5283 stack_size
= stack_bottom
- &stack_top_variable
;
5287 stack
= stack_bottom
;
5288 stack_size
= &stack_top_variable
- stack_bottom
;
5290 if (stack_size
<= MAX_SAVE_STACK
)
5292 if (stack_copy_size
< stack_size
)
5294 stack_copy
= xrealloc (stack_copy
, stack_size
);
5295 stack_copy_size
= stack_size
;
5297 memcpy (stack_copy
, stack
, stack_size
);
5300 #endif /* MAX_SAVE_STACK > 0 */
5302 if (garbage_collection_messages
)
5303 message1_nolog ("Garbage collecting...");
5307 shrink_regexp_cache ();
5311 /* Mark all the special slots that serve as the roots of accessibility. */
5313 mark_buffer (&buffer_defaults
);
5314 mark_buffer (&buffer_local_symbols
);
5316 for (i
= 0; i
< staticidx
; i
++)
5317 mark_object (*staticvec
[i
]);
5327 #ifdef HAVE_WINDOW_SYSTEM
5328 mark_fringe_data ();
5331 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5336 /* Everything is now marked, except for the things that require special
5337 finalization, i.e. the undo_list.
5338 Look thru every buffer's undo list
5339 for elements that update markers that were not marked,
5341 FOR_EACH_BUFFER (nextb
)
5343 /* If a buffer's undo list is Qt, that means that undo is
5344 turned off in that buffer. Calling truncate_undo_list on
5345 Qt tends to return NULL, which effectively turns undo back on.
5346 So don't call truncate_undo_list if undo_list is Qt. */
5347 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5349 Lisp_Object tail
, prev
;
5350 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5352 while (CONSP (tail
))
5354 if (CONSP (XCAR (tail
))
5355 && MARKERP (XCAR (XCAR (tail
)))
5356 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5359 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5363 XSETCDR (prev
, tail
);
5373 /* Now that we have stripped the elements that need not be in the
5374 undo_list any more, we can finally mark the list. */
5375 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5380 /* Clear the mark bits that we set in certain root slots. */
5383 VECTOR_UNMARK (&buffer_defaults
);
5384 VECTOR_UNMARK (&buffer_local_symbols
);
5386 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5396 consing_since_gc
= 0;
5397 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5398 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5400 gc_relative_threshold
= 0;
5401 if (FLOATP (Vgc_cons_percentage
))
5402 { /* Set gc_cons_combined_threshold. */
5403 double tot
= total_bytes_of_live_objects ();
5405 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5408 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5409 gc_relative_threshold
= tot
;
5411 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5415 if (garbage_collection_messages
)
5417 if (message_p
|| minibuf_level
> 0)
5420 message1_nolog ("Garbage collecting...done");
5423 unbind_to (count
, Qnil
);
5425 Lisp_Object total
[11];
5426 int total_size
= 10;
5428 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5429 bounded_number (total_conses
),
5430 bounded_number (total_free_conses
));
5432 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5433 bounded_number (total_symbols
),
5434 bounded_number (total_free_symbols
));
5436 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5437 bounded_number (total_markers
),
5438 bounded_number (total_free_markers
));
5440 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5441 bounded_number (total_strings
),
5442 bounded_number (total_free_strings
));
5444 total
[4] = list3 (Qstring_bytes
, make_number (1),
5445 bounded_number (total_string_bytes
));
5447 total
[5] = list3 (Qvectors
,
5448 make_number (header_size
+ sizeof (Lisp_Object
)),
5449 bounded_number (total_vectors
));
5451 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5452 bounded_number (total_vector_slots
),
5453 bounded_number (total_free_vector_slots
));
5455 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5456 bounded_number (total_floats
),
5457 bounded_number (total_free_floats
));
5459 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5460 bounded_number (total_intervals
),
5461 bounded_number (total_free_intervals
));
5463 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5464 bounded_number (total_buffers
));
5466 #ifdef DOUG_LEA_MALLOC
5468 total
[10] = list4 (Qheap
, make_number (1024),
5469 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5470 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5472 retval
= Flist (total_size
, total
);
5475 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5477 /* Compute average percentage of zombies. */
5479 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5480 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5482 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5483 max_live
= max (nlive
, max_live
);
5484 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5485 max_zombies
= max (nzombies
, max_zombies
);
5490 if (!NILP (Vpost_gc_hook
))
5492 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5493 safe_run_hooks (Qpost_gc_hook
);
5494 unbind_to (gc_count
, Qnil
);
5497 /* Accumulate statistics. */
5498 if (FLOATP (Vgc_elapsed
))
5500 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5501 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5502 + EMACS_TIME_TO_DOUBLE (since_start
));
5507 /* Collect profiling data. */
5508 if (profiler_memory_running
)
5511 size_t tot_after
= total_bytes_of_live_objects ();
5512 if (tot_before
> tot_after
)
5513 swept
= tot_before
- tot_after
;
5514 malloc_probe (swept
);
5521 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5522 only interesting objects referenced from glyphs are strings. */
5525 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5527 struct glyph_row
*row
= matrix
->rows
;
5528 struct glyph_row
*end
= row
+ matrix
->nrows
;
5530 for (; row
< end
; ++row
)
5534 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5536 struct glyph
*glyph
= row
->glyphs
[area
];
5537 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5539 for (; glyph
< end_glyph
; ++glyph
)
5540 if (STRINGP (glyph
->object
)
5541 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5542 mark_object (glyph
->object
);
5548 /* Mark Lisp faces in the face cache C. */
5551 mark_face_cache (struct face_cache
*c
)
5556 for (i
= 0; i
< c
->used
; ++i
)
5558 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5562 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5563 mark_object (face
->lface
[j
]);
5571 /* Mark reference to a Lisp_Object.
5572 If the object referred to has not been seen yet, recursively mark
5573 all the references contained in it. */
5575 #define LAST_MARKED_SIZE 500
5576 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5577 static int last_marked_index
;
5579 /* For debugging--call abort when we cdr down this many
5580 links of a list, in mark_object. In debugging,
5581 the call to abort will hit a breakpoint.
5582 Normally this is zero and the check never goes off. */
5583 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5586 mark_vectorlike (struct Lisp_Vector
*ptr
)
5588 ptrdiff_t size
= ptr
->header
.size
;
5591 eassert (!VECTOR_MARKED_P (ptr
));
5592 VECTOR_MARK (ptr
); /* Else mark it. */
5593 if (size
& PSEUDOVECTOR_FLAG
)
5594 size
&= PSEUDOVECTOR_SIZE_MASK
;
5596 /* Note that this size is not the memory-footprint size, but only
5597 the number of Lisp_Object fields that we should trace.
5598 The distinction is used e.g. by Lisp_Process which places extra
5599 non-Lisp_Object fields at the end of the structure... */
5600 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5601 mark_object (ptr
->contents
[i
]);
5604 /* Like mark_vectorlike but optimized for char-tables (and
5605 sub-char-tables) assuming that the contents are mostly integers or
5609 mark_char_table (struct Lisp_Vector
*ptr
)
5611 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5614 eassert (!VECTOR_MARKED_P (ptr
));
5616 for (i
= 0; i
< size
; i
++)
5618 Lisp_Object val
= ptr
->contents
[i
];
5620 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5622 if (SUB_CHAR_TABLE_P (val
))
5624 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5625 mark_char_table (XVECTOR (val
));
5632 /* Mark the chain of overlays starting at PTR. */
5635 mark_overlay (struct Lisp_Overlay
*ptr
)
5637 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5640 mark_object (ptr
->start
);
5641 mark_object (ptr
->end
);
5642 mark_object (ptr
->plist
);
5646 /* Mark Lisp_Objects and special pointers in BUFFER. */
5649 mark_buffer (struct buffer
*buffer
)
5651 /* This is handled much like other pseudovectors... */
5652 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5654 /* ...but there are some buffer-specific things. */
5656 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5658 /* For now, we just don't mark the undo_list. It's done later in
5659 a special way just before the sweep phase, and after stripping
5660 some of its elements that are not needed any more. */
5662 mark_overlay (buffer
->overlays_before
);
5663 mark_overlay (buffer
->overlays_after
);
5665 /* If this is an indirect buffer, mark its base buffer. */
5666 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5667 mark_buffer (buffer
->base_buffer
);
5670 /* Remove killed buffers or items whose car is a killed buffer from
5671 LIST, and mark other items. Return changed LIST, which is marked. */
5674 mark_discard_killed_buffers (Lisp_Object list
)
5676 Lisp_Object tail
, *prev
= &list
;
5678 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5681 Lisp_Object tem
= XCAR (tail
);
5684 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5685 *prev
= XCDR (tail
);
5688 CONS_MARK (XCONS (tail
));
5689 mark_object (XCAR (tail
));
5690 prev
= xcdr_addr (tail
);
5697 /* Determine type of generic Lisp_Object and mark it accordingly. */
5700 mark_object (Lisp_Object arg
)
5702 register Lisp_Object obj
= arg
;
5703 #ifdef GC_CHECK_MARKED_OBJECTS
5707 ptrdiff_t cdr_count
= 0;
5711 if (PURE_POINTER_P (XPNTR (obj
)))
5714 last_marked
[last_marked_index
++] = obj
;
5715 if (last_marked_index
== LAST_MARKED_SIZE
)
5716 last_marked_index
= 0;
5718 /* Perform some sanity checks on the objects marked here. Abort if
5719 we encounter an object we know is bogus. This increases GC time
5720 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5721 #ifdef GC_CHECK_MARKED_OBJECTS
5723 po
= (void *) XPNTR (obj
);
5725 /* Check that the object pointed to by PO is known to be a Lisp
5726 structure allocated from the heap. */
5727 #define CHECK_ALLOCATED() \
5729 m = mem_find (po); \
5734 /* Check that the object pointed to by PO is live, using predicate
5736 #define CHECK_LIVE(LIVEP) \
5738 if (!LIVEP (m, po)) \
5742 /* Check both of the above conditions. */
5743 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5745 CHECK_ALLOCATED (); \
5746 CHECK_LIVE (LIVEP); \
5749 #else /* not GC_CHECK_MARKED_OBJECTS */
5751 #define CHECK_LIVE(LIVEP) (void) 0
5752 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5754 #endif /* not GC_CHECK_MARKED_OBJECTS */
5756 switch (XTYPE (obj
))
5760 register struct Lisp_String
*ptr
= XSTRING (obj
);
5761 if (STRING_MARKED_P (ptr
))
5763 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5765 MARK_INTERVAL_TREE (ptr
->intervals
);
5766 #ifdef GC_CHECK_STRING_BYTES
5767 /* Check that the string size recorded in the string is the
5768 same as the one recorded in the sdata structure. */
5770 #endif /* GC_CHECK_STRING_BYTES */
5774 case Lisp_Vectorlike
:
5776 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5777 register ptrdiff_t pvectype
;
5779 if (VECTOR_MARKED_P (ptr
))
5782 #ifdef GC_CHECK_MARKED_OBJECTS
5784 if (m
== MEM_NIL
&& !SUBRP (obj
))
5786 #endif /* GC_CHECK_MARKED_OBJECTS */
5788 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5789 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5790 >> PSEUDOVECTOR_AREA_BITS
);
5792 pvectype
= PVEC_NORMAL_VECTOR
;
5794 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5795 CHECK_LIVE (live_vector_p
);
5800 #ifdef GC_CHECK_MARKED_OBJECTS
5809 #endif /* GC_CHECK_MARKED_OBJECTS */
5810 mark_buffer ((struct buffer
*) ptr
);
5814 { /* We could treat this just like a vector, but it is better
5815 to save the COMPILED_CONSTANTS element for last and avoid
5817 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5821 for (i
= 0; i
< size
; i
++)
5822 if (i
!= COMPILED_CONSTANTS
)
5823 mark_object (ptr
->contents
[i
]);
5824 if (size
> COMPILED_CONSTANTS
)
5826 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5833 mark_vectorlike (ptr
);
5834 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5839 struct window
*w
= (struct window
*) ptr
;
5841 mark_vectorlike (ptr
);
5843 /* Mark glyph matrices, if any. Marking window
5844 matrices is sufficient because frame matrices
5845 use the same glyph memory. */
5846 if (w
->current_matrix
)
5848 mark_glyph_matrix (w
->current_matrix
);
5849 mark_glyph_matrix (w
->desired_matrix
);
5852 /* Filter out killed buffers from both buffer lists
5853 in attempt to help GC to reclaim killed buffers faster.
5854 We can do it elsewhere for live windows, but this is the
5855 best place to do it for dead windows. */
5857 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5859 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5863 case PVEC_HASH_TABLE
:
5865 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5867 mark_vectorlike (ptr
);
5868 mark_object (h
->test
.name
);
5869 mark_object (h
->test
.user_hash_function
);
5870 mark_object (h
->test
.user_cmp_function
);
5871 /* If hash table is not weak, mark all keys and values.
5872 For weak tables, mark only the vector. */
5874 mark_object (h
->key_and_value
);
5876 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5880 case PVEC_CHAR_TABLE
:
5881 mark_char_table (ptr
);
5884 case PVEC_BOOL_VECTOR
:
5885 /* No Lisp_Objects to mark in a bool vector. */
5896 mark_vectorlike (ptr
);
5903 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5904 struct Lisp_Symbol
*ptrx
;
5908 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5910 mark_object (ptr
->function
);
5911 mark_object (ptr
->plist
);
5912 switch (ptr
->redirect
)
5914 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5915 case SYMBOL_VARALIAS
:
5918 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5922 case SYMBOL_LOCALIZED
:
5924 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5925 Lisp_Object where
= blv
->where
;
5926 /* If the value is set up for a killed buffer or deleted
5927 frame, restore it's global binding. If the value is
5928 forwarded to a C variable, either it's not a Lisp_Object
5929 var, or it's staticpro'd already. */
5930 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5931 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5932 swap_in_global_binding (ptr
);
5933 mark_object (blv
->where
);
5934 mark_object (blv
->valcell
);
5935 mark_object (blv
->defcell
);
5938 case SYMBOL_FORWARDED
:
5939 /* If the value is forwarded to a buffer or keyboard field,
5940 these are marked when we see the corresponding object.
5941 And if it's forwarded to a C variable, either it's not
5942 a Lisp_Object var, or it's staticpro'd already. */
5944 default: emacs_abort ();
5946 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5947 MARK_STRING (XSTRING (ptr
->name
));
5948 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5953 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5954 XSETSYMBOL (obj
, ptrx
);
5961 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5963 if (XMISCANY (obj
)->gcmarkbit
)
5966 switch (XMISCTYPE (obj
))
5968 case Lisp_Misc_Marker
:
5969 /* DO NOT mark thru the marker's chain.
5970 The buffer's markers chain does not preserve markers from gc;
5971 instead, markers are removed from the chain when freed by gc. */
5972 XMISCANY (obj
)->gcmarkbit
= 1;
5975 case Lisp_Misc_Save_Value
:
5976 XMISCANY (obj
)->gcmarkbit
= 1;
5978 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5979 /* If `save_type' is zero, `data[0].pointer' is the address
5980 of a memory area containing `data[1].integer' potential
5982 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
5984 Lisp_Object
*p
= ptr
->data
[0].pointer
;
5986 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
5987 mark_maybe_object (*p
);
5991 /* Find Lisp_Objects in `data[N]' slots and mark them. */
5993 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
5994 if (save_type (ptr
, i
) == SAVE_OBJECT
)
5995 mark_object (ptr
->data
[i
].object
);
6000 case Lisp_Misc_Overlay
:
6001 mark_overlay (XOVERLAY (obj
));
6011 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6012 if (CONS_MARKED_P (ptr
))
6014 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6016 /* If the cdr is nil, avoid recursion for the car. */
6017 if (EQ (ptr
->u
.cdr
, Qnil
))
6023 mark_object (ptr
->car
);
6026 if (cdr_count
== mark_object_loop_halt
)
6032 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6033 FLOAT_MARK (XFLOAT (obj
));
6044 #undef CHECK_ALLOCATED
6045 #undef CHECK_ALLOCATED_AND_LIVE
6047 /* Mark the Lisp pointers in the terminal objects.
6048 Called by Fgarbage_collect. */
6051 mark_terminals (void)
6054 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6056 eassert (t
->name
!= NULL
);
6057 #ifdef HAVE_WINDOW_SYSTEM
6058 /* If a terminal object is reachable from a stacpro'ed object,
6059 it might have been marked already. Make sure the image cache
6061 mark_image_cache (t
->image_cache
);
6062 #endif /* HAVE_WINDOW_SYSTEM */
6063 if (!VECTOR_MARKED_P (t
))
6064 mark_vectorlike ((struct Lisp_Vector
*)t
);
6070 /* Value is non-zero if OBJ will survive the current GC because it's
6071 either marked or does not need to be marked to survive. */
6074 survives_gc_p (Lisp_Object obj
)
6078 switch (XTYPE (obj
))
6085 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6089 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6093 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6096 case Lisp_Vectorlike
:
6097 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6101 survives_p
= CONS_MARKED_P (XCONS (obj
));
6105 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6112 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6117 /* Sweep: find all structures not marked, and free them. */
6122 /* Remove or mark entries in weak hash tables.
6123 This must be done before any object is unmarked. */
6124 sweep_weak_hash_tables ();
6127 check_string_bytes (!noninteractive
);
6129 /* Put all unmarked conses on free list */
6131 register struct cons_block
*cblk
;
6132 struct cons_block
**cprev
= &cons_block
;
6133 register int lim
= cons_block_index
;
6134 EMACS_INT num_free
= 0, num_used
= 0;
6138 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6142 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6144 /* Scan the mark bits an int at a time. */
6145 for (i
= 0; i
< ilim
; i
++)
6147 if (cblk
->gcmarkbits
[i
] == -1)
6149 /* Fast path - all cons cells for this int are marked. */
6150 cblk
->gcmarkbits
[i
] = 0;
6151 num_used
+= BITS_PER_INT
;
6155 /* Some cons cells for this int are not marked.
6156 Find which ones, and free them. */
6157 int start
, pos
, stop
;
6159 start
= i
* BITS_PER_INT
;
6161 if (stop
> BITS_PER_INT
)
6162 stop
= BITS_PER_INT
;
6165 for (pos
= start
; pos
< stop
; pos
++)
6167 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6170 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6171 cons_free_list
= &cblk
->conses
[pos
];
6173 cons_free_list
->car
= Vdead
;
6179 CONS_UNMARK (&cblk
->conses
[pos
]);
6185 lim
= CONS_BLOCK_SIZE
;
6186 /* If this block contains only free conses and we have already
6187 seen more than two blocks worth of free conses then deallocate
6189 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6191 *cprev
= cblk
->next
;
6192 /* Unhook from the free list. */
6193 cons_free_list
= cblk
->conses
[0].u
.chain
;
6194 lisp_align_free (cblk
);
6198 num_free
+= this_free
;
6199 cprev
= &cblk
->next
;
6202 total_conses
= num_used
;
6203 total_free_conses
= num_free
;
6206 /* Put all unmarked floats on free list */
6208 register struct float_block
*fblk
;
6209 struct float_block
**fprev
= &float_block
;
6210 register int lim
= float_block_index
;
6211 EMACS_INT num_free
= 0, num_used
= 0;
6213 float_free_list
= 0;
6215 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6219 for (i
= 0; i
< lim
; i
++)
6220 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6223 fblk
->floats
[i
].u
.chain
= float_free_list
;
6224 float_free_list
= &fblk
->floats
[i
];
6229 FLOAT_UNMARK (&fblk
->floats
[i
]);
6231 lim
= FLOAT_BLOCK_SIZE
;
6232 /* If this block contains only free floats and we have already
6233 seen more than two blocks worth of free floats then deallocate
6235 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6237 *fprev
= fblk
->next
;
6238 /* Unhook from the free list. */
6239 float_free_list
= fblk
->floats
[0].u
.chain
;
6240 lisp_align_free (fblk
);
6244 num_free
+= this_free
;
6245 fprev
= &fblk
->next
;
6248 total_floats
= num_used
;
6249 total_free_floats
= num_free
;
6252 /* Put all unmarked intervals on free list */
6254 register struct interval_block
*iblk
;
6255 struct interval_block
**iprev
= &interval_block
;
6256 register int lim
= interval_block_index
;
6257 EMACS_INT num_free
= 0, num_used
= 0;
6259 interval_free_list
= 0;
6261 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6266 for (i
= 0; i
< lim
; i
++)
6268 if (!iblk
->intervals
[i
].gcmarkbit
)
6270 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6271 interval_free_list
= &iblk
->intervals
[i
];
6277 iblk
->intervals
[i
].gcmarkbit
= 0;
6280 lim
= INTERVAL_BLOCK_SIZE
;
6281 /* If this block contains only free intervals and we have already
6282 seen more than two blocks worth of free intervals then
6283 deallocate this block. */
6284 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6286 *iprev
= iblk
->next
;
6287 /* Unhook from the free list. */
6288 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6293 num_free
+= this_free
;
6294 iprev
= &iblk
->next
;
6297 total_intervals
= num_used
;
6298 total_free_intervals
= num_free
;
6301 /* Put all unmarked symbols on free list */
6303 register struct symbol_block
*sblk
;
6304 struct symbol_block
**sprev
= &symbol_block
;
6305 register int lim
= symbol_block_index
;
6306 EMACS_INT num_free
= 0, num_used
= 0;
6308 symbol_free_list
= NULL
;
6310 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6313 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6314 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6316 for (; sym
< end
; ++sym
)
6318 /* Check if the symbol was created during loadup. In such a case
6319 it might be pointed to by pure bytecode which we don't trace,
6320 so we conservatively assume that it is live. */
6321 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6323 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6325 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6326 xfree (SYMBOL_BLV (&sym
->s
));
6327 sym
->s
.next
= symbol_free_list
;
6328 symbol_free_list
= &sym
->s
;
6330 symbol_free_list
->function
= Vdead
;
6338 UNMARK_STRING (XSTRING (sym
->s
.name
));
6339 sym
->s
.gcmarkbit
= 0;
6343 lim
= SYMBOL_BLOCK_SIZE
;
6344 /* If this block contains only free symbols and we have already
6345 seen more than two blocks worth of free symbols then deallocate
6347 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6349 *sprev
= sblk
->next
;
6350 /* Unhook from the free list. */
6351 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6356 num_free
+= this_free
;
6357 sprev
= &sblk
->next
;
6360 total_symbols
= num_used
;
6361 total_free_symbols
= num_free
;
6364 /* Put all unmarked misc's on free list.
6365 For a marker, first unchain it from the buffer it points into. */
6367 register struct marker_block
*mblk
;
6368 struct marker_block
**mprev
= &marker_block
;
6369 register int lim
= marker_block_index
;
6370 EMACS_INT num_free
= 0, num_used
= 0;
6372 marker_free_list
= 0;
6374 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6379 for (i
= 0; i
< lim
; i
++)
6381 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6383 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6384 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6385 /* Set the type of the freed object to Lisp_Misc_Free.
6386 We could leave the type alone, since nobody checks it,
6387 but this might catch bugs faster. */
6388 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6389 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6390 marker_free_list
= &mblk
->markers
[i
].m
;
6396 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6399 lim
= MARKER_BLOCK_SIZE
;
6400 /* If this block contains only free markers and we have already
6401 seen more than two blocks worth of free markers then deallocate
6403 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6405 *mprev
= mblk
->next
;
6406 /* Unhook from the free list. */
6407 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6412 num_free
+= this_free
;
6413 mprev
= &mblk
->next
;
6417 total_markers
= num_used
;
6418 total_free_markers
= num_free
;
6421 /* Free all unmarked buffers */
6423 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6426 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6427 if (!VECTOR_MARKED_P (buffer
))
6429 *bprev
= buffer
->next
;
6434 VECTOR_UNMARK (buffer
);
6435 /* Do not use buffer_(set|get)_intervals here. */
6436 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6438 bprev
= &buffer
->next
;
6443 check_string_bytes (!noninteractive
);
6449 /* Debugging aids. */
6451 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6452 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6453 This may be helpful in debugging Emacs's memory usage.
6454 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6459 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6464 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6465 doc
: /* Return a list of counters that measure how much consing there has been.
6466 Each of these counters increments for a certain kind of object.
6467 The counters wrap around from the largest positive integer to zero.
6468 Garbage collection does not decrease them.
6469 The elements of the value are as follows:
6470 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6471 All are in units of 1 = one object consed
6472 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6474 MISCS include overlays, markers, and some internal types.
6475 Frames, windows, buffers, and subprocesses count as vectors
6476 (but the contents of a buffer's text do not count here). */)
6479 return listn (CONSTYPE_HEAP
, 8,
6480 bounded_number (cons_cells_consed
),
6481 bounded_number (floats_consed
),
6482 bounded_number (vector_cells_consed
),
6483 bounded_number (symbols_consed
),
6484 bounded_number (string_chars_consed
),
6485 bounded_number (misc_objects_consed
),
6486 bounded_number (intervals_consed
),
6487 bounded_number (strings_consed
));
6490 /* Find at most FIND_MAX symbols which have OBJ as their value or
6491 function. This is used in gdbinit's `xwhichsymbols' command. */
6494 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6496 struct symbol_block
*sblk
;
6497 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6498 Lisp_Object found
= Qnil
;
6502 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6504 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6507 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6509 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6513 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6516 XSETSYMBOL (tem
, sym
);
6517 val
= find_symbol_value (tem
);
6519 || EQ (sym
->function
, obj
)
6520 || (!NILP (sym
->function
)
6521 && COMPILEDP (sym
->function
)
6522 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6525 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6527 found
= Fcons (tem
, found
);
6528 if (--find_max
== 0)
6536 unbind_to (gc_count
, Qnil
);
6540 #ifdef ENABLE_CHECKING
6542 bool suppress_checking
;
6545 die (const char *msg
, const char *file
, int line
)
6547 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6549 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6553 /* Initialization. */
6556 init_alloc_once (void)
6558 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6560 pure_size
= PURESIZE
;
6562 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6564 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6567 #ifdef DOUG_LEA_MALLOC
6568 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6569 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6570 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6575 refill_memory_reserve ();
6576 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6583 byte_stack_list
= 0;
6585 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6586 setjmp_tested_p
= longjmps_done
= 0;
6589 Vgc_elapsed
= make_float (0.0);
6594 syms_of_alloc (void)
6596 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6597 doc
: /* Number of bytes of consing between garbage collections.
6598 Garbage collection can happen automatically once this many bytes have been
6599 allocated since the last garbage collection. All data types count.
6601 Garbage collection happens automatically only when `eval' is called.
6603 By binding this temporarily to a large number, you can effectively
6604 prevent garbage collection during a part of the program.
6605 See also `gc-cons-percentage'. */);
6607 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6608 doc
: /* Portion of the heap used for allocation.
6609 Garbage collection can happen automatically once this portion of the heap
6610 has been allocated since the last garbage collection.
6611 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6612 Vgc_cons_percentage
= make_float (0.1);
6614 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6615 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6617 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6618 doc
: /* Number of cons cells that have been consed so far. */);
6620 DEFVAR_INT ("floats-consed", floats_consed
,
6621 doc
: /* Number of floats that have been consed so far. */);
6623 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6624 doc
: /* Number of vector cells that have been consed so far. */);
6626 DEFVAR_INT ("symbols-consed", symbols_consed
,
6627 doc
: /* Number of symbols that have been consed so far. */);
6629 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6630 doc
: /* Number of string characters that have been consed so far. */);
6632 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6633 doc
: /* Number of miscellaneous objects that have been consed so far.
6634 These include markers and overlays, plus certain objects not visible
6637 DEFVAR_INT ("intervals-consed", intervals_consed
,
6638 doc
: /* Number of intervals that have been consed so far. */);
6640 DEFVAR_INT ("strings-consed", strings_consed
,
6641 doc
: /* Number of strings that have been consed so far. */);
6643 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6644 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6645 This means that certain objects should be allocated in shared (pure) space.
6646 It can also be set to a hash-table, in which case this table is used to
6647 do hash-consing of the objects allocated to pure space. */);
6649 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6650 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6651 garbage_collection_messages
= 0;
6653 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6654 doc
: /* Hook run after garbage collection has finished. */);
6655 Vpost_gc_hook
= Qnil
;
6656 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6658 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6659 doc
: /* Precomputed `signal' argument for memory-full error. */);
6660 /* We build this in advance because if we wait until we need it, we might
6661 not be able to allocate the memory to hold it. */
6663 = listn (CONSTYPE_PURE
, 2, Qerror
,
6664 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6666 DEFVAR_LISP ("memory-full", Vmemory_full
,
6667 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6668 Vmemory_full
= Qnil
;
6670 DEFSYM (Qconses
, "conses");
6671 DEFSYM (Qsymbols
, "symbols");
6672 DEFSYM (Qmiscs
, "miscs");
6673 DEFSYM (Qstrings
, "strings");
6674 DEFSYM (Qvectors
, "vectors");
6675 DEFSYM (Qfloats
, "floats");
6676 DEFSYM (Qintervals
, "intervals");
6677 DEFSYM (Qbuffers
, "buffers");
6678 DEFSYM (Qstring_bytes
, "string-bytes");
6679 DEFSYM (Qvector_slots
, "vector-slots");
6680 DEFSYM (Qheap
, "heap");
6681 DEFSYM (Qautomatic_gc
, "Automatic GC");
6683 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6684 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6686 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6687 doc
: /* Accumulated time elapsed in garbage collections.
6688 The time is in seconds as a floating point value. */);
6689 DEFVAR_INT ("gcs-done", gcs_done
,
6690 doc
: /* Accumulated number of garbage collections done. */);
6695 defsubr (&Smake_byte_code
);
6696 defsubr (&Smake_list
);
6697 defsubr (&Smake_vector
);
6698 defsubr (&Smake_string
);
6699 defsubr (&Smake_bool_vector
);
6700 defsubr (&Smake_symbol
);
6701 defsubr (&Smake_marker
);
6702 defsubr (&Spurecopy
);
6703 defsubr (&Sgarbage_collect
);
6704 defsubr (&Smemory_limit
);
6705 defsubr (&Smemory_use_counts
);
6707 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6708 defsubr (&Sgc_status
);
6712 /* When compiled with GCC, GDB might say "No enum type named
6713 pvec_type" if we don't have at least one symbol with that type, and
6714 then xbacktrace could fail. Similarly for the other enums and
6715 their values. Some non-GCC compilers don't like these constructs. */
6719 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6720 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6721 enum char_bits char_bits
;
6722 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6723 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6724 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6725 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6726 enum Lisp_Bits Lisp_Bits
;
6727 enum Lisp_Compiled Lisp_Compiled
;
6728 enum maxargs maxargs
;
6729 enum MAX_ALLOCA MAX_ALLOCA
;
6730 enum More_Lisp_Bits More_Lisp_Bits
;
6731 enum pvec_type pvec_type
;
6732 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6733 #endif /* __GNUC__ */