1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
24 #include <limits.h> /* For CHAR_BIT. */
26 #ifdef ENABLE_CHECKING
27 #include <signal.h> /* For SIGABRT. */
36 #include "intervals.h"
38 #include "character.h"
43 #include "blockinput.h"
44 #include "termhooks.h" /* For struct terminal. */
45 #ifdef HAVE_WINDOW_SYSTEM
47 #endif /* HAVE_WINDOW_SYSTEM */
50 #include <execinfo.h> /* For backtrace. */
52 #if (defined ENABLE_CHECKING \
53 && defined HAVE_VALGRIND_VALGRIND_H \
54 && !defined USE_VALGRIND)
55 # define USE_VALGRIND 1
59 #include <valgrind/valgrind.h>
60 #include <valgrind/memcheck.h>
61 static bool valgrind_p
;
64 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
65 Doable only if GC_MARK_STACK. */
67 # undef GC_CHECK_MARKED_OBJECTS
70 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
71 memory. Can do this only if using gmalloc.c and if not checking
74 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
75 || defined GC_CHECK_MARKED_OBJECTS)
76 #undef GC_MALLOC_CHECK
87 #include "w32heap.h" /* for sbrk */
90 #ifdef DOUG_LEA_MALLOC
94 /* Specify maximum number of areas to mmap. It would be nice to use a
95 value that explicitly means "no limit". */
97 #define MMAP_MAX_AREAS 100000000
99 #endif /* not DOUG_LEA_MALLOC */
101 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
102 to a struct Lisp_String. */
104 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
105 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
106 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
108 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
109 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
110 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
112 /* Default value of gc_cons_threshold (see below). */
114 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
116 /* Global variables. */
117 struct emacs_globals globals
;
119 /* Number of bytes of consing done since the last gc. */
121 EMACS_INT consing_since_gc
;
123 /* Similar minimum, computed from Vgc_cons_percentage. */
125 EMACS_INT gc_relative_threshold
;
127 /* Minimum number of bytes of consing since GC before next GC,
128 when memory is full. */
130 EMACS_INT memory_full_cons_threshold
;
132 /* True during GC. */
136 /* True means abort if try to GC.
137 This is for code which is written on the assumption that
138 no GC will happen, so as to verify that assumption. */
142 /* Number of live and free conses etc. */
144 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
145 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
146 static EMACS_INT total_free_floats
, total_floats
;
148 /* Points to memory space allocated as "spare", to be freed if we run
149 out of memory. We keep one large block, four cons-blocks, and
150 two string blocks. */
152 static char *spare_memory
[7];
154 /* Amount of spare memory to keep in large reserve block, or to see
155 whether this much is available when malloc fails on a larger request. */
157 #define SPARE_MEMORY (1 << 14)
159 /* Initialize it to a nonzero value to force it into data space
160 (rather than bss space). That way unexec will remap it into text
161 space (pure), on some systems. We have not implemented the
162 remapping on more recent systems because this is less important
163 nowadays than in the days of small memories and timesharing. */
165 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
166 #define PUREBEG (char *) pure
168 /* Pointer to the pure area, and its size. */
170 static char *purebeg
;
171 static ptrdiff_t pure_size
;
173 /* Number of bytes of pure storage used before pure storage overflowed.
174 If this is non-zero, this implies that an overflow occurred. */
176 static ptrdiff_t pure_bytes_used_before_overflow
;
178 /* True if P points into pure space. */
180 #define PURE_POINTER_P(P) \
181 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
183 /* Index in pure at which next pure Lisp object will be allocated.. */
185 static ptrdiff_t pure_bytes_used_lisp
;
187 /* Number of bytes allocated for non-Lisp objects in pure storage. */
189 static ptrdiff_t pure_bytes_used_non_lisp
;
191 /* If nonzero, this is a warning delivered by malloc and not yet
194 const char *pending_malloc_warning
;
196 #if 0 /* Normally, pointer sanity only on request... */
197 #ifdef ENABLE_CHECKING
198 #define SUSPICIOUS_OBJECT_CHECKING 1
202 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
203 bug is unresolved. */
204 #define SUSPICIOUS_OBJECT_CHECKING 1
206 #ifdef SUSPICIOUS_OBJECT_CHECKING
207 struct suspicious_free_record
209 void *suspicious_object
;
210 void *backtrace
[128];
212 static void *suspicious_objects
[32];
213 static int suspicious_object_index
;
214 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
215 static int suspicious_free_history_index
;
216 /* Find the first currently-monitored suspicious pointer in range
217 [begin,end) or NULL if no such pointer exists. */
218 static void *find_suspicious_object_in_range (void *begin
, void *end
);
219 static void detect_suspicious_free (void *ptr
);
221 # define find_suspicious_object_in_range(begin, end) NULL
222 # define detect_suspicious_free(ptr) (void)
225 /* Maximum amount of C stack to save when a GC happens. */
227 #ifndef MAX_SAVE_STACK
228 #define MAX_SAVE_STACK 16000
231 /* Buffer in which we save a copy of the C stack at each GC. */
233 #if MAX_SAVE_STACK > 0
234 static char *stack_copy
;
235 static ptrdiff_t stack_copy_size
;
237 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
238 avoiding any address sanitization. */
240 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
241 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
243 if (! ADDRESS_SANITIZER
)
244 return memcpy (dest
, src
, size
);
250 for (i
= 0; i
< size
; i
++)
256 #endif /* MAX_SAVE_STACK > 0 */
258 static Lisp_Object Qconses
;
259 static Lisp_Object Qsymbols
;
260 static Lisp_Object Qmiscs
;
261 static Lisp_Object Qstrings
;
262 static Lisp_Object Qvectors
;
263 static Lisp_Object Qfloats
;
264 static Lisp_Object Qintervals
;
265 static Lisp_Object Qbuffers
;
266 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
267 static Lisp_Object Qgc_cons_threshold
;
268 Lisp_Object Qautomatic_gc
;
269 Lisp_Object Qchar_table_extra_slots
;
271 /* Hook run after GC has finished. */
273 static Lisp_Object Qpost_gc_hook
;
275 static void mark_terminals (void);
276 static void gc_sweep (void);
277 static Lisp_Object
make_pure_vector (ptrdiff_t);
278 static void mark_buffer (struct buffer
*);
280 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
281 static void refill_memory_reserve (void);
283 static void compact_small_strings (void);
284 static void free_large_strings (void);
285 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
287 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
288 what memory allocated via lisp_malloc and lisp_align_malloc is intended
289 for what purpose. This enumeration specifies the type of memory. */
300 /* Since all non-bool pseudovectors are small enough to be
301 allocated from vector blocks, this memory type denotes
302 large regular vectors and large bool pseudovectors. */
304 /* Special type to denote vector blocks. */
305 MEM_TYPE_VECTOR_BLOCK
,
306 /* Special type to denote reserved memory. */
310 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
312 /* A unique object in pure space used to make some Lisp objects
313 on free lists recognizable in O(1). */
315 static Lisp_Object Vdead
;
316 #define DEADP(x) EQ (x, Vdead)
318 #ifdef GC_MALLOC_CHECK
320 enum mem_type allocated_mem_type
;
322 #endif /* GC_MALLOC_CHECK */
324 /* A node in the red-black tree describing allocated memory containing
325 Lisp data. Each such block is recorded with its start and end
326 address when it is allocated, and removed from the tree when it
329 A red-black tree is a balanced binary tree with the following
332 1. Every node is either red or black.
333 2. Every leaf is black.
334 3. If a node is red, then both of its children are black.
335 4. Every simple path from a node to a descendant leaf contains
336 the same number of black nodes.
337 5. The root is always black.
339 When nodes are inserted into the tree, or deleted from the tree,
340 the tree is "fixed" so that these properties are always true.
342 A red-black tree with N internal nodes has height at most 2
343 log(N+1). Searches, insertions and deletions are done in O(log N).
344 Please see a text book about data structures for a detailed
345 description of red-black trees. Any book worth its salt should
350 /* Children of this node. These pointers are never NULL. When there
351 is no child, the value is MEM_NIL, which points to a dummy node. */
352 struct mem_node
*left
, *right
;
354 /* The parent of this node. In the root node, this is NULL. */
355 struct mem_node
*parent
;
357 /* Start and end of allocated region. */
361 enum {MEM_BLACK
, MEM_RED
} color
;
367 /* Base address of stack. Set in main. */
369 Lisp_Object
*stack_base
;
371 /* Root of the tree describing allocated Lisp memory. */
373 static struct mem_node
*mem_root
;
375 /* Lowest and highest known address in the heap. */
377 static void *min_heap_address
, *max_heap_address
;
379 /* Sentinel node of the tree. */
381 static struct mem_node mem_z
;
382 #define MEM_NIL &mem_z
384 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
385 static void mem_insert_fixup (struct mem_node
*);
386 static void mem_rotate_left (struct mem_node
*);
387 static void mem_rotate_right (struct mem_node
*);
388 static void mem_delete (struct mem_node
*);
389 static void mem_delete_fixup (struct mem_node
*);
390 static struct mem_node
*mem_find (void *);
392 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
398 /* Recording what needs to be marked for gc. */
400 struct gcpro
*gcprolist
;
402 /* Addresses of staticpro'd variables. Initialize it to a nonzero
403 value; otherwise some compilers put it into BSS. */
405 enum { NSTATICS
= 2048 };
406 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
408 /* Index of next unused slot in staticvec. */
410 static int staticidx
;
412 static void *pure_alloc (size_t, int);
414 /* Return X rounded to the next multiple of Y. Arguments should not
415 have side effects, as they are evaluated more than once. Assume X
416 + Y - 1 does not overflow. Tune for Y being a power of 2. */
418 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
419 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
420 : ((x) + (y) - 1) & ~ ((y) - 1))
422 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
425 ALIGN (void *ptr
, int alignment
)
427 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
431 XFLOAT_INIT (Lisp_Object f
, double n
)
433 XFLOAT (f
)->u
.data
= n
;
437 pointers_fit_in_lispobj_p (void)
439 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
443 mmap_lisp_allowed_p (void)
445 /* If we can't store all memory addresses in our lisp objects, it's
446 risky to let the heap use mmap and give us addresses from all
447 over our address space. We also can't use mmap for lisp objects
448 if we might dump: unexec doesn't preserve the contents of mmaped
450 return pointers_fit_in_lispobj_p () && !might_dump
;
454 /************************************************************************
456 ************************************************************************/
458 /* Function malloc calls this if it finds we are near exhausting storage. */
461 malloc_warning (const char *str
)
463 pending_malloc_warning
= str
;
467 /* Display an already-pending malloc warning. */
470 display_malloc_warning (void)
472 call3 (intern ("display-warning"),
474 build_string (pending_malloc_warning
),
475 intern ("emergency"));
476 pending_malloc_warning
= 0;
479 /* Called if we can't allocate relocatable space for a buffer. */
482 buffer_memory_full (ptrdiff_t nbytes
)
484 /* If buffers use the relocating allocator, no need to free
485 spare_memory, because we may have plenty of malloc space left
486 that we could get, and if we don't, the malloc that fails will
487 itself cause spare_memory to be freed. If buffers don't use the
488 relocating allocator, treat this like any other failing
492 memory_full (nbytes
);
494 /* This used to call error, but if we've run out of memory, we could
495 get infinite recursion trying to build the string. */
496 xsignal (Qnil
, Vmemory_signal_data
);
500 /* A common multiple of the positive integers A and B. Ideally this
501 would be the least common multiple, but there's no way to do that
502 as a constant expression in C, so do the best that we can easily do. */
503 #define COMMON_MULTIPLE(a, b) \
504 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
506 #ifndef XMALLOC_OVERRUN_CHECK
507 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
510 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
513 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
514 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
515 block size in little-endian order. The trailer consists of
516 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
518 The header is used to detect whether this block has been allocated
519 through these functions, as some low-level libc functions may
520 bypass the malloc hooks. */
522 #define XMALLOC_OVERRUN_CHECK_SIZE 16
523 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
524 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
526 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
527 hold a size_t value and (2) the header size is a multiple of the
528 alignment that Emacs needs for C types and for USE_LSB_TAG. */
529 #define XMALLOC_BASE_ALIGNMENT \
530 alignof (union { long double d; intmax_t i; void *p; })
533 # define XMALLOC_HEADER_ALIGNMENT \
534 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
536 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
538 #define XMALLOC_OVERRUN_SIZE_SIZE \
539 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
540 + XMALLOC_HEADER_ALIGNMENT - 1) \
541 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
542 - XMALLOC_OVERRUN_CHECK_SIZE)
544 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
545 { '\x9a', '\x9b', '\xae', '\xaf',
546 '\xbf', '\xbe', '\xce', '\xcf',
547 '\xea', '\xeb', '\xec', '\xed',
548 '\xdf', '\xde', '\x9c', '\x9d' };
550 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
551 { '\xaa', '\xab', '\xac', '\xad',
552 '\xba', '\xbb', '\xbc', '\xbd',
553 '\xca', '\xcb', '\xcc', '\xcd',
554 '\xda', '\xdb', '\xdc', '\xdd' };
556 /* Insert and extract the block size in the header. */
559 xmalloc_put_size (unsigned char *ptr
, size_t size
)
562 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
564 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
570 xmalloc_get_size (unsigned char *ptr
)
574 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
575 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
584 /* Like malloc, but wraps allocated block with header and trailer. */
587 overrun_check_malloc (size_t size
)
589 register unsigned char *val
;
590 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
593 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
596 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
597 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
598 xmalloc_put_size (val
, size
);
599 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
600 XMALLOC_OVERRUN_CHECK_SIZE
);
606 /* Like realloc, but checks old block for overrun, and wraps new block
607 with header and trailer. */
610 overrun_check_realloc (void *block
, size_t size
)
612 register unsigned char *val
= (unsigned char *) block
;
613 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
617 && memcmp (xmalloc_overrun_check_header
,
618 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
619 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
621 size_t osize
= xmalloc_get_size (val
);
622 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
623 XMALLOC_OVERRUN_CHECK_SIZE
))
625 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
626 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
627 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
630 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
634 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
635 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
636 xmalloc_put_size (val
, size
);
637 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
638 XMALLOC_OVERRUN_CHECK_SIZE
);
643 /* Like free, but checks block for overrun. */
646 overrun_check_free (void *block
)
648 unsigned char *val
= (unsigned char *) block
;
651 && memcmp (xmalloc_overrun_check_header
,
652 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
653 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
655 size_t osize
= xmalloc_get_size (val
);
656 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
657 XMALLOC_OVERRUN_CHECK_SIZE
))
659 #ifdef XMALLOC_CLEAR_FREE_MEMORY
660 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
661 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
663 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
664 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
665 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
675 #define malloc overrun_check_malloc
676 #define realloc overrun_check_realloc
677 #define free overrun_check_free
680 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
681 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
682 If that variable is set, block input while in one of Emacs's memory
683 allocation functions. There should be no need for this debugging
684 option, since signal handlers do not allocate memory, but Emacs
685 formerly allocated memory in signal handlers and this compile-time
686 option remains as a way to help debug the issue should it rear its
688 #ifdef XMALLOC_BLOCK_INPUT_CHECK
689 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
691 malloc_block_input (void)
693 if (block_input_in_memory_allocators
)
697 malloc_unblock_input (void)
699 if (block_input_in_memory_allocators
)
702 # define MALLOC_BLOCK_INPUT malloc_block_input ()
703 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
705 # define MALLOC_BLOCK_INPUT ((void) 0)
706 # define MALLOC_UNBLOCK_INPUT ((void) 0)
709 #define MALLOC_PROBE(size) \
711 if (profiler_memory_running) \
712 malloc_probe (size); \
716 /* Like malloc but check for no memory and block interrupt input.. */
719 xmalloc (size_t size
)
725 MALLOC_UNBLOCK_INPUT
;
733 /* Like the above, but zeroes out the memory just allocated. */
736 xzalloc (size_t size
)
742 MALLOC_UNBLOCK_INPUT
;
746 memset (val
, 0, size
);
751 /* Like realloc but check for no memory and block interrupt input.. */
754 xrealloc (void *block
, size_t size
)
759 /* We must call malloc explicitly when BLOCK is 0, since some
760 reallocs don't do this. */
764 val
= realloc (block
, size
);
765 MALLOC_UNBLOCK_INPUT
;
774 /* Like free but block interrupt input. */
783 MALLOC_UNBLOCK_INPUT
;
784 /* We don't call refill_memory_reserve here
785 because in practice the call in r_alloc_free seems to suffice. */
789 /* Other parts of Emacs pass large int values to allocator functions
790 expecting ptrdiff_t. This is portable in practice, but check it to
792 verify (INT_MAX
<= PTRDIFF_MAX
);
795 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
796 Signal an error on memory exhaustion, and block interrupt input. */
799 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
801 eassert (0 <= nitems
&& 0 < item_size
);
802 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
803 memory_full (SIZE_MAX
);
804 return xmalloc (nitems
* item_size
);
808 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
809 Signal an error on memory exhaustion, and block interrupt input. */
812 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
814 eassert (0 <= nitems
&& 0 < item_size
);
815 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
816 memory_full (SIZE_MAX
);
817 return xrealloc (pa
, nitems
* item_size
);
821 /* Grow PA, which points to an array of *NITEMS items, and return the
822 location of the reallocated array, updating *NITEMS to reflect its
823 new size. The new array will contain at least NITEMS_INCR_MIN more
824 items, but will not contain more than NITEMS_MAX items total.
825 ITEM_SIZE is the size of each item, in bytes.
827 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
828 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
831 If PA is null, then allocate a new array instead of reallocating
834 Block interrupt input as needed. If memory exhaustion occurs, set
835 *NITEMS to zero if PA is null, and signal an error (i.e., do not
838 Thus, to grow an array A without saving its old contents, do
839 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
840 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
841 and signals an error, and later this code is reexecuted and
842 attempts to free A. */
845 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
846 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
848 /* The approximate size to use for initial small allocation
849 requests. This is the largest "small" request for the GNU C
851 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
853 /* If the array is tiny, grow it to about (but no greater than)
854 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
855 ptrdiff_t n
= *nitems
;
856 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
857 ptrdiff_t half_again
= n
>> 1;
858 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
860 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
861 NITEMS_MAX, and what the C language can represent safely. */
862 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
863 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
864 ? nitems_max
: C_language_max
);
865 ptrdiff_t nitems_incr_max
= n_max
- n
;
866 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
868 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
871 if (nitems_incr_max
< incr
)
872 memory_full (SIZE_MAX
);
874 pa
= xrealloc (pa
, n
* item_size
);
880 /* Like strdup, but uses xmalloc. */
883 xstrdup (const char *s
)
887 size
= strlen (s
) + 1;
888 return memcpy (xmalloc (size
), s
, size
);
891 /* Like above, but duplicates Lisp string to C string. */
894 xlispstrdup (Lisp_Object string
)
896 ptrdiff_t size
= SBYTES (string
) + 1;
897 return memcpy (xmalloc (size
), SSDATA (string
), size
);
900 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
901 pointed to. If STRING is null, assign it without copying anything.
902 Allocate before freeing, to avoid a dangling pointer if allocation
906 dupstring (char **ptr
, char const *string
)
909 *ptr
= string
? xstrdup (string
) : 0;
914 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
915 argument is a const pointer. */
918 xputenv (char const *string
)
920 if (putenv ((char *) string
) != 0)
924 /* Return a newly allocated memory block of SIZE bytes, remembering
925 to free it when unwinding. */
927 record_xmalloc (size_t size
)
929 void *p
= xmalloc (size
);
930 record_unwind_protect_ptr (xfree
, p
);
935 /* Like malloc but used for allocating Lisp data. NBYTES is the
936 number of bytes to allocate, TYPE describes the intended use of the
937 allocated memory block (for strings, for conses, ...). */
940 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
944 lisp_malloc (size_t nbytes
, enum mem_type type
)
950 #ifdef GC_MALLOC_CHECK
951 allocated_mem_type
= type
;
954 val
= malloc (nbytes
);
957 /* If the memory just allocated cannot be addressed thru a Lisp
958 object's pointer, and it needs to be,
959 that's equivalent to running out of memory. */
960 if (val
&& type
!= MEM_TYPE_NON_LISP
)
963 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
964 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
966 lisp_malloc_loser
= val
;
973 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
974 if (val
&& type
!= MEM_TYPE_NON_LISP
)
975 mem_insert (val
, (char *) val
+ nbytes
, type
);
978 MALLOC_UNBLOCK_INPUT
;
980 memory_full (nbytes
);
981 MALLOC_PROBE (nbytes
);
985 /* Free BLOCK. This must be called to free memory allocated with a
986 call to lisp_malloc. */
989 lisp_free (void *block
)
993 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
994 mem_delete (mem_find (block
));
996 MALLOC_UNBLOCK_INPUT
;
999 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1001 /* The entry point is lisp_align_malloc which returns blocks of at most
1002 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1004 /* Use aligned_alloc if it or a simple substitute is available.
1005 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1006 clang 3.3 anyway. */
1008 #if ! ADDRESS_SANITIZER
1009 # if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC
1010 # define USE_ALIGNED_ALLOC 1
1011 /* Defined in gmalloc.c. */
1012 void *aligned_alloc (size_t, size_t);
1013 # elif defined HAVE_ALIGNED_ALLOC
1014 # define USE_ALIGNED_ALLOC 1
1015 # elif defined HAVE_POSIX_MEMALIGN
1016 # define USE_ALIGNED_ALLOC 1
1018 aligned_alloc (size_t alignment
, size_t size
)
1021 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1026 /* BLOCK_ALIGN has to be a power of 2. */
1027 #define BLOCK_ALIGN (1 << 10)
1029 /* Padding to leave at the end of a malloc'd block. This is to give
1030 malloc a chance to minimize the amount of memory wasted to alignment.
1031 It should be tuned to the particular malloc library used.
1032 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1033 aligned_alloc on the other hand would ideally prefer a value of 4
1034 because otherwise, there's 1020 bytes wasted between each ablocks.
1035 In Emacs, testing shows that those 1020 can most of the time be
1036 efficiently used by malloc to place other objects, so a value of 0 can
1037 still preferable unless you have a lot of aligned blocks and virtually
1039 #define BLOCK_PADDING 0
1040 #define BLOCK_BYTES \
1041 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1043 /* Internal data structures and constants. */
1045 #define ABLOCKS_SIZE 16
1047 /* An aligned block of memory. */
1052 char payload
[BLOCK_BYTES
];
1053 struct ablock
*next_free
;
1055 /* `abase' is the aligned base of the ablocks. */
1056 /* It is overloaded to hold the virtual `busy' field that counts
1057 the number of used ablock in the parent ablocks.
1058 The first ablock has the `busy' field, the others have the `abase'
1059 field. To tell the difference, we assume that pointers will have
1060 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1061 is used to tell whether the real base of the parent ablocks is `abase'
1062 (if not, the word before the first ablock holds a pointer to the
1064 struct ablocks
*abase
;
1065 /* The padding of all but the last ablock is unused. The padding of
1066 the last ablock in an ablocks is not allocated. */
1068 char padding
[BLOCK_PADDING
];
1072 /* A bunch of consecutive aligned blocks. */
1075 struct ablock blocks
[ABLOCKS_SIZE
];
1078 /* Size of the block requested from malloc or aligned_alloc. */
1079 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1081 #define ABLOCK_ABASE(block) \
1082 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1083 ? (struct ablocks *)(block) \
1086 /* Virtual `busy' field. */
1087 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1089 /* Pointer to the (not necessarily aligned) malloc block. */
1090 #ifdef USE_ALIGNED_ALLOC
1091 #define ABLOCKS_BASE(abase) (abase)
1093 #define ABLOCKS_BASE(abase) \
1094 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1097 /* The list of free ablock. */
1098 static struct ablock
*free_ablock
;
1100 /* Allocate an aligned block of nbytes.
1101 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1102 smaller or equal to BLOCK_BYTES. */
1104 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1107 struct ablocks
*abase
;
1109 eassert (nbytes
<= BLOCK_BYTES
);
1113 #ifdef GC_MALLOC_CHECK
1114 allocated_mem_type
= type
;
1120 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1122 #ifdef DOUG_LEA_MALLOC
1123 if (!mmap_lisp_allowed_p ())
1124 mallopt (M_MMAP_MAX
, 0);
1127 #ifdef USE_ALIGNED_ALLOC
1128 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1130 base
= malloc (ABLOCKS_BYTES
);
1131 abase
= ALIGN (base
, BLOCK_ALIGN
);
1136 MALLOC_UNBLOCK_INPUT
;
1137 memory_full (ABLOCKS_BYTES
);
1140 aligned
= (base
== abase
);
1142 ((void **) abase
)[-1] = base
;
1144 #ifdef DOUG_LEA_MALLOC
1145 if (!mmap_lisp_allowed_p ())
1146 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1150 /* If the memory just allocated cannot be addressed thru a Lisp
1151 object's pointer, and it needs to be, that's equivalent to
1152 running out of memory. */
1153 if (type
!= MEM_TYPE_NON_LISP
)
1156 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1157 XSETCONS (tem
, end
);
1158 if ((char *) XCONS (tem
) != end
)
1160 lisp_malloc_loser
= base
;
1162 MALLOC_UNBLOCK_INPUT
;
1163 memory_full (SIZE_MAX
);
1168 /* Initialize the blocks and put them on the free list.
1169 If `base' was not properly aligned, we can't use the last block. */
1170 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1172 abase
->blocks
[i
].abase
= abase
;
1173 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1174 free_ablock
= &abase
->blocks
[i
];
1176 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1178 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1179 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1180 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1181 eassert (ABLOCKS_BASE (abase
) == base
);
1182 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1185 abase
= ABLOCK_ABASE (free_ablock
);
1186 ABLOCKS_BUSY (abase
)
1187 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1189 free_ablock
= free_ablock
->x
.next_free
;
1191 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1192 if (type
!= MEM_TYPE_NON_LISP
)
1193 mem_insert (val
, (char *) val
+ nbytes
, type
);
1196 MALLOC_UNBLOCK_INPUT
;
1198 MALLOC_PROBE (nbytes
);
1200 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1205 lisp_align_free (void *block
)
1207 struct ablock
*ablock
= block
;
1208 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1211 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1212 mem_delete (mem_find (block
));
1214 /* Put on free list. */
1215 ablock
->x
.next_free
= free_ablock
;
1216 free_ablock
= ablock
;
1217 /* Update busy count. */
1218 ABLOCKS_BUSY (abase
)
1219 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1221 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1222 { /* All the blocks are free. */
1223 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1224 struct ablock
**tem
= &free_ablock
;
1225 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1229 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1232 *tem
= (*tem
)->x
.next_free
;
1235 tem
= &(*tem
)->x
.next_free
;
1237 eassert ((aligned
& 1) == aligned
);
1238 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1239 #ifdef USE_POSIX_MEMALIGN
1240 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1242 free (ABLOCKS_BASE (abase
));
1244 MALLOC_UNBLOCK_INPUT
;
1248 /***********************************************************************
1250 ***********************************************************************/
1252 /* Number of intervals allocated in an interval_block structure.
1253 The 1020 is 1024 minus malloc overhead. */
1255 #define INTERVAL_BLOCK_SIZE \
1256 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1258 /* Intervals are allocated in chunks in the form of an interval_block
1261 struct interval_block
1263 /* Place `intervals' first, to preserve alignment. */
1264 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1265 struct interval_block
*next
;
1268 /* Current interval block. Its `next' pointer points to older
1271 static struct interval_block
*interval_block
;
1273 /* Index in interval_block above of the next unused interval
1276 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1278 /* Number of free and live intervals. */
1280 static EMACS_INT total_free_intervals
, total_intervals
;
1282 /* List of free intervals. */
1284 static INTERVAL interval_free_list
;
1286 /* Return a new interval. */
1289 make_interval (void)
1295 if (interval_free_list
)
1297 val
= interval_free_list
;
1298 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1302 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1304 struct interval_block
*newi
1305 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1307 newi
->next
= interval_block
;
1308 interval_block
= newi
;
1309 interval_block_index
= 0;
1310 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1312 val
= &interval_block
->intervals
[interval_block_index
++];
1315 MALLOC_UNBLOCK_INPUT
;
1317 consing_since_gc
+= sizeof (struct interval
);
1319 total_free_intervals
--;
1320 RESET_INTERVAL (val
);
1326 /* Mark Lisp objects in interval I. */
1329 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1331 /* Intervals should never be shared. So, if extra internal checking is
1332 enabled, GC aborts if it seems to have visited an interval twice. */
1333 eassert (!i
->gcmarkbit
);
1335 mark_object (i
->plist
);
1338 /* Mark the interval tree rooted in I. */
1340 #define MARK_INTERVAL_TREE(i) \
1342 if (i && !i->gcmarkbit) \
1343 traverse_intervals_noorder (i, mark_interval, Qnil); \
1346 /***********************************************************************
1348 ***********************************************************************/
1350 /* Lisp_Strings are allocated in string_block structures. When a new
1351 string_block is allocated, all the Lisp_Strings it contains are
1352 added to a free-list string_free_list. When a new Lisp_String is
1353 needed, it is taken from that list. During the sweep phase of GC,
1354 string_blocks that are entirely free are freed, except two which
1357 String data is allocated from sblock structures. Strings larger
1358 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1359 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1361 Sblocks consist internally of sdata structures, one for each
1362 Lisp_String. The sdata structure points to the Lisp_String it
1363 belongs to. The Lisp_String points back to the `u.data' member of
1364 its sdata structure.
1366 When a Lisp_String is freed during GC, it is put back on
1367 string_free_list, and its `data' member and its sdata's `string'
1368 pointer is set to null. The size of the string is recorded in the
1369 `n.nbytes' member of the sdata. So, sdata structures that are no
1370 longer used, can be easily recognized, and it's easy to compact the
1371 sblocks of small strings which we do in compact_small_strings. */
1373 /* Size in bytes of an sblock structure used for small strings. This
1374 is 8192 minus malloc overhead. */
1376 #define SBLOCK_SIZE 8188
1378 /* Strings larger than this are considered large strings. String data
1379 for large strings is allocated from individual sblocks. */
1381 #define LARGE_STRING_BYTES 1024
1383 /* The SDATA typedef is a struct or union describing string memory
1384 sub-allocated from an sblock. This is where the contents of Lisp
1385 strings are stored. */
1389 /* Back-pointer to the string this sdata belongs to. If null, this
1390 structure is free, and NBYTES (in this structure or in the union below)
1391 contains the string's byte size (the same value that STRING_BYTES
1392 would return if STRING were non-null). If non-null, STRING_BYTES
1393 (STRING) is the size of the data, and DATA contains the string's
1395 struct Lisp_String
*string
;
1397 #ifdef GC_CHECK_STRING_BYTES
1401 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1404 #ifdef GC_CHECK_STRING_BYTES
1406 typedef struct sdata sdata
;
1407 #define SDATA_NBYTES(S) (S)->nbytes
1408 #define SDATA_DATA(S) (S)->data
1414 struct Lisp_String
*string
;
1416 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1417 which has a flexible array member. However, if implemented by
1418 giving this union a member of type 'struct sdata', the union
1419 could not be the last (flexible) member of 'struct sblock',
1420 because C99 prohibits a flexible array member from having a type
1421 that is itself a flexible array. So, comment this member out here,
1422 but remember that the option's there when using this union. */
1427 /* When STRING is null. */
1430 struct Lisp_String
*string
;
1435 #define SDATA_NBYTES(S) (S)->n.nbytes
1436 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1438 #endif /* not GC_CHECK_STRING_BYTES */
1440 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1442 /* Structure describing a block of memory which is sub-allocated to
1443 obtain string data memory for strings. Blocks for small strings
1444 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1445 as large as needed. */
1450 struct sblock
*next
;
1452 /* Pointer to the next free sdata block. This points past the end
1453 of the sblock if there isn't any space left in this block. */
1457 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1460 /* Number of Lisp strings in a string_block structure. The 1020 is
1461 1024 minus malloc overhead. */
1463 #define STRING_BLOCK_SIZE \
1464 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1466 /* Structure describing a block from which Lisp_String structures
1471 /* Place `strings' first, to preserve alignment. */
1472 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1473 struct string_block
*next
;
1476 /* Head and tail of the list of sblock structures holding Lisp string
1477 data. We always allocate from current_sblock. The NEXT pointers
1478 in the sblock structures go from oldest_sblock to current_sblock. */
1480 static struct sblock
*oldest_sblock
, *current_sblock
;
1482 /* List of sblocks for large strings. */
1484 static struct sblock
*large_sblocks
;
1486 /* List of string_block structures. */
1488 static struct string_block
*string_blocks
;
1490 /* Free-list of Lisp_Strings. */
1492 static struct Lisp_String
*string_free_list
;
1494 /* Number of live and free Lisp_Strings. */
1496 static EMACS_INT total_strings
, total_free_strings
;
1498 /* Number of bytes used by live strings. */
1500 static EMACS_INT total_string_bytes
;
1502 /* Given a pointer to a Lisp_String S which is on the free-list
1503 string_free_list, return a pointer to its successor in the
1506 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1508 /* Return a pointer to the sdata structure belonging to Lisp string S.
1509 S must be live, i.e. S->data must not be null. S->data is actually
1510 a pointer to the `u.data' member of its sdata structure; the
1511 structure starts at a constant offset in front of that. */
1513 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1516 #ifdef GC_CHECK_STRING_OVERRUN
1518 /* We check for overrun in string data blocks by appending a small
1519 "cookie" after each allocated string data block, and check for the
1520 presence of this cookie during GC. */
1522 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1523 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1524 { '\xde', '\xad', '\xbe', '\xef' };
1527 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1530 /* Value is the size of an sdata structure large enough to hold NBYTES
1531 bytes of string data. The value returned includes a terminating
1532 NUL byte, the size of the sdata structure, and padding. */
1534 #ifdef GC_CHECK_STRING_BYTES
1536 #define SDATA_SIZE(NBYTES) \
1537 ((SDATA_DATA_OFFSET \
1539 + sizeof (ptrdiff_t) - 1) \
1540 & ~(sizeof (ptrdiff_t) - 1))
1542 #else /* not GC_CHECK_STRING_BYTES */
1544 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1545 less than the size of that member. The 'max' is not needed when
1546 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1547 alignment code reserves enough space. */
1549 #define SDATA_SIZE(NBYTES) \
1550 ((SDATA_DATA_OFFSET \
1551 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1553 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1555 + sizeof (ptrdiff_t) - 1) \
1556 & ~(sizeof (ptrdiff_t) - 1))
1558 #endif /* not GC_CHECK_STRING_BYTES */
1560 /* Extra bytes to allocate for each string. */
1562 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1564 /* Exact bound on the number of bytes in a string, not counting the
1565 terminating null. A string cannot contain more bytes than
1566 STRING_BYTES_BOUND, nor can it be so long that the size_t
1567 arithmetic in allocate_string_data would overflow while it is
1568 calculating a value to be passed to malloc. */
1569 static ptrdiff_t const STRING_BYTES_MAX
=
1570 min (STRING_BYTES_BOUND
,
1571 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1573 - offsetof (struct sblock
, data
)
1574 - SDATA_DATA_OFFSET
)
1575 & ~(sizeof (EMACS_INT
) - 1)));
1577 /* Initialize string allocation. Called from init_alloc_once. */
1582 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1583 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1587 #ifdef GC_CHECK_STRING_BYTES
1589 static int check_string_bytes_count
;
1591 /* Like STRING_BYTES, but with debugging check. Can be
1592 called during GC, so pay attention to the mark bit. */
1595 string_bytes (struct Lisp_String
*s
)
1598 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1600 if (!PURE_POINTER_P (s
)
1602 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1607 /* Check validity of Lisp strings' string_bytes member in B. */
1610 check_sblock (struct sblock
*b
)
1612 sdata
*from
, *end
, *from_end
;
1616 for (from
= b
->data
; from
< end
; from
= from_end
)
1618 /* Compute the next FROM here because copying below may
1619 overwrite data we need to compute it. */
1622 /* Check that the string size recorded in the string is the
1623 same as the one recorded in the sdata structure. */
1624 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1625 : SDATA_NBYTES (from
));
1626 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1631 /* Check validity of Lisp strings' string_bytes member. ALL_P
1632 means check all strings, otherwise check only most
1633 recently allocated strings. Used for hunting a bug. */
1636 check_string_bytes (bool all_p
)
1642 for (b
= large_sblocks
; b
; b
= b
->next
)
1644 struct Lisp_String
*s
= b
->data
[0].string
;
1649 for (b
= oldest_sblock
; b
; b
= b
->next
)
1652 else if (current_sblock
)
1653 check_sblock (current_sblock
);
1656 #else /* not GC_CHECK_STRING_BYTES */
1658 #define check_string_bytes(all) ((void) 0)
1660 #endif /* GC_CHECK_STRING_BYTES */
1662 #ifdef GC_CHECK_STRING_FREE_LIST
1664 /* Walk through the string free list looking for bogus next pointers.
1665 This may catch buffer overrun from a previous string. */
1668 check_string_free_list (void)
1670 struct Lisp_String
*s
;
1672 /* Pop a Lisp_String off the free-list. */
1673 s
= string_free_list
;
1676 if ((uintptr_t) s
< 1024)
1678 s
= NEXT_FREE_LISP_STRING (s
);
1682 #define check_string_free_list()
1685 /* Return a new Lisp_String. */
1687 static struct Lisp_String
*
1688 allocate_string (void)
1690 struct Lisp_String
*s
;
1694 /* If the free-list is empty, allocate a new string_block, and
1695 add all the Lisp_Strings in it to the free-list. */
1696 if (string_free_list
== NULL
)
1698 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1701 b
->next
= string_blocks
;
1704 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1707 /* Every string on a free list should have NULL data pointer. */
1709 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1710 string_free_list
= s
;
1713 total_free_strings
+= STRING_BLOCK_SIZE
;
1716 check_string_free_list ();
1718 /* Pop a Lisp_String off the free-list. */
1719 s
= string_free_list
;
1720 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1722 MALLOC_UNBLOCK_INPUT
;
1724 --total_free_strings
;
1727 consing_since_gc
+= sizeof *s
;
1729 #ifdef GC_CHECK_STRING_BYTES
1730 if (!noninteractive
)
1732 if (++check_string_bytes_count
== 200)
1734 check_string_bytes_count
= 0;
1735 check_string_bytes (1);
1738 check_string_bytes (0);
1740 #endif /* GC_CHECK_STRING_BYTES */
1746 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1747 plus a NUL byte at the end. Allocate an sdata structure for S, and
1748 set S->data to its `u.data' member. Store a NUL byte at the end of
1749 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1750 S->data if it was initially non-null. */
1753 allocate_string_data (struct Lisp_String
*s
,
1754 EMACS_INT nchars
, EMACS_INT nbytes
)
1756 sdata
*data
, *old_data
;
1758 ptrdiff_t needed
, old_nbytes
;
1760 if (STRING_BYTES_MAX
< nbytes
)
1763 /* Determine the number of bytes needed to store NBYTES bytes
1765 needed
= SDATA_SIZE (nbytes
);
1768 old_data
= SDATA_OF_STRING (s
);
1769 old_nbytes
= STRING_BYTES (s
);
1776 if (nbytes
> LARGE_STRING_BYTES
)
1778 size_t size
= offsetof (struct sblock
, data
) + needed
;
1780 #ifdef DOUG_LEA_MALLOC
1781 if (!mmap_lisp_allowed_p ())
1782 mallopt (M_MMAP_MAX
, 0);
1785 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1787 #ifdef DOUG_LEA_MALLOC
1788 if (!mmap_lisp_allowed_p ())
1789 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1792 b
->next_free
= b
->data
;
1793 b
->data
[0].string
= NULL
;
1794 b
->next
= large_sblocks
;
1797 else if (current_sblock
== NULL
1798 || (((char *) current_sblock
+ SBLOCK_SIZE
1799 - (char *) current_sblock
->next_free
)
1800 < (needed
+ GC_STRING_EXTRA
)))
1802 /* Not enough room in the current sblock. */
1803 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1804 b
->next_free
= b
->data
;
1805 b
->data
[0].string
= NULL
;
1809 current_sblock
->next
= b
;
1817 data
= b
->next_free
;
1818 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1820 MALLOC_UNBLOCK_INPUT
;
1823 s
->data
= SDATA_DATA (data
);
1824 #ifdef GC_CHECK_STRING_BYTES
1825 SDATA_NBYTES (data
) = nbytes
;
1828 s
->size_byte
= nbytes
;
1829 s
->data
[nbytes
] = '\0';
1830 #ifdef GC_CHECK_STRING_OVERRUN
1831 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1832 GC_STRING_OVERRUN_COOKIE_SIZE
);
1835 /* Note that Faset may call to this function when S has already data
1836 assigned. In this case, mark data as free by setting it's string
1837 back-pointer to null, and record the size of the data in it. */
1840 SDATA_NBYTES (old_data
) = old_nbytes
;
1841 old_data
->string
= NULL
;
1844 consing_since_gc
+= needed
;
1848 /* Sweep and compact strings. */
1850 NO_INLINE
/* For better stack traces */
1852 sweep_strings (void)
1854 struct string_block
*b
, *next
;
1855 struct string_block
*live_blocks
= NULL
;
1857 string_free_list
= NULL
;
1858 total_strings
= total_free_strings
= 0;
1859 total_string_bytes
= 0;
1861 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1862 for (b
= string_blocks
; b
; b
= next
)
1865 struct Lisp_String
*free_list_before
= string_free_list
;
1869 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1871 struct Lisp_String
*s
= b
->strings
+ i
;
1875 /* String was not on free-list before. */
1876 if (STRING_MARKED_P (s
))
1878 /* String is live; unmark it and its intervals. */
1881 /* Do not use string_(set|get)_intervals here. */
1882 s
->intervals
= balance_intervals (s
->intervals
);
1885 total_string_bytes
+= STRING_BYTES (s
);
1889 /* String is dead. Put it on the free-list. */
1890 sdata
*data
= SDATA_OF_STRING (s
);
1892 /* Save the size of S in its sdata so that we know
1893 how large that is. Reset the sdata's string
1894 back-pointer so that we know it's free. */
1895 #ifdef GC_CHECK_STRING_BYTES
1896 if (string_bytes (s
) != SDATA_NBYTES (data
))
1899 data
->n
.nbytes
= STRING_BYTES (s
);
1901 data
->string
= NULL
;
1903 /* Reset the strings's `data' member so that we
1907 /* Put the string on the free-list. */
1908 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1909 string_free_list
= s
;
1915 /* S was on the free-list before. Put it there again. */
1916 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1917 string_free_list
= s
;
1922 /* Free blocks that contain free Lisp_Strings only, except
1923 the first two of them. */
1924 if (nfree
== STRING_BLOCK_SIZE
1925 && total_free_strings
> STRING_BLOCK_SIZE
)
1928 string_free_list
= free_list_before
;
1932 total_free_strings
+= nfree
;
1933 b
->next
= live_blocks
;
1938 check_string_free_list ();
1940 string_blocks
= live_blocks
;
1941 free_large_strings ();
1942 compact_small_strings ();
1944 check_string_free_list ();
1948 /* Free dead large strings. */
1951 free_large_strings (void)
1953 struct sblock
*b
, *next
;
1954 struct sblock
*live_blocks
= NULL
;
1956 for (b
= large_sblocks
; b
; b
= next
)
1960 if (b
->data
[0].string
== NULL
)
1964 b
->next
= live_blocks
;
1969 large_sblocks
= live_blocks
;
1973 /* Compact data of small strings. Free sblocks that don't contain
1974 data of live strings after compaction. */
1977 compact_small_strings (void)
1979 struct sblock
*b
, *tb
, *next
;
1980 sdata
*from
, *to
, *end
, *tb_end
;
1981 sdata
*to_end
, *from_end
;
1983 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1984 to, and TB_END is the end of TB. */
1986 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1989 /* Step through the blocks from the oldest to the youngest. We
1990 expect that old blocks will stabilize over time, so that less
1991 copying will happen this way. */
1992 for (b
= oldest_sblock
; b
; b
= b
->next
)
1995 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1997 for (from
= b
->data
; from
< end
; from
= from_end
)
1999 /* Compute the next FROM here because copying below may
2000 overwrite data we need to compute it. */
2002 struct Lisp_String
*s
= from
->string
;
2004 #ifdef GC_CHECK_STRING_BYTES
2005 /* Check that the string size recorded in the string is the
2006 same as the one recorded in the sdata structure. */
2007 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2009 #endif /* GC_CHECK_STRING_BYTES */
2011 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2012 eassert (nbytes
<= LARGE_STRING_BYTES
);
2014 nbytes
= SDATA_SIZE (nbytes
);
2015 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2017 #ifdef GC_CHECK_STRING_OVERRUN
2018 if (memcmp (string_overrun_cookie
,
2019 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2020 GC_STRING_OVERRUN_COOKIE_SIZE
))
2024 /* Non-NULL S means it's alive. Copy its data. */
2027 /* If TB is full, proceed with the next sblock. */
2028 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2029 if (to_end
> tb_end
)
2033 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2035 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2038 /* Copy, and update the string's `data' pointer. */
2041 eassert (tb
!= b
|| to
< from
);
2042 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2043 to
->string
->data
= SDATA_DATA (to
);
2046 /* Advance past the sdata we copied to. */
2052 /* The rest of the sblocks following TB don't contain live data, so
2053 we can free them. */
2054 for (b
= tb
->next
; b
; b
= next
)
2062 current_sblock
= tb
;
2066 string_overflow (void)
2068 error ("Maximum string size exceeded");
2071 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2072 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2073 LENGTH must be an integer.
2074 INIT must be an integer that represents a character. */)
2075 (Lisp_Object length
, Lisp_Object init
)
2077 register Lisp_Object val
;
2081 CHECK_NATNUM (length
);
2082 CHECK_CHARACTER (init
);
2084 c
= XFASTINT (init
);
2085 if (ASCII_CHAR_P (c
))
2087 nbytes
= XINT (length
);
2088 val
= make_uninit_string (nbytes
);
2089 memset (SDATA (val
), c
, nbytes
);
2090 SDATA (val
)[nbytes
] = 0;
2094 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2095 ptrdiff_t len
= CHAR_STRING (c
, str
);
2096 EMACS_INT string_len
= XINT (length
);
2097 unsigned char *p
, *beg
, *end
;
2099 if (string_len
> STRING_BYTES_MAX
/ len
)
2101 nbytes
= len
* string_len
;
2102 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2103 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2105 /* First time we just copy `str' to the data of `val'. */
2107 memcpy (p
, str
, len
);
2110 /* Next time we copy largest possible chunk from
2111 initialized to uninitialized part of `val'. */
2112 len
= min (p
- beg
, end
- p
);
2113 memcpy (p
, beg
, len
);
2122 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2126 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2128 EMACS_INT nbits
= bool_vector_size (a
);
2131 unsigned char *data
= bool_vector_uchar_data (a
);
2132 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2133 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2134 int last_mask
= ~ (~0 << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2135 memset (data
, pattern
, nbytes
- 1);
2136 data
[nbytes
- 1] = pattern
& last_mask
;
2141 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2144 make_uninit_bool_vector (EMACS_INT nbits
)
2147 EMACS_INT words
= bool_vector_words (nbits
);
2148 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2149 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2152 struct Lisp_Bool_Vector
*p
2153 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2154 XSETVECTOR (val
, p
);
2155 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2158 /* Clear padding at the end. */
2160 p
->data
[words
- 1] = 0;
2165 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2166 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2167 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2168 (Lisp_Object length
, Lisp_Object init
)
2172 CHECK_NATNUM (length
);
2173 val
= make_uninit_bool_vector (XFASTINT (length
));
2174 return bool_vector_fill (val
, init
);
2178 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2179 of characters from the contents. This string may be unibyte or
2180 multibyte, depending on the contents. */
2183 make_string (const char *contents
, ptrdiff_t nbytes
)
2185 register Lisp_Object val
;
2186 ptrdiff_t nchars
, multibyte_nbytes
;
2188 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2189 &nchars
, &multibyte_nbytes
);
2190 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2191 /* CONTENTS contains no multibyte sequences or contains an invalid
2192 multibyte sequence. We must make unibyte string. */
2193 val
= make_unibyte_string (contents
, nbytes
);
2195 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2200 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2203 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2205 register Lisp_Object val
;
2206 val
= make_uninit_string (length
);
2207 memcpy (SDATA (val
), contents
, length
);
2212 /* Make a multibyte string from NCHARS characters occupying NBYTES
2213 bytes at CONTENTS. */
2216 make_multibyte_string (const char *contents
,
2217 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2219 register Lisp_Object val
;
2220 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2221 memcpy (SDATA (val
), contents
, nbytes
);
2226 /* Make a string from NCHARS characters occupying NBYTES bytes at
2227 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2230 make_string_from_bytes (const char *contents
,
2231 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2233 register Lisp_Object val
;
2234 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2235 memcpy (SDATA (val
), contents
, nbytes
);
2236 if (SBYTES (val
) == SCHARS (val
))
2237 STRING_SET_UNIBYTE (val
);
2242 /* Make a string from NCHARS characters occupying NBYTES bytes at
2243 CONTENTS. The argument MULTIBYTE controls whether to label the
2244 string as multibyte. If NCHARS is negative, it counts the number of
2245 characters by itself. */
2248 make_specified_string (const char *contents
,
2249 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2256 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2261 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2262 memcpy (SDATA (val
), contents
, nbytes
);
2264 STRING_SET_UNIBYTE (val
);
2269 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2270 occupying LENGTH bytes. */
2273 make_uninit_string (EMACS_INT length
)
2278 return empty_unibyte_string
;
2279 val
= make_uninit_multibyte_string (length
, length
);
2280 STRING_SET_UNIBYTE (val
);
2285 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2286 which occupy NBYTES bytes. */
2289 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2292 struct Lisp_String
*s
;
2297 return empty_multibyte_string
;
2299 s
= allocate_string ();
2300 s
->intervals
= NULL
;
2301 allocate_string_data (s
, nchars
, nbytes
);
2302 XSETSTRING (string
, s
);
2303 string_chars_consed
+= nbytes
;
2307 /* Print arguments to BUF according to a FORMAT, then return
2308 a Lisp_String initialized with the data from BUF. */
2311 make_formatted_string (char *buf
, const char *format
, ...)
2316 va_start (ap
, format
);
2317 length
= vsprintf (buf
, format
, ap
);
2319 return make_string (buf
, length
);
2323 /***********************************************************************
2325 ***********************************************************************/
2327 /* We store float cells inside of float_blocks, allocating a new
2328 float_block with malloc whenever necessary. Float cells reclaimed
2329 by GC are put on a free list to be reallocated before allocating
2330 any new float cells from the latest float_block. */
2332 #define FLOAT_BLOCK_SIZE \
2333 (((BLOCK_BYTES - sizeof (struct float_block *) \
2334 /* The compiler might add padding at the end. */ \
2335 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2336 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2338 #define GETMARKBIT(block,n) \
2339 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2340 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2343 #define SETMARKBIT(block,n) \
2344 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2345 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2347 #define UNSETMARKBIT(block,n) \
2348 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2349 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2351 #define FLOAT_BLOCK(fptr) \
2352 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2354 #define FLOAT_INDEX(fptr) \
2355 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2359 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2360 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2361 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2362 struct float_block
*next
;
2365 #define FLOAT_MARKED_P(fptr) \
2366 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2368 #define FLOAT_MARK(fptr) \
2369 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2371 #define FLOAT_UNMARK(fptr) \
2372 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2374 /* Current float_block. */
2376 static struct float_block
*float_block
;
2378 /* Index of first unused Lisp_Float in the current float_block. */
2380 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2382 /* Free-list of Lisp_Floats. */
2384 static struct Lisp_Float
*float_free_list
;
2386 /* Return a new float object with value FLOAT_VALUE. */
2389 make_float (double float_value
)
2391 register Lisp_Object val
;
2395 if (float_free_list
)
2397 /* We use the data field for chaining the free list
2398 so that we won't use the same field that has the mark bit. */
2399 XSETFLOAT (val
, float_free_list
);
2400 float_free_list
= float_free_list
->u
.chain
;
2404 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2406 struct float_block
*new
2407 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2408 new->next
= float_block
;
2409 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2411 float_block_index
= 0;
2412 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2414 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2415 float_block_index
++;
2418 MALLOC_UNBLOCK_INPUT
;
2420 XFLOAT_INIT (val
, float_value
);
2421 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2422 consing_since_gc
+= sizeof (struct Lisp_Float
);
2424 total_free_floats
--;
2430 /***********************************************************************
2432 ***********************************************************************/
2434 /* We store cons cells inside of cons_blocks, allocating a new
2435 cons_block with malloc whenever necessary. Cons cells reclaimed by
2436 GC are put on a free list to be reallocated before allocating
2437 any new cons cells from the latest cons_block. */
2439 #define CONS_BLOCK_SIZE \
2440 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2441 /* The compiler might add padding at the end. */ \
2442 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2443 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2445 #define CONS_BLOCK(fptr) \
2446 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2448 #define CONS_INDEX(fptr) \
2449 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2453 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2454 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2455 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2456 struct cons_block
*next
;
2459 #define CONS_MARKED_P(fptr) \
2460 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2462 #define CONS_MARK(fptr) \
2463 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2465 #define CONS_UNMARK(fptr) \
2466 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2468 /* Current cons_block. */
2470 static struct cons_block
*cons_block
;
2472 /* Index of first unused Lisp_Cons in the current block. */
2474 static int cons_block_index
= CONS_BLOCK_SIZE
;
2476 /* Free-list of Lisp_Cons structures. */
2478 static struct Lisp_Cons
*cons_free_list
;
2480 /* Explicitly free a cons cell by putting it on the free-list. */
2483 free_cons (struct Lisp_Cons
*ptr
)
2485 ptr
->u
.chain
= cons_free_list
;
2489 cons_free_list
= ptr
;
2490 consing_since_gc
-= sizeof *ptr
;
2491 total_free_conses
++;
2494 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2495 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2496 (Lisp_Object car
, Lisp_Object cdr
)
2498 register Lisp_Object val
;
2504 /* We use the cdr for chaining the free list
2505 so that we won't use the same field that has the mark bit. */
2506 XSETCONS (val
, cons_free_list
);
2507 cons_free_list
= cons_free_list
->u
.chain
;
2511 if (cons_block_index
== CONS_BLOCK_SIZE
)
2513 struct cons_block
*new
2514 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2515 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2516 new->next
= cons_block
;
2518 cons_block_index
= 0;
2519 total_free_conses
+= CONS_BLOCK_SIZE
;
2521 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2525 MALLOC_UNBLOCK_INPUT
;
2529 eassert (!CONS_MARKED_P (XCONS (val
)));
2530 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2531 total_free_conses
--;
2532 cons_cells_consed
++;
2536 #ifdef GC_CHECK_CONS_LIST
2537 /* Get an error now if there's any junk in the cons free list. */
2539 check_cons_list (void)
2541 struct Lisp_Cons
*tail
= cons_free_list
;
2544 tail
= tail
->u
.chain
;
2548 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2551 list1 (Lisp_Object arg1
)
2553 return Fcons (arg1
, Qnil
);
2557 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2559 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2564 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2566 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2571 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2573 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2578 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2580 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2581 Fcons (arg5
, Qnil
)))));
2584 /* Make a list of COUNT Lisp_Objects, where ARG is the
2585 first one. Allocate conses from pure space if TYPE
2586 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2589 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2593 Lisp_Object val
, *objp
;
2595 /* Change to SAFE_ALLOCA if you hit this eassert. */
2596 eassert (count
<= MAX_ALLOCA
/ word_size
);
2598 objp
= alloca (count
* word_size
);
2601 for (i
= 1; i
< count
; i
++)
2602 objp
[i
] = va_arg (ap
, Lisp_Object
);
2605 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2607 if (type
== CONSTYPE_PURE
)
2608 val
= pure_cons (objp
[i
], val
);
2609 else if (type
== CONSTYPE_HEAP
)
2610 val
= Fcons (objp
[i
], val
);
2617 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2618 doc
: /* Return a newly created list with specified arguments as elements.
2619 Any number of arguments, even zero arguments, are allowed.
2620 usage: (list &rest OBJECTS) */)
2621 (ptrdiff_t nargs
, Lisp_Object
*args
)
2623 register Lisp_Object val
;
2629 val
= Fcons (args
[nargs
], val
);
2635 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2636 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2637 (register Lisp_Object length
, Lisp_Object init
)
2639 register Lisp_Object val
;
2640 register EMACS_INT size
;
2642 CHECK_NATNUM (length
);
2643 size
= XFASTINT (length
);
2648 val
= Fcons (init
, val
);
2653 val
= Fcons (init
, val
);
2658 val
= Fcons (init
, val
);
2663 val
= Fcons (init
, val
);
2668 val
= Fcons (init
, val
);
2683 /***********************************************************************
2685 ***********************************************************************/
2687 /* Sometimes a vector's contents are merely a pointer internally used
2688 in vector allocation code. Usually you don't want to touch this. */
2690 static struct Lisp_Vector
*
2691 next_vector (struct Lisp_Vector
*v
)
2693 return XUNTAG (v
->contents
[0], 0);
2697 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2699 v
->contents
[0] = make_lisp_ptr (p
, 0);
2702 /* This value is balanced well enough to avoid too much internal overhead
2703 for the most common cases; it's not required to be a power of two, but
2704 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2706 #define VECTOR_BLOCK_SIZE 4096
2710 /* Alignment of struct Lisp_Vector objects. */
2711 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2712 USE_LSB_TAG
? GCALIGNMENT
: 1),
2714 /* Vector size requests are a multiple of this. */
2715 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2718 /* Verify assumptions described above. */
2719 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2720 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2722 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2723 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2724 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2725 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2727 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2729 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2731 /* Size of the minimal vector allocated from block. */
2733 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2735 /* Size of the largest vector allocated from block. */
2737 #define VBLOCK_BYTES_MAX \
2738 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2740 /* We maintain one free list for each possible block-allocated
2741 vector size, and this is the number of free lists we have. */
2743 #define VECTOR_MAX_FREE_LIST_INDEX \
2744 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2746 /* Common shortcut to advance vector pointer over a block data. */
2748 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2750 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2752 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2754 /* Common shortcut to setup vector on a free list. */
2756 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2758 (tmp) = ((nbytes - header_size) / word_size); \
2759 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2760 eassert ((nbytes) % roundup_size == 0); \
2761 (tmp) = VINDEX (nbytes); \
2762 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2763 set_next_vector (v, vector_free_lists[tmp]); \
2764 vector_free_lists[tmp] = (v); \
2765 total_free_vector_slots += (nbytes) / word_size; \
2768 /* This internal type is used to maintain the list of large vectors
2769 which are allocated at their own, e.g. outside of vector blocks.
2771 struct large_vector itself cannot contain a struct Lisp_Vector, as
2772 the latter contains a flexible array member and C99 does not allow
2773 such structs to be nested. Instead, each struct large_vector
2774 object LV is followed by a struct Lisp_Vector, which is at offset
2775 large_vector_offset from LV, and whose address is therefore
2776 large_vector_vec (&LV). */
2780 struct large_vector
*next
;
2785 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2788 static struct Lisp_Vector
*
2789 large_vector_vec (struct large_vector
*p
)
2791 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
2794 /* This internal type is used to maintain an underlying storage
2795 for small vectors. */
2799 char data
[VECTOR_BLOCK_BYTES
];
2800 struct vector_block
*next
;
2803 /* Chain of vector blocks. */
2805 static struct vector_block
*vector_blocks
;
2807 /* Vector free lists, where NTH item points to a chain of free
2808 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2810 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2812 /* Singly-linked list of large vectors. */
2814 static struct large_vector
*large_vectors
;
2816 /* The only vector with 0 slots, allocated from pure space. */
2818 Lisp_Object zero_vector
;
2820 /* Number of live vectors. */
2822 static EMACS_INT total_vectors
;
2824 /* Total size of live and free vectors, in Lisp_Object units. */
2826 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2828 /* Get a new vector block. */
2830 static struct vector_block
*
2831 allocate_vector_block (void)
2833 struct vector_block
*block
= xmalloc (sizeof *block
);
2835 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2836 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2837 MEM_TYPE_VECTOR_BLOCK
);
2840 block
->next
= vector_blocks
;
2841 vector_blocks
= block
;
2845 /* Called once to initialize vector allocation. */
2850 zero_vector
= make_pure_vector (0);
2853 /* Allocate vector from a vector block. */
2855 static struct Lisp_Vector
*
2856 allocate_vector_from_block (size_t nbytes
)
2858 struct Lisp_Vector
*vector
;
2859 struct vector_block
*block
;
2860 size_t index
, restbytes
;
2862 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2863 eassert (nbytes
% roundup_size
== 0);
2865 /* First, try to allocate from a free list
2866 containing vectors of the requested size. */
2867 index
= VINDEX (nbytes
);
2868 if (vector_free_lists
[index
])
2870 vector
= vector_free_lists
[index
];
2871 vector_free_lists
[index
] = next_vector (vector
);
2872 total_free_vector_slots
-= nbytes
/ word_size
;
2876 /* Next, check free lists containing larger vectors. Since
2877 we will split the result, we should have remaining space
2878 large enough to use for one-slot vector at least. */
2879 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2880 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2881 if (vector_free_lists
[index
])
2883 /* This vector is larger than requested. */
2884 vector
= vector_free_lists
[index
];
2885 vector_free_lists
[index
] = next_vector (vector
);
2886 total_free_vector_slots
-= nbytes
/ word_size
;
2888 /* Excess bytes are used for the smaller vector,
2889 which should be set on an appropriate free list. */
2890 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2891 eassert (restbytes
% roundup_size
== 0);
2892 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2896 /* Finally, need a new vector block. */
2897 block
= allocate_vector_block ();
2899 /* New vector will be at the beginning of this block. */
2900 vector
= (struct Lisp_Vector
*) block
->data
;
2902 /* If the rest of space from this block is large enough
2903 for one-slot vector at least, set up it on a free list. */
2904 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2905 if (restbytes
>= VBLOCK_BYTES_MIN
)
2907 eassert (restbytes
% roundup_size
== 0);
2908 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2913 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2915 #define VECTOR_IN_BLOCK(vector, block) \
2916 ((char *) (vector) <= (block)->data \
2917 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2919 /* Return the memory footprint of V in bytes. */
2922 vector_nbytes (struct Lisp_Vector
*v
)
2924 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2927 if (size
& PSEUDOVECTOR_FLAG
)
2929 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2931 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
2932 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
2933 * sizeof (bits_word
));
2934 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
2935 verify (header_size
<= bool_header_size
);
2936 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
2939 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
2940 + ((size
& PSEUDOVECTOR_REST_MASK
)
2941 >> PSEUDOVECTOR_SIZE_BITS
));
2945 return vroundup (header_size
+ word_size
* nwords
);
2948 /* Release extra resources still in use by VECTOR, which may be any
2949 vector-like object. For now, this is used just to free data in
2953 cleanup_vector (struct Lisp_Vector
*vector
)
2955 detect_suspicious_free (vector
);
2956 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
2957 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
2958 == FONT_OBJECT_MAX
))
2960 /* Attempt to catch subtle bugs like Bug#16140. */
2961 eassert (valid_font_driver (((struct font
*) vector
)->driver
));
2962 ((struct font
*) vector
)->driver
->close ((struct font
*) vector
);
2966 /* Reclaim space used by unmarked vectors. */
2968 NO_INLINE
/* For better stack traces */
2970 sweep_vectors (void)
2972 struct vector_block
*block
, **bprev
= &vector_blocks
;
2973 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2974 struct Lisp_Vector
*vector
, *next
;
2976 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2977 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2979 /* Looking through vector blocks. */
2981 for (block
= vector_blocks
; block
; block
= *bprev
)
2983 bool free_this_block
= 0;
2986 for (vector
= (struct Lisp_Vector
*) block
->data
;
2987 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2989 if (VECTOR_MARKED_P (vector
))
2991 VECTOR_UNMARK (vector
);
2993 nbytes
= vector_nbytes (vector
);
2994 total_vector_slots
+= nbytes
/ word_size
;
2995 next
= ADVANCE (vector
, nbytes
);
2999 ptrdiff_t total_bytes
;
3001 cleanup_vector (vector
);
3002 nbytes
= vector_nbytes (vector
);
3003 total_bytes
= nbytes
;
3004 next
= ADVANCE (vector
, nbytes
);
3006 /* While NEXT is not marked, try to coalesce with VECTOR,
3007 thus making VECTOR of the largest possible size. */
3009 while (VECTOR_IN_BLOCK (next
, block
))
3011 if (VECTOR_MARKED_P (next
))
3013 cleanup_vector (next
);
3014 nbytes
= vector_nbytes (next
);
3015 total_bytes
+= nbytes
;
3016 next
= ADVANCE (next
, nbytes
);
3019 eassert (total_bytes
% roundup_size
== 0);
3021 if (vector
== (struct Lisp_Vector
*) block
->data
3022 && !VECTOR_IN_BLOCK (next
, block
))
3023 /* This block should be freed because all of its
3024 space was coalesced into the only free vector. */
3025 free_this_block
= 1;
3029 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3034 if (free_this_block
)
3036 *bprev
= block
->next
;
3037 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
3038 mem_delete (mem_find (block
->data
));
3043 bprev
= &block
->next
;
3046 /* Sweep large vectors. */
3048 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3050 vector
= large_vector_vec (lv
);
3051 if (VECTOR_MARKED_P (vector
))
3053 VECTOR_UNMARK (vector
);
3055 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3057 /* All non-bool pseudovectors are small enough to be allocated
3058 from vector blocks. This code should be redesigned if some
3059 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3060 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3061 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3065 += header_size
/ word_size
+ vector
->header
.size
;
3076 /* Value is a pointer to a newly allocated Lisp_Vector structure
3077 with room for LEN Lisp_Objects. */
3079 static struct Lisp_Vector
*
3080 allocate_vectorlike (ptrdiff_t len
)
3082 struct Lisp_Vector
*p
;
3087 p
= XVECTOR (zero_vector
);
3090 size_t nbytes
= header_size
+ len
* word_size
;
3092 #ifdef DOUG_LEA_MALLOC
3093 if (!mmap_lisp_allowed_p ())
3094 mallopt (M_MMAP_MAX
, 0);
3097 if (nbytes
<= VBLOCK_BYTES_MAX
)
3098 p
= allocate_vector_from_block (vroundup (nbytes
));
3101 struct large_vector
*lv
3102 = lisp_malloc ((large_vector_offset
+ header_size
3104 MEM_TYPE_VECTORLIKE
);
3105 lv
->next
= large_vectors
;
3107 p
= large_vector_vec (lv
);
3110 #ifdef DOUG_LEA_MALLOC
3111 if (!mmap_lisp_allowed_p ())
3112 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3115 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3118 consing_since_gc
+= nbytes
;
3119 vector_cells_consed
+= len
;
3122 MALLOC_UNBLOCK_INPUT
;
3128 /* Allocate a vector with LEN slots. */
3130 struct Lisp_Vector
*
3131 allocate_vector (EMACS_INT len
)
3133 struct Lisp_Vector
*v
;
3134 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3136 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3137 memory_full (SIZE_MAX
);
3138 v
= allocate_vectorlike (len
);
3139 v
->header
.size
= len
;
3144 /* Allocate other vector-like structures. */
3146 struct Lisp_Vector
*
3147 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
3149 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3152 /* Catch bogus values. */
3153 eassert (tag
<= PVEC_FONT
);
3154 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3155 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3157 /* Only the first lisplen slots will be traced normally by the GC. */
3158 for (i
= 0; i
< lisplen
; ++i
)
3159 v
->contents
[i
] = Qnil
;
3161 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3166 allocate_buffer (void)
3168 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3170 BUFFER_PVEC_INIT (b
);
3171 /* Put B on the chain of all buffers including killed ones. */
3172 b
->next
= all_buffers
;
3174 /* Note that the rest fields of B are not initialized. */
3178 struct Lisp_Hash_Table
*
3179 allocate_hash_table (void)
3181 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3185 allocate_window (void)
3189 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3190 /* Users assumes that non-Lisp data is zeroed. */
3191 memset (&w
->current_matrix
, 0,
3192 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3197 allocate_terminal (void)
3201 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3202 /* Users assumes that non-Lisp data is zeroed. */
3203 memset (&t
->next_terminal
, 0,
3204 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3209 allocate_frame (void)
3213 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3214 /* Users assumes that non-Lisp data is zeroed. */
3215 memset (&f
->face_cache
, 0,
3216 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3220 struct Lisp_Process
*
3221 allocate_process (void)
3223 struct Lisp_Process
*p
;
3225 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3226 /* Users assumes that non-Lisp data is zeroed. */
3228 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3232 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3233 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3234 See also the function `vector'. */)
3235 (register Lisp_Object length
, Lisp_Object init
)
3238 register ptrdiff_t sizei
;
3239 register ptrdiff_t i
;
3240 register struct Lisp_Vector
*p
;
3242 CHECK_NATNUM (length
);
3244 p
= allocate_vector (XFASTINT (length
));
3245 sizei
= XFASTINT (length
);
3246 for (i
= 0; i
< sizei
; i
++)
3247 p
->contents
[i
] = init
;
3249 XSETVECTOR (vector
, p
);
3254 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3255 doc
: /* Return a newly created vector with specified arguments as elements.
3256 Any number of arguments, even zero arguments, are allowed.
3257 usage: (vector &rest OBJECTS) */)
3258 (ptrdiff_t nargs
, Lisp_Object
*args
)
3261 register Lisp_Object val
= make_uninit_vector (nargs
);
3262 register struct Lisp_Vector
*p
= XVECTOR (val
);
3264 for (i
= 0; i
< nargs
; i
++)
3265 p
->contents
[i
] = args
[i
];
3270 make_byte_code (struct Lisp_Vector
*v
)
3272 /* Don't allow the global zero_vector to become a byte code object. */
3273 eassert (0 < v
->header
.size
);
3275 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3276 && STRING_MULTIBYTE (v
->contents
[1]))
3277 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3278 earlier because they produced a raw 8-bit string for byte-code
3279 and now such a byte-code string is loaded as multibyte while
3280 raw 8-bit characters converted to multibyte form. Thus, now we
3281 must convert them back to the original unibyte form. */
3282 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3283 XSETPVECTYPE (v
, PVEC_COMPILED
);
3286 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3287 doc
: /* Create a byte-code object with specified arguments as elements.
3288 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3289 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3290 and (optional) INTERACTIVE-SPEC.
3291 The first four arguments are required; at most six have any
3293 The ARGLIST can be either like the one of `lambda', in which case the arguments
3294 will be dynamically bound before executing the byte code, or it can be an
3295 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3296 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3297 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3298 argument to catch the left-over arguments. If such an integer is used, the
3299 arguments will not be dynamically bound but will be instead pushed on the
3300 stack before executing the byte-code.
3301 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3302 (ptrdiff_t nargs
, Lisp_Object
*args
)
3305 register Lisp_Object val
= make_uninit_vector (nargs
);
3306 register struct Lisp_Vector
*p
= XVECTOR (val
);
3308 /* We used to purecopy everything here, if purify-flag was set. This worked
3309 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3310 dangerous, since make-byte-code is used during execution to build
3311 closures, so any closure built during the preload phase would end up
3312 copied into pure space, including its free variables, which is sometimes
3313 just wasteful and other times plainly wrong (e.g. those free vars may want
3316 for (i
= 0; i
< nargs
; i
++)
3317 p
->contents
[i
] = args
[i
];
3319 XSETCOMPILED (val
, p
);
3325 /***********************************************************************
3327 ***********************************************************************/
3329 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3330 of the required alignment if LSB tags are used. */
3332 union aligned_Lisp_Symbol
3334 struct Lisp_Symbol s
;
3336 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3341 /* Each symbol_block is just under 1020 bytes long, since malloc
3342 really allocates in units of powers of two and uses 4 bytes for its
3345 #define SYMBOL_BLOCK_SIZE \
3346 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3350 /* Place `symbols' first, to preserve alignment. */
3351 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3352 struct symbol_block
*next
;
3355 /* Current symbol block and index of first unused Lisp_Symbol
3358 static struct symbol_block
*symbol_block
;
3359 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3360 /* Pointer to the first symbol_block that contains pinned symbols.
3361 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3362 10K of which are pinned (and all but 250 of them are interned in obarray),
3363 whereas a "typical session" has in the order of 30K symbols.
3364 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3365 than 30K to find the 10K symbols we need to mark. */
3366 static struct symbol_block
*symbol_block_pinned
;
3368 /* List of free symbols. */
3370 static struct Lisp_Symbol
*symbol_free_list
;
3373 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3375 XSYMBOL (sym
)->name
= name
;
3378 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3379 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3380 Its value is void, and its function definition and property list are nil. */)
3383 register Lisp_Object val
;
3384 register struct Lisp_Symbol
*p
;
3386 CHECK_STRING (name
);
3390 if (symbol_free_list
)
3392 XSETSYMBOL (val
, symbol_free_list
);
3393 symbol_free_list
= symbol_free_list
->next
;
3397 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3399 struct symbol_block
*new
3400 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3401 new->next
= symbol_block
;
3403 symbol_block_index
= 0;
3404 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3406 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3407 symbol_block_index
++;
3410 MALLOC_UNBLOCK_INPUT
;
3413 set_symbol_name (val
, name
);
3414 set_symbol_plist (val
, Qnil
);
3415 p
->redirect
= SYMBOL_PLAINVAL
;
3416 SET_SYMBOL_VAL (p
, Qunbound
);
3417 set_symbol_function (val
, Qnil
);
3418 set_symbol_next (val
, NULL
);
3419 p
->gcmarkbit
= false;
3420 p
->interned
= SYMBOL_UNINTERNED
;
3422 p
->declared_special
= false;
3424 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3426 total_free_symbols
--;
3432 /***********************************************************************
3433 Marker (Misc) Allocation
3434 ***********************************************************************/
3436 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3437 the required alignment when LSB tags are used. */
3439 union aligned_Lisp_Misc
3443 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3448 /* Allocation of markers and other objects that share that structure.
3449 Works like allocation of conses. */
3451 #define MARKER_BLOCK_SIZE \
3452 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3456 /* Place `markers' first, to preserve alignment. */
3457 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3458 struct marker_block
*next
;
3461 static struct marker_block
*marker_block
;
3462 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3464 static union Lisp_Misc
*marker_free_list
;
3466 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3469 allocate_misc (enum Lisp_Misc_Type type
)
3475 if (marker_free_list
)
3477 XSETMISC (val
, marker_free_list
);
3478 marker_free_list
= marker_free_list
->u_free
.chain
;
3482 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3484 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3485 new->next
= marker_block
;
3487 marker_block_index
= 0;
3488 total_free_markers
+= MARKER_BLOCK_SIZE
;
3490 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3491 marker_block_index
++;
3494 MALLOC_UNBLOCK_INPUT
;
3496 --total_free_markers
;
3497 consing_since_gc
+= sizeof (union Lisp_Misc
);
3498 misc_objects_consed
++;
3499 XMISCANY (val
)->type
= type
;
3500 XMISCANY (val
)->gcmarkbit
= 0;
3504 /* Free a Lisp_Misc object. */
3507 free_misc (Lisp_Object misc
)
3509 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3510 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3511 marker_free_list
= XMISC (misc
);
3512 consing_since_gc
-= sizeof (union Lisp_Misc
);
3513 total_free_markers
++;
3516 /* Verify properties of Lisp_Save_Value's representation
3517 that are assumed here and elsewhere. */
3519 verify (SAVE_UNUSED
== 0);
3520 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3524 /* Return Lisp_Save_Value objects for the various combinations
3525 that callers need. */
3528 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3530 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3531 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3532 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3533 p
->data
[0].integer
= a
;
3534 p
->data
[1].integer
= b
;
3535 p
->data
[2].integer
= c
;
3540 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3543 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3544 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3545 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3546 p
->data
[0].object
= a
;
3547 p
->data
[1].object
= b
;
3548 p
->data
[2].object
= c
;
3549 p
->data
[3].object
= d
;
3554 make_save_ptr (void *a
)
3556 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3557 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3558 p
->save_type
= SAVE_POINTER
;
3559 p
->data
[0].pointer
= a
;
3564 make_save_ptr_int (void *a
, ptrdiff_t b
)
3566 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3567 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3568 p
->save_type
= SAVE_TYPE_PTR_INT
;
3569 p
->data
[0].pointer
= a
;
3570 p
->data
[1].integer
= b
;
3574 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3576 make_save_ptr_ptr (void *a
, void *b
)
3578 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3579 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3580 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3581 p
->data
[0].pointer
= a
;
3582 p
->data
[1].pointer
= b
;
3588 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3590 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3591 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3592 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3593 p
->data
[0].funcpointer
= a
;
3594 p
->data
[1].pointer
= b
;
3595 p
->data
[2].object
= c
;
3599 /* Return a Lisp_Save_Value object that represents an array A
3600 of N Lisp objects. */
3603 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3605 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3606 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3607 p
->save_type
= SAVE_TYPE_MEMORY
;
3608 p
->data
[0].pointer
= a
;
3609 p
->data
[1].integer
= n
;
3613 /* Free a Lisp_Save_Value object. Do not use this function
3614 if SAVE contains pointer other than returned by xmalloc. */
3617 free_save_value (Lisp_Object save
)
3619 xfree (XSAVE_POINTER (save
, 0));
3623 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3626 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3628 register Lisp_Object overlay
;
3630 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3631 OVERLAY_START (overlay
) = start
;
3632 OVERLAY_END (overlay
) = end
;
3633 set_overlay_plist (overlay
, plist
);
3634 XOVERLAY (overlay
)->next
= NULL
;
3638 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3639 doc
: /* Return a newly allocated marker which does not point at any place. */)
3642 register Lisp_Object val
;
3643 register struct Lisp_Marker
*p
;
3645 val
= allocate_misc (Lisp_Misc_Marker
);
3651 p
->insertion_type
= 0;
3652 p
->need_adjustment
= 0;
3656 /* Return a newly allocated marker which points into BUF
3657 at character position CHARPOS and byte position BYTEPOS. */
3660 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3663 struct Lisp_Marker
*m
;
3665 /* No dead buffers here. */
3666 eassert (BUFFER_LIVE_P (buf
));
3668 /* Every character is at least one byte. */
3669 eassert (charpos
<= bytepos
);
3671 obj
= allocate_misc (Lisp_Misc_Marker
);
3674 m
->charpos
= charpos
;
3675 m
->bytepos
= bytepos
;
3676 m
->insertion_type
= 0;
3677 m
->need_adjustment
= 0;
3678 m
->next
= BUF_MARKERS (buf
);
3679 BUF_MARKERS (buf
) = m
;
3683 /* Put MARKER back on the free list after using it temporarily. */
3686 free_marker (Lisp_Object marker
)
3688 unchain_marker (XMARKER (marker
));
3693 /* Return a newly created vector or string with specified arguments as
3694 elements. If all the arguments are characters that can fit
3695 in a string of events, make a string; otherwise, make a vector.
3697 Any number of arguments, even zero arguments, are allowed. */
3700 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3704 for (i
= 0; i
< nargs
; i
++)
3705 /* The things that fit in a string
3706 are characters that are in 0...127,
3707 after discarding the meta bit and all the bits above it. */
3708 if (!INTEGERP (args
[i
])
3709 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3710 return Fvector (nargs
, args
);
3712 /* Since the loop exited, we know that all the things in it are
3713 characters, so we can make a string. */
3717 result
= Fmake_string (make_number (nargs
), make_number (0));
3718 for (i
= 0; i
< nargs
; i
++)
3720 SSET (result
, i
, XINT (args
[i
]));
3721 /* Move the meta bit to the right place for a string char. */
3722 if (XINT (args
[i
]) & CHAR_META
)
3723 SSET (result
, i
, SREF (result
, i
) | 0x80);
3732 /************************************************************************
3733 Memory Full Handling
3734 ************************************************************************/
3737 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3738 there may have been size_t overflow so that malloc was never
3739 called, or perhaps malloc was invoked successfully but the
3740 resulting pointer had problems fitting into a tagged EMACS_INT. In
3741 either case this counts as memory being full even though malloc did
3745 memory_full (size_t nbytes
)
3747 /* Do not go into hysterics merely because a large request failed. */
3748 bool enough_free_memory
= 0;
3749 if (SPARE_MEMORY
< nbytes
)
3754 p
= malloc (SPARE_MEMORY
);
3758 enough_free_memory
= 1;
3760 MALLOC_UNBLOCK_INPUT
;
3763 if (! enough_free_memory
)
3769 memory_full_cons_threshold
= sizeof (struct cons_block
);
3771 /* The first time we get here, free the spare memory. */
3772 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
3773 if (spare_memory
[i
])
3776 free (spare_memory
[i
]);
3777 else if (i
>= 1 && i
<= 4)
3778 lisp_align_free (spare_memory
[i
]);
3780 lisp_free (spare_memory
[i
]);
3781 spare_memory
[i
] = 0;
3785 /* This used to call error, but if we've run out of memory, we could
3786 get infinite recursion trying to build the string. */
3787 xsignal (Qnil
, Vmemory_signal_data
);
3790 /* If we released our reserve (due to running out of memory),
3791 and we have a fair amount free once again,
3792 try to set aside another reserve in case we run out once more.
3794 This is called when a relocatable block is freed in ralloc.c,
3795 and also directly from this file, in case we're not using ralloc.c. */
3798 refill_memory_reserve (void)
3800 #ifndef SYSTEM_MALLOC
3801 if (spare_memory
[0] == 0)
3802 spare_memory
[0] = malloc (SPARE_MEMORY
);
3803 if (spare_memory
[1] == 0)
3804 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3806 if (spare_memory
[2] == 0)
3807 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3809 if (spare_memory
[3] == 0)
3810 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3812 if (spare_memory
[4] == 0)
3813 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3815 if (spare_memory
[5] == 0)
3816 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3818 if (spare_memory
[6] == 0)
3819 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3821 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3822 Vmemory_full
= Qnil
;
3826 /************************************************************************
3828 ************************************************************************/
3830 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3832 /* Conservative C stack marking requires a method to identify possibly
3833 live Lisp objects given a pointer value. We do this by keeping
3834 track of blocks of Lisp data that are allocated in a red-black tree
3835 (see also the comment of mem_node which is the type of nodes in
3836 that tree). Function lisp_malloc adds information for an allocated
3837 block to the red-black tree with calls to mem_insert, and function
3838 lisp_free removes it with mem_delete. Functions live_string_p etc
3839 call mem_find to lookup information about a given pointer in the
3840 tree, and use that to determine if the pointer points to a Lisp
3843 /* Initialize this part of alloc.c. */
3848 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3849 mem_z
.parent
= NULL
;
3850 mem_z
.color
= MEM_BLACK
;
3851 mem_z
.start
= mem_z
.end
= NULL
;
3856 /* Value is a pointer to the mem_node containing START. Value is
3857 MEM_NIL if there is no node in the tree containing START. */
3859 static struct mem_node
*
3860 mem_find (void *start
)
3864 if (start
< min_heap_address
|| start
> max_heap_address
)
3867 /* Make the search always successful to speed up the loop below. */
3868 mem_z
.start
= start
;
3869 mem_z
.end
= (char *) start
+ 1;
3872 while (start
< p
->start
|| start
>= p
->end
)
3873 p
= start
< p
->start
? p
->left
: p
->right
;
3878 /* Insert a new node into the tree for a block of memory with start
3879 address START, end address END, and type TYPE. Value is a
3880 pointer to the node that was inserted. */
3882 static struct mem_node
*
3883 mem_insert (void *start
, void *end
, enum mem_type type
)
3885 struct mem_node
*c
, *parent
, *x
;
3887 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3888 min_heap_address
= start
;
3889 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3890 max_heap_address
= end
;
3892 /* See where in the tree a node for START belongs. In this
3893 particular application, it shouldn't happen that a node is already
3894 present. For debugging purposes, let's check that. */
3898 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3900 while (c
!= MEM_NIL
)
3902 if (start
>= c
->start
&& start
< c
->end
)
3905 c
= start
< c
->start
? c
->left
: c
->right
;
3908 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3910 while (c
!= MEM_NIL
)
3913 c
= start
< c
->start
? c
->left
: c
->right
;
3916 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3918 /* Create a new node. */
3919 #ifdef GC_MALLOC_CHECK
3920 x
= malloc (sizeof *x
);
3924 x
= xmalloc (sizeof *x
);
3930 x
->left
= x
->right
= MEM_NIL
;
3933 /* Insert it as child of PARENT or install it as root. */
3936 if (start
< parent
->start
)
3944 /* Re-establish red-black tree properties. */
3945 mem_insert_fixup (x
);
3951 /* Re-establish the red-black properties of the tree, and thereby
3952 balance the tree, after node X has been inserted; X is always red. */
3955 mem_insert_fixup (struct mem_node
*x
)
3957 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3959 /* X is red and its parent is red. This is a violation of
3960 red-black tree property #3. */
3962 if (x
->parent
== x
->parent
->parent
->left
)
3964 /* We're on the left side of our grandparent, and Y is our
3966 struct mem_node
*y
= x
->parent
->parent
->right
;
3968 if (y
->color
== MEM_RED
)
3970 /* Uncle and parent are red but should be black because
3971 X is red. Change the colors accordingly and proceed
3972 with the grandparent. */
3973 x
->parent
->color
= MEM_BLACK
;
3974 y
->color
= MEM_BLACK
;
3975 x
->parent
->parent
->color
= MEM_RED
;
3976 x
= x
->parent
->parent
;
3980 /* Parent and uncle have different colors; parent is
3981 red, uncle is black. */
3982 if (x
== x
->parent
->right
)
3985 mem_rotate_left (x
);
3988 x
->parent
->color
= MEM_BLACK
;
3989 x
->parent
->parent
->color
= MEM_RED
;
3990 mem_rotate_right (x
->parent
->parent
);
3995 /* This is the symmetrical case of above. */
3996 struct mem_node
*y
= x
->parent
->parent
->left
;
3998 if (y
->color
== MEM_RED
)
4000 x
->parent
->color
= MEM_BLACK
;
4001 y
->color
= MEM_BLACK
;
4002 x
->parent
->parent
->color
= MEM_RED
;
4003 x
= x
->parent
->parent
;
4007 if (x
== x
->parent
->left
)
4010 mem_rotate_right (x
);
4013 x
->parent
->color
= MEM_BLACK
;
4014 x
->parent
->parent
->color
= MEM_RED
;
4015 mem_rotate_left (x
->parent
->parent
);
4020 /* The root may have been changed to red due to the algorithm. Set
4021 it to black so that property #5 is satisfied. */
4022 mem_root
->color
= MEM_BLACK
;
4033 mem_rotate_left (struct mem_node
*x
)
4037 /* Turn y's left sub-tree into x's right sub-tree. */
4040 if (y
->left
!= MEM_NIL
)
4041 y
->left
->parent
= x
;
4043 /* Y's parent was x's parent. */
4045 y
->parent
= x
->parent
;
4047 /* Get the parent to point to y instead of x. */
4050 if (x
== x
->parent
->left
)
4051 x
->parent
->left
= y
;
4053 x
->parent
->right
= y
;
4058 /* Put x on y's left. */
4072 mem_rotate_right (struct mem_node
*x
)
4074 struct mem_node
*y
= x
->left
;
4077 if (y
->right
!= MEM_NIL
)
4078 y
->right
->parent
= x
;
4081 y
->parent
= x
->parent
;
4084 if (x
== x
->parent
->right
)
4085 x
->parent
->right
= y
;
4087 x
->parent
->left
= y
;
4098 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4101 mem_delete (struct mem_node
*z
)
4103 struct mem_node
*x
, *y
;
4105 if (!z
|| z
== MEM_NIL
)
4108 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4113 while (y
->left
!= MEM_NIL
)
4117 if (y
->left
!= MEM_NIL
)
4122 x
->parent
= y
->parent
;
4125 if (y
== y
->parent
->left
)
4126 y
->parent
->left
= x
;
4128 y
->parent
->right
= x
;
4135 z
->start
= y
->start
;
4140 if (y
->color
== MEM_BLACK
)
4141 mem_delete_fixup (x
);
4143 #ifdef GC_MALLOC_CHECK
4151 /* Re-establish the red-black properties of the tree, after a
4155 mem_delete_fixup (struct mem_node
*x
)
4157 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4159 if (x
== x
->parent
->left
)
4161 struct mem_node
*w
= x
->parent
->right
;
4163 if (w
->color
== MEM_RED
)
4165 w
->color
= MEM_BLACK
;
4166 x
->parent
->color
= MEM_RED
;
4167 mem_rotate_left (x
->parent
);
4168 w
= x
->parent
->right
;
4171 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4178 if (w
->right
->color
== MEM_BLACK
)
4180 w
->left
->color
= MEM_BLACK
;
4182 mem_rotate_right (w
);
4183 w
= x
->parent
->right
;
4185 w
->color
= x
->parent
->color
;
4186 x
->parent
->color
= MEM_BLACK
;
4187 w
->right
->color
= MEM_BLACK
;
4188 mem_rotate_left (x
->parent
);
4194 struct mem_node
*w
= x
->parent
->left
;
4196 if (w
->color
== MEM_RED
)
4198 w
->color
= MEM_BLACK
;
4199 x
->parent
->color
= MEM_RED
;
4200 mem_rotate_right (x
->parent
);
4201 w
= x
->parent
->left
;
4204 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4211 if (w
->left
->color
== MEM_BLACK
)
4213 w
->right
->color
= MEM_BLACK
;
4215 mem_rotate_left (w
);
4216 w
= x
->parent
->left
;
4219 w
->color
= x
->parent
->color
;
4220 x
->parent
->color
= MEM_BLACK
;
4221 w
->left
->color
= MEM_BLACK
;
4222 mem_rotate_right (x
->parent
);
4228 x
->color
= MEM_BLACK
;
4232 /* Value is non-zero if P is a pointer to a live Lisp string on
4233 the heap. M is a pointer to the mem_block for P. */
4236 live_string_p (struct mem_node
*m
, void *p
)
4238 if (m
->type
== MEM_TYPE_STRING
)
4240 struct string_block
*b
= m
->start
;
4241 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4243 /* P must point to the start of a Lisp_String structure, and it
4244 must not be on the free-list. */
4246 && offset
% sizeof b
->strings
[0] == 0
4247 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4248 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4255 /* Value is non-zero if P is a pointer to a live Lisp cons on
4256 the heap. M is a pointer to the mem_block for P. */
4259 live_cons_p (struct mem_node
*m
, void *p
)
4261 if (m
->type
== MEM_TYPE_CONS
)
4263 struct cons_block
*b
= m
->start
;
4264 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4266 /* P must point to the start of a Lisp_Cons, not be
4267 one of the unused cells in the current cons block,
4268 and not be on the free-list. */
4270 && offset
% sizeof b
->conses
[0] == 0
4271 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4273 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4274 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4281 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4282 the heap. M is a pointer to the mem_block for P. */
4285 live_symbol_p (struct mem_node
*m
, void *p
)
4287 if (m
->type
== MEM_TYPE_SYMBOL
)
4289 struct symbol_block
*b
= m
->start
;
4290 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4292 /* P must point to the start of a Lisp_Symbol, not be
4293 one of the unused cells in the current symbol block,
4294 and not be on the free-list. */
4296 && offset
% sizeof b
->symbols
[0] == 0
4297 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4298 && (b
!= symbol_block
4299 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4300 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4307 /* Value is non-zero if P is a pointer to a live Lisp float on
4308 the heap. M is a pointer to the mem_block for P. */
4311 live_float_p (struct mem_node
*m
, void *p
)
4313 if (m
->type
== MEM_TYPE_FLOAT
)
4315 struct float_block
*b
= m
->start
;
4316 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4318 /* P must point to the start of a Lisp_Float and not be
4319 one of the unused cells in the current float block. */
4321 && offset
% sizeof b
->floats
[0] == 0
4322 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4323 && (b
!= float_block
4324 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4331 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4332 the heap. M is a pointer to the mem_block for P. */
4335 live_misc_p (struct mem_node
*m
, void *p
)
4337 if (m
->type
== MEM_TYPE_MISC
)
4339 struct marker_block
*b
= m
->start
;
4340 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4342 /* P must point to the start of a Lisp_Misc, not be
4343 one of the unused cells in the current misc block,
4344 and not be on the free-list. */
4346 && offset
% sizeof b
->markers
[0] == 0
4347 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4348 && (b
!= marker_block
4349 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4350 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4357 /* Value is non-zero if P is a pointer to a live vector-like object.
4358 M is a pointer to the mem_block for P. */
4361 live_vector_p (struct mem_node
*m
, void *p
)
4363 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4365 /* This memory node corresponds to a vector block. */
4366 struct vector_block
*block
= m
->start
;
4367 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4369 /* P is in the block's allocation range. Scan the block
4370 up to P and see whether P points to the start of some
4371 vector which is not on a free list. FIXME: check whether
4372 some allocation patterns (probably a lot of short vectors)
4373 may cause a substantial overhead of this loop. */
4374 while (VECTOR_IN_BLOCK (vector
, block
)
4375 && vector
<= (struct Lisp_Vector
*) p
)
4377 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4380 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4383 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4384 /* This memory node corresponds to a large vector. */
4390 /* Value is non-zero if P is a pointer to a live buffer. M is a
4391 pointer to the mem_block for P. */
4394 live_buffer_p (struct mem_node
*m
, void *p
)
4396 /* P must point to the start of the block, and the buffer
4397 must not have been killed. */
4398 return (m
->type
== MEM_TYPE_BUFFER
4400 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4403 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4407 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4409 /* Currently not used, but may be called from gdb. */
4411 void dump_zombies (void) EXTERNALLY_VISIBLE
;
4413 /* Array of objects that are kept alive because the C stack contains
4414 a pattern that looks like a reference to them. */
4416 #define MAX_ZOMBIES 10
4417 static Lisp_Object zombies
[MAX_ZOMBIES
];
4419 /* Number of zombie objects. */
4421 static EMACS_INT nzombies
;
4423 /* Number of garbage collections. */
4425 static EMACS_INT ngcs
;
4427 /* Average percentage of zombies per collection. */
4429 static double avg_zombies
;
4431 /* Max. number of live and zombie objects. */
4433 static EMACS_INT max_live
, max_zombies
;
4435 /* Average number of live objects per GC. */
4437 static double avg_live
;
4439 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4440 doc
: /* Show information about live and zombie objects. */)
4443 Lisp_Object args
[8], zombie_list
= Qnil
;
4445 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4446 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4447 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4448 args
[1] = make_number (ngcs
);
4449 args
[2] = make_float (avg_live
);
4450 args
[3] = make_float (avg_zombies
);
4451 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4452 args
[5] = make_number (max_live
);
4453 args
[6] = make_number (max_zombies
);
4454 args
[7] = zombie_list
;
4455 return Fmessage (8, args
);
4458 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4461 /* Mark OBJ if we can prove it's a Lisp_Object. */
4464 mark_maybe_object (Lisp_Object obj
)
4471 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4477 po
= (void *) XPNTR (obj
);
4484 switch (XTYPE (obj
))
4487 mark_p
= (live_string_p (m
, po
)
4488 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4492 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4496 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4500 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4503 case Lisp_Vectorlike
:
4504 /* Note: can't check BUFFERP before we know it's a
4505 buffer because checking that dereferences the pointer
4506 PO which might point anywhere. */
4507 if (live_vector_p (m
, po
))
4508 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4509 else if (live_buffer_p (m
, po
))
4510 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4514 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4523 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4524 if (nzombies
< MAX_ZOMBIES
)
4525 zombies
[nzombies
] = obj
;
4534 /* If P points to Lisp data, mark that as live if it isn't already
4538 mark_maybe_pointer (void *p
)
4544 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4547 /* Quickly rule out some values which can't point to Lisp data.
4548 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4549 Otherwise, assume that Lisp data is aligned on even addresses. */
4550 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4556 Lisp_Object obj
= Qnil
;
4560 case MEM_TYPE_NON_LISP
:
4561 case MEM_TYPE_SPARE
:
4562 /* Nothing to do; not a pointer to Lisp memory. */
4565 case MEM_TYPE_BUFFER
:
4566 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4567 XSETVECTOR (obj
, p
);
4571 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4575 case MEM_TYPE_STRING
:
4576 if (live_string_p (m
, p
)
4577 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4578 XSETSTRING (obj
, p
);
4582 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4586 case MEM_TYPE_SYMBOL
:
4587 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4588 XSETSYMBOL (obj
, p
);
4591 case MEM_TYPE_FLOAT
:
4592 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4596 case MEM_TYPE_VECTORLIKE
:
4597 case MEM_TYPE_VECTOR_BLOCK
:
4598 if (live_vector_p (m
, p
))
4601 XSETVECTOR (tem
, p
);
4602 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4617 /* Alignment of pointer values. Use alignof, as it sometimes returns
4618 a smaller alignment than GCC's __alignof__ and mark_memory might
4619 miss objects if __alignof__ were used. */
4620 #define GC_POINTER_ALIGNMENT alignof (void *)
4622 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4623 not suffice, which is the typical case. A host where a Lisp_Object is
4624 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4625 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4626 suffice to widen it to to a Lisp_Object and check it that way. */
4627 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4628 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4629 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4630 nor mark_maybe_object can follow the pointers. This should not occur on
4631 any practical porting target. */
4632 # error "MSB type bits straddle pointer-word boundaries"
4634 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4635 pointer words that hold pointers ORed with type bits. */
4636 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4638 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4639 words that hold unmodified pointers. */
4640 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4643 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4644 or END+OFFSET..START. */
4646 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4647 mark_memory (void *start
, void *end
)
4652 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4656 /* Make START the pointer to the start of the memory region,
4657 if it isn't already. */
4665 /* Mark Lisp data pointed to. This is necessary because, in some
4666 situations, the C compiler optimizes Lisp objects away, so that
4667 only a pointer to them remains. Example:
4669 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4672 Lisp_Object obj = build_string ("test");
4673 struct Lisp_String *s = XSTRING (obj);
4674 Fgarbage_collect ();
4675 fprintf (stderr, "test `%s'\n", s->data);
4679 Here, `obj' isn't really used, and the compiler optimizes it
4680 away. The only reference to the life string is through the
4683 for (pp
= start
; (void *) pp
< end
; pp
++)
4684 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4686 void *p
= *(void **) ((char *) pp
+ i
);
4687 mark_maybe_pointer (p
);
4688 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4689 mark_maybe_object (XIL ((intptr_t) p
));
4693 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4695 static bool setjmp_tested_p
;
4696 static int longjmps_done
;
4698 #define SETJMP_WILL_LIKELY_WORK "\
4700 Emacs garbage collector has been changed to use conservative stack\n\
4701 marking. Emacs has determined that the method it uses to do the\n\
4702 marking will likely work on your system, but this isn't sure.\n\
4704 If you are a system-programmer, or can get the help of a local wizard\n\
4705 who is, please take a look at the function mark_stack in alloc.c, and\n\
4706 verify that the methods used are appropriate for your system.\n\
4708 Please mail the result to <emacs-devel@gnu.org>.\n\
4711 #define SETJMP_WILL_NOT_WORK "\
4713 Emacs garbage collector has been changed to use conservative stack\n\
4714 marking. Emacs has determined that the default method it uses to do the\n\
4715 marking will not work on your system. We will need a system-dependent\n\
4716 solution for your system.\n\
4718 Please take a look at the function mark_stack in alloc.c, and\n\
4719 try to find a way to make it work on your system.\n\
4721 Note that you may get false negatives, depending on the compiler.\n\
4722 In particular, you need to use -O with GCC for this test.\n\
4724 Please mail the result to <emacs-devel@gnu.org>.\n\
4728 /* Perform a quick check if it looks like setjmp saves registers in a
4729 jmp_buf. Print a message to stderr saying so. When this test
4730 succeeds, this is _not_ a proof that setjmp is sufficient for
4731 conservative stack marking. Only the sources or a disassembly
4741 /* Arrange for X to be put in a register. */
4747 if (longjmps_done
== 1)
4749 /* Came here after the longjmp at the end of the function.
4751 If x == 1, the longjmp has restored the register to its
4752 value before the setjmp, and we can hope that setjmp
4753 saves all such registers in the jmp_buf, although that
4756 For other values of X, either something really strange is
4757 taking place, or the setjmp just didn't save the register. */
4760 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4763 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4770 if (longjmps_done
== 1)
4771 sys_longjmp (jbuf
, 1);
4774 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4777 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4779 /* Abort if anything GCPRO'd doesn't survive the GC. */
4787 for (p
= gcprolist
; p
; p
= p
->next
)
4788 for (i
= 0; i
< p
->nvars
; ++i
)
4789 if (!survives_gc_p (p
->var
[i
]))
4790 /* FIXME: It's not necessarily a bug. It might just be that the
4791 GCPRO is unnecessary or should release the object sooner. */
4795 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4802 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4803 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4805 fprintf (stderr
, " %d = ", i
);
4806 debug_print (zombies
[i
]);
4810 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4813 /* Mark live Lisp objects on the C stack.
4815 There are several system-dependent problems to consider when
4816 porting this to new architectures:
4820 We have to mark Lisp objects in CPU registers that can hold local
4821 variables or are used to pass parameters.
4823 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4824 something that either saves relevant registers on the stack, or
4825 calls mark_maybe_object passing it each register's contents.
4827 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4828 implementation assumes that calling setjmp saves registers we need
4829 to see in a jmp_buf which itself lies on the stack. This doesn't
4830 have to be true! It must be verified for each system, possibly
4831 by taking a look at the source code of setjmp.
4833 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4834 can use it as a machine independent method to store all registers
4835 to the stack. In this case the macros described in the previous
4836 two paragraphs are not used.
4840 Architectures differ in the way their processor stack is organized.
4841 For example, the stack might look like this
4844 | Lisp_Object | size = 4
4846 | something else | size = 2
4848 | Lisp_Object | size = 4
4852 In such a case, not every Lisp_Object will be aligned equally. To
4853 find all Lisp_Object on the stack it won't be sufficient to walk
4854 the stack in steps of 4 bytes. Instead, two passes will be
4855 necessary, one starting at the start of the stack, and a second
4856 pass starting at the start of the stack + 2. Likewise, if the
4857 minimal alignment of Lisp_Objects on the stack is 1, four passes
4858 would be necessary, each one starting with one byte more offset
4859 from the stack start. */
4866 #ifdef HAVE___BUILTIN_UNWIND_INIT
4867 /* Force callee-saved registers and register windows onto the stack.
4868 This is the preferred method if available, obviating the need for
4869 machine dependent methods. */
4870 __builtin_unwind_init ();
4872 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4873 #ifndef GC_SAVE_REGISTERS_ON_STACK
4874 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4875 union aligned_jmpbuf
{
4879 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4881 /* This trick flushes the register windows so that all the state of
4882 the process is contained in the stack. */
4883 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4884 needed on ia64 too. See mach_dep.c, where it also says inline
4885 assembler doesn't work with relevant proprietary compilers. */
4887 #if defined (__sparc64__) && defined (__FreeBSD__)
4888 /* FreeBSD does not have a ta 3 handler. */
4895 /* Save registers that we need to see on the stack. We need to see
4896 registers used to hold register variables and registers used to
4898 #ifdef GC_SAVE_REGISTERS_ON_STACK
4899 GC_SAVE_REGISTERS_ON_STACK (end
);
4900 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4902 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4903 setjmp will definitely work, test it
4904 and print a message with the result
4906 if (!setjmp_tested_p
)
4908 setjmp_tested_p
= 1;
4911 #endif /* GC_SETJMP_WORKS */
4914 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4915 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4916 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4918 /* This assumes that the stack is a contiguous region in memory. If
4919 that's not the case, something has to be done here to iterate
4920 over the stack segments. */
4921 mark_memory (stack_base
, end
);
4923 /* Allow for marking a secondary stack, like the register stack on the
4925 #ifdef GC_MARK_SECONDARY_STACK
4926 GC_MARK_SECONDARY_STACK ();
4929 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4934 #else /* GC_MARK_STACK == 0 */
4936 #define mark_maybe_object(obj) emacs_abort ()
4938 #endif /* GC_MARK_STACK != 0 */
4941 /* Determine whether it is safe to access memory at address P. */
4943 valid_pointer_p (void *p
)
4946 return w32_valid_pointer_p (p
, 16);
4950 /* Obviously, we cannot just access it (we would SEGV trying), so we
4951 trick the o/s to tell us whether p is a valid pointer.
4952 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4953 not validate p in that case. */
4955 if (emacs_pipe (fd
) == 0)
4957 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4958 emacs_close (fd
[1]);
4959 emacs_close (fd
[0]);
4967 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4968 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4969 cannot validate OBJ. This function can be quite slow, so its primary
4970 use is the manual debugging. The only exception is print_object, where
4971 we use it to check whether the memory referenced by the pointer of
4972 Lisp_Save_Value object contains valid objects. */
4975 valid_lisp_object_p (Lisp_Object obj
)
4985 p
= (void *) XPNTR (obj
);
4986 if (PURE_POINTER_P (p
))
4989 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4993 return valid_pointer_p (p
);
5000 int valid
= valid_pointer_p (p
);
5012 case MEM_TYPE_NON_LISP
:
5013 case MEM_TYPE_SPARE
:
5016 case MEM_TYPE_BUFFER
:
5017 return live_buffer_p (m
, p
) ? 1 : 2;
5020 return live_cons_p (m
, p
);
5022 case MEM_TYPE_STRING
:
5023 return live_string_p (m
, p
);
5026 return live_misc_p (m
, p
);
5028 case MEM_TYPE_SYMBOL
:
5029 return live_symbol_p (m
, p
);
5031 case MEM_TYPE_FLOAT
:
5032 return live_float_p (m
, p
);
5034 case MEM_TYPE_VECTORLIKE
:
5035 case MEM_TYPE_VECTOR_BLOCK
:
5036 return live_vector_p (m
, p
);
5049 /***********************************************************************
5050 Pure Storage Management
5051 ***********************************************************************/
5053 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5054 pointer to it. TYPE is the Lisp type for which the memory is
5055 allocated. TYPE < 0 means it's not used for a Lisp object. */
5058 pure_alloc (size_t size
, int type
)
5062 size_t alignment
= GCALIGNMENT
;
5064 size_t alignment
= alignof (EMACS_INT
);
5066 /* Give Lisp_Floats an extra alignment. */
5067 if (type
== Lisp_Float
)
5068 alignment
= alignof (struct Lisp_Float
);
5074 /* Allocate space for a Lisp object from the beginning of the free
5075 space with taking account of alignment. */
5076 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
5077 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5081 /* Allocate space for a non-Lisp object from the end of the free
5083 pure_bytes_used_non_lisp
+= size
;
5084 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5086 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5088 if (pure_bytes_used
<= pure_size
)
5091 /* Don't allocate a large amount here,
5092 because it might get mmap'd and then its address
5093 might not be usable. */
5094 purebeg
= xmalloc (10000);
5096 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5097 pure_bytes_used
= 0;
5098 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5103 /* Print a warning if PURESIZE is too small. */
5106 check_pure_size (void)
5108 if (pure_bytes_used_before_overflow
)
5109 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5111 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5115 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5116 the non-Lisp data pool of the pure storage, and return its start
5117 address. Return NULL if not found. */
5120 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5123 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5124 const unsigned char *p
;
5127 if (pure_bytes_used_non_lisp
<= nbytes
)
5130 /* Set up the Boyer-Moore table. */
5132 for (i
= 0; i
< 256; i
++)
5135 p
= (const unsigned char *) data
;
5137 bm_skip
[*p
++] = skip
;
5139 last_char_skip
= bm_skip
['\0'];
5141 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5142 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5144 /* See the comments in the function `boyer_moore' (search.c) for the
5145 use of `infinity'. */
5146 infinity
= pure_bytes_used_non_lisp
+ 1;
5147 bm_skip
['\0'] = infinity
;
5149 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5153 /* Check the last character (== '\0'). */
5156 start
+= bm_skip
[*(p
+ start
)];
5158 while (start
<= start_max
);
5160 if (start
< infinity
)
5161 /* Couldn't find the last character. */
5164 /* No less than `infinity' means we could find the last
5165 character at `p[start - infinity]'. */
5168 /* Check the remaining characters. */
5169 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5171 return non_lisp_beg
+ start
;
5173 start
+= last_char_skip
;
5175 while (start
<= start_max
);
5181 /* Return a string allocated in pure space. DATA is a buffer holding
5182 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5183 means make the result string multibyte.
5185 Must get an error if pure storage is full, since if it cannot hold
5186 a large string it may be able to hold conses that point to that
5187 string; then the string is not protected from gc. */
5190 make_pure_string (const char *data
,
5191 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5194 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5195 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5196 if (s
->data
== NULL
)
5198 s
->data
= pure_alloc (nbytes
+ 1, -1);
5199 memcpy (s
->data
, data
, nbytes
);
5200 s
->data
[nbytes
] = '\0';
5203 s
->size_byte
= multibyte
? nbytes
: -1;
5204 s
->intervals
= NULL
;
5205 XSETSTRING (string
, s
);
5209 /* Return a string allocated in pure space. Do not
5210 allocate the string data, just point to DATA. */
5213 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5216 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5219 s
->data
= (unsigned char *) data
;
5220 s
->intervals
= NULL
;
5221 XSETSTRING (string
, s
);
5225 static Lisp_Object
purecopy (Lisp_Object obj
);
5227 /* Return a cons allocated from pure space. Give it pure copies
5228 of CAR as car and CDR as cdr. */
5231 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5234 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5236 XSETCAR (new, purecopy (car
));
5237 XSETCDR (new, purecopy (cdr
));
5242 /* Value is a float object with value NUM allocated from pure space. */
5245 make_pure_float (double num
)
5248 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5250 XFLOAT_INIT (new, num
);
5255 /* Return a vector with room for LEN Lisp_Objects allocated from
5259 make_pure_vector (ptrdiff_t len
)
5262 size_t size
= header_size
+ len
* word_size
;
5263 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5264 XSETVECTOR (new, p
);
5265 XVECTOR (new)->header
.size
= len
;
5270 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5271 doc
: /* Make a copy of object OBJ in pure storage.
5272 Recursively copies contents of vectors and cons cells.
5273 Does not copy symbols. Copies strings without text properties. */)
5274 (register Lisp_Object obj
)
5276 if (NILP (Vpurify_flag
))
5278 else if (MARKERP (obj
) || OVERLAYP (obj
)
5279 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5280 /* Can't purify those. */
5283 return purecopy (obj
);
5287 purecopy (Lisp_Object obj
)
5289 if (PURE_POINTER_P (XPNTR (obj
)) || INTEGERP (obj
) || SUBRP (obj
))
5290 return obj
; /* Already pure. */
5292 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5294 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5300 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5301 else if (FLOATP (obj
))
5302 obj
= make_pure_float (XFLOAT_DATA (obj
));
5303 else if (STRINGP (obj
))
5304 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5306 STRING_MULTIBYTE (obj
));
5307 else if (COMPILEDP (obj
) || VECTORP (obj
))
5309 register struct Lisp_Vector
*vec
;
5310 register ptrdiff_t i
;
5314 if (size
& PSEUDOVECTOR_FLAG
)
5315 size
&= PSEUDOVECTOR_SIZE_MASK
;
5316 vec
= XVECTOR (make_pure_vector (size
));
5317 for (i
= 0; i
< size
; i
++)
5318 vec
->contents
[i
] = purecopy (AREF (obj
, i
));
5319 if (COMPILEDP (obj
))
5321 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5322 XSETCOMPILED (obj
, vec
);
5325 XSETVECTOR (obj
, vec
);
5327 else if (SYMBOLP (obj
))
5329 if (!XSYMBOL (obj
)->pinned
)
5330 { /* We can't purify them, but they appear in many pure objects.
5331 Mark them as `pinned' so we know to mark them at every GC cycle. */
5332 XSYMBOL (obj
)->pinned
= true;
5333 symbol_block_pinned
= symbol_block
;
5339 Lisp_Object args
[2];
5340 args
[0] = build_pure_c_string ("Don't know how to purify: %S");
5342 Fsignal (Qerror
, (Fcons (Fformat (2, args
), Qnil
)));
5345 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5346 Fputhash (obj
, obj
, Vpurify_flag
);
5353 /***********************************************************************
5355 ***********************************************************************/
5357 /* Put an entry in staticvec, pointing at the variable with address
5361 staticpro (Lisp_Object
*varaddress
)
5363 if (staticidx
>= NSTATICS
)
5364 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5365 staticvec
[staticidx
++] = varaddress
;
5369 /***********************************************************************
5371 ***********************************************************************/
5373 /* Temporarily prevent garbage collection. */
5376 inhibit_garbage_collection (void)
5378 ptrdiff_t count
= SPECPDL_INDEX ();
5380 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5384 /* Used to avoid possible overflows when
5385 converting from C to Lisp integers. */
5388 bounded_number (EMACS_INT number
)
5390 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5393 /* Calculate total bytes of live objects. */
5396 total_bytes_of_live_objects (void)
5399 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5400 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5401 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5402 tot
+= total_string_bytes
;
5403 tot
+= total_vector_slots
* word_size
;
5404 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5405 tot
+= total_intervals
* sizeof (struct interval
);
5406 tot
+= total_strings
* sizeof (struct Lisp_String
);
5410 #ifdef HAVE_WINDOW_SYSTEM
5412 /* This code has a few issues on MS-Windows, see Bug#15876 and Bug#16140. */
5414 #if !defined (HAVE_NTGUI)
5416 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5417 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5420 compact_font_cache_entry (Lisp_Object entry
)
5422 Lisp_Object tail
, *prev
= &entry
;
5424 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5427 Lisp_Object obj
= XCAR (tail
);
5429 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5430 if (CONSP (obj
) && FONT_SPEC_P (XCAR (obj
))
5431 && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj
)))
5432 && VECTORP (XCDR (obj
)))
5434 ptrdiff_t i
, size
= ASIZE (XCDR (obj
)) & ~ARRAY_MARK_FLAG
;
5436 /* If font-spec is not marked, most likely all font-entities
5437 are not marked too. But we must be sure that nothing is
5438 marked within OBJ before we really drop it. */
5439 for (i
= 0; i
< size
; i
++)
5440 if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj
), i
))))
5447 *prev
= XCDR (tail
);
5449 prev
= xcdr_addr (tail
);
5454 #endif /* not HAVE_NTGUI */
5456 /* Compact font caches on all terminals and mark
5457 everything which is still here after compaction. */
5460 compact_font_caches (void)
5464 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5466 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5467 #if !defined (HAVE_NTGUI)
5472 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5473 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5475 #endif /* not HAVE_NTGUI */
5476 mark_object (cache
);
5480 #else /* not HAVE_WINDOW_SYSTEM */
5482 #define compact_font_caches() (void)(0)
5484 #endif /* HAVE_WINDOW_SYSTEM */
5486 /* Remove (MARKER . DATA) entries with unmarked MARKER
5487 from buffer undo LIST and return changed list. */
5490 compact_undo_list (Lisp_Object list
)
5492 Lisp_Object tail
, *prev
= &list
;
5494 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5496 if (CONSP (XCAR (tail
))
5497 && MARKERP (XCAR (XCAR (tail
)))
5498 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5499 *prev
= XCDR (tail
);
5501 prev
= xcdr_addr (tail
);
5507 mark_pinned_symbols (void)
5509 struct symbol_block
*sblk
;
5510 int lim
= (symbol_block_pinned
== symbol_block
5511 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5513 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5515 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5516 for (; sym
< end
; ++sym
)
5518 mark_object (make_lisp_ptr (&sym
->s
, Lisp_Symbol
));
5520 lim
= SYMBOL_BLOCK_SIZE
;
5524 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5525 doc
: /* Reclaim storage for Lisp objects no longer needed.
5526 Garbage collection happens automatically if you cons more than
5527 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5528 `garbage-collect' normally returns a list with info on amount of space in use,
5529 where each entry has the form (NAME SIZE USED FREE), where:
5530 - NAME is a symbol describing the kind of objects this entry represents,
5531 - SIZE is the number of bytes used by each one,
5532 - USED is the number of those objects that were found live in the heap,
5533 - FREE is the number of those objects that are not live but that Emacs
5534 keeps around for future allocations (maybe because it does not know how
5535 to return them to the OS).
5536 However, if there was overflow in pure space, `garbage-collect'
5537 returns nil, because real GC can't be done.
5538 See Info node `(elisp)Garbage Collection'. */)
5541 struct buffer
*nextb
;
5542 char stack_top_variable
;
5545 ptrdiff_t count
= SPECPDL_INDEX ();
5546 struct timespec start
;
5547 Lisp_Object retval
= Qnil
;
5548 size_t tot_before
= 0;
5553 /* Can't GC if pure storage overflowed because we can't determine
5554 if something is a pure object or not. */
5555 if (pure_bytes_used_before_overflow
)
5558 /* Record this function, so it appears on the profiler's backtraces. */
5559 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5563 /* Don't keep undo information around forever.
5564 Do this early on, so it is no problem if the user quits. */
5565 FOR_EACH_BUFFER (nextb
)
5566 compact_buffer (nextb
);
5568 if (profiler_memory_running
)
5569 tot_before
= total_bytes_of_live_objects ();
5571 start
= current_timespec ();
5573 /* In case user calls debug_print during GC,
5574 don't let that cause a recursive GC. */
5575 consing_since_gc
= 0;
5577 /* Save what's currently displayed in the echo area. */
5578 message_p
= push_message ();
5579 record_unwind_protect_void (pop_message_unwind
);
5581 /* Save a copy of the contents of the stack, for debugging. */
5582 #if MAX_SAVE_STACK > 0
5583 if (NILP (Vpurify_flag
))
5586 ptrdiff_t stack_size
;
5587 if (&stack_top_variable
< stack_bottom
)
5589 stack
= &stack_top_variable
;
5590 stack_size
= stack_bottom
- &stack_top_variable
;
5594 stack
= stack_bottom
;
5595 stack_size
= &stack_top_variable
- stack_bottom
;
5597 if (stack_size
<= MAX_SAVE_STACK
)
5599 if (stack_copy_size
< stack_size
)
5601 stack_copy
= xrealloc (stack_copy
, stack_size
);
5602 stack_copy_size
= stack_size
;
5604 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5607 #endif /* MAX_SAVE_STACK > 0 */
5609 if (garbage_collection_messages
)
5610 message1_nolog ("Garbage collecting...");
5614 shrink_regexp_cache ();
5618 /* Mark all the special slots that serve as the roots of accessibility. */
5620 mark_buffer (&buffer_defaults
);
5621 mark_buffer (&buffer_local_symbols
);
5623 for (i
= 0; i
< staticidx
; i
++)
5624 mark_object (*staticvec
[i
]);
5626 mark_pinned_symbols ();
5635 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5636 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5640 register struct gcpro
*tail
;
5641 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5642 for (i
= 0; i
< tail
->nvars
; i
++)
5643 mark_object (tail
->var
[i
]);
5648 struct handler
*handler
;
5649 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5651 mark_object (handler
->tag_or_ch
);
5652 mark_object (handler
->val
);
5655 #ifdef HAVE_WINDOW_SYSTEM
5656 mark_fringe_data ();
5659 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5663 /* Everything is now marked, except for the data in font caches
5664 and undo lists. They're compacted by removing an items which
5665 aren't reachable otherwise. */
5667 compact_font_caches ();
5669 FOR_EACH_BUFFER (nextb
)
5671 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5672 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5673 /* Now that we have stripped the elements that need not be
5674 in the undo_list any more, we can finally mark the list. */
5675 mark_object (BVAR (nextb
, undo_list
));
5680 /* Clear the mark bits that we set in certain root slots. */
5682 unmark_byte_stack ();
5683 VECTOR_UNMARK (&buffer_defaults
);
5684 VECTOR_UNMARK (&buffer_local_symbols
);
5686 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5696 consing_since_gc
= 0;
5697 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5698 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5700 gc_relative_threshold
= 0;
5701 if (FLOATP (Vgc_cons_percentage
))
5702 { /* Set gc_cons_combined_threshold. */
5703 double tot
= total_bytes_of_live_objects ();
5705 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5708 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5709 gc_relative_threshold
= tot
;
5711 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5715 if (garbage_collection_messages
)
5717 if (message_p
|| minibuf_level
> 0)
5720 message1_nolog ("Garbage collecting...done");
5723 unbind_to (count
, Qnil
);
5725 Lisp_Object total
[11];
5726 int total_size
= 10;
5728 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5729 bounded_number (total_conses
),
5730 bounded_number (total_free_conses
));
5732 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5733 bounded_number (total_symbols
),
5734 bounded_number (total_free_symbols
));
5736 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5737 bounded_number (total_markers
),
5738 bounded_number (total_free_markers
));
5740 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5741 bounded_number (total_strings
),
5742 bounded_number (total_free_strings
));
5744 total
[4] = list3 (Qstring_bytes
, make_number (1),
5745 bounded_number (total_string_bytes
));
5747 total
[5] = list3 (Qvectors
,
5748 make_number (header_size
+ sizeof (Lisp_Object
)),
5749 bounded_number (total_vectors
));
5751 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5752 bounded_number (total_vector_slots
),
5753 bounded_number (total_free_vector_slots
));
5755 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5756 bounded_number (total_floats
),
5757 bounded_number (total_free_floats
));
5759 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5760 bounded_number (total_intervals
),
5761 bounded_number (total_free_intervals
));
5763 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5764 bounded_number (total_buffers
));
5766 #ifdef DOUG_LEA_MALLOC
5768 total
[10] = list4 (Qheap
, make_number (1024),
5769 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5770 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5772 retval
= Flist (total_size
, total
);
5775 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5777 /* Compute average percentage of zombies. */
5779 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5780 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5782 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5783 max_live
= max (nlive
, max_live
);
5784 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5785 max_zombies
= max (nzombies
, max_zombies
);
5790 if (!NILP (Vpost_gc_hook
))
5792 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5793 safe_run_hooks (Qpost_gc_hook
);
5794 unbind_to (gc_count
, Qnil
);
5797 /* Accumulate statistics. */
5798 if (FLOATP (Vgc_elapsed
))
5800 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5801 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5802 + timespectod (since_start
));
5807 /* Collect profiling data. */
5808 if (profiler_memory_running
)
5811 size_t tot_after
= total_bytes_of_live_objects ();
5812 if (tot_before
> tot_after
)
5813 swept
= tot_before
- tot_after
;
5814 malloc_probe (swept
);
5821 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5822 only interesting objects referenced from glyphs are strings. */
5825 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5827 struct glyph_row
*row
= matrix
->rows
;
5828 struct glyph_row
*end
= row
+ matrix
->nrows
;
5830 for (; row
< end
; ++row
)
5834 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5836 struct glyph
*glyph
= row
->glyphs
[area
];
5837 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5839 for (; glyph
< end_glyph
; ++glyph
)
5840 if (STRINGP (glyph
->object
)
5841 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5842 mark_object (glyph
->object
);
5847 /* Mark reference to a Lisp_Object.
5848 If the object referred to has not been seen yet, recursively mark
5849 all the references contained in it. */
5851 #define LAST_MARKED_SIZE 500
5852 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5853 static int last_marked_index
;
5855 /* For debugging--call abort when we cdr down this many
5856 links of a list, in mark_object. In debugging,
5857 the call to abort will hit a breakpoint.
5858 Normally this is zero and the check never goes off. */
5859 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5862 mark_vectorlike (struct Lisp_Vector
*ptr
)
5864 ptrdiff_t size
= ptr
->header
.size
;
5867 eassert (!VECTOR_MARKED_P (ptr
));
5868 VECTOR_MARK (ptr
); /* Else mark it. */
5869 if (size
& PSEUDOVECTOR_FLAG
)
5870 size
&= PSEUDOVECTOR_SIZE_MASK
;
5872 /* Note that this size is not the memory-footprint size, but only
5873 the number of Lisp_Object fields that we should trace.
5874 The distinction is used e.g. by Lisp_Process which places extra
5875 non-Lisp_Object fields at the end of the structure... */
5876 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5877 mark_object (ptr
->contents
[i
]);
5880 /* Like mark_vectorlike but optimized for char-tables (and
5881 sub-char-tables) assuming that the contents are mostly integers or
5885 mark_char_table (struct Lisp_Vector
*ptr
)
5887 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5890 eassert (!VECTOR_MARKED_P (ptr
));
5892 for (i
= 0; i
< size
; i
++)
5894 Lisp_Object val
= ptr
->contents
[i
];
5896 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5898 if (SUB_CHAR_TABLE_P (val
))
5900 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5901 mark_char_table (XVECTOR (val
));
5908 /* Mark the chain of overlays starting at PTR. */
5911 mark_overlay (struct Lisp_Overlay
*ptr
)
5913 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5916 mark_object (ptr
->start
);
5917 mark_object (ptr
->end
);
5918 mark_object (ptr
->plist
);
5922 /* Mark Lisp_Objects and special pointers in BUFFER. */
5925 mark_buffer (struct buffer
*buffer
)
5927 /* This is handled much like other pseudovectors... */
5928 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5930 /* ...but there are some buffer-specific things. */
5932 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5934 /* For now, we just don't mark the undo_list. It's done later in
5935 a special way just before the sweep phase, and after stripping
5936 some of its elements that are not needed any more. */
5938 mark_overlay (buffer
->overlays_before
);
5939 mark_overlay (buffer
->overlays_after
);
5941 /* If this is an indirect buffer, mark its base buffer. */
5942 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5943 mark_buffer (buffer
->base_buffer
);
5946 /* Mark Lisp faces in the face cache C. */
5949 mark_face_cache (struct face_cache
*c
)
5954 for (i
= 0; i
< c
->used
; ++i
)
5956 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5960 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
5961 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
5963 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5964 mark_object (face
->lface
[j
]);
5970 /* Remove killed buffers or items whose car is a killed buffer from
5971 LIST, and mark other items. Return changed LIST, which is marked. */
5974 mark_discard_killed_buffers (Lisp_Object list
)
5976 Lisp_Object tail
, *prev
= &list
;
5978 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5981 Lisp_Object tem
= XCAR (tail
);
5984 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5985 *prev
= XCDR (tail
);
5988 CONS_MARK (XCONS (tail
));
5989 mark_object (XCAR (tail
));
5990 prev
= xcdr_addr (tail
);
5997 /* Determine type of generic Lisp_Object and mark it accordingly. */
6000 mark_object (Lisp_Object arg
)
6002 register Lisp_Object obj
= arg
;
6003 #ifdef GC_CHECK_MARKED_OBJECTS
6007 ptrdiff_t cdr_count
= 0;
6011 if (PURE_POINTER_P (XPNTR (obj
)))
6014 last_marked
[last_marked_index
++] = obj
;
6015 if (last_marked_index
== LAST_MARKED_SIZE
)
6016 last_marked_index
= 0;
6018 /* Perform some sanity checks on the objects marked here. Abort if
6019 we encounter an object we know is bogus. This increases GC time
6020 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
6021 #ifdef GC_CHECK_MARKED_OBJECTS
6023 po
= (void *) XPNTR (obj
);
6025 /* Check that the object pointed to by PO is known to be a Lisp
6026 structure allocated from the heap. */
6027 #define CHECK_ALLOCATED() \
6029 m = mem_find (po); \
6034 /* Check that the object pointed to by PO is live, using predicate
6036 #define CHECK_LIVE(LIVEP) \
6038 if (!LIVEP (m, po)) \
6042 /* Check both of the above conditions. */
6043 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6045 CHECK_ALLOCATED (); \
6046 CHECK_LIVE (LIVEP); \
6049 #else /* not GC_CHECK_MARKED_OBJECTS */
6051 #define CHECK_LIVE(LIVEP) (void) 0
6052 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
6054 #endif /* not GC_CHECK_MARKED_OBJECTS */
6056 switch (XTYPE (obj
))
6060 register struct Lisp_String
*ptr
= XSTRING (obj
);
6061 if (STRING_MARKED_P (ptr
))
6063 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6065 MARK_INTERVAL_TREE (ptr
->intervals
);
6066 #ifdef GC_CHECK_STRING_BYTES
6067 /* Check that the string size recorded in the string is the
6068 same as the one recorded in the sdata structure. */
6070 #endif /* GC_CHECK_STRING_BYTES */
6074 case Lisp_Vectorlike
:
6076 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6077 register ptrdiff_t pvectype
;
6079 if (VECTOR_MARKED_P (ptr
))
6082 #ifdef GC_CHECK_MARKED_OBJECTS
6084 if (m
== MEM_NIL
&& !SUBRP (obj
))
6086 #endif /* GC_CHECK_MARKED_OBJECTS */
6088 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6089 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6090 >> PSEUDOVECTOR_AREA_BITS
);
6092 pvectype
= PVEC_NORMAL_VECTOR
;
6094 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6095 CHECK_LIVE (live_vector_p
);
6100 #ifdef GC_CHECK_MARKED_OBJECTS
6109 #endif /* GC_CHECK_MARKED_OBJECTS */
6110 mark_buffer ((struct buffer
*) ptr
);
6114 { /* We could treat this just like a vector, but it is better
6115 to save the COMPILED_CONSTANTS element for last and avoid
6117 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6121 for (i
= 0; i
< size
; i
++)
6122 if (i
!= COMPILED_CONSTANTS
)
6123 mark_object (ptr
->contents
[i
]);
6124 if (size
> COMPILED_CONSTANTS
)
6126 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
6134 struct frame
*f
= (struct frame
*) ptr
;
6136 mark_vectorlike (ptr
);
6137 mark_face_cache (f
->face_cache
);
6138 #ifdef HAVE_WINDOW_SYSTEM
6139 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6141 struct font
*font
= FRAME_FONT (f
);
6143 if (font
&& !VECTOR_MARKED_P (font
))
6144 mark_vectorlike ((struct Lisp_Vector
*) font
);
6152 struct window
*w
= (struct window
*) ptr
;
6154 mark_vectorlike (ptr
);
6156 /* Mark glyph matrices, if any. Marking window
6157 matrices is sufficient because frame matrices
6158 use the same glyph memory. */
6159 if (w
->current_matrix
)
6161 mark_glyph_matrix (w
->current_matrix
);
6162 mark_glyph_matrix (w
->desired_matrix
);
6165 /* Filter out killed buffers from both buffer lists
6166 in attempt to help GC to reclaim killed buffers faster.
6167 We can do it elsewhere for live windows, but this is the
6168 best place to do it for dead windows. */
6170 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6172 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6176 case PVEC_HASH_TABLE
:
6178 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6180 mark_vectorlike (ptr
);
6181 mark_object (h
->test
.name
);
6182 mark_object (h
->test
.user_hash_function
);
6183 mark_object (h
->test
.user_cmp_function
);
6184 /* If hash table is not weak, mark all keys and values.
6185 For weak tables, mark only the vector. */
6187 mark_object (h
->key_and_value
);
6189 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6193 case PVEC_CHAR_TABLE
:
6194 mark_char_table (ptr
);
6197 case PVEC_BOOL_VECTOR
:
6198 /* No Lisp_Objects to mark in a bool vector. */
6209 mark_vectorlike (ptr
);
6216 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6217 struct Lisp_Symbol
*ptrx
;
6221 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6223 mark_object (ptr
->function
);
6224 mark_object (ptr
->plist
);
6225 switch (ptr
->redirect
)
6227 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6228 case SYMBOL_VARALIAS
:
6231 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6235 case SYMBOL_LOCALIZED
:
6237 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6238 Lisp_Object where
= blv
->where
;
6239 /* If the value is set up for a killed buffer or deleted
6240 frame, restore it's global binding. If the value is
6241 forwarded to a C variable, either it's not a Lisp_Object
6242 var, or it's staticpro'd already. */
6243 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6244 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6245 swap_in_global_binding (ptr
);
6246 mark_object (blv
->where
);
6247 mark_object (blv
->valcell
);
6248 mark_object (blv
->defcell
);
6251 case SYMBOL_FORWARDED
:
6252 /* If the value is forwarded to a buffer or keyboard field,
6253 these are marked when we see the corresponding object.
6254 And if it's forwarded to a C variable, either it's not
6255 a Lisp_Object var, or it's staticpro'd already. */
6257 default: emacs_abort ();
6259 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6260 MARK_STRING (XSTRING (ptr
->name
));
6261 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6266 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6267 XSETSYMBOL (obj
, ptrx
);
6274 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6276 if (XMISCANY (obj
)->gcmarkbit
)
6279 switch (XMISCTYPE (obj
))
6281 case Lisp_Misc_Marker
:
6282 /* DO NOT mark thru the marker's chain.
6283 The buffer's markers chain does not preserve markers from gc;
6284 instead, markers are removed from the chain when freed by gc. */
6285 XMISCANY (obj
)->gcmarkbit
= 1;
6288 case Lisp_Misc_Save_Value
:
6289 XMISCANY (obj
)->gcmarkbit
= 1;
6291 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6292 /* If `save_type' is zero, `data[0].pointer' is the address
6293 of a memory area containing `data[1].integer' potential
6295 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6297 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6299 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6300 mark_maybe_object (*p
);
6304 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6306 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6307 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6308 mark_object (ptr
->data
[i
].object
);
6313 case Lisp_Misc_Overlay
:
6314 mark_overlay (XOVERLAY (obj
));
6324 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6325 if (CONS_MARKED_P (ptr
))
6327 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6329 /* If the cdr is nil, avoid recursion for the car. */
6330 if (EQ (ptr
->u
.cdr
, Qnil
))
6336 mark_object (ptr
->car
);
6339 if (cdr_count
== mark_object_loop_halt
)
6345 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6346 FLOAT_MARK (XFLOAT (obj
));
6357 #undef CHECK_ALLOCATED
6358 #undef CHECK_ALLOCATED_AND_LIVE
6360 /* Mark the Lisp pointers in the terminal objects.
6361 Called by Fgarbage_collect. */
6364 mark_terminals (void)
6367 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6369 eassert (t
->name
!= NULL
);
6370 #ifdef HAVE_WINDOW_SYSTEM
6371 /* If a terminal object is reachable from a stacpro'ed object,
6372 it might have been marked already. Make sure the image cache
6374 mark_image_cache (t
->image_cache
);
6375 #endif /* HAVE_WINDOW_SYSTEM */
6376 if (!VECTOR_MARKED_P (t
))
6377 mark_vectorlike ((struct Lisp_Vector
*)t
);
6383 /* Value is non-zero if OBJ will survive the current GC because it's
6384 either marked or does not need to be marked to survive. */
6387 survives_gc_p (Lisp_Object obj
)
6391 switch (XTYPE (obj
))
6398 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6402 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6406 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6409 case Lisp_Vectorlike
:
6410 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6414 survives_p
= CONS_MARKED_P (XCONS (obj
));
6418 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6425 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6431 NO_INLINE
/* For better stack traces */
6435 register struct cons_block
*cblk
;
6436 struct cons_block
**cprev
= &cons_block
;
6437 register int lim
= cons_block_index
;
6438 EMACS_INT num_free
= 0, num_used
= 0;
6442 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6446 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6448 /* Scan the mark bits an int at a time. */
6449 for (i
= 0; i
< ilim
; i
++)
6451 if (cblk
->gcmarkbits
[i
] == -1)
6453 /* Fast path - all cons cells for this int are marked. */
6454 cblk
->gcmarkbits
[i
] = 0;
6455 num_used
+= BITS_PER_INT
;
6459 /* Some cons cells for this int are not marked.
6460 Find which ones, and free them. */
6461 int start
, pos
, stop
;
6463 start
= i
* BITS_PER_INT
;
6465 if (stop
> BITS_PER_INT
)
6466 stop
= BITS_PER_INT
;
6469 for (pos
= start
; pos
< stop
; pos
++)
6471 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6474 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6475 cons_free_list
= &cblk
->conses
[pos
];
6477 cons_free_list
->car
= Vdead
;
6483 CONS_UNMARK (&cblk
->conses
[pos
]);
6489 lim
= CONS_BLOCK_SIZE
;
6490 /* If this block contains only free conses and we have already
6491 seen more than two blocks worth of free conses then deallocate
6493 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6495 *cprev
= cblk
->next
;
6496 /* Unhook from the free list. */
6497 cons_free_list
= cblk
->conses
[0].u
.chain
;
6498 lisp_align_free (cblk
);
6502 num_free
+= this_free
;
6503 cprev
= &cblk
->next
;
6506 total_conses
= num_used
;
6507 total_free_conses
= num_free
;
6510 NO_INLINE
/* For better stack traces */
6514 register struct float_block
*fblk
;
6515 struct float_block
**fprev
= &float_block
;
6516 register int lim
= float_block_index
;
6517 EMACS_INT num_free
= 0, num_used
= 0;
6519 float_free_list
= 0;
6521 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6525 for (i
= 0; i
< lim
; i
++)
6526 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6529 fblk
->floats
[i
].u
.chain
= float_free_list
;
6530 float_free_list
= &fblk
->floats
[i
];
6535 FLOAT_UNMARK (&fblk
->floats
[i
]);
6537 lim
= FLOAT_BLOCK_SIZE
;
6538 /* If this block contains only free floats and we have already
6539 seen more than two blocks worth of free floats then deallocate
6541 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6543 *fprev
= fblk
->next
;
6544 /* Unhook from the free list. */
6545 float_free_list
= fblk
->floats
[0].u
.chain
;
6546 lisp_align_free (fblk
);
6550 num_free
+= this_free
;
6551 fprev
= &fblk
->next
;
6554 total_floats
= num_used
;
6555 total_free_floats
= num_free
;
6558 NO_INLINE
/* For better stack traces */
6560 sweep_intervals (void)
6562 register struct interval_block
*iblk
;
6563 struct interval_block
**iprev
= &interval_block
;
6564 register int lim
= interval_block_index
;
6565 EMACS_INT num_free
= 0, num_used
= 0;
6567 interval_free_list
= 0;
6569 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6574 for (i
= 0; i
< lim
; i
++)
6576 if (!iblk
->intervals
[i
].gcmarkbit
)
6578 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6579 interval_free_list
= &iblk
->intervals
[i
];
6585 iblk
->intervals
[i
].gcmarkbit
= 0;
6588 lim
= INTERVAL_BLOCK_SIZE
;
6589 /* If this block contains only free intervals and we have already
6590 seen more than two blocks worth of free intervals then
6591 deallocate this block. */
6592 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6594 *iprev
= iblk
->next
;
6595 /* Unhook from the free list. */
6596 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6601 num_free
+= this_free
;
6602 iprev
= &iblk
->next
;
6605 total_intervals
= num_used
;
6606 total_free_intervals
= num_free
;
6609 NO_INLINE
/* For better stack traces */
6611 sweep_symbols (void)
6613 register struct symbol_block
*sblk
;
6614 struct symbol_block
**sprev
= &symbol_block
;
6615 register int lim
= symbol_block_index
;
6616 EMACS_INT num_free
= 0, num_used
= 0;
6618 symbol_free_list
= NULL
;
6620 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6623 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6624 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6626 for (; sym
< end
; ++sym
)
6628 if (!sym
->s
.gcmarkbit
)
6630 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6631 xfree (SYMBOL_BLV (&sym
->s
));
6632 sym
->s
.next
= symbol_free_list
;
6633 symbol_free_list
= &sym
->s
;
6635 symbol_free_list
->function
= Vdead
;
6642 sym
->s
.gcmarkbit
= 0;
6646 lim
= SYMBOL_BLOCK_SIZE
;
6647 /* If this block contains only free symbols and we have already
6648 seen more than two blocks worth of free symbols then deallocate
6650 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6652 *sprev
= sblk
->next
;
6653 /* Unhook from the free list. */
6654 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6659 num_free
+= this_free
;
6660 sprev
= &sblk
->next
;
6663 total_symbols
= num_used
;
6664 total_free_symbols
= num_free
;
6667 NO_INLINE
/* For better stack traces */
6671 register struct marker_block
*mblk
;
6672 struct marker_block
**mprev
= &marker_block
;
6673 register int lim
= marker_block_index
;
6674 EMACS_INT num_free
= 0, num_used
= 0;
6676 /* Put all unmarked misc's on free list. For a marker, first
6677 unchain it from the buffer it points into. */
6679 marker_free_list
= 0;
6681 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6686 for (i
= 0; i
< lim
; i
++)
6688 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6690 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6691 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6692 /* Set the type of the freed object to Lisp_Misc_Free.
6693 We could leave the type alone, since nobody checks it,
6694 but this might catch bugs faster. */
6695 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6696 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6697 marker_free_list
= &mblk
->markers
[i
].m
;
6703 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6706 lim
= MARKER_BLOCK_SIZE
;
6707 /* If this block contains only free markers and we have already
6708 seen more than two blocks worth of free markers then deallocate
6710 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6712 *mprev
= mblk
->next
;
6713 /* Unhook from the free list. */
6714 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6719 num_free
+= this_free
;
6720 mprev
= &mblk
->next
;
6724 total_markers
= num_used
;
6725 total_free_markers
= num_free
;
6728 NO_INLINE
/* For better stack traces */
6730 sweep_buffers (void)
6732 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6735 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6736 if (!VECTOR_MARKED_P (buffer
))
6738 *bprev
= buffer
->next
;
6743 VECTOR_UNMARK (buffer
);
6744 /* Do not use buffer_(set|get)_intervals here. */
6745 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6747 bprev
= &buffer
->next
;
6751 /* Sweep: find all structures not marked, and free them. */
6755 /* Remove or mark entries in weak hash tables.
6756 This must be done before any object is unmarked. */
6757 sweep_weak_hash_tables ();
6760 check_string_bytes (!noninteractive
);
6768 check_string_bytes (!noninteractive
);
6772 /* Debugging aids. */
6774 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6775 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6776 This may be helpful in debugging Emacs's memory usage.
6777 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6783 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
6786 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6792 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6793 doc
: /* Return a list of counters that measure how much consing there has been.
6794 Each of these counters increments for a certain kind of object.
6795 The counters wrap around from the largest positive integer to zero.
6796 Garbage collection does not decrease them.
6797 The elements of the value are as follows:
6798 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6799 All are in units of 1 = one object consed
6800 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6802 MISCS include overlays, markers, and some internal types.
6803 Frames, windows, buffers, and subprocesses count as vectors
6804 (but the contents of a buffer's text do not count here). */)
6807 return listn (CONSTYPE_HEAP
, 8,
6808 bounded_number (cons_cells_consed
),
6809 bounded_number (floats_consed
),
6810 bounded_number (vector_cells_consed
),
6811 bounded_number (symbols_consed
),
6812 bounded_number (string_chars_consed
),
6813 bounded_number (misc_objects_consed
),
6814 bounded_number (intervals_consed
),
6815 bounded_number (strings_consed
));
6818 /* Find at most FIND_MAX symbols which have OBJ as their value or
6819 function. This is used in gdbinit's `xwhichsymbols' command. */
6822 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6824 struct symbol_block
*sblk
;
6825 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6826 Lisp_Object found
= Qnil
;
6830 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6832 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6835 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6837 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6841 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6844 XSETSYMBOL (tem
, sym
);
6845 val
= find_symbol_value (tem
);
6847 || EQ (sym
->function
, obj
)
6848 || (!NILP (sym
->function
)
6849 && COMPILEDP (sym
->function
)
6850 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6853 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6855 found
= Fcons (tem
, found
);
6856 if (--find_max
== 0)
6864 unbind_to (gc_count
, Qnil
);
6868 #ifdef SUSPICIOUS_OBJECT_CHECKING
6871 find_suspicious_object_in_range (void *begin
, void *end
)
6873 char *begin_a
= begin
;
6877 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
6879 char *suspicious_object
= suspicious_objects
[i
];
6880 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
6881 return suspicious_object
;
6888 detect_suspicious_free (void *ptr
)
6892 eassert (ptr
!= NULL
);
6894 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
6895 if (suspicious_objects
[i
] == ptr
)
6897 struct suspicious_free_record
*rec
6898 = &suspicious_free_history
[suspicious_free_history_index
++];
6899 if (suspicious_free_history_index
==
6900 ARRAYELTS (suspicious_free_history
))
6902 suspicious_free_history_index
= 0;
6905 memset (rec
, 0, sizeof (*rec
));
6906 rec
->suspicious_object
= ptr
;
6907 backtrace (rec
->backtrace
, ARRAYELTS (rec
->backtrace
));
6908 suspicious_objects
[i
] = NULL
;
6912 #endif /* SUSPICIOUS_OBJECT_CHECKING */
6914 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
6915 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
6916 If Emacs is compiled with suspicous object checking, capture
6917 a stack trace when OBJ is freed in order to help track down
6918 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
6921 #ifdef SUSPICIOUS_OBJECT_CHECKING
6922 /* Right now, we care only about vectors. */
6923 if (VECTORLIKEP (obj
))
6925 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
6926 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
6927 suspicious_object_index
= 0;
6933 #ifdef ENABLE_CHECKING
6935 bool suppress_checking
;
6938 die (const char *msg
, const char *file
, int line
)
6940 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6942 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6946 /* Initialization. */
6949 init_alloc_once (void)
6951 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6953 pure_size
= PURESIZE
;
6955 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6957 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6960 #ifdef DOUG_LEA_MALLOC
6961 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6962 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6963 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6968 refill_memory_reserve ();
6969 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6976 byte_stack_list
= 0;
6978 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6979 setjmp_tested_p
= longjmps_done
= 0;
6982 Vgc_elapsed
= make_float (0.0);
6986 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
6991 syms_of_alloc (void)
6993 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6994 doc
: /* Number of bytes of consing between garbage collections.
6995 Garbage collection can happen automatically once this many bytes have been
6996 allocated since the last garbage collection. All data types count.
6998 Garbage collection happens automatically only when `eval' is called.
7000 By binding this temporarily to a large number, you can effectively
7001 prevent garbage collection during a part of the program.
7002 See also `gc-cons-percentage'. */);
7004 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7005 doc
: /* Portion of the heap used for allocation.
7006 Garbage collection can happen automatically once this portion of the heap
7007 has been allocated since the last garbage collection.
7008 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7009 Vgc_cons_percentage
= make_float (0.1);
7011 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7012 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7014 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7015 doc
: /* Number of cons cells that have been consed so far. */);
7017 DEFVAR_INT ("floats-consed", floats_consed
,
7018 doc
: /* Number of floats that have been consed so far. */);
7020 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7021 doc
: /* Number of vector cells that have been consed so far. */);
7023 DEFVAR_INT ("symbols-consed", symbols_consed
,
7024 doc
: /* Number of symbols that have been consed so far. */);
7026 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7027 doc
: /* Number of string characters that have been consed so far. */);
7029 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7030 doc
: /* Number of miscellaneous objects that have been consed so far.
7031 These include markers and overlays, plus certain objects not visible
7034 DEFVAR_INT ("intervals-consed", intervals_consed
,
7035 doc
: /* Number of intervals that have been consed so far. */);
7037 DEFVAR_INT ("strings-consed", strings_consed
,
7038 doc
: /* Number of strings that have been consed so far. */);
7040 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7041 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7042 This means that certain objects should be allocated in shared (pure) space.
7043 It can also be set to a hash-table, in which case this table is used to
7044 do hash-consing of the objects allocated to pure space. */);
7046 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7047 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7048 garbage_collection_messages
= 0;
7050 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7051 doc
: /* Hook run after garbage collection has finished. */);
7052 Vpost_gc_hook
= Qnil
;
7053 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7055 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7056 doc
: /* Precomputed `signal' argument for memory-full error. */);
7057 /* We build this in advance because if we wait until we need it, we might
7058 not be able to allocate the memory to hold it. */
7060 = listn (CONSTYPE_PURE
, 2, Qerror
,
7061 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7063 DEFVAR_LISP ("memory-full", Vmemory_full
,
7064 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7065 Vmemory_full
= Qnil
;
7067 DEFSYM (Qconses
, "conses");
7068 DEFSYM (Qsymbols
, "symbols");
7069 DEFSYM (Qmiscs
, "miscs");
7070 DEFSYM (Qstrings
, "strings");
7071 DEFSYM (Qvectors
, "vectors");
7072 DEFSYM (Qfloats
, "floats");
7073 DEFSYM (Qintervals
, "intervals");
7074 DEFSYM (Qbuffers
, "buffers");
7075 DEFSYM (Qstring_bytes
, "string-bytes");
7076 DEFSYM (Qvector_slots
, "vector-slots");
7077 DEFSYM (Qheap
, "heap");
7078 DEFSYM (Qautomatic_gc
, "Automatic GC");
7080 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7081 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7083 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7084 doc
: /* Accumulated time elapsed in garbage collections.
7085 The time is in seconds as a floating point value. */);
7086 DEFVAR_INT ("gcs-done", gcs_done
,
7087 doc
: /* Accumulated number of garbage collections done. */);
7092 defsubr (&Smake_byte_code
);
7093 defsubr (&Smake_list
);
7094 defsubr (&Smake_vector
);
7095 defsubr (&Smake_string
);
7096 defsubr (&Smake_bool_vector
);
7097 defsubr (&Smake_symbol
);
7098 defsubr (&Smake_marker
);
7099 defsubr (&Spurecopy
);
7100 defsubr (&Sgarbage_collect
);
7101 defsubr (&Smemory_limit
);
7102 defsubr (&Smemory_use_counts
);
7103 defsubr (&Ssuspicious_object
);
7105 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
7106 defsubr (&Sgc_status
);
7110 /* When compiled with GCC, GDB might say "No enum type named
7111 pvec_type" if we don't have at least one symbol with that type, and
7112 then xbacktrace could fail. Similarly for the other enums and
7113 their values. Some non-GCC compilers don't like these constructs. */
7117 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7118 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
7119 enum char_bits char_bits
;
7120 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7121 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7122 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
7123 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
7124 enum Lisp_Bits Lisp_Bits
;
7125 enum Lisp_Compiled Lisp_Compiled
;
7126 enum maxargs maxargs
;
7127 enum MAX_ALLOCA MAX_ALLOCA
;
7128 enum More_Lisp_Bits More_Lisp_Bits
;
7129 enum pvec_type pvec_type
;
7130 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7131 #endif /* __GNUC__ */