1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 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. */
25 #include <signal.h> /* For SIGABRT, SIGDANGER. */
32 #include "dispextern.h"
33 #include "intervals.h"
37 #include "character.h"
42 #include "blockinput.h"
43 #include "termhooks.h" /* For struct terminal. */
44 #ifdef HAVE_WINDOW_SYSTEM
46 #endif /* HAVE_WINDOW_SYSTEM */
49 #include <execinfo.h> /* For backtrace. */
51 #ifdef HAVE_LINUX_SYSINFO
52 #include <sys/sysinfo.h>
56 #include "dosfns.h" /* For dos_memory_info. */
63 #if (defined ENABLE_CHECKING \
64 && defined HAVE_VALGRIND_VALGRIND_H \
65 && !defined USE_VALGRIND)
66 # define USE_VALGRIND 1
70 #include <valgrind/valgrind.h>
71 #include <valgrind/memcheck.h>
72 static bool valgrind_p
;
75 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */
77 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
78 memory. Can do this only if using gmalloc.c and if not checking
81 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
82 || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
83 #undef GC_MALLOC_CHECK
94 #include "w32heap.h" /* for sbrk */
97 #if defined DOUG_LEA_MALLOC || defined GNU_LINUX
98 /* The address where the heap starts. */
109 #ifdef DOUG_LEA_MALLOC
111 /* Specify maximum number of areas to mmap. It would be nice to use a
112 value that explicitly means "no limit". */
114 #define MMAP_MAX_AREAS 100000000
116 /* A pointer to the memory allocated that copies that static data
117 inside glibc's malloc. */
118 static void *malloc_state_ptr
;
120 /* Restore the dumped malloc state. Because malloc can be invoked
121 even before main (e.g. by the dynamic linker), the dumped malloc
122 state must be restored as early as possible using this special hook. */
124 malloc_initialize_hook (void)
126 static bool malloc_using_checking
;
131 malloc_using_checking
= getenv ("MALLOC_CHECK_") != NULL
;
135 if (!malloc_using_checking
)
137 /* Work around a bug in glibc's malloc. MALLOC_CHECK_ must be
138 ignored if the heap to be restored was constructed without
139 malloc checking. Can't use unsetenv, since that calls malloc. */
143 if (strncmp (*p
, "MALLOC_CHECK_=", 14) == 0)
153 malloc_set_state (malloc_state_ptr
);
154 # ifndef XMALLOC_OVERRUN_CHECK
155 alloc_unexec_post ();
160 /* Declare the malloc initialization hook, which runs before 'main' starts.
161 EXTERNALLY_VISIBLE works around Bug#22522. */
162 # ifndef __MALLOC_HOOK_VOLATILE
163 # define __MALLOC_HOOK_VOLATILE
165 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
166 = malloc_initialize_hook
;
170 /* Allocator-related actions to do just before and after unexec. */
173 alloc_unexec_pre (void)
175 #ifdef DOUG_LEA_MALLOC
176 malloc_state_ptr
= malloc_get_state ();
179 bss_sbrk_did_unexec
= true;
184 alloc_unexec_post (void)
186 #ifdef DOUG_LEA_MALLOC
187 free (malloc_state_ptr
);
190 bss_sbrk_did_unexec
= false;
194 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
195 to a struct Lisp_String. */
197 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
198 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
199 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
201 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
202 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
203 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
205 /* Default value of gc_cons_threshold (see below). */
207 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
209 /* Global variables. */
210 struct emacs_globals globals
;
212 /* Number of bytes of consing done since the last gc. */
214 EMACS_INT consing_since_gc
;
216 /* Similar minimum, computed from Vgc_cons_percentage. */
218 EMACS_INT gc_relative_threshold
;
220 /* Minimum number of bytes of consing since GC before next GC,
221 when memory is full. */
223 EMACS_INT memory_full_cons_threshold
;
225 /* True during GC. */
229 /* True means abort if try to GC.
230 This is for code which is written on the assumption that
231 no GC will happen, so as to verify that assumption. */
235 /* Number of live and free conses etc. */
237 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
238 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
239 static EMACS_INT total_free_floats
, total_floats
;
241 /* Points to memory space allocated as "spare", to be freed if we run
242 out of memory. We keep one large block, four cons-blocks, and
243 two string blocks. */
245 static char *spare_memory
[7];
247 /* Amount of spare memory to keep in large reserve block, or to see
248 whether this much is available when malloc fails on a larger request. */
250 #define SPARE_MEMORY (1 << 14)
252 /* Initialize it to a nonzero value to force it into data space
253 (rather than bss space). That way unexec will remap it into text
254 space (pure), on some systems. We have not implemented the
255 remapping on more recent systems because this is less important
256 nowadays than in the days of small memories and timesharing. */
258 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
259 #define PUREBEG (char *) pure
261 /* Pointer to the pure area, and its size. */
263 static char *purebeg
;
264 static ptrdiff_t pure_size
;
266 /* Number of bytes of pure storage used before pure storage overflowed.
267 If this is non-zero, this implies that an overflow occurred. */
269 static ptrdiff_t pure_bytes_used_before_overflow
;
271 /* Index in pure at which next pure Lisp object will be allocated.. */
273 static ptrdiff_t pure_bytes_used_lisp
;
275 /* Number of bytes allocated for non-Lisp objects in pure storage. */
277 static ptrdiff_t pure_bytes_used_non_lisp
;
279 /* If nonzero, this is a warning delivered by malloc and not yet
282 const char *pending_malloc_warning
;
284 #if 0 /* Normally, pointer sanity only on request... */
285 #ifdef ENABLE_CHECKING
286 #define SUSPICIOUS_OBJECT_CHECKING 1
290 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
291 bug is unresolved. */
292 #define SUSPICIOUS_OBJECT_CHECKING 1
294 #ifdef SUSPICIOUS_OBJECT_CHECKING
295 struct suspicious_free_record
297 void *suspicious_object
;
298 void *backtrace
[128];
300 static void *suspicious_objects
[32];
301 static int suspicious_object_index
;
302 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
303 static int suspicious_free_history_index
;
304 /* Find the first currently-monitored suspicious pointer in range
305 [begin,end) or NULL if no such pointer exists. */
306 static void *find_suspicious_object_in_range (void *begin
, void *end
);
307 static void detect_suspicious_free (void *ptr
);
309 # define find_suspicious_object_in_range(begin, end) NULL
310 # define detect_suspicious_free(ptr) (void)
313 /* Maximum amount of C stack to save when a GC happens. */
315 #ifndef MAX_SAVE_STACK
316 #define MAX_SAVE_STACK 16000
319 /* Buffer in which we save a copy of the C stack at each GC. */
321 #if MAX_SAVE_STACK > 0
322 static char *stack_copy
;
323 static ptrdiff_t stack_copy_size
;
325 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
326 avoiding any address sanitization. */
328 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
329 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
331 if (! ADDRESS_SANITIZER
)
332 return memcpy (dest
, src
, size
);
338 for (i
= 0; i
< size
; i
++)
344 #endif /* MAX_SAVE_STACK > 0 */
346 static void mark_terminals (void);
347 static void gc_sweep (void);
348 static Lisp_Object
make_pure_vector (ptrdiff_t);
349 static void mark_buffer (struct buffer
*);
351 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
352 static void refill_memory_reserve (void);
354 static void compact_small_strings (void);
355 static void free_large_strings (void);
356 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
358 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
359 what memory allocated via lisp_malloc and lisp_align_malloc is intended
360 for what purpose. This enumeration specifies the type of memory. */
371 /* Since all non-bool pseudovectors are small enough to be
372 allocated from vector blocks, this memory type denotes
373 large regular vectors and large bool pseudovectors. */
375 /* Special type to denote vector blocks. */
376 MEM_TYPE_VECTOR_BLOCK
,
377 /* Special type to denote reserved memory. */
381 /* A unique object in pure space used to make some Lisp objects
382 on free lists recognizable in O(1). */
384 static Lisp_Object Vdead
;
385 #define DEADP(x) EQ (x, Vdead)
387 #ifdef GC_MALLOC_CHECK
389 enum mem_type allocated_mem_type
;
391 #endif /* GC_MALLOC_CHECK */
393 /* A node in the red-black tree describing allocated memory containing
394 Lisp data. Each such block is recorded with its start and end
395 address when it is allocated, and removed from the tree when it
398 A red-black tree is a balanced binary tree with the following
401 1. Every node is either red or black.
402 2. Every leaf is black.
403 3. If a node is red, then both of its children are black.
404 4. Every simple path from a node to a descendant leaf contains
405 the same number of black nodes.
406 5. The root is always black.
408 When nodes are inserted into the tree, or deleted from the tree,
409 the tree is "fixed" so that these properties are always true.
411 A red-black tree with N internal nodes has height at most 2
412 log(N+1). Searches, insertions and deletions are done in O(log N).
413 Please see a text book about data structures for a detailed
414 description of red-black trees. Any book worth its salt should
419 /* Children of this node. These pointers are never NULL. When there
420 is no child, the value is MEM_NIL, which points to a dummy node. */
421 struct mem_node
*left
, *right
;
423 /* The parent of this node. In the root node, this is NULL. */
424 struct mem_node
*parent
;
426 /* Start and end of allocated region. */
430 enum {MEM_BLACK
, MEM_RED
} color
;
436 /* Base address of stack. Set in main. */
438 Lisp_Object
*stack_base
;
440 /* Root of the tree describing allocated Lisp memory. */
442 static struct mem_node
*mem_root
;
444 /* Lowest and highest known address in the heap. */
446 static void *min_heap_address
, *max_heap_address
;
448 /* Sentinel node of the tree. */
450 static struct mem_node mem_z
;
451 #define MEM_NIL &mem_z
453 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
454 static void mem_insert_fixup (struct mem_node
*);
455 static void mem_rotate_left (struct mem_node
*);
456 static void mem_rotate_right (struct mem_node
*);
457 static void mem_delete (struct mem_node
*);
458 static void mem_delete_fixup (struct mem_node
*);
459 static struct mem_node
*mem_find (void *);
465 /* Addresses of staticpro'd variables. Initialize it to a nonzero
466 value; otherwise some compilers put it into BSS. */
468 enum { NSTATICS
= 2048 };
469 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
471 /* Index of next unused slot in staticvec. */
473 static int staticidx
;
475 static void *pure_alloc (size_t, int);
477 /* Return X rounded to the next multiple of Y. Arguments should not
478 have side effects, as they are evaluated more than once. Assume X
479 + Y - 1 does not overflow. Tune for Y being a power of 2. */
481 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
482 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
483 : ((x) + (y) - 1) & ~ ((y) - 1))
485 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
488 ALIGN (void *ptr
, int alignment
)
490 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
493 /* Extract the pointer hidden within A, if A is not a symbol.
494 If A is a symbol, extract the hidden pointer's offset from lispsym,
495 converted to void *. */
497 #define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
498 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
500 /* Extract the pointer hidden within A. */
502 #define macro_XPNTR(a) \
503 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
504 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
506 /* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
507 functions, as functions are cleaner and can be used in debuggers.
508 Also, define them as macros if being compiled with GCC without
509 optimization, for performance in that case. The macro_* names are
510 private to this section of code. */
512 static ATTRIBUTE_UNUSED
void *
513 XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a
)
515 return macro_XPNTR_OR_SYMBOL_OFFSET (a
);
517 static ATTRIBUTE_UNUSED
void *
518 XPNTR (Lisp_Object a
)
520 return macro_XPNTR (a
);
523 #if DEFINE_KEY_OPS_AS_MACROS
524 # define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
525 # define XPNTR(a) macro_XPNTR (a)
529 XFLOAT_INIT (Lisp_Object f
, double n
)
531 XFLOAT (f
)->u
.data
= n
;
534 #ifdef DOUG_LEA_MALLOC
536 pointers_fit_in_lispobj_p (void)
538 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
542 mmap_lisp_allowed_p (void)
544 /* If we can't store all memory addresses in our lisp objects, it's
545 risky to let the heap use mmap and give us addresses from all
546 over our address space. We also can't use mmap for lisp objects
547 if we might dump: unexec doesn't preserve the contents of mmapped
549 return pointers_fit_in_lispobj_p () && !might_dump
;
553 /* Head of a circularly-linked list of extant finalizers. */
554 static struct Lisp_Finalizer finalizers
;
556 /* Head of a circularly-linked list of finalizers that must be invoked
557 because we deemed them unreachable. This list must be global, and
558 not a local inside garbage_collect_1, in case we GC again while
559 running finalizers. */
560 static struct Lisp_Finalizer doomed_finalizers
;
563 /************************************************************************
565 ************************************************************************/
567 #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
569 /* Function malloc calls this if it finds we are near exhausting storage. */
572 malloc_warning (const char *str
)
574 pending_malloc_warning
= str
;
579 /* Display an already-pending malloc warning. */
582 display_malloc_warning (void)
584 call3 (intern ("display-warning"),
586 build_string (pending_malloc_warning
),
587 intern ("emergency"));
588 pending_malloc_warning
= 0;
591 /* Called if we can't allocate relocatable space for a buffer. */
594 buffer_memory_full (ptrdiff_t nbytes
)
596 /* If buffers use the relocating allocator, no need to free
597 spare_memory, because we may have plenty of malloc space left
598 that we could get, and if we don't, the malloc that fails will
599 itself cause spare_memory to be freed. If buffers don't use the
600 relocating allocator, treat this like any other failing
604 memory_full (nbytes
);
606 /* This used to call error, but if we've run out of memory, we could
607 get infinite recursion trying to build the string. */
608 xsignal (Qnil
, Vmemory_signal_data
);
612 /* A common multiple of the positive integers A and B. Ideally this
613 would be the least common multiple, but there's no way to do that
614 as a constant expression in C, so do the best that we can easily do. */
615 #define COMMON_MULTIPLE(a, b) \
616 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
618 #ifndef XMALLOC_OVERRUN_CHECK
619 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
622 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
625 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
626 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
627 block size in little-endian order. The trailer consists of
628 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
630 The header is used to detect whether this block has been allocated
631 through these functions, as some low-level libc functions may
632 bypass the malloc hooks. */
634 #define XMALLOC_OVERRUN_CHECK_SIZE 16
635 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
636 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
638 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
639 hold a size_t value and (2) the header size is a multiple of the
640 alignment that Emacs needs for C types and for USE_LSB_TAG. */
641 #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
643 #define XMALLOC_HEADER_ALIGNMENT \
644 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
645 #define XMALLOC_OVERRUN_SIZE_SIZE \
646 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
647 + XMALLOC_HEADER_ALIGNMENT - 1) \
648 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
649 - XMALLOC_OVERRUN_CHECK_SIZE)
651 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
652 { '\x9a', '\x9b', '\xae', '\xaf',
653 '\xbf', '\xbe', '\xce', '\xcf',
654 '\xea', '\xeb', '\xec', '\xed',
655 '\xdf', '\xde', '\x9c', '\x9d' };
657 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
658 { '\xaa', '\xab', '\xac', '\xad',
659 '\xba', '\xbb', '\xbc', '\xbd',
660 '\xca', '\xcb', '\xcc', '\xcd',
661 '\xda', '\xdb', '\xdc', '\xdd' };
663 /* Insert and extract the block size in the header. */
666 xmalloc_put_size (unsigned char *ptr
, size_t size
)
669 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
671 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
677 xmalloc_get_size (unsigned char *ptr
)
681 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
682 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
691 /* Like malloc, but wraps allocated block with header and trailer. */
694 overrun_check_malloc (size_t size
)
696 register unsigned char *val
;
697 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
700 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
703 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
704 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
705 xmalloc_put_size (val
, size
);
706 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
707 XMALLOC_OVERRUN_CHECK_SIZE
);
713 /* Like realloc, but checks old block for overrun, and wraps new block
714 with header and trailer. */
717 overrun_check_realloc (void *block
, size_t size
)
719 register unsigned char *val
= (unsigned char *) block
;
720 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
724 && memcmp (xmalloc_overrun_check_header
,
725 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
726 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
728 size_t osize
= xmalloc_get_size (val
);
729 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
730 XMALLOC_OVERRUN_CHECK_SIZE
))
732 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
733 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
734 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
737 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
741 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
742 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
743 xmalloc_put_size (val
, size
);
744 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
745 XMALLOC_OVERRUN_CHECK_SIZE
);
750 /* Like free, but checks block for overrun. */
753 overrun_check_free (void *block
)
755 unsigned char *val
= (unsigned char *) block
;
758 && memcmp (xmalloc_overrun_check_header
,
759 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
760 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
762 size_t osize
= xmalloc_get_size (val
);
763 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
764 XMALLOC_OVERRUN_CHECK_SIZE
))
766 #ifdef XMALLOC_CLEAR_FREE_MEMORY
767 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
768 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
770 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
771 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
772 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
782 #define malloc overrun_check_malloc
783 #define realloc overrun_check_realloc
784 #define free overrun_check_free
787 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
788 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
789 If that variable is set, block input while in one of Emacs's memory
790 allocation functions. There should be no need for this debugging
791 option, since signal handlers do not allocate memory, but Emacs
792 formerly allocated memory in signal handlers and this compile-time
793 option remains as a way to help debug the issue should it rear its
795 #ifdef XMALLOC_BLOCK_INPUT_CHECK
796 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
798 malloc_block_input (void)
800 if (block_input_in_memory_allocators
)
804 malloc_unblock_input (void)
806 if (block_input_in_memory_allocators
)
809 # define MALLOC_BLOCK_INPUT malloc_block_input ()
810 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
812 # define MALLOC_BLOCK_INPUT ((void) 0)
813 # define MALLOC_UNBLOCK_INPUT ((void) 0)
816 #define MALLOC_PROBE(size) \
818 if (profiler_memory_running) \
819 malloc_probe (size); \
823 /* Like malloc but check for no memory and block interrupt input.. */
826 xmalloc (size_t size
)
832 MALLOC_UNBLOCK_INPUT
;
840 /* Like the above, but zeroes out the memory just allocated. */
843 xzalloc (size_t size
)
849 MALLOC_UNBLOCK_INPUT
;
853 memset (val
, 0, size
);
858 /* Like realloc but check for no memory and block interrupt input.. */
861 xrealloc (void *block
, size_t size
)
866 /* We must call malloc explicitly when BLOCK is 0, since some
867 reallocs don't do this. */
871 val
= realloc (block
, size
);
872 MALLOC_UNBLOCK_INPUT
;
881 /* Like free but block interrupt input. */
890 MALLOC_UNBLOCK_INPUT
;
891 /* We don't call refill_memory_reserve here
892 because in practice the call in r_alloc_free seems to suffice. */
896 /* Other parts of Emacs pass large int values to allocator functions
897 expecting ptrdiff_t. This is portable in practice, but check it to
899 verify (INT_MAX
<= PTRDIFF_MAX
);
902 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
903 Signal an error on memory exhaustion, and block interrupt input. */
906 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
908 eassert (0 <= nitems
&& 0 < item_size
);
910 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
911 memory_full (SIZE_MAX
);
912 return xmalloc (nbytes
);
916 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
917 Signal an error on memory exhaustion, and block interrupt input. */
920 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
922 eassert (0 <= nitems
&& 0 < item_size
);
924 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
925 memory_full (SIZE_MAX
);
926 return xrealloc (pa
, nbytes
);
930 /* Grow PA, which points to an array of *NITEMS items, and return the
931 location of the reallocated array, updating *NITEMS to reflect its
932 new size. The new array will contain at least NITEMS_INCR_MIN more
933 items, but will not contain more than NITEMS_MAX items total.
934 ITEM_SIZE is the size of each item, in bytes.
936 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
937 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
940 If PA is null, then allocate a new array instead of reallocating
943 Block interrupt input as needed. If memory exhaustion occurs, set
944 *NITEMS to zero if PA is null, and signal an error (i.e., do not
947 Thus, to grow an array A without saving its old contents, do
948 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
949 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
950 and signals an error, and later this code is reexecuted and
951 attempts to free A. */
954 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
955 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
957 ptrdiff_t n0
= *nitems
;
958 eassume (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n0
&& -1 <= nitems_max
);
960 /* The approximate size to use for initial small allocation
961 requests. This is the largest "small" request for the GNU C
963 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
965 /* If the array is tiny, grow it to about (but no greater than)
966 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
967 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
968 NITEMS_MAX, and what the C language can represent safely. */
971 if (INT_ADD_WRAPV (n0
, n0
>> 1, &n
))
973 if (0 <= nitems_max
&& nitems_max
< n
)
976 ptrdiff_t adjusted_nbytes
977 = ((INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
978 ? min (PTRDIFF_MAX
, SIZE_MAX
)
979 : nbytes
< DEFAULT_MXFAST
? DEFAULT_MXFAST
: 0);
982 n
= adjusted_nbytes
/ item_size
;
983 nbytes
= adjusted_nbytes
- adjusted_nbytes
% item_size
;
988 if (n
- n0
< nitems_incr_min
989 && (INT_ADD_WRAPV (n0
, nitems_incr_min
, &n
)
990 || (0 <= nitems_max
&& nitems_max
< n
)
991 || INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
)))
992 memory_full (SIZE_MAX
);
993 pa
= xrealloc (pa
, nbytes
);
999 /* Like strdup, but uses xmalloc. */
1002 xstrdup (const char *s
)
1006 size
= strlen (s
) + 1;
1007 return memcpy (xmalloc (size
), s
, size
);
1010 /* Like above, but duplicates Lisp string to C string. */
1013 xlispstrdup (Lisp_Object string
)
1015 ptrdiff_t size
= SBYTES (string
) + 1;
1016 return memcpy (xmalloc (size
), SSDATA (string
), size
);
1019 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1020 pointed to. If STRING is null, assign it without copying anything.
1021 Allocate before freeing, to avoid a dangling pointer if allocation
1025 dupstring (char **ptr
, char const *string
)
1028 *ptr
= string
? xstrdup (string
) : 0;
1033 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1034 argument is a const pointer. */
1037 xputenv (char const *string
)
1039 if (putenv ((char *) string
) != 0)
1043 /* Return a newly allocated memory block of SIZE bytes, remembering
1044 to free it when unwinding. */
1046 record_xmalloc (size_t size
)
1048 void *p
= xmalloc (size
);
1049 record_unwind_protect_ptr (xfree
, p
);
1054 /* Like malloc but used for allocating Lisp data. NBYTES is the
1055 number of bytes to allocate, TYPE describes the intended use of the
1056 allocated memory block (for strings, for conses, ...). */
1059 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
1063 lisp_malloc (size_t nbytes
, enum mem_type type
)
1069 #ifdef GC_MALLOC_CHECK
1070 allocated_mem_type
= type
;
1073 val
= malloc (nbytes
);
1076 /* If the memory just allocated cannot be addressed thru a Lisp
1077 object's pointer, and it needs to be,
1078 that's equivalent to running out of memory. */
1079 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1082 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
1083 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
1085 lisp_malloc_loser
= val
;
1092 #ifndef GC_MALLOC_CHECK
1093 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1094 mem_insert (val
, (char *) val
+ nbytes
, type
);
1097 MALLOC_UNBLOCK_INPUT
;
1099 memory_full (nbytes
);
1100 MALLOC_PROBE (nbytes
);
1104 /* Free BLOCK. This must be called to free memory allocated with a
1105 call to lisp_malloc. */
1108 lisp_free (void *block
)
1112 #ifndef GC_MALLOC_CHECK
1113 mem_delete (mem_find (block
));
1115 MALLOC_UNBLOCK_INPUT
;
1118 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1120 /* The entry point is lisp_align_malloc which returns blocks of at most
1121 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1123 /* Use aligned_alloc if it or a simple substitute is available.
1124 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1125 clang 3.3 anyway. */
1127 #if ! ADDRESS_SANITIZER
1128 # if defined HYBRID_MALLOC
1129 # if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
1130 # define USE_ALIGNED_ALLOC 1
1132 # elif !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC
1133 # define USE_ALIGNED_ALLOC 1
1134 # elif defined HAVE_ALIGNED_ALLOC
1135 # define USE_ALIGNED_ALLOC 1
1136 # elif defined HAVE_POSIX_MEMALIGN
1137 # define USE_ALIGNED_ALLOC 1
1139 aligned_alloc (size_t alignment
, size_t size
)
1142 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1147 /* BLOCK_ALIGN has to be a power of 2. */
1148 #define BLOCK_ALIGN (1 << 10)
1150 /* Padding to leave at the end of a malloc'd block. This is to give
1151 malloc a chance to minimize the amount of memory wasted to alignment.
1152 It should be tuned to the particular malloc library used.
1153 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1154 aligned_alloc on the other hand would ideally prefer a value of 4
1155 because otherwise, there's 1020 bytes wasted between each ablocks.
1156 In Emacs, testing shows that those 1020 can most of the time be
1157 efficiently used by malloc to place other objects, so a value of 0 can
1158 still preferable unless you have a lot of aligned blocks and virtually
1160 #define BLOCK_PADDING 0
1161 #define BLOCK_BYTES \
1162 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1164 /* Internal data structures and constants. */
1166 #define ABLOCKS_SIZE 16
1168 /* An aligned block of memory. */
1173 char payload
[BLOCK_BYTES
];
1174 struct ablock
*next_free
;
1176 /* `abase' is the aligned base of the ablocks. */
1177 /* It is overloaded to hold the virtual `busy' field that counts
1178 the number of used ablock in the parent ablocks.
1179 The first ablock has the `busy' field, the others have the `abase'
1180 field. To tell the difference, we assume that pointers will have
1181 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1182 is used to tell whether the real base of the parent ablocks is `abase'
1183 (if not, the word before the first ablock holds a pointer to the
1185 struct ablocks
*abase
;
1186 /* The padding of all but the last ablock is unused. The padding of
1187 the last ablock in an ablocks is not allocated. */
1189 char padding
[BLOCK_PADDING
];
1193 /* A bunch of consecutive aligned blocks. */
1196 struct ablock blocks
[ABLOCKS_SIZE
];
1199 /* Size of the block requested from malloc or aligned_alloc. */
1200 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1202 #define ABLOCK_ABASE(block) \
1203 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1204 ? (struct ablocks *)(block) \
1207 /* Virtual `busy' field. */
1208 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1210 /* Pointer to the (not necessarily aligned) malloc block. */
1211 #ifdef USE_ALIGNED_ALLOC
1212 #define ABLOCKS_BASE(abase) (abase)
1214 #define ABLOCKS_BASE(abase) \
1215 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1218 /* The list of free ablock. */
1219 static struct ablock
*free_ablock
;
1221 /* Allocate an aligned block of nbytes.
1222 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1223 smaller or equal to BLOCK_BYTES. */
1225 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1228 struct ablocks
*abase
;
1230 eassert (nbytes
<= BLOCK_BYTES
);
1234 #ifdef GC_MALLOC_CHECK
1235 allocated_mem_type
= type
;
1241 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1243 #ifdef DOUG_LEA_MALLOC
1244 if (!mmap_lisp_allowed_p ())
1245 mallopt (M_MMAP_MAX
, 0);
1248 #ifdef USE_ALIGNED_ALLOC
1249 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1251 base
= malloc (ABLOCKS_BYTES
);
1252 abase
= ALIGN (base
, BLOCK_ALIGN
);
1257 MALLOC_UNBLOCK_INPUT
;
1258 memory_full (ABLOCKS_BYTES
);
1261 aligned
= (base
== abase
);
1263 ((void **) abase
)[-1] = base
;
1265 #ifdef DOUG_LEA_MALLOC
1266 if (!mmap_lisp_allowed_p ())
1267 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1271 /* If the memory just allocated cannot be addressed thru a Lisp
1272 object's pointer, and it needs to be, that's equivalent to
1273 running out of memory. */
1274 if (type
!= MEM_TYPE_NON_LISP
)
1277 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1278 XSETCONS (tem
, end
);
1279 if ((char *) XCONS (tem
) != end
)
1281 lisp_malloc_loser
= base
;
1283 MALLOC_UNBLOCK_INPUT
;
1284 memory_full (SIZE_MAX
);
1289 /* Initialize the blocks and put them on the free list.
1290 If `base' was not properly aligned, we can't use the last block. */
1291 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1293 abase
->blocks
[i
].abase
= abase
;
1294 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1295 free_ablock
= &abase
->blocks
[i
];
1297 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1299 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1300 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1301 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1302 eassert (ABLOCKS_BASE (abase
) == base
);
1303 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1306 abase
= ABLOCK_ABASE (free_ablock
);
1307 ABLOCKS_BUSY (abase
)
1308 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1310 free_ablock
= free_ablock
->x
.next_free
;
1312 #ifndef GC_MALLOC_CHECK
1313 if (type
!= MEM_TYPE_NON_LISP
)
1314 mem_insert (val
, (char *) val
+ nbytes
, type
);
1317 MALLOC_UNBLOCK_INPUT
;
1319 MALLOC_PROBE (nbytes
);
1321 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1326 lisp_align_free (void *block
)
1328 struct ablock
*ablock
= block
;
1329 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1332 #ifndef GC_MALLOC_CHECK
1333 mem_delete (mem_find (block
));
1335 /* Put on free list. */
1336 ablock
->x
.next_free
= free_ablock
;
1337 free_ablock
= ablock
;
1338 /* Update busy count. */
1339 ABLOCKS_BUSY (abase
)
1340 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1342 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1343 { /* All the blocks are free. */
1344 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1345 struct ablock
**tem
= &free_ablock
;
1346 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1350 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1353 *tem
= (*tem
)->x
.next_free
;
1356 tem
= &(*tem
)->x
.next_free
;
1358 eassert ((aligned
& 1) == aligned
);
1359 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1360 #ifdef USE_POSIX_MEMALIGN
1361 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1363 free (ABLOCKS_BASE (abase
));
1365 MALLOC_UNBLOCK_INPUT
;
1369 /***********************************************************************
1371 ***********************************************************************/
1373 /* Number of intervals allocated in an interval_block structure.
1374 The 1020 is 1024 minus malloc overhead. */
1376 #define INTERVAL_BLOCK_SIZE \
1377 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1379 /* Intervals are allocated in chunks in the form of an interval_block
1382 struct interval_block
1384 /* Place `intervals' first, to preserve alignment. */
1385 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1386 struct interval_block
*next
;
1389 /* Current interval block. Its `next' pointer points to older
1392 static struct interval_block
*interval_block
;
1394 /* Index in interval_block above of the next unused interval
1397 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1399 /* Number of free and live intervals. */
1401 static EMACS_INT total_free_intervals
, total_intervals
;
1403 /* List of free intervals. */
1405 static INTERVAL interval_free_list
;
1407 /* Return a new interval. */
1410 make_interval (void)
1416 if (interval_free_list
)
1418 val
= interval_free_list
;
1419 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1423 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1425 struct interval_block
*newi
1426 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1428 newi
->next
= interval_block
;
1429 interval_block
= newi
;
1430 interval_block_index
= 0;
1431 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1433 val
= &interval_block
->intervals
[interval_block_index
++];
1436 MALLOC_UNBLOCK_INPUT
;
1438 consing_since_gc
+= sizeof (struct interval
);
1440 total_free_intervals
--;
1441 RESET_INTERVAL (val
);
1447 /* Mark Lisp objects in interval I. */
1450 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1452 /* Intervals should never be shared. So, if extra internal checking is
1453 enabled, GC aborts if it seems to have visited an interval twice. */
1454 eassert (!i
->gcmarkbit
);
1456 mark_object (i
->plist
);
1459 /* Mark the interval tree rooted in I. */
1461 #define MARK_INTERVAL_TREE(i) \
1463 if (i && !i->gcmarkbit) \
1464 traverse_intervals_noorder (i, mark_interval, Qnil); \
1467 /***********************************************************************
1469 ***********************************************************************/
1471 /* Lisp_Strings are allocated in string_block structures. When a new
1472 string_block is allocated, all the Lisp_Strings it contains are
1473 added to a free-list string_free_list. When a new Lisp_String is
1474 needed, it is taken from that list. During the sweep phase of GC,
1475 string_blocks that are entirely free are freed, except two which
1478 String data is allocated from sblock structures. Strings larger
1479 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1480 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1482 Sblocks consist internally of sdata structures, one for each
1483 Lisp_String. The sdata structure points to the Lisp_String it
1484 belongs to. The Lisp_String points back to the `u.data' member of
1485 its sdata structure.
1487 When a Lisp_String is freed during GC, it is put back on
1488 string_free_list, and its `data' member and its sdata's `string'
1489 pointer is set to null. The size of the string is recorded in the
1490 `n.nbytes' member of the sdata. So, sdata structures that are no
1491 longer used, can be easily recognized, and it's easy to compact the
1492 sblocks of small strings which we do in compact_small_strings. */
1494 /* Size in bytes of an sblock structure used for small strings. This
1495 is 8192 minus malloc overhead. */
1497 #define SBLOCK_SIZE 8188
1499 /* Strings larger than this are considered large strings. String data
1500 for large strings is allocated from individual sblocks. */
1502 #define LARGE_STRING_BYTES 1024
1504 /* The SDATA typedef is a struct or union describing string memory
1505 sub-allocated from an sblock. This is where the contents of Lisp
1506 strings are stored. */
1510 /* Back-pointer to the string this sdata belongs to. If null, this
1511 structure is free, and NBYTES (in this structure or in the union below)
1512 contains the string's byte size (the same value that STRING_BYTES
1513 would return if STRING were non-null). If non-null, STRING_BYTES
1514 (STRING) is the size of the data, and DATA contains the string's
1516 struct Lisp_String
*string
;
1518 #ifdef GC_CHECK_STRING_BYTES
1522 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1525 #ifdef GC_CHECK_STRING_BYTES
1527 typedef struct sdata sdata
;
1528 #define SDATA_NBYTES(S) (S)->nbytes
1529 #define SDATA_DATA(S) (S)->data
1535 struct Lisp_String
*string
;
1537 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1538 which has a flexible array member. However, if implemented by
1539 giving this union a member of type 'struct sdata', the union
1540 could not be the last (flexible) member of 'struct sblock',
1541 because C99 prohibits a flexible array member from having a type
1542 that is itself a flexible array. So, comment this member out here,
1543 but remember that the option's there when using this union. */
1548 /* When STRING is null. */
1551 struct Lisp_String
*string
;
1556 #define SDATA_NBYTES(S) (S)->n.nbytes
1557 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1559 #endif /* not GC_CHECK_STRING_BYTES */
1561 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1563 /* Structure describing a block of memory which is sub-allocated to
1564 obtain string data memory for strings. Blocks for small strings
1565 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1566 as large as needed. */
1571 struct sblock
*next
;
1573 /* Pointer to the next free sdata block. This points past the end
1574 of the sblock if there isn't any space left in this block. */
1578 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1581 /* Number of Lisp strings in a string_block structure. The 1020 is
1582 1024 minus malloc overhead. */
1584 #define STRING_BLOCK_SIZE \
1585 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1587 /* Structure describing a block from which Lisp_String structures
1592 /* Place `strings' first, to preserve alignment. */
1593 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1594 struct string_block
*next
;
1597 /* Head and tail of the list of sblock structures holding Lisp string
1598 data. We always allocate from current_sblock. The NEXT pointers
1599 in the sblock structures go from oldest_sblock to current_sblock. */
1601 static struct sblock
*oldest_sblock
, *current_sblock
;
1603 /* List of sblocks for large strings. */
1605 static struct sblock
*large_sblocks
;
1607 /* List of string_block structures. */
1609 static struct string_block
*string_blocks
;
1611 /* Free-list of Lisp_Strings. */
1613 static struct Lisp_String
*string_free_list
;
1615 /* Number of live and free Lisp_Strings. */
1617 static EMACS_INT total_strings
, total_free_strings
;
1619 /* Number of bytes used by live strings. */
1621 static EMACS_INT total_string_bytes
;
1623 /* Given a pointer to a Lisp_String S which is on the free-list
1624 string_free_list, return a pointer to its successor in the
1627 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1629 /* Return a pointer to the sdata structure belonging to Lisp string S.
1630 S must be live, i.e. S->data must not be null. S->data is actually
1631 a pointer to the `u.data' member of its sdata structure; the
1632 structure starts at a constant offset in front of that. */
1634 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1637 #ifdef GC_CHECK_STRING_OVERRUN
1639 /* We check for overrun in string data blocks by appending a small
1640 "cookie" after each allocated string data block, and check for the
1641 presence of this cookie during GC. */
1643 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1644 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1645 { '\xde', '\xad', '\xbe', '\xef' };
1648 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1651 /* Value is the size of an sdata structure large enough to hold NBYTES
1652 bytes of string data. The value returned includes a terminating
1653 NUL byte, the size of the sdata structure, and padding. */
1655 #ifdef GC_CHECK_STRING_BYTES
1657 #define SDATA_SIZE(NBYTES) \
1658 ((SDATA_DATA_OFFSET \
1660 + sizeof (ptrdiff_t) - 1) \
1661 & ~(sizeof (ptrdiff_t) - 1))
1663 #else /* not GC_CHECK_STRING_BYTES */
1665 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1666 less than the size of that member. The 'max' is not needed when
1667 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1668 alignment code reserves enough space. */
1670 #define SDATA_SIZE(NBYTES) \
1671 ((SDATA_DATA_OFFSET \
1672 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1674 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1676 + sizeof (ptrdiff_t) - 1) \
1677 & ~(sizeof (ptrdiff_t) - 1))
1679 #endif /* not GC_CHECK_STRING_BYTES */
1681 /* Extra bytes to allocate for each string. */
1683 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1685 /* Exact bound on the number of bytes in a string, not counting the
1686 terminating null. A string cannot contain more bytes than
1687 STRING_BYTES_BOUND, nor can it be so long that the size_t
1688 arithmetic in allocate_string_data would overflow while it is
1689 calculating a value to be passed to malloc. */
1690 static ptrdiff_t const STRING_BYTES_MAX
=
1691 min (STRING_BYTES_BOUND
,
1692 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1694 - offsetof (struct sblock
, data
)
1695 - SDATA_DATA_OFFSET
)
1696 & ~(sizeof (EMACS_INT
) - 1)));
1698 /* Initialize string allocation. Called from init_alloc_once. */
1703 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1704 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1708 #ifdef GC_CHECK_STRING_BYTES
1710 static int check_string_bytes_count
;
1712 /* Like STRING_BYTES, but with debugging check. Can be
1713 called during GC, so pay attention to the mark bit. */
1716 string_bytes (struct Lisp_String
*s
)
1719 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1721 if (!PURE_P (s
) && s
->data
&& nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1726 /* Check validity of Lisp strings' string_bytes member in B. */
1729 check_sblock (struct sblock
*b
)
1731 sdata
*from
, *end
, *from_end
;
1735 for (from
= b
->data
; from
< end
; from
= from_end
)
1737 /* Compute the next FROM here because copying below may
1738 overwrite data we need to compute it. */
1741 /* Check that the string size recorded in the string is the
1742 same as the one recorded in the sdata structure. */
1743 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1744 : SDATA_NBYTES (from
));
1745 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1750 /* Check validity of Lisp strings' string_bytes member. ALL_P
1751 means check all strings, otherwise check only most
1752 recently allocated strings. Used for hunting a bug. */
1755 check_string_bytes (bool all_p
)
1761 for (b
= large_sblocks
; b
; b
= b
->next
)
1763 struct Lisp_String
*s
= b
->data
[0].string
;
1768 for (b
= oldest_sblock
; b
; b
= b
->next
)
1771 else if (current_sblock
)
1772 check_sblock (current_sblock
);
1775 #else /* not GC_CHECK_STRING_BYTES */
1777 #define check_string_bytes(all) ((void) 0)
1779 #endif /* GC_CHECK_STRING_BYTES */
1781 #ifdef GC_CHECK_STRING_FREE_LIST
1783 /* Walk through the string free list looking for bogus next pointers.
1784 This may catch buffer overrun from a previous string. */
1787 check_string_free_list (void)
1789 struct Lisp_String
*s
;
1791 /* Pop a Lisp_String off the free-list. */
1792 s
= string_free_list
;
1795 if ((uintptr_t) s
< 1024)
1797 s
= NEXT_FREE_LISP_STRING (s
);
1801 #define check_string_free_list()
1804 /* Return a new Lisp_String. */
1806 static struct Lisp_String
*
1807 allocate_string (void)
1809 struct Lisp_String
*s
;
1813 /* If the free-list is empty, allocate a new string_block, and
1814 add all the Lisp_Strings in it to the free-list. */
1815 if (string_free_list
== NULL
)
1817 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1820 b
->next
= string_blocks
;
1823 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1826 /* Every string on a free list should have NULL data pointer. */
1828 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1829 string_free_list
= s
;
1832 total_free_strings
+= STRING_BLOCK_SIZE
;
1835 check_string_free_list ();
1837 /* Pop a Lisp_String off the free-list. */
1838 s
= string_free_list
;
1839 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1841 MALLOC_UNBLOCK_INPUT
;
1843 --total_free_strings
;
1846 consing_since_gc
+= sizeof *s
;
1848 #ifdef GC_CHECK_STRING_BYTES
1849 if (!noninteractive
)
1851 if (++check_string_bytes_count
== 200)
1853 check_string_bytes_count
= 0;
1854 check_string_bytes (1);
1857 check_string_bytes (0);
1859 #endif /* GC_CHECK_STRING_BYTES */
1865 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1866 plus a NUL byte at the end. Allocate an sdata structure for S, and
1867 set S->data to its `u.data' member. Store a NUL byte at the end of
1868 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1869 S->data if it was initially non-null. */
1872 allocate_string_data (struct Lisp_String
*s
,
1873 EMACS_INT nchars
, EMACS_INT nbytes
)
1875 sdata
*data
, *old_data
;
1877 ptrdiff_t needed
, old_nbytes
;
1879 if (STRING_BYTES_MAX
< nbytes
)
1882 /* Determine the number of bytes needed to store NBYTES bytes
1884 needed
= SDATA_SIZE (nbytes
);
1887 old_data
= SDATA_OF_STRING (s
);
1888 old_nbytes
= STRING_BYTES (s
);
1895 if (nbytes
> LARGE_STRING_BYTES
)
1897 size_t size
= offsetof (struct sblock
, data
) + needed
;
1899 #ifdef DOUG_LEA_MALLOC
1900 if (!mmap_lisp_allowed_p ())
1901 mallopt (M_MMAP_MAX
, 0);
1904 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1906 #ifdef DOUG_LEA_MALLOC
1907 if (!mmap_lisp_allowed_p ())
1908 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1911 b
->next_free
= b
->data
;
1912 b
->data
[0].string
= NULL
;
1913 b
->next
= large_sblocks
;
1916 else if (current_sblock
== NULL
1917 || (((char *) current_sblock
+ SBLOCK_SIZE
1918 - (char *) current_sblock
->next_free
)
1919 < (needed
+ GC_STRING_EXTRA
)))
1921 /* Not enough room in the current sblock. */
1922 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1923 b
->next_free
= b
->data
;
1924 b
->data
[0].string
= NULL
;
1928 current_sblock
->next
= b
;
1936 data
= b
->next_free
;
1937 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1939 MALLOC_UNBLOCK_INPUT
;
1942 s
->data
= SDATA_DATA (data
);
1943 #ifdef GC_CHECK_STRING_BYTES
1944 SDATA_NBYTES (data
) = nbytes
;
1947 s
->size_byte
= nbytes
;
1948 s
->data
[nbytes
] = '\0';
1949 #ifdef GC_CHECK_STRING_OVERRUN
1950 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1951 GC_STRING_OVERRUN_COOKIE_SIZE
);
1954 /* Note that Faset may call to this function when S has already data
1955 assigned. In this case, mark data as free by setting it's string
1956 back-pointer to null, and record the size of the data in it. */
1959 SDATA_NBYTES (old_data
) = old_nbytes
;
1960 old_data
->string
= NULL
;
1963 consing_since_gc
+= needed
;
1967 /* Sweep and compact strings. */
1969 NO_INLINE
/* For better stack traces */
1971 sweep_strings (void)
1973 struct string_block
*b
, *next
;
1974 struct string_block
*live_blocks
= NULL
;
1976 string_free_list
= NULL
;
1977 total_strings
= total_free_strings
= 0;
1978 total_string_bytes
= 0;
1980 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1981 for (b
= string_blocks
; b
; b
= next
)
1984 struct Lisp_String
*free_list_before
= string_free_list
;
1988 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1990 struct Lisp_String
*s
= b
->strings
+ i
;
1994 /* String was not on free-list before. */
1995 if (STRING_MARKED_P (s
))
1997 /* String is live; unmark it and its intervals. */
2000 /* Do not use string_(set|get)_intervals here. */
2001 s
->intervals
= balance_intervals (s
->intervals
);
2004 total_string_bytes
+= STRING_BYTES (s
);
2008 /* String is dead. Put it on the free-list. */
2009 sdata
*data
= SDATA_OF_STRING (s
);
2011 /* Save the size of S in its sdata so that we know
2012 how large that is. Reset the sdata's string
2013 back-pointer so that we know it's free. */
2014 #ifdef GC_CHECK_STRING_BYTES
2015 if (string_bytes (s
) != SDATA_NBYTES (data
))
2018 data
->n
.nbytes
= STRING_BYTES (s
);
2020 data
->string
= NULL
;
2022 /* Reset the strings's `data' member so that we
2026 /* Put the string on the free-list. */
2027 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2028 string_free_list
= s
;
2034 /* S was on the free-list before. Put it there again. */
2035 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2036 string_free_list
= s
;
2041 /* Free blocks that contain free Lisp_Strings only, except
2042 the first two of them. */
2043 if (nfree
== STRING_BLOCK_SIZE
2044 && total_free_strings
> STRING_BLOCK_SIZE
)
2047 string_free_list
= free_list_before
;
2051 total_free_strings
+= nfree
;
2052 b
->next
= live_blocks
;
2057 check_string_free_list ();
2059 string_blocks
= live_blocks
;
2060 free_large_strings ();
2061 compact_small_strings ();
2063 check_string_free_list ();
2067 /* Free dead large strings. */
2070 free_large_strings (void)
2072 struct sblock
*b
, *next
;
2073 struct sblock
*live_blocks
= NULL
;
2075 for (b
= large_sblocks
; b
; b
= next
)
2079 if (b
->data
[0].string
== NULL
)
2083 b
->next
= live_blocks
;
2088 large_sblocks
= live_blocks
;
2092 /* Compact data of small strings. Free sblocks that don't contain
2093 data of live strings after compaction. */
2096 compact_small_strings (void)
2098 struct sblock
*b
, *tb
, *next
;
2099 sdata
*from
, *to
, *end
, *tb_end
;
2100 sdata
*to_end
, *from_end
;
2102 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2103 to, and TB_END is the end of TB. */
2105 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2108 /* Step through the blocks from the oldest to the youngest. We
2109 expect that old blocks will stabilize over time, so that less
2110 copying will happen this way. */
2111 for (b
= oldest_sblock
; b
; b
= b
->next
)
2114 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2116 for (from
= b
->data
; from
< end
; from
= from_end
)
2118 /* Compute the next FROM here because copying below may
2119 overwrite data we need to compute it. */
2121 struct Lisp_String
*s
= from
->string
;
2123 #ifdef GC_CHECK_STRING_BYTES
2124 /* Check that the string size recorded in the string is the
2125 same as the one recorded in the sdata structure. */
2126 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2128 #endif /* GC_CHECK_STRING_BYTES */
2130 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2131 eassert (nbytes
<= LARGE_STRING_BYTES
);
2133 nbytes
= SDATA_SIZE (nbytes
);
2134 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2136 #ifdef GC_CHECK_STRING_OVERRUN
2137 if (memcmp (string_overrun_cookie
,
2138 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2139 GC_STRING_OVERRUN_COOKIE_SIZE
))
2143 /* Non-NULL S means it's alive. Copy its data. */
2146 /* If TB is full, proceed with the next sblock. */
2147 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2148 if (to_end
> tb_end
)
2152 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2154 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2157 /* Copy, and update the string's `data' pointer. */
2160 eassert (tb
!= b
|| to
< from
);
2161 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2162 to
->string
->data
= SDATA_DATA (to
);
2165 /* Advance past the sdata we copied to. */
2171 /* The rest of the sblocks following TB don't contain live data, so
2172 we can free them. */
2173 for (b
= tb
->next
; b
; b
= next
)
2181 current_sblock
= tb
;
2185 string_overflow (void)
2187 error ("Maximum string size exceeded");
2190 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2191 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2192 LENGTH must be an integer.
2193 INIT must be an integer that represents a character. */)
2194 (Lisp_Object length
, Lisp_Object init
)
2196 register Lisp_Object val
;
2200 CHECK_NATNUM (length
);
2201 CHECK_CHARACTER (init
);
2203 c
= XFASTINT (init
);
2204 if (ASCII_CHAR_P (c
))
2206 nbytes
= XINT (length
);
2207 val
= make_uninit_string (nbytes
);
2210 memset (SDATA (val
), c
, nbytes
);
2211 SDATA (val
)[nbytes
] = 0;
2216 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2217 ptrdiff_t len
= CHAR_STRING (c
, str
);
2218 EMACS_INT string_len
= XINT (length
);
2219 unsigned char *p
, *beg
, *end
;
2221 if (INT_MULTIPLY_WRAPV (len
, string_len
, &nbytes
))
2223 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2224 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2226 /* First time we just copy `str' to the data of `val'. */
2228 memcpy (p
, str
, len
);
2231 /* Next time we copy largest possible chunk from
2232 initialized to uninitialized part of `val'. */
2233 len
= min (p
- beg
, end
- p
);
2234 memcpy (p
, beg
, len
);
2244 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2248 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2250 EMACS_INT nbits
= bool_vector_size (a
);
2253 unsigned char *data
= bool_vector_uchar_data (a
);
2254 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2255 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2256 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2257 memset (data
, pattern
, nbytes
- 1);
2258 data
[nbytes
- 1] = pattern
& last_mask
;
2263 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2266 make_uninit_bool_vector (EMACS_INT nbits
)
2269 EMACS_INT words
= bool_vector_words (nbits
);
2270 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2271 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2274 struct Lisp_Bool_Vector
*p
2275 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2276 XSETVECTOR (val
, p
);
2277 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2280 /* Clear padding at the end. */
2282 p
->data
[words
- 1] = 0;
2287 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2288 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2289 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2290 (Lisp_Object length
, Lisp_Object init
)
2294 CHECK_NATNUM (length
);
2295 val
= make_uninit_bool_vector (XFASTINT (length
));
2296 return bool_vector_fill (val
, init
);
2299 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2300 doc
: /* Return a new bool-vector with specified arguments as elements.
2301 Any number of arguments, even zero arguments, are allowed.
2302 usage: (bool-vector &rest OBJECTS) */)
2303 (ptrdiff_t nargs
, Lisp_Object
*args
)
2308 vector
= make_uninit_bool_vector (nargs
);
2309 for (i
= 0; i
< nargs
; i
++)
2310 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2315 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2316 of characters from the contents. This string may be unibyte or
2317 multibyte, depending on the contents. */
2320 make_string (const char *contents
, ptrdiff_t nbytes
)
2322 register Lisp_Object val
;
2323 ptrdiff_t nchars
, multibyte_nbytes
;
2325 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2326 &nchars
, &multibyte_nbytes
);
2327 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2328 /* CONTENTS contains no multibyte sequences or contains an invalid
2329 multibyte sequence. We must make unibyte string. */
2330 val
= make_unibyte_string (contents
, nbytes
);
2332 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2336 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2339 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2341 register Lisp_Object val
;
2342 val
= make_uninit_string (length
);
2343 memcpy (SDATA (val
), contents
, length
);
2348 /* Make a multibyte string from NCHARS characters occupying NBYTES
2349 bytes at CONTENTS. */
2352 make_multibyte_string (const char *contents
,
2353 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2355 register Lisp_Object val
;
2356 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2357 memcpy (SDATA (val
), contents
, nbytes
);
2362 /* Make a string from NCHARS characters occupying NBYTES bytes at
2363 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2366 make_string_from_bytes (const char *contents
,
2367 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2369 register Lisp_Object val
;
2370 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2371 memcpy (SDATA (val
), contents
, nbytes
);
2372 if (SBYTES (val
) == SCHARS (val
))
2373 STRING_SET_UNIBYTE (val
);
2378 /* Make a string from NCHARS characters occupying NBYTES bytes at
2379 CONTENTS. The argument MULTIBYTE controls whether to label the
2380 string as multibyte. If NCHARS is negative, it counts the number of
2381 characters by itself. */
2384 make_specified_string (const char *contents
,
2385 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2392 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2397 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2398 memcpy (SDATA (val
), contents
, nbytes
);
2400 STRING_SET_UNIBYTE (val
);
2405 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2406 occupying LENGTH bytes. */
2409 make_uninit_string (EMACS_INT length
)
2414 return empty_unibyte_string
;
2415 val
= make_uninit_multibyte_string (length
, length
);
2416 STRING_SET_UNIBYTE (val
);
2421 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2422 which occupy NBYTES bytes. */
2425 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2428 struct Lisp_String
*s
;
2433 return empty_multibyte_string
;
2435 s
= allocate_string ();
2436 s
->intervals
= NULL
;
2437 allocate_string_data (s
, nchars
, nbytes
);
2438 XSETSTRING (string
, s
);
2439 string_chars_consed
+= nbytes
;
2443 /* Print arguments to BUF according to a FORMAT, then return
2444 a Lisp_String initialized with the data from BUF. */
2447 make_formatted_string (char *buf
, const char *format
, ...)
2452 va_start (ap
, format
);
2453 length
= vsprintf (buf
, format
, ap
);
2455 return make_string (buf
, length
);
2459 /***********************************************************************
2461 ***********************************************************************/
2463 /* We store float cells inside of float_blocks, allocating a new
2464 float_block with malloc whenever necessary. Float cells reclaimed
2465 by GC are put on a free list to be reallocated before allocating
2466 any new float cells from the latest float_block. */
2468 #define FLOAT_BLOCK_SIZE \
2469 (((BLOCK_BYTES - sizeof (struct float_block *) \
2470 /* The compiler might add padding at the end. */ \
2471 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2472 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2474 #define GETMARKBIT(block,n) \
2475 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2476 >> ((n) % BITS_PER_BITS_WORD)) \
2479 #define SETMARKBIT(block,n) \
2480 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2481 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2483 #define UNSETMARKBIT(block,n) \
2484 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2485 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2487 #define FLOAT_BLOCK(fptr) \
2488 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2490 #define FLOAT_INDEX(fptr) \
2491 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2495 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2496 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2497 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2498 struct float_block
*next
;
2501 #define FLOAT_MARKED_P(fptr) \
2502 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2504 #define FLOAT_MARK(fptr) \
2505 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2507 #define FLOAT_UNMARK(fptr) \
2508 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2510 /* Current float_block. */
2512 static struct float_block
*float_block
;
2514 /* Index of first unused Lisp_Float in the current float_block. */
2516 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2518 /* Free-list of Lisp_Floats. */
2520 static struct Lisp_Float
*float_free_list
;
2522 /* Return a new float object with value FLOAT_VALUE. */
2525 make_float (double float_value
)
2527 register Lisp_Object val
;
2531 if (float_free_list
)
2533 /* We use the data field for chaining the free list
2534 so that we won't use the same field that has the mark bit. */
2535 XSETFLOAT (val
, float_free_list
);
2536 float_free_list
= float_free_list
->u
.chain
;
2540 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2542 struct float_block
*new
2543 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2544 new->next
= float_block
;
2545 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2547 float_block_index
= 0;
2548 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2550 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2551 float_block_index
++;
2554 MALLOC_UNBLOCK_INPUT
;
2556 XFLOAT_INIT (val
, float_value
);
2557 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2558 consing_since_gc
+= sizeof (struct Lisp_Float
);
2560 total_free_floats
--;
2566 /***********************************************************************
2568 ***********************************************************************/
2570 /* We store cons cells inside of cons_blocks, allocating a new
2571 cons_block with malloc whenever necessary. Cons cells reclaimed by
2572 GC are put on a free list to be reallocated before allocating
2573 any new cons cells from the latest cons_block. */
2575 #define CONS_BLOCK_SIZE \
2576 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2577 /* The compiler might add padding at the end. */ \
2578 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2579 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2581 #define CONS_BLOCK(fptr) \
2582 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2584 #define CONS_INDEX(fptr) \
2585 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2589 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2590 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2591 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2592 struct cons_block
*next
;
2595 #define CONS_MARKED_P(fptr) \
2596 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2598 #define CONS_MARK(fptr) \
2599 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2601 #define CONS_UNMARK(fptr) \
2602 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2604 /* Current cons_block. */
2606 static struct cons_block
*cons_block
;
2608 /* Index of first unused Lisp_Cons in the current block. */
2610 static int cons_block_index
= CONS_BLOCK_SIZE
;
2612 /* Free-list of Lisp_Cons structures. */
2614 static struct Lisp_Cons
*cons_free_list
;
2616 /* Explicitly free a cons cell by putting it on the free-list. */
2619 free_cons (struct Lisp_Cons
*ptr
)
2621 ptr
->u
.chain
= cons_free_list
;
2623 cons_free_list
= ptr
;
2624 consing_since_gc
-= sizeof *ptr
;
2625 total_free_conses
++;
2628 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2629 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2630 (Lisp_Object car
, Lisp_Object cdr
)
2632 register Lisp_Object val
;
2638 /* We use the cdr for chaining the free list
2639 so that we won't use the same field that has the mark bit. */
2640 XSETCONS (val
, cons_free_list
);
2641 cons_free_list
= cons_free_list
->u
.chain
;
2645 if (cons_block_index
== CONS_BLOCK_SIZE
)
2647 struct cons_block
*new
2648 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2649 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2650 new->next
= cons_block
;
2652 cons_block_index
= 0;
2653 total_free_conses
+= CONS_BLOCK_SIZE
;
2655 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2659 MALLOC_UNBLOCK_INPUT
;
2663 eassert (!CONS_MARKED_P (XCONS (val
)));
2664 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2665 total_free_conses
--;
2666 cons_cells_consed
++;
2670 #ifdef GC_CHECK_CONS_LIST
2671 /* Get an error now if there's any junk in the cons free list. */
2673 check_cons_list (void)
2675 struct Lisp_Cons
*tail
= cons_free_list
;
2678 tail
= tail
->u
.chain
;
2682 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2685 list1 (Lisp_Object arg1
)
2687 return Fcons (arg1
, Qnil
);
2691 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2693 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2698 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2700 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2705 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2707 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2712 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2714 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2715 Fcons (arg5
, Qnil
)))));
2718 /* Make a list of COUNT Lisp_Objects, where ARG is the
2719 first one. Allocate conses from pure space if TYPE
2720 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2723 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2725 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2728 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2729 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2730 default: emacs_abort ();
2733 eassume (0 < count
);
2734 Lisp_Object val
= cons (arg
, Qnil
);
2735 Lisp_Object tail
= val
;
2739 for (ptrdiff_t i
= 1; i
< count
; i
++)
2741 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2742 XSETCDR (tail
, elem
);
2750 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2751 doc
: /* Return a newly created list with specified arguments as elements.
2752 Any number of arguments, even zero arguments, are allowed.
2753 usage: (list &rest OBJECTS) */)
2754 (ptrdiff_t nargs
, Lisp_Object
*args
)
2756 register Lisp_Object val
;
2762 val
= Fcons (args
[nargs
], val
);
2768 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2769 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2770 (register Lisp_Object length
, Lisp_Object init
)
2772 register Lisp_Object val
;
2773 register EMACS_INT size
;
2775 CHECK_NATNUM (length
);
2776 size
= XFASTINT (length
);
2781 val
= Fcons (init
, val
);
2786 val
= Fcons (init
, val
);
2791 val
= Fcons (init
, val
);
2796 val
= Fcons (init
, val
);
2801 val
= Fcons (init
, val
);
2816 /***********************************************************************
2818 ***********************************************************************/
2820 /* Sometimes a vector's contents are merely a pointer internally used
2821 in vector allocation code. On the rare platforms where a null
2822 pointer cannot be tagged, represent it with a Lisp 0.
2823 Usually you don't want to touch this. */
2825 static struct Lisp_Vector
*
2826 next_vector (struct Lisp_Vector
*v
)
2828 return XUNTAG (v
->contents
[0], Lisp_Int0
);
2832 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2834 v
->contents
[0] = make_lisp_ptr (p
, Lisp_Int0
);
2837 /* This value is balanced well enough to avoid too much internal overhead
2838 for the most common cases; it's not required to be a power of two, but
2839 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2841 #define VECTOR_BLOCK_SIZE 4096
2845 /* Alignment of struct Lisp_Vector objects. */
2846 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2849 /* Vector size requests are a multiple of this. */
2850 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2853 /* Verify assumptions described above. */
2854 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2855 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2857 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2858 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2859 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2860 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2862 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2864 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2866 /* Size of the minimal vector allocated from block. */
2868 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2870 /* Size of the largest vector allocated from block. */
2872 #define VBLOCK_BYTES_MAX \
2873 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2875 /* We maintain one free list for each possible block-allocated
2876 vector size, and this is the number of free lists we have. */
2878 #define VECTOR_MAX_FREE_LIST_INDEX \
2879 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2881 /* Common shortcut to advance vector pointer over a block data. */
2883 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2885 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2887 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2889 /* Common shortcut to setup vector on a free list. */
2891 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2893 (tmp) = ((nbytes - header_size) / word_size); \
2894 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2895 eassert ((nbytes) % roundup_size == 0); \
2896 (tmp) = VINDEX (nbytes); \
2897 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2898 set_next_vector (v, vector_free_lists[tmp]); \
2899 vector_free_lists[tmp] = (v); \
2900 total_free_vector_slots += (nbytes) / word_size; \
2903 /* This internal type is used to maintain the list of large vectors
2904 which are allocated at their own, e.g. outside of vector blocks.
2906 struct large_vector itself cannot contain a struct Lisp_Vector, as
2907 the latter contains a flexible array member and C99 does not allow
2908 such structs to be nested. Instead, each struct large_vector
2909 object LV is followed by a struct Lisp_Vector, which is at offset
2910 large_vector_offset from LV, and whose address is therefore
2911 large_vector_vec (&LV). */
2915 struct large_vector
*next
;
2920 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2923 static struct Lisp_Vector
*
2924 large_vector_vec (struct large_vector
*p
)
2926 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
2929 /* This internal type is used to maintain an underlying storage
2930 for small vectors. */
2934 char data
[VECTOR_BLOCK_BYTES
];
2935 struct vector_block
*next
;
2938 /* Chain of vector blocks. */
2940 static struct vector_block
*vector_blocks
;
2942 /* Vector free lists, where NTH item points to a chain of free
2943 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2945 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2947 /* Singly-linked list of large vectors. */
2949 static struct large_vector
*large_vectors
;
2951 /* The only vector with 0 slots, allocated from pure space. */
2953 Lisp_Object zero_vector
;
2955 /* Number of live vectors. */
2957 static EMACS_INT total_vectors
;
2959 /* Total size of live and free vectors, in Lisp_Object units. */
2961 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2963 /* Get a new vector block. */
2965 static struct vector_block
*
2966 allocate_vector_block (void)
2968 struct vector_block
*block
= xmalloc (sizeof *block
);
2970 #ifndef GC_MALLOC_CHECK
2971 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2972 MEM_TYPE_VECTOR_BLOCK
);
2975 block
->next
= vector_blocks
;
2976 vector_blocks
= block
;
2980 /* Called once to initialize vector allocation. */
2985 zero_vector
= make_pure_vector (0);
2988 /* Allocate vector from a vector block. */
2990 static struct Lisp_Vector
*
2991 allocate_vector_from_block (size_t nbytes
)
2993 struct Lisp_Vector
*vector
;
2994 struct vector_block
*block
;
2995 size_t index
, restbytes
;
2997 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2998 eassert (nbytes
% roundup_size
== 0);
3000 /* First, try to allocate from a free list
3001 containing vectors of the requested size. */
3002 index
= VINDEX (nbytes
);
3003 if (vector_free_lists
[index
])
3005 vector
= vector_free_lists
[index
];
3006 vector_free_lists
[index
] = next_vector (vector
);
3007 total_free_vector_slots
-= nbytes
/ word_size
;
3011 /* Next, check free lists containing larger vectors. Since
3012 we will split the result, we should have remaining space
3013 large enough to use for one-slot vector at least. */
3014 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3015 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3016 if (vector_free_lists
[index
])
3018 /* This vector is larger than requested. */
3019 vector
= vector_free_lists
[index
];
3020 vector_free_lists
[index
] = next_vector (vector
);
3021 total_free_vector_slots
-= nbytes
/ word_size
;
3023 /* Excess bytes are used for the smaller vector,
3024 which should be set on an appropriate free list. */
3025 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3026 eassert (restbytes
% roundup_size
== 0);
3027 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3031 /* Finally, need a new vector block. */
3032 block
= allocate_vector_block ();
3034 /* New vector will be at the beginning of this block. */
3035 vector
= (struct Lisp_Vector
*) block
->data
;
3037 /* If the rest of space from this block is large enough
3038 for one-slot vector at least, set up it on a free list. */
3039 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3040 if (restbytes
>= VBLOCK_BYTES_MIN
)
3042 eassert (restbytes
% roundup_size
== 0);
3043 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3048 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3050 #define VECTOR_IN_BLOCK(vector, block) \
3051 ((char *) (vector) <= (block)->data \
3052 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3054 /* Return the memory footprint of V in bytes. */
3057 vector_nbytes (struct Lisp_Vector
*v
)
3059 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
3062 if (size
& PSEUDOVECTOR_FLAG
)
3064 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
3066 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
3067 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
3068 * sizeof (bits_word
));
3069 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
3070 verify (header_size
<= bool_header_size
);
3071 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
3074 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
3075 + ((size
& PSEUDOVECTOR_REST_MASK
)
3076 >> PSEUDOVECTOR_SIZE_BITS
));
3080 return vroundup (header_size
+ word_size
* nwords
);
3083 /* Release extra resources still in use by VECTOR, which may be any
3084 vector-like object. For now, this is used just to free data in
3088 cleanup_vector (struct Lisp_Vector
*vector
)
3090 detect_suspicious_free (vector
);
3091 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
3092 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
3093 == FONT_OBJECT_MAX
))
3095 struct font_driver
*drv
= ((struct font
*) vector
)->driver
;
3097 /* The font driver might sometimes be NULL, e.g. if Emacs was
3098 interrupted before it had time to set it up. */
3101 /* Attempt to catch subtle bugs like Bug#16140. */
3102 eassert (valid_font_driver (drv
));
3103 drv
->close ((struct font
*) vector
);
3108 /* Reclaim space used by unmarked vectors. */
3110 NO_INLINE
/* For better stack traces */
3112 sweep_vectors (void)
3114 struct vector_block
*block
, **bprev
= &vector_blocks
;
3115 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3116 struct Lisp_Vector
*vector
, *next
;
3118 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3119 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3121 /* Looking through vector blocks. */
3123 for (block
= vector_blocks
; block
; block
= *bprev
)
3125 bool free_this_block
= 0;
3128 for (vector
= (struct Lisp_Vector
*) block
->data
;
3129 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3131 if (VECTOR_MARKED_P (vector
))
3133 VECTOR_UNMARK (vector
);
3135 nbytes
= vector_nbytes (vector
);
3136 total_vector_slots
+= nbytes
/ word_size
;
3137 next
= ADVANCE (vector
, nbytes
);
3141 ptrdiff_t total_bytes
;
3143 cleanup_vector (vector
);
3144 nbytes
= vector_nbytes (vector
);
3145 total_bytes
= nbytes
;
3146 next
= ADVANCE (vector
, nbytes
);
3148 /* While NEXT is not marked, try to coalesce with VECTOR,
3149 thus making VECTOR of the largest possible size. */
3151 while (VECTOR_IN_BLOCK (next
, block
))
3153 if (VECTOR_MARKED_P (next
))
3155 cleanup_vector (next
);
3156 nbytes
= vector_nbytes (next
);
3157 total_bytes
+= nbytes
;
3158 next
= ADVANCE (next
, nbytes
);
3161 eassert (total_bytes
% roundup_size
== 0);
3163 if (vector
== (struct Lisp_Vector
*) block
->data
3164 && !VECTOR_IN_BLOCK (next
, block
))
3165 /* This block should be freed because all of its
3166 space was coalesced into the only free vector. */
3167 free_this_block
= 1;
3171 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3176 if (free_this_block
)
3178 *bprev
= block
->next
;
3179 #ifndef GC_MALLOC_CHECK
3180 mem_delete (mem_find (block
->data
));
3185 bprev
= &block
->next
;
3188 /* Sweep large vectors. */
3190 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3192 vector
= large_vector_vec (lv
);
3193 if (VECTOR_MARKED_P (vector
))
3195 VECTOR_UNMARK (vector
);
3197 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3199 /* All non-bool pseudovectors are small enough to be allocated
3200 from vector blocks. This code should be redesigned if some
3201 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3202 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3203 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3207 += header_size
/ word_size
+ vector
->header
.size
;
3218 /* Value is a pointer to a newly allocated Lisp_Vector structure
3219 with room for LEN Lisp_Objects. */
3221 static struct Lisp_Vector
*
3222 allocate_vectorlike (ptrdiff_t len
)
3224 struct Lisp_Vector
*p
;
3229 p
= XVECTOR (zero_vector
);
3232 size_t nbytes
= header_size
+ len
* word_size
;
3234 #ifdef DOUG_LEA_MALLOC
3235 if (!mmap_lisp_allowed_p ())
3236 mallopt (M_MMAP_MAX
, 0);
3239 if (nbytes
<= VBLOCK_BYTES_MAX
)
3240 p
= allocate_vector_from_block (vroundup (nbytes
));
3243 struct large_vector
*lv
3244 = lisp_malloc ((large_vector_offset
+ header_size
3246 MEM_TYPE_VECTORLIKE
);
3247 lv
->next
= large_vectors
;
3249 p
= large_vector_vec (lv
);
3252 #ifdef DOUG_LEA_MALLOC
3253 if (!mmap_lisp_allowed_p ())
3254 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3257 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3260 consing_since_gc
+= nbytes
;
3261 vector_cells_consed
+= len
;
3264 MALLOC_UNBLOCK_INPUT
;
3270 /* Allocate a vector with LEN slots. */
3272 struct Lisp_Vector
*
3273 allocate_vector (EMACS_INT len
)
3275 struct Lisp_Vector
*v
;
3276 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3278 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3279 memory_full (SIZE_MAX
);
3280 v
= allocate_vectorlike (len
);
3282 v
->header
.size
= len
;
3287 /* Allocate other vector-like structures. */
3289 struct Lisp_Vector
*
3290 allocate_pseudovector (int memlen
, int lisplen
,
3291 int zerolen
, enum pvec_type tag
)
3293 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3295 /* Catch bogus values. */
3296 eassert (0 <= tag
&& tag
<= PVEC_FONT
);
3297 eassert (0 <= lisplen
&& lisplen
<= zerolen
&& zerolen
<= memlen
);
3298 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3299 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3301 /* Only the first LISPLEN slots will be traced normally by the GC. */
3302 memclear (v
->contents
, zerolen
* word_size
);
3303 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3308 allocate_buffer (void)
3310 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3312 BUFFER_PVEC_INIT (b
);
3313 /* Put B on the chain of all buffers including killed ones. */
3314 b
->next
= all_buffers
;
3316 /* Note that the rest fields of B are not initialized. */
3320 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3321 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3322 See also the function `vector'. */)
3323 (register Lisp_Object length
, Lisp_Object init
)
3326 register ptrdiff_t sizei
;
3327 register ptrdiff_t i
;
3328 register struct Lisp_Vector
*p
;
3330 CHECK_NATNUM (length
);
3332 p
= allocate_vector (XFASTINT (length
));
3333 sizei
= XFASTINT (length
);
3334 for (i
= 0; i
< sizei
; i
++)
3335 p
->contents
[i
] = init
;
3337 XSETVECTOR (vector
, p
);
3341 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3342 doc
: /* Return a newly created vector with specified arguments as elements.
3343 Any number of arguments, even zero arguments, are allowed.
3344 usage: (vector &rest OBJECTS) */)
3345 (ptrdiff_t nargs
, Lisp_Object
*args
)
3348 register Lisp_Object val
= make_uninit_vector (nargs
);
3349 register struct Lisp_Vector
*p
= XVECTOR (val
);
3351 for (i
= 0; i
< nargs
; i
++)
3352 p
->contents
[i
] = args
[i
];
3357 make_byte_code (struct Lisp_Vector
*v
)
3359 /* Don't allow the global zero_vector to become a byte code object. */
3360 eassert (0 < v
->header
.size
);
3362 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3363 && STRING_MULTIBYTE (v
->contents
[1]))
3364 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3365 earlier because they produced a raw 8-bit string for byte-code
3366 and now such a byte-code string is loaded as multibyte while
3367 raw 8-bit characters converted to multibyte form. Thus, now we
3368 must convert them back to the original unibyte form. */
3369 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3370 XSETPVECTYPE (v
, PVEC_COMPILED
);
3373 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3374 doc
: /* Create a byte-code object with specified arguments as elements.
3375 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3376 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3377 and (optional) INTERACTIVE-SPEC.
3378 The first four arguments are required; at most six have any
3380 The ARGLIST can be either like the one of `lambda', in which case the arguments
3381 will be dynamically bound before executing the byte code, or it can be an
3382 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3383 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3384 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3385 argument to catch the left-over arguments. If such an integer is used, the
3386 arguments will not be dynamically bound but will be instead pushed on the
3387 stack before executing the byte-code.
3388 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3389 (ptrdiff_t nargs
, Lisp_Object
*args
)
3392 register Lisp_Object val
= make_uninit_vector (nargs
);
3393 register struct Lisp_Vector
*p
= XVECTOR (val
);
3395 /* We used to purecopy everything here, if purify-flag was set. This worked
3396 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3397 dangerous, since make-byte-code is used during execution to build
3398 closures, so any closure built during the preload phase would end up
3399 copied into pure space, including its free variables, which is sometimes
3400 just wasteful and other times plainly wrong (e.g. those free vars may want
3403 for (i
= 0; i
< nargs
; i
++)
3404 p
->contents
[i
] = args
[i
];
3406 XSETCOMPILED (val
, p
);
3412 /***********************************************************************
3414 ***********************************************************************/
3416 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3417 of the required alignment. */
3419 union aligned_Lisp_Symbol
3421 struct Lisp_Symbol s
;
3422 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3426 /* Each symbol_block is just under 1020 bytes long, since malloc
3427 really allocates in units of powers of two and uses 4 bytes for its
3430 #define SYMBOL_BLOCK_SIZE \
3431 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3435 /* Place `symbols' first, to preserve alignment. */
3436 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3437 struct symbol_block
*next
;
3440 /* Current symbol block and index of first unused Lisp_Symbol
3443 static struct symbol_block
*symbol_block
;
3444 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3445 /* Pointer to the first symbol_block that contains pinned symbols.
3446 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3447 10K of which are pinned (and all but 250 of them are interned in obarray),
3448 whereas a "typical session" has in the order of 30K symbols.
3449 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3450 than 30K to find the 10K symbols we need to mark. */
3451 static struct symbol_block
*symbol_block_pinned
;
3453 /* List of free symbols. */
3455 static struct Lisp_Symbol
*symbol_free_list
;
3458 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3460 XSYMBOL (sym
)->name
= name
;
3464 init_symbol (Lisp_Object val
, Lisp_Object name
)
3466 struct Lisp_Symbol
*p
= XSYMBOL (val
);
3467 set_symbol_name (val
, name
);
3468 set_symbol_plist (val
, Qnil
);
3469 p
->redirect
= SYMBOL_PLAINVAL
;
3470 SET_SYMBOL_VAL (p
, Qunbound
);
3471 set_symbol_function (val
, Qnil
);
3472 set_symbol_next (val
, NULL
);
3473 p
->gcmarkbit
= false;
3474 p
->interned
= SYMBOL_UNINTERNED
;
3476 p
->declared_special
= false;
3480 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3481 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3482 Its value is void, and its function definition and property list are nil. */)
3487 CHECK_STRING (name
);
3491 if (symbol_free_list
)
3493 XSETSYMBOL (val
, symbol_free_list
);
3494 symbol_free_list
= symbol_free_list
->next
;
3498 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3500 struct symbol_block
*new
3501 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3502 new->next
= symbol_block
;
3504 symbol_block_index
= 0;
3505 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3507 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3508 symbol_block_index
++;
3511 MALLOC_UNBLOCK_INPUT
;
3513 init_symbol (val
, name
);
3514 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3516 total_free_symbols
--;
3522 /***********************************************************************
3523 Marker (Misc) Allocation
3524 ***********************************************************************/
3526 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3527 the required alignment. */
3529 union aligned_Lisp_Misc
3532 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3536 /* Allocation of markers and other objects that share that structure.
3537 Works like allocation of conses. */
3539 #define MARKER_BLOCK_SIZE \
3540 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3544 /* Place `markers' first, to preserve alignment. */
3545 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3546 struct marker_block
*next
;
3549 static struct marker_block
*marker_block
;
3550 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3552 static union Lisp_Misc
*marker_free_list
;
3554 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3557 allocate_misc (enum Lisp_Misc_Type type
)
3563 if (marker_free_list
)
3565 XSETMISC (val
, marker_free_list
);
3566 marker_free_list
= marker_free_list
->u_free
.chain
;
3570 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3572 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3573 new->next
= marker_block
;
3575 marker_block_index
= 0;
3576 total_free_markers
+= MARKER_BLOCK_SIZE
;
3578 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3579 marker_block_index
++;
3582 MALLOC_UNBLOCK_INPUT
;
3584 --total_free_markers
;
3585 consing_since_gc
+= sizeof (union Lisp_Misc
);
3586 misc_objects_consed
++;
3587 XMISCANY (val
)->type
= type
;
3588 XMISCANY (val
)->gcmarkbit
= 0;
3592 /* Free a Lisp_Misc object. */
3595 free_misc (Lisp_Object misc
)
3597 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3598 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3599 marker_free_list
= XMISC (misc
);
3600 consing_since_gc
-= sizeof (union Lisp_Misc
);
3601 total_free_markers
++;
3604 /* Verify properties of Lisp_Save_Value's representation
3605 that are assumed here and elsewhere. */
3607 verify (SAVE_UNUSED
== 0);
3608 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3612 /* Return Lisp_Save_Value objects for the various combinations
3613 that callers need. */
3616 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3618 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3619 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3620 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3621 p
->data
[0].integer
= a
;
3622 p
->data
[1].integer
= b
;
3623 p
->data
[2].integer
= c
;
3628 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3631 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3632 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3633 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3634 p
->data
[0].object
= a
;
3635 p
->data
[1].object
= b
;
3636 p
->data
[2].object
= c
;
3637 p
->data
[3].object
= d
;
3642 make_save_ptr (void *a
)
3644 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3645 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3646 p
->save_type
= SAVE_POINTER
;
3647 p
->data
[0].pointer
= a
;
3652 make_save_ptr_int (void *a
, ptrdiff_t b
)
3654 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3655 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3656 p
->save_type
= SAVE_TYPE_PTR_INT
;
3657 p
->data
[0].pointer
= a
;
3658 p
->data
[1].integer
= b
;
3662 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3664 make_save_ptr_ptr (void *a
, void *b
)
3666 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3667 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3668 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3669 p
->data
[0].pointer
= a
;
3670 p
->data
[1].pointer
= b
;
3676 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3678 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3679 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3680 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3681 p
->data
[0].funcpointer
= a
;
3682 p
->data
[1].pointer
= b
;
3683 p
->data
[2].object
= c
;
3687 /* Return a Lisp_Save_Value object that represents an array A
3688 of N Lisp objects. */
3691 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3693 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3694 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3695 p
->save_type
= SAVE_TYPE_MEMORY
;
3696 p
->data
[0].pointer
= a
;
3697 p
->data
[1].integer
= n
;
3701 /* Free a Lisp_Save_Value object. Do not use this function
3702 if SAVE contains pointer other than returned by xmalloc. */
3705 free_save_value (Lisp_Object save
)
3707 xfree (XSAVE_POINTER (save
, 0));
3711 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3714 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3716 register Lisp_Object overlay
;
3718 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3719 OVERLAY_START (overlay
) = start
;
3720 OVERLAY_END (overlay
) = end
;
3721 set_overlay_plist (overlay
, plist
);
3722 XOVERLAY (overlay
)->next
= NULL
;
3726 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3727 doc
: /* Return a newly allocated marker which does not point at any place. */)
3730 register Lisp_Object val
;
3731 register struct Lisp_Marker
*p
;
3733 val
= allocate_misc (Lisp_Misc_Marker
);
3739 p
->insertion_type
= 0;
3740 p
->need_adjustment
= 0;
3744 /* Return a newly allocated marker which points into BUF
3745 at character position CHARPOS and byte position BYTEPOS. */
3748 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3751 struct Lisp_Marker
*m
;
3753 /* No dead buffers here. */
3754 eassert (BUFFER_LIVE_P (buf
));
3756 /* Every character is at least one byte. */
3757 eassert (charpos
<= bytepos
);
3759 obj
= allocate_misc (Lisp_Misc_Marker
);
3762 m
->charpos
= charpos
;
3763 m
->bytepos
= bytepos
;
3764 m
->insertion_type
= 0;
3765 m
->need_adjustment
= 0;
3766 m
->next
= BUF_MARKERS (buf
);
3767 BUF_MARKERS (buf
) = m
;
3771 /* Put MARKER back on the free list after using it temporarily. */
3774 free_marker (Lisp_Object marker
)
3776 unchain_marker (XMARKER (marker
));
3781 /* Return a newly created vector or string with specified arguments as
3782 elements. If all the arguments are characters that can fit
3783 in a string of events, make a string; otherwise, make a vector.
3785 Any number of arguments, even zero arguments, are allowed. */
3788 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3792 for (i
= 0; i
< nargs
; i
++)
3793 /* The things that fit in a string
3794 are characters that are in 0...127,
3795 after discarding the meta bit and all the bits above it. */
3796 if (!INTEGERP (args
[i
])
3797 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3798 return Fvector (nargs
, args
);
3800 /* Since the loop exited, we know that all the things in it are
3801 characters, so we can make a string. */
3805 result
= Fmake_string (make_number (nargs
), make_number (0));
3806 for (i
= 0; i
< nargs
; i
++)
3808 SSET (result
, i
, XINT (args
[i
]));
3809 /* Move the meta bit to the right place for a string char. */
3810 if (XINT (args
[i
]) & CHAR_META
)
3811 SSET (result
, i
, SREF (result
, i
) | 0x80);
3819 /* Create a new module user ptr object. */
3821 make_user_ptr (void (*finalizer
) (void *), void *p
)
3824 struct Lisp_User_Ptr
*uptr
;
3826 obj
= allocate_misc (Lisp_Misc_User_Ptr
);
3827 uptr
= XUSER_PTR (obj
);
3828 uptr
->finalizer
= finalizer
;
3836 init_finalizer_list (struct Lisp_Finalizer
*head
)
3838 head
->prev
= head
->next
= head
;
3841 /* Insert FINALIZER before ELEMENT. */
3844 finalizer_insert (struct Lisp_Finalizer
*element
,
3845 struct Lisp_Finalizer
*finalizer
)
3847 eassert (finalizer
->prev
== NULL
);
3848 eassert (finalizer
->next
== NULL
);
3849 finalizer
->next
= element
;
3850 finalizer
->prev
= element
->prev
;
3851 finalizer
->prev
->next
= finalizer
;
3852 element
->prev
= finalizer
;
3856 unchain_finalizer (struct Lisp_Finalizer
*finalizer
)
3858 if (finalizer
->prev
!= NULL
)
3860 eassert (finalizer
->next
!= NULL
);
3861 finalizer
->prev
->next
= finalizer
->next
;
3862 finalizer
->next
->prev
= finalizer
->prev
;
3863 finalizer
->prev
= finalizer
->next
= NULL
;
3868 mark_finalizer_list (struct Lisp_Finalizer
*head
)
3870 for (struct Lisp_Finalizer
*finalizer
= head
->next
;
3872 finalizer
= finalizer
->next
)
3874 finalizer
->base
.gcmarkbit
= true;
3875 mark_object (finalizer
->function
);
3879 /* Move doomed finalizers to list DEST from list SRC. A doomed
3880 finalizer is one that is not GC-reachable and whose
3881 finalizer->function is non-nil. */
3884 queue_doomed_finalizers (struct Lisp_Finalizer
*dest
,
3885 struct Lisp_Finalizer
*src
)
3887 struct Lisp_Finalizer
*finalizer
= src
->next
;
3888 while (finalizer
!= src
)
3890 struct Lisp_Finalizer
*next
= finalizer
->next
;
3891 if (!finalizer
->base
.gcmarkbit
&& !NILP (finalizer
->function
))
3893 unchain_finalizer (finalizer
);
3894 finalizer_insert (dest
, finalizer
);
3902 run_finalizer_handler (Lisp_Object args
)
3904 add_to_log ("finalizer failed: %S", args
);
3909 run_finalizer_function (Lisp_Object function
)
3911 ptrdiff_t count
= SPECPDL_INDEX ();
3913 specbind (Qinhibit_quit
, Qt
);
3914 internal_condition_case_1 (call0
, function
, Qt
, run_finalizer_handler
);
3915 unbind_to (count
, Qnil
);
3919 run_finalizers (struct Lisp_Finalizer
*finalizers
)
3921 struct Lisp_Finalizer
*finalizer
;
3922 Lisp_Object function
;
3924 while (finalizers
->next
!= finalizers
)
3926 finalizer
= finalizers
->next
;
3927 eassert (finalizer
->base
.type
== Lisp_Misc_Finalizer
);
3928 unchain_finalizer (finalizer
);
3929 function
= finalizer
->function
;
3930 if (!NILP (function
))
3932 finalizer
->function
= Qnil
;
3933 run_finalizer_function (function
);
3938 DEFUN ("make-finalizer", Fmake_finalizer
, Smake_finalizer
, 1, 1, 0,
3939 doc
: /* Make a finalizer that will run FUNCTION.
3940 FUNCTION will be called after garbage collection when the returned
3941 finalizer object becomes unreachable. If the finalizer object is
3942 reachable only through references from finalizer objects, it does not
3943 count as reachable for the purpose of deciding whether to run
3944 FUNCTION. FUNCTION will be run once per finalizer object. */)
3945 (Lisp_Object function
)
3947 Lisp_Object val
= allocate_misc (Lisp_Misc_Finalizer
);
3948 struct Lisp_Finalizer
*finalizer
= XFINALIZER (val
);
3949 finalizer
->function
= function
;
3950 finalizer
->prev
= finalizer
->next
= NULL
;
3951 finalizer_insert (&finalizers
, finalizer
);
3956 /************************************************************************
3957 Memory Full Handling
3958 ************************************************************************/
3961 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3962 there may have been size_t overflow so that malloc was never
3963 called, or perhaps malloc was invoked successfully but the
3964 resulting pointer had problems fitting into a tagged EMACS_INT. In
3965 either case this counts as memory being full even though malloc did
3969 memory_full (size_t nbytes
)
3971 /* Do not go into hysterics merely because a large request failed. */
3972 bool enough_free_memory
= 0;
3973 if (SPARE_MEMORY
< nbytes
)
3978 p
= malloc (SPARE_MEMORY
);
3982 enough_free_memory
= 1;
3984 MALLOC_UNBLOCK_INPUT
;
3987 if (! enough_free_memory
)
3993 memory_full_cons_threshold
= sizeof (struct cons_block
);
3995 /* The first time we get here, free the spare memory. */
3996 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
3997 if (spare_memory
[i
])
4000 free (spare_memory
[i
]);
4001 else if (i
>= 1 && i
<= 4)
4002 lisp_align_free (spare_memory
[i
]);
4004 lisp_free (spare_memory
[i
]);
4005 spare_memory
[i
] = 0;
4009 /* This used to call error, but if we've run out of memory, we could
4010 get infinite recursion trying to build the string. */
4011 xsignal (Qnil
, Vmemory_signal_data
);
4014 /* If we released our reserve (due to running out of memory),
4015 and we have a fair amount free once again,
4016 try to set aside another reserve in case we run out once more.
4018 This is called when a relocatable block is freed in ralloc.c,
4019 and also directly from this file, in case we're not using ralloc.c. */
4022 refill_memory_reserve (void)
4024 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4025 if (spare_memory
[0] == 0)
4026 spare_memory
[0] = malloc (SPARE_MEMORY
);
4027 if (spare_memory
[1] == 0)
4028 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
4030 if (spare_memory
[2] == 0)
4031 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
4033 if (spare_memory
[3] == 0)
4034 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
4036 if (spare_memory
[4] == 0)
4037 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
4039 if (spare_memory
[5] == 0)
4040 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
4042 if (spare_memory
[6] == 0)
4043 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
4045 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
4046 Vmemory_full
= Qnil
;
4050 /************************************************************************
4052 ************************************************************************/
4054 /* Conservative C stack marking requires a method to identify possibly
4055 live Lisp objects given a pointer value. We do this by keeping
4056 track of blocks of Lisp data that are allocated in a red-black tree
4057 (see also the comment of mem_node which is the type of nodes in
4058 that tree). Function lisp_malloc adds information for an allocated
4059 block to the red-black tree with calls to mem_insert, and function
4060 lisp_free removes it with mem_delete. Functions live_string_p etc
4061 call mem_find to lookup information about a given pointer in the
4062 tree, and use that to determine if the pointer points to a Lisp
4065 /* Initialize this part of alloc.c. */
4070 mem_z
.left
= mem_z
.right
= MEM_NIL
;
4071 mem_z
.parent
= NULL
;
4072 mem_z
.color
= MEM_BLACK
;
4073 mem_z
.start
= mem_z
.end
= NULL
;
4078 /* Value is a pointer to the mem_node containing START. Value is
4079 MEM_NIL if there is no node in the tree containing START. */
4081 static struct mem_node
*
4082 mem_find (void *start
)
4086 if (start
< min_heap_address
|| start
> max_heap_address
)
4089 /* Make the search always successful to speed up the loop below. */
4090 mem_z
.start
= start
;
4091 mem_z
.end
= (char *) start
+ 1;
4094 while (start
< p
->start
|| start
>= p
->end
)
4095 p
= start
< p
->start
? p
->left
: p
->right
;
4100 /* Insert a new node into the tree for a block of memory with start
4101 address START, end address END, and type TYPE. Value is a
4102 pointer to the node that was inserted. */
4104 static struct mem_node
*
4105 mem_insert (void *start
, void *end
, enum mem_type type
)
4107 struct mem_node
*c
, *parent
, *x
;
4109 if (min_heap_address
== NULL
|| start
< min_heap_address
)
4110 min_heap_address
= start
;
4111 if (max_heap_address
== NULL
|| end
> max_heap_address
)
4112 max_heap_address
= end
;
4114 /* See where in the tree a node for START belongs. In this
4115 particular application, it shouldn't happen that a node is already
4116 present. For debugging purposes, let's check that. */
4120 while (c
!= MEM_NIL
)
4123 c
= start
< c
->start
? c
->left
: c
->right
;
4126 /* Create a new node. */
4127 #ifdef GC_MALLOC_CHECK
4128 x
= malloc (sizeof *x
);
4132 x
= xmalloc (sizeof *x
);
4138 x
->left
= x
->right
= MEM_NIL
;
4141 /* Insert it as child of PARENT or install it as root. */
4144 if (start
< parent
->start
)
4152 /* Re-establish red-black tree properties. */
4153 mem_insert_fixup (x
);
4159 /* Re-establish the red-black properties of the tree, and thereby
4160 balance the tree, after node X has been inserted; X is always red. */
4163 mem_insert_fixup (struct mem_node
*x
)
4165 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4167 /* X is red and its parent is red. This is a violation of
4168 red-black tree property #3. */
4170 if (x
->parent
== x
->parent
->parent
->left
)
4172 /* We're on the left side of our grandparent, and Y is our
4174 struct mem_node
*y
= x
->parent
->parent
->right
;
4176 if (y
->color
== MEM_RED
)
4178 /* Uncle and parent are red but should be black because
4179 X is red. Change the colors accordingly and proceed
4180 with the grandparent. */
4181 x
->parent
->color
= MEM_BLACK
;
4182 y
->color
= MEM_BLACK
;
4183 x
->parent
->parent
->color
= MEM_RED
;
4184 x
= x
->parent
->parent
;
4188 /* Parent and uncle have different colors; parent is
4189 red, uncle is black. */
4190 if (x
== x
->parent
->right
)
4193 mem_rotate_left (x
);
4196 x
->parent
->color
= MEM_BLACK
;
4197 x
->parent
->parent
->color
= MEM_RED
;
4198 mem_rotate_right (x
->parent
->parent
);
4203 /* This is the symmetrical case of above. */
4204 struct mem_node
*y
= x
->parent
->parent
->left
;
4206 if (y
->color
== MEM_RED
)
4208 x
->parent
->color
= MEM_BLACK
;
4209 y
->color
= MEM_BLACK
;
4210 x
->parent
->parent
->color
= MEM_RED
;
4211 x
= x
->parent
->parent
;
4215 if (x
== x
->parent
->left
)
4218 mem_rotate_right (x
);
4221 x
->parent
->color
= MEM_BLACK
;
4222 x
->parent
->parent
->color
= MEM_RED
;
4223 mem_rotate_left (x
->parent
->parent
);
4228 /* The root may have been changed to red due to the algorithm. Set
4229 it to black so that property #5 is satisfied. */
4230 mem_root
->color
= MEM_BLACK
;
4241 mem_rotate_left (struct mem_node
*x
)
4245 /* Turn y's left sub-tree into x's right sub-tree. */
4248 if (y
->left
!= MEM_NIL
)
4249 y
->left
->parent
= x
;
4251 /* Y's parent was x's parent. */
4253 y
->parent
= x
->parent
;
4255 /* Get the parent to point to y instead of x. */
4258 if (x
== x
->parent
->left
)
4259 x
->parent
->left
= y
;
4261 x
->parent
->right
= y
;
4266 /* Put x on y's left. */
4280 mem_rotate_right (struct mem_node
*x
)
4282 struct mem_node
*y
= x
->left
;
4285 if (y
->right
!= MEM_NIL
)
4286 y
->right
->parent
= x
;
4289 y
->parent
= x
->parent
;
4292 if (x
== x
->parent
->right
)
4293 x
->parent
->right
= y
;
4295 x
->parent
->left
= y
;
4306 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4309 mem_delete (struct mem_node
*z
)
4311 struct mem_node
*x
, *y
;
4313 if (!z
|| z
== MEM_NIL
)
4316 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4321 while (y
->left
!= MEM_NIL
)
4325 if (y
->left
!= MEM_NIL
)
4330 x
->parent
= y
->parent
;
4333 if (y
== y
->parent
->left
)
4334 y
->parent
->left
= x
;
4336 y
->parent
->right
= x
;
4343 z
->start
= y
->start
;
4348 if (y
->color
== MEM_BLACK
)
4349 mem_delete_fixup (x
);
4351 #ifdef GC_MALLOC_CHECK
4359 /* Re-establish the red-black properties of the tree, after a
4363 mem_delete_fixup (struct mem_node
*x
)
4365 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4367 if (x
== x
->parent
->left
)
4369 struct mem_node
*w
= x
->parent
->right
;
4371 if (w
->color
== MEM_RED
)
4373 w
->color
= MEM_BLACK
;
4374 x
->parent
->color
= MEM_RED
;
4375 mem_rotate_left (x
->parent
);
4376 w
= x
->parent
->right
;
4379 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4386 if (w
->right
->color
== MEM_BLACK
)
4388 w
->left
->color
= MEM_BLACK
;
4390 mem_rotate_right (w
);
4391 w
= x
->parent
->right
;
4393 w
->color
= x
->parent
->color
;
4394 x
->parent
->color
= MEM_BLACK
;
4395 w
->right
->color
= MEM_BLACK
;
4396 mem_rotate_left (x
->parent
);
4402 struct mem_node
*w
= x
->parent
->left
;
4404 if (w
->color
== MEM_RED
)
4406 w
->color
= MEM_BLACK
;
4407 x
->parent
->color
= MEM_RED
;
4408 mem_rotate_right (x
->parent
);
4409 w
= x
->parent
->left
;
4412 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4419 if (w
->left
->color
== MEM_BLACK
)
4421 w
->right
->color
= MEM_BLACK
;
4423 mem_rotate_left (w
);
4424 w
= x
->parent
->left
;
4427 w
->color
= x
->parent
->color
;
4428 x
->parent
->color
= MEM_BLACK
;
4429 w
->left
->color
= MEM_BLACK
;
4430 mem_rotate_right (x
->parent
);
4436 x
->color
= MEM_BLACK
;
4440 /* Value is non-zero if P is a pointer to a live Lisp string on
4441 the heap. M is a pointer to the mem_block for P. */
4444 live_string_p (struct mem_node
*m
, void *p
)
4446 if (m
->type
== MEM_TYPE_STRING
)
4448 struct string_block
*b
= m
->start
;
4449 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4451 /* P must point to the start of a Lisp_String structure, and it
4452 must not be on the free-list. */
4454 && offset
% sizeof b
->strings
[0] == 0
4455 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4456 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4463 /* Value is non-zero if P is a pointer to a live Lisp cons on
4464 the heap. M is a pointer to the mem_block for P. */
4467 live_cons_p (struct mem_node
*m
, void *p
)
4469 if (m
->type
== MEM_TYPE_CONS
)
4471 struct cons_block
*b
= m
->start
;
4472 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4474 /* P must point to the start of a Lisp_Cons, not be
4475 one of the unused cells in the current cons block,
4476 and not be on the free-list. */
4478 && offset
% sizeof b
->conses
[0] == 0
4479 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4481 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4482 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4489 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4490 the heap. M is a pointer to the mem_block for P. */
4493 live_symbol_p (struct mem_node
*m
, void *p
)
4495 if (m
->type
== MEM_TYPE_SYMBOL
)
4497 struct symbol_block
*b
= m
->start
;
4498 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4500 /* P must point to the start of a Lisp_Symbol, not be
4501 one of the unused cells in the current symbol block,
4502 and not be on the free-list. */
4504 && offset
% sizeof b
->symbols
[0] == 0
4505 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4506 && (b
!= symbol_block
4507 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4508 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4515 /* Value is non-zero if P is a pointer to a live Lisp float on
4516 the heap. M is a pointer to the mem_block for P. */
4519 live_float_p (struct mem_node
*m
, void *p
)
4521 if (m
->type
== MEM_TYPE_FLOAT
)
4523 struct float_block
*b
= m
->start
;
4524 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4526 /* P must point to the start of a Lisp_Float and not be
4527 one of the unused cells in the current float block. */
4529 && offset
% sizeof b
->floats
[0] == 0
4530 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4531 && (b
!= float_block
4532 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4539 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4540 the heap. M is a pointer to the mem_block for P. */
4543 live_misc_p (struct mem_node
*m
, void *p
)
4545 if (m
->type
== MEM_TYPE_MISC
)
4547 struct marker_block
*b
= m
->start
;
4548 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4550 /* P must point to the start of a Lisp_Misc, not be
4551 one of the unused cells in the current misc block,
4552 and not be on the free-list. */
4554 && offset
% sizeof b
->markers
[0] == 0
4555 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4556 && (b
!= marker_block
4557 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4558 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4565 /* Value is non-zero if P is a pointer to a live vector-like object.
4566 M is a pointer to the mem_block for P. */
4569 live_vector_p (struct mem_node
*m
, void *p
)
4571 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4573 /* This memory node corresponds to a vector block. */
4574 struct vector_block
*block
= m
->start
;
4575 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4577 /* P is in the block's allocation range. Scan the block
4578 up to P and see whether P points to the start of some
4579 vector which is not on a free list. FIXME: check whether
4580 some allocation patterns (probably a lot of short vectors)
4581 may cause a substantial overhead of this loop. */
4582 while (VECTOR_IN_BLOCK (vector
, block
)
4583 && vector
<= (struct Lisp_Vector
*) p
)
4585 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4588 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4591 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4592 /* This memory node corresponds to a large vector. */
4598 /* Value is non-zero if P is a pointer to a live buffer. M is a
4599 pointer to the mem_block for P. */
4602 live_buffer_p (struct mem_node
*m
, void *p
)
4604 /* P must point to the start of the block, and the buffer
4605 must not have been killed. */
4606 return (m
->type
== MEM_TYPE_BUFFER
4608 && !NILP (((struct buffer
*) p
)->name_
));
4611 /* Mark OBJ if we can prove it's a Lisp_Object. */
4614 mark_maybe_object (Lisp_Object obj
)
4618 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4624 void *po
= XPNTR (obj
);
4625 struct mem_node
*m
= mem_find (po
);
4629 bool mark_p
= false;
4631 switch (XTYPE (obj
))
4634 mark_p
= (live_string_p (m
, po
)
4635 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4639 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4643 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4647 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4650 case Lisp_Vectorlike
:
4651 /* Note: can't check BUFFERP before we know it's a
4652 buffer because checking that dereferences the pointer
4653 PO which might point anywhere. */
4654 if (live_vector_p (m
, po
))
4655 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4656 else if (live_buffer_p (m
, po
))
4657 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4661 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4673 /* Return true if P can point to Lisp data, and false otherwise.
4674 Symbols are implemented via offsets not pointers, but the offsets
4675 are also multiples of GCALIGNMENT. */
4678 maybe_lisp_pointer (void *p
)
4680 return (uintptr_t) p
% GCALIGNMENT
== 0;
4683 #ifndef HAVE_MODULES
4684 enum { HAVE_MODULES
= false };
4687 /* If P points to Lisp data, mark that as live if it isn't already
4691 mark_maybe_pointer (void *p
)
4697 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4700 if (sizeof (Lisp_Object
) == sizeof (void *) || !HAVE_MODULES
)
4702 if (!maybe_lisp_pointer (p
))
4707 /* For the wide-int case, also mark emacs_value tagged pointers,
4708 which can be generated by emacs-module.c's value_to_lisp. */
4709 p
= (void *) ((uintptr_t) p
& ~(GCALIGNMENT
- 1));
4715 Lisp_Object obj
= Qnil
;
4719 case MEM_TYPE_NON_LISP
:
4720 case MEM_TYPE_SPARE
:
4721 /* Nothing to do; not a pointer to Lisp memory. */
4724 case MEM_TYPE_BUFFER
:
4725 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4726 XSETVECTOR (obj
, p
);
4730 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4734 case MEM_TYPE_STRING
:
4735 if (live_string_p (m
, p
)
4736 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4737 XSETSTRING (obj
, p
);
4741 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4745 case MEM_TYPE_SYMBOL
:
4746 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4747 XSETSYMBOL (obj
, p
);
4750 case MEM_TYPE_FLOAT
:
4751 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4755 case MEM_TYPE_VECTORLIKE
:
4756 case MEM_TYPE_VECTOR_BLOCK
:
4757 if (live_vector_p (m
, p
))
4760 XSETVECTOR (tem
, p
);
4761 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4776 /* Alignment of pointer values. Use alignof, as it sometimes returns
4777 a smaller alignment than GCC's __alignof__ and mark_memory might
4778 miss objects if __alignof__ were used. */
4779 #define GC_POINTER_ALIGNMENT alignof (void *)
4781 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4782 or END+OFFSET..START. */
4784 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4785 mark_memory (void *start
, void *end
)
4789 /* Make START the pointer to the start of the memory region,
4790 if it isn't already. */
4798 eassert (((uintptr_t) start
) % GC_POINTER_ALIGNMENT
== 0);
4800 /* Mark Lisp data pointed to. This is necessary because, in some
4801 situations, the C compiler optimizes Lisp objects away, so that
4802 only a pointer to them remains. Example:
4804 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4807 Lisp_Object obj = build_string ("test");
4808 struct Lisp_String *s = XSTRING (obj);
4809 Fgarbage_collect ();
4810 fprintf (stderr, "test '%s'\n", s->data);
4814 Here, `obj' isn't really used, and the compiler optimizes it
4815 away. The only reference to the life string is through the
4818 for (pp
= start
; (void *) pp
< end
; pp
+= GC_POINTER_ALIGNMENT
)
4820 mark_maybe_pointer (*(void **) pp
);
4821 mark_maybe_object (*(Lisp_Object
*) pp
);
4825 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4827 static bool setjmp_tested_p
;
4828 static int longjmps_done
;
4830 #define SETJMP_WILL_LIKELY_WORK "\
4832 Emacs garbage collector has been changed to use conservative stack\n\
4833 marking. Emacs has determined that the method it uses to do the\n\
4834 marking will likely work on your system, but this isn't sure.\n\
4836 If you are a system-programmer, or can get the help of a local wizard\n\
4837 who is, please take a look at the function mark_stack in alloc.c, and\n\
4838 verify that the methods used are appropriate for your system.\n\
4840 Please mail the result to <emacs-devel@gnu.org>.\n\
4843 #define SETJMP_WILL_NOT_WORK "\
4845 Emacs garbage collector has been changed to use conservative stack\n\
4846 marking. Emacs has determined that the default method it uses to do the\n\
4847 marking will not work on your system. We will need a system-dependent\n\
4848 solution for your system.\n\
4850 Please take a look at the function mark_stack in alloc.c, and\n\
4851 try to find a way to make it work on your system.\n\
4853 Note that you may get false negatives, depending on the compiler.\n\
4854 In particular, you need to use -O with GCC for this test.\n\
4856 Please mail the result to <emacs-devel@gnu.org>.\n\
4860 /* Perform a quick check if it looks like setjmp saves registers in a
4861 jmp_buf. Print a message to stderr saying so. When this test
4862 succeeds, this is _not_ a proof that setjmp is sufficient for
4863 conservative stack marking. Only the sources or a disassembly
4873 /* Arrange for X to be put in a register. */
4879 if (longjmps_done
== 1)
4881 /* Came here after the longjmp at the end of the function.
4883 If x == 1, the longjmp has restored the register to its
4884 value before the setjmp, and we can hope that setjmp
4885 saves all such registers in the jmp_buf, although that
4888 For other values of X, either something really strange is
4889 taking place, or the setjmp just didn't save the register. */
4892 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4895 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4902 if (longjmps_done
== 1)
4903 sys_longjmp (jbuf
, 1);
4906 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4909 /* Mark live Lisp objects on the C stack.
4911 There are several system-dependent problems to consider when
4912 porting this to new architectures:
4916 We have to mark Lisp objects in CPU registers that can hold local
4917 variables or are used to pass parameters.
4919 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4920 something that either saves relevant registers on the stack, or
4921 calls mark_maybe_object passing it each register's contents.
4923 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4924 implementation assumes that calling setjmp saves registers we need
4925 to see in a jmp_buf which itself lies on the stack. This doesn't
4926 have to be true! It must be verified for each system, possibly
4927 by taking a look at the source code of setjmp.
4929 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4930 can use it as a machine independent method to store all registers
4931 to the stack. In this case the macros described in the previous
4932 two paragraphs are not used.
4936 Architectures differ in the way their processor stack is organized.
4937 For example, the stack might look like this
4940 | Lisp_Object | size = 4
4942 | something else | size = 2
4944 | Lisp_Object | size = 4
4948 In such a case, not every Lisp_Object will be aligned equally. To
4949 find all Lisp_Object on the stack it won't be sufficient to walk
4950 the stack in steps of 4 bytes. Instead, two passes will be
4951 necessary, one starting at the start of the stack, and a second
4952 pass starting at the start of the stack + 2. Likewise, if the
4953 minimal alignment of Lisp_Objects on the stack is 1, four passes
4954 would be necessary, each one starting with one byte more offset
4955 from the stack start. */
4958 mark_stack (void *end
)
4961 /* This assumes that the stack is a contiguous region in memory. If
4962 that's not the case, something has to be done here to iterate
4963 over the stack segments. */
4964 mark_memory (stack_base
, end
);
4966 /* Allow for marking a secondary stack, like the register stack on the
4968 #ifdef GC_MARK_SECONDARY_STACK
4969 GC_MARK_SECONDARY_STACK ();
4974 c_symbol_p (struct Lisp_Symbol
*sym
)
4976 char *lispsym_ptr
= (char *) lispsym
;
4977 char *sym_ptr
= (char *) sym
;
4978 ptrdiff_t lispsym_offset
= sym_ptr
- lispsym_ptr
;
4979 return 0 <= lispsym_offset
&& lispsym_offset
< sizeof lispsym
;
4982 /* Determine whether it is safe to access memory at address P. */
4984 valid_pointer_p (void *p
)
4987 return w32_valid_pointer_p (p
, 16);
4990 if (ADDRESS_SANITIZER
)
4995 /* Obviously, we cannot just access it (we would SEGV trying), so we
4996 trick the o/s to tell us whether p is a valid pointer.
4997 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4998 not validate p in that case. */
5000 if (emacs_pipe (fd
) == 0)
5002 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
5003 emacs_close (fd
[1]);
5004 emacs_close (fd
[0]);
5012 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5013 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5014 cannot validate OBJ. This function can be quite slow, so its primary
5015 use is the manual debugging. The only exception is print_object, where
5016 we use it to check whether the memory referenced by the pointer of
5017 Lisp_Save_Value object contains valid objects. */
5020 valid_lisp_object_p (Lisp_Object obj
)
5025 void *p
= XPNTR (obj
);
5029 if (SYMBOLP (obj
) && c_symbol_p (p
))
5030 return ((char *) p
- (char *) lispsym
) % sizeof lispsym
[0] == 0;
5032 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5035 struct mem_node
*m
= mem_find (p
);
5039 int valid
= valid_pointer_p (p
);
5051 case MEM_TYPE_NON_LISP
:
5052 case MEM_TYPE_SPARE
:
5055 case MEM_TYPE_BUFFER
:
5056 return live_buffer_p (m
, p
) ? 1 : 2;
5059 return live_cons_p (m
, p
);
5061 case MEM_TYPE_STRING
:
5062 return live_string_p (m
, p
);
5065 return live_misc_p (m
, p
);
5067 case MEM_TYPE_SYMBOL
:
5068 return live_symbol_p (m
, p
);
5070 case MEM_TYPE_FLOAT
:
5071 return live_float_p (m
, p
);
5073 case MEM_TYPE_VECTORLIKE
:
5074 case MEM_TYPE_VECTOR_BLOCK
:
5075 return live_vector_p (m
, p
);
5084 /***********************************************************************
5085 Pure Storage Management
5086 ***********************************************************************/
5088 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5089 pointer to it. TYPE is the Lisp type for which the memory is
5090 allocated. TYPE < 0 means it's not used for a Lisp object. */
5093 pure_alloc (size_t size
, int type
)
5100 /* Allocate space for a Lisp object from the beginning of the free
5101 space with taking account of alignment. */
5102 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, GCALIGNMENT
);
5103 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5107 /* Allocate space for a non-Lisp object from the end of the free
5109 pure_bytes_used_non_lisp
+= size
;
5110 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5112 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5114 if (pure_bytes_used
<= pure_size
)
5117 /* Don't allocate a large amount here,
5118 because it might get mmap'd and then its address
5119 might not be usable. */
5120 purebeg
= xmalloc (10000);
5122 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5123 pure_bytes_used
= 0;
5124 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5129 /* Print a warning if PURESIZE is too small. */
5132 check_pure_size (void)
5134 if (pure_bytes_used_before_overflow
)
5135 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5137 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5141 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5142 the non-Lisp data pool of the pure storage, and return its start
5143 address. Return NULL if not found. */
5146 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5149 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5150 const unsigned char *p
;
5153 if (pure_bytes_used_non_lisp
<= nbytes
)
5156 /* Set up the Boyer-Moore table. */
5158 for (i
= 0; i
< 256; i
++)
5161 p
= (const unsigned char *) data
;
5163 bm_skip
[*p
++] = skip
;
5165 last_char_skip
= bm_skip
['\0'];
5167 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5168 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5170 /* See the comments in the function `boyer_moore' (search.c) for the
5171 use of `infinity'. */
5172 infinity
= pure_bytes_used_non_lisp
+ 1;
5173 bm_skip
['\0'] = infinity
;
5175 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5179 /* Check the last character (== '\0'). */
5182 start
+= bm_skip
[*(p
+ start
)];
5184 while (start
<= start_max
);
5186 if (start
< infinity
)
5187 /* Couldn't find the last character. */
5190 /* No less than `infinity' means we could find the last
5191 character at `p[start - infinity]'. */
5194 /* Check the remaining characters. */
5195 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5197 return non_lisp_beg
+ start
;
5199 start
+= last_char_skip
;
5201 while (start
<= start_max
);
5207 /* Return a string allocated in pure space. DATA is a buffer holding
5208 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5209 means make the result string multibyte.
5211 Must get an error if pure storage is full, since if it cannot hold
5212 a large string it may be able to hold conses that point to that
5213 string; then the string is not protected from gc. */
5216 make_pure_string (const char *data
,
5217 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5220 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5221 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5222 if (s
->data
== NULL
)
5224 s
->data
= pure_alloc (nbytes
+ 1, -1);
5225 memcpy (s
->data
, data
, nbytes
);
5226 s
->data
[nbytes
] = '\0';
5229 s
->size_byte
= multibyte
? nbytes
: -1;
5230 s
->intervals
= NULL
;
5231 XSETSTRING (string
, s
);
5235 /* Return a string allocated in pure space. Do not
5236 allocate the string data, just point to DATA. */
5239 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5242 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5245 s
->data
= (unsigned char *) data
;
5246 s
->intervals
= NULL
;
5247 XSETSTRING (string
, s
);
5251 static Lisp_Object
purecopy (Lisp_Object obj
);
5253 /* Return a cons allocated from pure space. Give it pure copies
5254 of CAR as car and CDR as cdr. */
5257 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5260 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5262 XSETCAR (new, purecopy (car
));
5263 XSETCDR (new, purecopy (cdr
));
5268 /* Value is a float object with value NUM allocated from pure space. */
5271 make_pure_float (double num
)
5274 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5276 XFLOAT_INIT (new, num
);
5281 /* Return a vector with room for LEN Lisp_Objects allocated from
5285 make_pure_vector (ptrdiff_t len
)
5288 size_t size
= header_size
+ len
* word_size
;
5289 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5290 XSETVECTOR (new, p
);
5291 XVECTOR (new)->header
.size
= len
;
5295 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5296 doc
: /* Make a copy of object OBJ in pure storage.
5297 Recursively copies contents of vectors and cons cells.
5298 Does not copy symbols. Copies strings without text properties. */)
5299 (register Lisp_Object obj
)
5301 if (NILP (Vpurify_flag
))
5303 else if (MARKERP (obj
) || OVERLAYP (obj
)
5304 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5305 /* Can't purify those. */
5308 return purecopy (obj
);
5312 purecopy (Lisp_Object obj
)
5315 || (! SYMBOLP (obj
) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj
)))
5317 return obj
; /* Already pure. */
5319 if (STRINGP (obj
) && XSTRING (obj
)->intervals
)
5320 message_with_string ("Dropping text-properties while making string `%s' pure",
5323 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5325 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5331 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5332 else if (FLOATP (obj
))
5333 obj
= make_pure_float (XFLOAT_DATA (obj
));
5334 else if (STRINGP (obj
))
5335 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5337 STRING_MULTIBYTE (obj
));
5338 else if (COMPILEDP (obj
) || VECTORP (obj
) || HASH_TABLE_P (obj
))
5340 struct Lisp_Vector
*objp
= XVECTOR (obj
);
5341 ptrdiff_t nbytes
= vector_nbytes (objp
);
5342 struct Lisp_Vector
*vec
= pure_alloc (nbytes
, Lisp_Vectorlike
);
5343 register ptrdiff_t i
;
5344 ptrdiff_t size
= ASIZE (obj
);
5345 if (size
& PSEUDOVECTOR_FLAG
)
5346 size
&= PSEUDOVECTOR_SIZE_MASK
;
5347 memcpy (vec
, objp
, nbytes
);
5348 for (i
= 0; i
< size
; i
++)
5349 vec
->contents
[i
] = purecopy (vec
->contents
[i
]);
5350 XSETVECTOR (obj
, vec
);
5352 else if (SYMBOLP (obj
))
5354 if (!XSYMBOL (obj
)->pinned
&& !c_symbol_p (XSYMBOL (obj
)))
5355 { /* We can't purify them, but they appear in many pure objects.
5356 Mark them as `pinned' so we know to mark them at every GC cycle. */
5357 XSYMBOL (obj
)->pinned
= true;
5358 symbol_block_pinned
= symbol_block
;
5360 /* Don't hash-cons it. */
5365 Lisp_Object fmt
= build_pure_c_string ("Don't know how to purify: %S");
5366 Fsignal (Qerror
, list1 (CALLN (Fformat
, fmt
, obj
)));
5369 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5370 Fputhash (obj
, obj
, Vpurify_flag
);
5377 /***********************************************************************
5379 ***********************************************************************/
5381 /* Put an entry in staticvec, pointing at the variable with address
5385 staticpro (Lisp_Object
*varaddress
)
5387 if (staticidx
>= NSTATICS
)
5388 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5389 staticvec
[staticidx
++] = varaddress
;
5393 /***********************************************************************
5395 ***********************************************************************/
5397 /* Temporarily prevent garbage collection. */
5400 inhibit_garbage_collection (void)
5402 ptrdiff_t count
= SPECPDL_INDEX ();
5404 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5408 /* Used to avoid possible overflows when
5409 converting from C to Lisp integers. */
5412 bounded_number (EMACS_INT number
)
5414 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5417 /* Calculate total bytes of live objects. */
5420 total_bytes_of_live_objects (void)
5423 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5424 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5425 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5426 tot
+= total_string_bytes
;
5427 tot
+= total_vector_slots
* word_size
;
5428 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5429 tot
+= total_intervals
* sizeof (struct interval
);
5430 tot
+= total_strings
* sizeof (struct Lisp_String
);
5434 #ifdef HAVE_WINDOW_SYSTEM
5436 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5437 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5440 compact_font_cache_entry (Lisp_Object entry
)
5442 Lisp_Object tail
, *prev
= &entry
;
5444 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5447 Lisp_Object obj
= XCAR (tail
);
5449 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5450 if (CONSP (obj
) && GC_FONT_SPEC_P (XCAR (obj
))
5451 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj
)))
5452 /* Don't use VECTORP here, as that calls ASIZE, which could
5453 hit assertion violation during GC. */
5454 && (VECTORLIKEP (XCDR (obj
))
5455 && ! (gc_asize (XCDR (obj
)) & PSEUDOVECTOR_FLAG
)))
5457 ptrdiff_t i
, size
= gc_asize (XCDR (obj
));
5458 Lisp_Object obj_cdr
= XCDR (obj
);
5460 /* If font-spec is not marked, most likely all font-entities
5461 are not marked too. But we must be sure that nothing is
5462 marked within OBJ before we really drop it. */
5463 for (i
= 0; i
< size
; i
++)
5465 Lisp_Object objlist
;
5467 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr
, i
))))
5470 objlist
= AREF (AREF (obj_cdr
, i
), FONT_OBJLIST_INDEX
);
5471 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
5473 Lisp_Object val
= XCAR (objlist
);
5474 struct font
*font
= GC_XFONT_OBJECT (val
);
5476 if (!NILP (AREF (val
, FONT_TYPE_INDEX
))
5477 && VECTOR_MARKED_P(font
))
5480 if (CONSP (objlist
))
5482 /* Found a marked font, bail out. */
5489 /* No marked fonts were found, so this entire font
5490 entity can be dropped. */
5495 *prev
= XCDR (tail
);
5497 prev
= xcdr_addr (tail
);
5502 /* Compact font caches on all terminals and mark
5503 everything which is still here after compaction. */
5506 compact_font_caches (void)
5510 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5512 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5517 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5518 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5520 mark_object (cache
);
5524 #else /* not HAVE_WINDOW_SYSTEM */
5526 #define compact_font_caches() (void)(0)
5528 #endif /* HAVE_WINDOW_SYSTEM */
5530 /* Remove (MARKER . DATA) entries with unmarked MARKER
5531 from buffer undo LIST and return changed list. */
5534 compact_undo_list (Lisp_Object list
)
5536 Lisp_Object tail
, *prev
= &list
;
5538 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5540 if (CONSP (XCAR (tail
))
5541 && MARKERP (XCAR (XCAR (tail
)))
5542 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5543 *prev
= XCDR (tail
);
5545 prev
= xcdr_addr (tail
);
5551 mark_pinned_symbols (void)
5553 struct symbol_block
*sblk
;
5554 int lim
= (symbol_block_pinned
== symbol_block
5555 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5557 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5559 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5560 for (; sym
< end
; ++sym
)
5562 mark_object (make_lisp_symbol (&sym
->s
));
5564 lim
= SYMBOL_BLOCK_SIZE
;
5568 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5569 separate function so that we could limit mark_stack in searching
5570 the stack frames below this function, thus avoiding the rare cases
5571 where mark_stack finds values that look like live Lisp objects on
5572 portions of stack that couldn't possibly contain such live objects.
5573 For more details of this, see the discussion at
5574 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5576 garbage_collect_1 (void *end
)
5578 struct buffer
*nextb
;
5579 char stack_top_variable
;
5582 ptrdiff_t count
= SPECPDL_INDEX ();
5583 struct timespec start
;
5584 Lisp_Object retval
= Qnil
;
5585 size_t tot_before
= 0;
5590 /* Can't GC if pure storage overflowed because we can't determine
5591 if something is a pure object or not. */
5592 if (pure_bytes_used_before_overflow
)
5595 /* Record this function, so it appears on the profiler's backtraces. */
5596 record_in_backtrace (Qautomatic_gc
, 0, 0);
5600 /* Don't keep undo information around forever.
5601 Do this early on, so it is no problem if the user quits. */
5602 FOR_EACH_BUFFER (nextb
)
5603 compact_buffer (nextb
);
5605 if (profiler_memory_running
)
5606 tot_before
= total_bytes_of_live_objects ();
5608 start
= current_timespec ();
5610 /* In case user calls debug_print during GC,
5611 don't let that cause a recursive GC. */
5612 consing_since_gc
= 0;
5614 /* Save what's currently displayed in the echo area. Don't do that
5615 if we are GC'ing because we've run out of memory, since
5616 push_message will cons, and we might have no memory for that. */
5617 if (NILP (Vmemory_full
))
5619 message_p
= push_message ();
5620 record_unwind_protect_void (pop_message_unwind
);
5625 /* Save a copy of the contents of the stack, for debugging. */
5626 #if MAX_SAVE_STACK > 0
5627 if (NILP (Vpurify_flag
))
5630 ptrdiff_t stack_size
;
5631 if (&stack_top_variable
< stack_bottom
)
5633 stack
= &stack_top_variable
;
5634 stack_size
= stack_bottom
- &stack_top_variable
;
5638 stack
= stack_bottom
;
5639 stack_size
= &stack_top_variable
- stack_bottom
;
5641 if (stack_size
<= MAX_SAVE_STACK
)
5643 if (stack_copy_size
< stack_size
)
5645 stack_copy
= xrealloc (stack_copy
, stack_size
);
5646 stack_copy_size
= stack_size
;
5648 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5651 #endif /* MAX_SAVE_STACK > 0 */
5653 if (garbage_collection_messages
)
5654 message1_nolog ("Garbage collecting...");
5658 shrink_regexp_cache ();
5662 /* Mark all the special slots that serve as the roots of accessibility. */
5664 mark_buffer (&buffer_defaults
);
5665 mark_buffer (&buffer_local_symbols
);
5667 for (i
= 0; i
< ARRAYELTS (lispsym
); i
++)
5668 mark_object (builtin_lisp_symbol (i
));
5670 for (i
= 0; i
< staticidx
; i
++)
5671 mark_object (*staticvec
[i
]);
5673 mark_pinned_symbols ();
5685 struct handler
*handler
;
5686 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5688 mark_object (handler
->tag_or_ch
);
5689 mark_object (handler
->val
);
5692 #ifdef HAVE_WINDOW_SYSTEM
5693 mark_fringe_data ();
5696 /* Everything is now marked, except for the data in font caches,
5697 undo lists, and finalizers. The first two are compacted by
5698 removing an items which aren't reachable otherwise. */
5700 compact_font_caches ();
5702 FOR_EACH_BUFFER (nextb
)
5704 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5705 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5706 /* Now that we have stripped the elements that need not be
5707 in the undo_list any more, we can finally mark the list. */
5708 mark_object (BVAR (nextb
, undo_list
));
5711 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5712 to doomed_finalizers so we can run their associated functions
5713 after GC. It's important to scan finalizers at this stage so
5714 that we can be sure that unmarked finalizers are really
5715 unreachable except for references from their associated functions
5716 and from other finalizers. */
5718 queue_doomed_finalizers (&doomed_finalizers
, &finalizers
);
5719 mark_finalizer_list (&doomed_finalizers
);
5723 relocate_byte_stack ();
5725 /* Clear the mark bits that we set in certain root slots. */
5726 VECTOR_UNMARK (&buffer_defaults
);
5727 VECTOR_UNMARK (&buffer_local_symbols
);
5735 consing_since_gc
= 0;
5736 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5737 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5739 gc_relative_threshold
= 0;
5740 if (FLOATP (Vgc_cons_percentage
))
5741 { /* Set gc_cons_combined_threshold. */
5742 double tot
= total_bytes_of_live_objects ();
5744 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5747 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5748 gc_relative_threshold
= tot
;
5750 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5754 if (garbage_collection_messages
&& NILP (Vmemory_full
))
5756 if (message_p
|| minibuf_level
> 0)
5759 message1_nolog ("Garbage collecting...done");
5762 unbind_to (count
, Qnil
);
5764 Lisp_Object total
[] = {
5765 list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5766 bounded_number (total_conses
),
5767 bounded_number (total_free_conses
)),
5768 list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5769 bounded_number (total_symbols
),
5770 bounded_number (total_free_symbols
)),
5771 list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5772 bounded_number (total_markers
),
5773 bounded_number (total_free_markers
)),
5774 list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5775 bounded_number (total_strings
),
5776 bounded_number (total_free_strings
)),
5777 list3 (Qstring_bytes
, make_number (1),
5778 bounded_number (total_string_bytes
)),
5780 make_number (header_size
+ sizeof (Lisp_Object
)),
5781 bounded_number (total_vectors
)),
5782 list4 (Qvector_slots
, make_number (word_size
),
5783 bounded_number (total_vector_slots
),
5784 bounded_number (total_free_vector_slots
)),
5785 list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5786 bounded_number (total_floats
),
5787 bounded_number (total_free_floats
)),
5788 list4 (Qintervals
, make_number (sizeof (struct interval
)),
5789 bounded_number (total_intervals
),
5790 bounded_number (total_free_intervals
)),
5791 list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5792 bounded_number (total_buffers
)),
5794 #ifdef DOUG_LEA_MALLOC
5795 list4 (Qheap
, make_number (1024),
5796 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5797 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10)),
5800 retval
= CALLMANY (Flist
, total
);
5802 /* GC is complete: now we can run our finalizer callbacks. */
5803 run_finalizers (&doomed_finalizers
);
5805 if (!NILP (Vpost_gc_hook
))
5807 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5808 safe_run_hooks (Qpost_gc_hook
);
5809 unbind_to (gc_count
, Qnil
);
5812 /* Accumulate statistics. */
5813 if (FLOATP (Vgc_elapsed
))
5815 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5816 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5817 + timespectod (since_start
));
5822 /* Collect profiling data. */
5823 if (profiler_memory_running
)
5826 size_t tot_after
= total_bytes_of_live_objects ();
5827 if (tot_before
> tot_after
)
5828 swept
= tot_before
- tot_after
;
5829 malloc_probe (swept
);
5835 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5836 doc
: /* Reclaim storage for Lisp objects no longer needed.
5837 Garbage collection happens automatically if you cons more than
5838 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5839 `garbage-collect' normally returns a list with info on amount of space in use,
5840 where each entry has the form (NAME SIZE USED FREE), where:
5841 - NAME is a symbol describing the kind of objects this entry represents,
5842 - SIZE is the number of bytes used by each one,
5843 - USED is the number of those objects that were found live in the heap,
5844 - FREE is the number of those objects that are not live but that Emacs
5845 keeps around for future allocations (maybe because it does not know how
5846 to return them to the OS).
5847 However, if there was overflow in pure space, `garbage-collect'
5848 returns nil, because real GC can't be done.
5849 See Info node `(elisp)Garbage Collection'. */)
5854 #ifdef HAVE___BUILTIN_UNWIND_INIT
5855 /* Force callee-saved registers and register windows onto the stack.
5856 This is the preferred method if available, obviating the need for
5857 machine dependent methods. */
5858 __builtin_unwind_init ();
5860 #else /* not HAVE___BUILTIN_UNWIND_INIT */
5861 #ifndef GC_SAVE_REGISTERS_ON_STACK
5862 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5863 union aligned_jmpbuf
{
5867 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
5869 /* This trick flushes the register windows so that all the state of
5870 the process is contained in the stack. */
5871 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5872 needed on ia64 too. See mach_dep.c, where it also says inline
5873 assembler doesn't work with relevant proprietary compilers. */
5875 #if defined (__sparc64__) && defined (__FreeBSD__)
5876 /* FreeBSD does not have a ta 3 handler. */
5883 /* Save registers that we need to see on the stack. We need to see
5884 registers used to hold register variables and registers used to
5886 #ifdef GC_SAVE_REGISTERS_ON_STACK
5887 GC_SAVE_REGISTERS_ON_STACK (end
);
5888 #else /* not GC_SAVE_REGISTERS_ON_STACK */
5890 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5891 setjmp will definitely work, test it
5892 and print a message with the result
5894 if (!setjmp_tested_p
)
5896 setjmp_tested_p
= 1;
5899 #endif /* GC_SETJMP_WORKS */
5902 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
5903 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
5904 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
5905 return garbage_collect_1 (end
);
5908 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5909 only interesting objects referenced from glyphs are strings. */
5912 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5914 struct glyph_row
*row
= matrix
->rows
;
5915 struct glyph_row
*end
= row
+ matrix
->nrows
;
5917 for (; row
< end
; ++row
)
5921 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5923 struct glyph
*glyph
= row
->glyphs
[area
];
5924 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5926 for (; glyph
< end_glyph
; ++glyph
)
5927 if (STRINGP (glyph
->object
)
5928 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5929 mark_object (glyph
->object
);
5934 /* Mark reference to a Lisp_Object.
5935 If the object referred to has not been seen yet, recursively mark
5936 all the references contained in it. */
5938 #define LAST_MARKED_SIZE 500
5939 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5940 static int last_marked_index
;
5942 /* For debugging--call abort when we cdr down this many
5943 links of a list, in mark_object. In debugging,
5944 the call to abort will hit a breakpoint.
5945 Normally this is zero and the check never goes off. */
5946 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5949 mark_vectorlike (struct Lisp_Vector
*ptr
)
5951 ptrdiff_t size
= ptr
->header
.size
;
5954 eassert (!VECTOR_MARKED_P (ptr
));
5955 VECTOR_MARK (ptr
); /* Else mark it. */
5956 if (size
& PSEUDOVECTOR_FLAG
)
5957 size
&= PSEUDOVECTOR_SIZE_MASK
;
5959 /* Note that this size is not the memory-footprint size, but only
5960 the number of Lisp_Object fields that we should trace.
5961 The distinction is used e.g. by Lisp_Process which places extra
5962 non-Lisp_Object fields at the end of the structure... */
5963 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5964 mark_object (ptr
->contents
[i
]);
5967 /* Like mark_vectorlike but optimized for char-tables (and
5968 sub-char-tables) assuming that the contents are mostly integers or
5972 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
5974 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5975 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
5976 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
5978 eassert (!VECTOR_MARKED_P (ptr
));
5980 for (i
= idx
; i
< size
; i
++)
5982 Lisp_Object val
= ptr
->contents
[i
];
5984 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5986 if (SUB_CHAR_TABLE_P (val
))
5988 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5989 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
5996 NO_INLINE
/* To reduce stack depth in mark_object. */
5998 mark_compiled (struct Lisp_Vector
*ptr
)
6000 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6003 for (i
= 0; i
< size
; i
++)
6004 if (i
!= COMPILED_CONSTANTS
)
6005 mark_object (ptr
->contents
[i
]);
6006 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6009 /* Mark the chain of overlays starting at PTR. */
6012 mark_overlay (struct Lisp_Overlay
*ptr
)
6014 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6017 /* These two are always markers and can be marked fast. */
6018 XMARKER (ptr
->start
)->gcmarkbit
= 1;
6019 XMARKER (ptr
->end
)->gcmarkbit
= 1;
6020 mark_object (ptr
->plist
);
6024 /* Mark Lisp_Objects and special pointers in BUFFER. */
6027 mark_buffer (struct buffer
*buffer
)
6029 /* This is handled much like other pseudovectors... */
6030 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6032 /* ...but there are some buffer-specific things. */
6034 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6036 /* For now, we just don't mark the undo_list. It's done later in
6037 a special way just before the sweep phase, and after stripping
6038 some of its elements that are not needed any more. */
6040 mark_overlay (buffer
->overlays_before
);
6041 mark_overlay (buffer
->overlays_after
);
6043 /* If this is an indirect buffer, mark its base buffer. */
6044 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6045 mark_buffer (buffer
->base_buffer
);
6048 /* Mark Lisp faces in the face cache C. */
6050 NO_INLINE
/* To reduce stack depth in mark_object. */
6052 mark_face_cache (struct face_cache
*c
)
6057 for (i
= 0; i
< c
->used
; ++i
)
6059 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
6063 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6064 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6066 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6067 mark_object (face
->lface
[j
]);
6073 NO_INLINE
/* To reduce stack depth in mark_object. */
6075 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6077 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6078 Lisp_Object where
= blv
->where
;
6079 /* If the value is set up for a killed buffer or deleted
6080 frame, restore its global binding. If the value is
6081 forwarded to a C variable, either it's not a Lisp_Object
6082 var, or it's staticpro'd already. */
6083 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6084 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6085 swap_in_global_binding (ptr
);
6086 mark_object (blv
->where
);
6087 mark_object (blv
->valcell
);
6088 mark_object (blv
->defcell
);
6091 NO_INLINE
/* To reduce stack depth in mark_object. */
6093 mark_save_value (struct Lisp_Save_Value
*ptr
)
6095 /* If `save_type' is zero, `data[0].pointer' is the address
6096 of a memory area containing `data[1].integer' potential
6098 if (ptr
->save_type
== SAVE_TYPE_MEMORY
)
6100 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6102 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6103 mark_maybe_object (*p
);
6107 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6109 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6110 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6111 mark_object (ptr
->data
[i
].object
);
6115 /* Remove killed buffers or items whose car is a killed buffer from
6116 LIST, and mark other items. Return changed LIST, which is marked. */
6119 mark_discard_killed_buffers (Lisp_Object list
)
6121 Lisp_Object tail
, *prev
= &list
;
6123 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6126 Lisp_Object tem
= XCAR (tail
);
6129 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6130 *prev
= XCDR (tail
);
6133 CONS_MARK (XCONS (tail
));
6134 mark_object (XCAR (tail
));
6135 prev
= xcdr_addr (tail
);
6142 /* Determine type of generic Lisp_Object and mark it accordingly.
6144 This function implements a straightforward depth-first marking
6145 algorithm and so the recursion depth may be very high (a few
6146 tens of thousands is not uncommon). To minimize stack usage,
6147 a few cold paths are moved out to NO_INLINE functions above.
6148 In general, inlining them doesn't help you to gain more speed. */
6151 mark_object (Lisp_Object arg
)
6153 register Lisp_Object obj
;
6155 #ifdef GC_CHECK_MARKED_OBJECTS
6158 ptrdiff_t cdr_count
= 0;
6167 last_marked
[last_marked_index
++] = obj
;
6168 if (last_marked_index
== LAST_MARKED_SIZE
)
6169 last_marked_index
= 0;
6171 /* Perform some sanity checks on the objects marked here. Abort if
6172 we encounter an object we know is bogus. This increases GC time
6174 #ifdef GC_CHECK_MARKED_OBJECTS
6176 /* Check that the object pointed to by PO is known to be a Lisp
6177 structure allocated from the heap. */
6178 #define CHECK_ALLOCATED() \
6180 m = mem_find (po); \
6185 /* Check that the object pointed to by PO is live, using predicate
6187 #define CHECK_LIVE(LIVEP) \
6189 if (!LIVEP (m, po)) \
6193 /* Check both of the above conditions, for non-symbols. */
6194 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6196 CHECK_ALLOCATED (); \
6197 CHECK_LIVE (LIVEP); \
6200 /* Check both of the above conditions, for symbols. */
6201 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6203 if (!c_symbol_p (ptr)) \
6205 CHECK_ALLOCATED (); \
6206 CHECK_LIVE (live_symbol_p); \
6210 #else /* not GC_CHECK_MARKED_OBJECTS */
6212 #define CHECK_LIVE(LIVEP) ((void) 0)
6213 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6214 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6216 #endif /* not GC_CHECK_MARKED_OBJECTS */
6218 switch (XTYPE (obj
))
6222 register struct Lisp_String
*ptr
= XSTRING (obj
);
6223 if (STRING_MARKED_P (ptr
))
6225 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6227 MARK_INTERVAL_TREE (ptr
->intervals
);
6228 #ifdef GC_CHECK_STRING_BYTES
6229 /* Check that the string size recorded in the string is the
6230 same as the one recorded in the sdata structure. */
6232 #endif /* GC_CHECK_STRING_BYTES */
6236 case Lisp_Vectorlike
:
6238 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6239 register ptrdiff_t pvectype
;
6241 if (VECTOR_MARKED_P (ptr
))
6244 #ifdef GC_CHECK_MARKED_OBJECTS
6246 if (m
== MEM_NIL
&& !SUBRP (obj
))
6248 #endif /* GC_CHECK_MARKED_OBJECTS */
6250 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6251 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6252 >> PSEUDOVECTOR_AREA_BITS
);
6254 pvectype
= PVEC_NORMAL_VECTOR
;
6256 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6257 CHECK_LIVE (live_vector_p
);
6262 #ifdef GC_CHECK_MARKED_OBJECTS
6271 #endif /* GC_CHECK_MARKED_OBJECTS */
6272 mark_buffer ((struct buffer
*) ptr
);
6276 /* Although we could treat this just like a vector, mark_compiled
6277 returns the COMPILED_CONSTANTS element, which is marked at the
6278 next iteration of goto-loop here. This is done to avoid a few
6279 recursive calls to mark_object. */
6280 obj
= mark_compiled (ptr
);
6287 struct frame
*f
= (struct frame
*) ptr
;
6289 mark_vectorlike (ptr
);
6290 mark_face_cache (f
->face_cache
);
6291 #ifdef HAVE_WINDOW_SYSTEM
6292 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6294 struct font
*font
= FRAME_FONT (f
);
6296 if (font
&& !VECTOR_MARKED_P (font
))
6297 mark_vectorlike ((struct Lisp_Vector
*) font
);
6305 struct window
*w
= (struct window
*) ptr
;
6307 mark_vectorlike (ptr
);
6309 /* Mark glyph matrices, if any. Marking window
6310 matrices is sufficient because frame matrices
6311 use the same glyph memory. */
6312 if (w
->current_matrix
)
6314 mark_glyph_matrix (w
->current_matrix
);
6315 mark_glyph_matrix (w
->desired_matrix
);
6318 /* Filter out killed buffers from both buffer lists
6319 in attempt to help GC to reclaim killed buffers faster.
6320 We can do it elsewhere for live windows, but this is the
6321 best place to do it for dead windows. */
6323 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6325 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6329 case PVEC_HASH_TABLE
:
6331 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6333 mark_vectorlike (ptr
);
6334 mark_object (h
->test
.name
);
6335 mark_object (h
->test
.user_hash_function
);
6336 mark_object (h
->test
.user_cmp_function
);
6337 /* If hash table is not weak, mark all keys and values.
6338 For weak tables, mark only the vector. */
6340 mark_object (h
->key_and_value
);
6342 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6346 case PVEC_CHAR_TABLE
:
6347 case PVEC_SUB_CHAR_TABLE
:
6348 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6351 case PVEC_BOOL_VECTOR
:
6352 /* No Lisp_Objects to mark in a bool vector. */
6363 mark_vectorlike (ptr
);
6370 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6374 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6376 /* Attempt to catch bogus objects. */
6377 eassert (valid_lisp_object_p (ptr
->function
));
6378 mark_object (ptr
->function
);
6379 mark_object (ptr
->plist
);
6380 switch (ptr
->redirect
)
6382 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6383 case SYMBOL_VARALIAS
:
6386 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6390 case SYMBOL_LOCALIZED
:
6391 mark_localized_symbol (ptr
);
6393 case SYMBOL_FORWARDED
:
6394 /* If the value is forwarded to a buffer or keyboard field,
6395 these are marked when we see the corresponding object.
6396 And if it's forwarded to a C variable, either it's not
6397 a Lisp_Object var, or it's staticpro'd already. */
6399 default: emacs_abort ();
6401 if (!PURE_P (XSTRING (ptr
->name
)))
6402 MARK_STRING (XSTRING (ptr
->name
));
6403 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6404 /* Inner loop to mark next symbol in this bucket, if any. */
6405 po
= ptr
= ptr
->next
;
6412 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6414 if (XMISCANY (obj
)->gcmarkbit
)
6417 switch (XMISCTYPE (obj
))
6419 case Lisp_Misc_Marker
:
6420 /* DO NOT mark thru the marker's chain.
6421 The buffer's markers chain does not preserve markers from gc;
6422 instead, markers are removed from the chain when freed by gc. */
6423 XMISCANY (obj
)->gcmarkbit
= 1;
6426 case Lisp_Misc_Save_Value
:
6427 XMISCANY (obj
)->gcmarkbit
= 1;
6428 mark_save_value (XSAVE_VALUE (obj
));
6431 case Lisp_Misc_Overlay
:
6432 mark_overlay (XOVERLAY (obj
));
6435 case Lisp_Misc_Finalizer
:
6436 XMISCANY (obj
)->gcmarkbit
= true;
6437 mark_object (XFINALIZER (obj
)->function
);
6441 case Lisp_Misc_User_Ptr
:
6442 XMISCANY (obj
)->gcmarkbit
= true;
6453 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6454 if (CONS_MARKED_P (ptr
))
6456 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6458 /* If the cdr is nil, avoid recursion for the car. */
6459 if (EQ (ptr
->u
.cdr
, Qnil
))
6465 mark_object (ptr
->car
);
6468 if (cdr_count
== mark_object_loop_halt
)
6474 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6475 FLOAT_MARK (XFLOAT (obj
));
6486 #undef CHECK_ALLOCATED
6487 #undef CHECK_ALLOCATED_AND_LIVE
6489 /* Mark the Lisp pointers in the terminal objects.
6490 Called by Fgarbage_collect. */
6493 mark_terminals (void)
6496 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6498 eassert (t
->name
!= NULL
);
6499 #ifdef HAVE_WINDOW_SYSTEM
6500 /* If a terminal object is reachable from a stacpro'ed object,
6501 it might have been marked already. Make sure the image cache
6503 mark_image_cache (t
->image_cache
);
6504 #endif /* HAVE_WINDOW_SYSTEM */
6505 if (!VECTOR_MARKED_P (t
))
6506 mark_vectorlike ((struct Lisp_Vector
*)t
);
6512 /* Value is non-zero if OBJ will survive the current GC because it's
6513 either marked or does not need to be marked to survive. */
6516 survives_gc_p (Lisp_Object obj
)
6520 switch (XTYPE (obj
))
6527 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6531 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6535 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6538 case Lisp_Vectorlike
:
6539 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6543 survives_p
= CONS_MARKED_P (XCONS (obj
));
6547 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6554 return survives_p
|| PURE_P (XPNTR (obj
));
6560 NO_INLINE
/* For better stack traces */
6564 struct cons_block
*cblk
;
6565 struct cons_block
**cprev
= &cons_block
;
6566 int lim
= cons_block_index
;
6567 EMACS_INT num_free
= 0, num_used
= 0;
6571 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6575 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6577 /* Scan the mark bits an int at a time. */
6578 for (i
= 0; i
< ilim
; i
++)
6580 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6582 /* Fast path - all cons cells for this int are marked. */
6583 cblk
->gcmarkbits
[i
] = 0;
6584 num_used
+= BITS_PER_BITS_WORD
;
6588 /* Some cons cells for this int are not marked.
6589 Find which ones, and free them. */
6590 int start
, pos
, stop
;
6592 start
= i
* BITS_PER_BITS_WORD
;
6594 if (stop
> BITS_PER_BITS_WORD
)
6595 stop
= BITS_PER_BITS_WORD
;
6598 for (pos
= start
; pos
< stop
; pos
++)
6600 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6603 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6604 cons_free_list
= &cblk
->conses
[pos
];
6605 cons_free_list
->car
= Vdead
;
6610 CONS_UNMARK (&cblk
->conses
[pos
]);
6616 lim
= CONS_BLOCK_SIZE
;
6617 /* If this block contains only free conses and we have already
6618 seen more than two blocks worth of free conses then deallocate
6620 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6622 *cprev
= cblk
->next
;
6623 /* Unhook from the free list. */
6624 cons_free_list
= cblk
->conses
[0].u
.chain
;
6625 lisp_align_free (cblk
);
6629 num_free
+= this_free
;
6630 cprev
= &cblk
->next
;
6633 total_conses
= num_used
;
6634 total_free_conses
= num_free
;
6637 NO_INLINE
/* For better stack traces */
6641 register struct float_block
*fblk
;
6642 struct float_block
**fprev
= &float_block
;
6643 register int lim
= float_block_index
;
6644 EMACS_INT num_free
= 0, num_used
= 0;
6646 float_free_list
= 0;
6648 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6652 for (i
= 0; i
< lim
; i
++)
6653 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6656 fblk
->floats
[i
].u
.chain
= float_free_list
;
6657 float_free_list
= &fblk
->floats
[i
];
6662 FLOAT_UNMARK (&fblk
->floats
[i
]);
6664 lim
= FLOAT_BLOCK_SIZE
;
6665 /* If this block contains only free floats and we have already
6666 seen more than two blocks worth of free floats then deallocate
6668 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6670 *fprev
= fblk
->next
;
6671 /* Unhook from the free list. */
6672 float_free_list
= fblk
->floats
[0].u
.chain
;
6673 lisp_align_free (fblk
);
6677 num_free
+= this_free
;
6678 fprev
= &fblk
->next
;
6681 total_floats
= num_used
;
6682 total_free_floats
= num_free
;
6685 NO_INLINE
/* For better stack traces */
6687 sweep_intervals (void)
6689 register struct interval_block
*iblk
;
6690 struct interval_block
**iprev
= &interval_block
;
6691 register int lim
= interval_block_index
;
6692 EMACS_INT num_free
= 0, num_used
= 0;
6694 interval_free_list
= 0;
6696 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6701 for (i
= 0; i
< lim
; i
++)
6703 if (!iblk
->intervals
[i
].gcmarkbit
)
6705 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6706 interval_free_list
= &iblk
->intervals
[i
];
6712 iblk
->intervals
[i
].gcmarkbit
= 0;
6715 lim
= INTERVAL_BLOCK_SIZE
;
6716 /* If this block contains only free intervals and we have already
6717 seen more than two blocks worth of free intervals then
6718 deallocate this block. */
6719 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6721 *iprev
= iblk
->next
;
6722 /* Unhook from the free list. */
6723 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6728 num_free
+= this_free
;
6729 iprev
= &iblk
->next
;
6732 total_intervals
= num_used
;
6733 total_free_intervals
= num_free
;
6736 NO_INLINE
/* For better stack traces */
6738 sweep_symbols (void)
6740 struct symbol_block
*sblk
;
6741 struct symbol_block
**sprev
= &symbol_block
;
6742 int lim
= symbol_block_index
;
6743 EMACS_INT num_free
= 0, num_used
= ARRAYELTS (lispsym
);
6745 symbol_free_list
= NULL
;
6747 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
6748 lispsym
[i
].gcmarkbit
= 0;
6750 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6753 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6754 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6756 for (; sym
< end
; ++sym
)
6758 if (!sym
->s
.gcmarkbit
)
6760 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6761 xfree (SYMBOL_BLV (&sym
->s
));
6762 sym
->s
.next
= symbol_free_list
;
6763 symbol_free_list
= &sym
->s
;
6764 symbol_free_list
->function
= Vdead
;
6770 sym
->s
.gcmarkbit
= 0;
6771 /* Attempt to catch bogus objects. */
6772 eassert (valid_lisp_object_p (sym
->s
.function
));
6776 lim
= SYMBOL_BLOCK_SIZE
;
6777 /* If this block contains only free symbols and we have already
6778 seen more than two blocks worth of free symbols then deallocate
6780 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6782 *sprev
= sblk
->next
;
6783 /* Unhook from the free list. */
6784 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6789 num_free
+= this_free
;
6790 sprev
= &sblk
->next
;
6793 total_symbols
= num_used
;
6794 total_free_symbols
= num_free
;
6797 NO_INLINE
/* For better stack traces. */
6801 register struct marker_block
*mblk
;
6802 struct marker_block
**mprev
= &marker_block
;
6803 register int lim
= marker_block_index
;
6804 EMACS_INT num_free
= 0, num_used
= 0;
6806 /* Put all unmarked misc's on free list. For a marker, first
6807 unchain it from the buffer it points into. */
6809 marker_free_list
= 0;
6811 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6816 for (i
= 0; i
< lim
; i
++)
6818 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6820 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6821 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6822 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Finalizer
)
6823 unchain_finalizer (&mblk
->markers
[i
].m
.u_finalizer
);
6825 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_User_Ptr
)
6827 struct Lisp_User_Ptr
*uptr
= &mblk
->markers
[i
].m
.u_user_ptr
;
6828 uptr
->finalizer (uptr
->p
);
6831 /* Set the type of the freed object to Lisp_Misc_Free.
6832 We could leave the type alone, since nobody checks it,
6833 but this might catch bugs faster. */
6834 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6835 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6836 marker_free_list
= &mblk
->markers
[i
].m
;
6842 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6845 lim
= MARKER_BLOCK_SIZE
;
6846 /* If this block contains only free markers and we have already
6847 seen more than two blocks worth of free markers then deallocate
6849 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6851 *mprev
= mblk
->next
;
6852 /* Unhook from the free list. */
6853 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6858 num_free
+= this_free
;
6859 mprev
= &mblk
->next
;
6863 total_markers
= num_used
;
6864 total_free_markers
= num_free
;
6867 NO_INLINE
/* For better stack traces */
6869 sweep_buffers (void)
6871 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6874 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6875 if (!VECTOR_MARKED_P (buffer
))
6877 *bprev
= buffer
->next
;
6882 VECTOR_UNMARK (buffer
);
6883 /* Do not use buffer_(set|get)_intervals here. */
6884 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6886 bprev
= &buffer
->next
;
6890 /* Sweep: find all structures not marked, and free them. */
6894 /* Remove or mark entries in weak hash tables.
6895 This must be done before any object is unmarked. */
6896 sweep_weak_hash_tables ();
6899 check_string_bytes (!noninteractive
);
6907 check_string_bytes (!noninteractive
);
6910 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
6911 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
6912 All values are in Kbytes. If there is no swap space,
6913 last two values are zero. If the system is not supported
6914 or memory information can't be obtained, return nil. */)
6917 #if defined HAVE_LINUX_SYSINFO
6923 #ifdef LINUX_SYSINFO_UNIT
6924 units
= si
.mem_unit
;
6928 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
6929 (uintmax_t) si
.freeram
* units
/ 1024,
6930 (uintmax_t) si
.totalswap
* units
/ 1024,
6931 (uintmax_t) si
.freeswap
* units
/ 1024);
6932 #elif defined WINDOWSNT
6933 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
6935 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6936 return list4i ((uintmax_t) totalram
/ 1024,
6937 (uintmax_t) freeram
/ 1024,
6938 (uintmax_t) totalswap
/ 1024,
6939 (uintmax_t) freeswap
/ 1024);
6943 unsigned long totalram
, freeram
, totalswap
, freeswap
;
6945 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6946 return list4i ((uintmax_t) totalram
/ 1024,
6947 (uintmax_t) freeram
/ 1024,
6948 (uintmax_t) totalswap
/ 1024,
6949 (uintmax_t) freeswap
/ 1024);
6952 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6953 /* FIXME: add more systems. */
6955 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6958 /* Debugging aids. */
6960 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6961 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6962 This may be helpful in debugging Emacs's memory usage.
6963 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6969 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
6972 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6978 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6979 doc
: /* Return a list of counters that measure how much consing there has been.
6980 Each of these counters increments for a certain kind of object.
6981 The counters wrap around from the largest positive integer to zero.
6982 Garbage collection does not decrease them.
6983 The elements of the value are as follows:
6984 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6985 All are in units of 1 = one object consed
6986 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6988 MISCS include overlays, markers, and some internal types.
6989 Frames, windows, buffers, and subprocesses count as vectors
6990 (but the contents of a buffer's text do not count here). */)
6993 return listn (CONSTYPE_HEAP
, 8,
6994 bounded_number (cons_cells_consed
),
6995 bounded_number (floats_consed
),
6996 bounded_number (vector_cells_consed
),
6997 bounded_number (symbols_consed
),
6998 bounded_number (string_chars_consed
),
6999 bounded_number (misc_objects_consed
),
7000 bounded_number (intervals_consed
),
7001 bounded_number (strings_consed
));
7005 symbol_uses_obj (Lisp_Object symbol
, Lisp_Object obj
)
7007 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
7008 Lisp_Object val
= find_symbol_value (symbol
);
7009 return (EQ (val
, obj
)
7010 || EQ (sym
->function
, obj
)
7011 || (!NILP (sym
->function
)
7012 && COMPILEDP (sym
->function
)
7013 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
7016 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)));
7019 /* Find at most FIND_MAX symbols which have OBJ as their value or
7020 function. This is used in gdbinit's `xwhichsymbols' command. */
7023 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
7025 struct symbol_block
*sblk
;
7026 ptrdiff_t gc_count
= inhibit_garbage_collection ();
7027 Lisp_Object found
= Qnil
;
7031 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
7033 Lisp_Object sym
= builtin_lisp_symbol (i
);
7034 if (symbol_uses_obj (sym
, obj
))
7036 found
= Fcons (sym
, found
);
7037 if (--find_max
== 0)
7042 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7044 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
7047 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
7049 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7052 Lisp_Object sym
= make_lisp_symbol (&aligned_sym
->s
);
7053 if (symbol_uses_obj (sym
, obj
))
7055 found
= Fcons (sym
, found
);
7056 if (--find_max
== 0)
7064 unbind_to (gc_count
, Qnil
);
7068 #ifdef SUSPICIOUS_OBJECT_CHECKING
7071 find_suspicious_object_in_range (void *begin
, void *end
)
7073 char *begin_a
= begin
;
7077 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7079 char *suspicious_object
= suspicious_objects
[i
];
7080 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7081 return suspicious_object
;
7088 note_suspicious_free (void* ptr
)
7090 struct suspicious_free_record
* rec
;
7092 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7093 if (suspicious_free_history_index
==
7094 ARRAYELTS (suspicious_free_history
))
7096 suspicious_free_history_index
= 0;
7099 memset (rec
, 0, sizeof (*rec
));
7100 rec
->suspicious_object
= ptr
;
7101 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7105 detect_suspicious_free (void* ptr
)
7109 eassert (ptr
!= NULL
);
7111 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7112 if (suspicious_objects
[i
] == ptr
)
7114 note_suspicious_free (ptr
);
7115 suspicious_objects
[i
] = NULL
;
7119 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7121 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7122 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7123 If Emacs is compiled with suspicious object checking, capture
7124 a stack trace when OBJ is freed in order to help track down
7125 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7128 #ifdef SUSPICIOUS_OBJECT_CHECKING
7129 /* Right now, we care only about vectors. */
7130 if (VECTORLIKEP (obj
))
7132 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7133 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7134 suspicious_object_index
= 0;
7140 #ifdef ENABLE_CHECKING
7142 bool suppress_checking
;
7145 die (const char *msg
, const char *file
, int line
)
7147 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7149 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7152 #endif /* ENABLE_CHECKING */
7154 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7156 /* Debugging check whether STR is ASCII-only. */
7159 verify_ascii (const char *str
)
7161 const unsigned char *ptr
= (unsigned char *) str
, *end
= ptr
+ strlen (str
);
7164 int c
= STRING_CHAR_ADVANCE (ptr
);
7165 if (!ASCII_CHAR_P (c
))
7171 /* Stress alloca with inconveniently sized requests and check
7172 whether all allocated areas may be used for Lisp_Object. */
7174 NO_INLINE
static void
7175 verify_alloca (void)
7178 enum { ALLOCA_CHECK_MAX
= 256 };
7179 /* Start from size of the smallest Lisp object. */
7180 for (i
= sizeof (struct Lisp_Cons
); i
<= ALLOCA_CHECK_MAX
; i
++)
7182 void *ptr
= alloca (i
);
7183 make_lisp_ptr (ptr
, Lisp_Cons
);
7187 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7189 #define verify_alloca() ((void) 0)
7191 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7193 /* Initialization. */
7196 init_alloc_once (void)
7198 /* Even though Qt's contents are not set up, its address is known. */
7202 pure_size
= PURESIZE
;
7205 init_finalizer_list (&finalizers
);
7206 init_finalizer_list (&doomed_finalizers
);
7209 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7211 #ifdef DOUG_LEA_MALLOC
7212 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7213 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7214 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7219 refill_memory_reserve ();
7220 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7226 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7227 setjmp_tested_p
= longjmps_done
= 0;
7229 Vgc_elapsed
= make_float (0.0);
7233 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7238 syms_of_alloc (void)
7240 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7241 doc
: /* Number of bytes of consing between garbage collections.
7242 Garbage collection can happen automatically once this many bytes have been
7243 allocated since the last garbage collection. All data types count.
7245 Garbage collection happens automatically only when `eval' is called.
7247 By binding this temporarily to a large number, you can effectively
7248 prevent garbage collection during a part of the program.
7249 See also `gc-cons-percentage'. */);
7251 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7252 doc
: /* Portion of the heap used for allocation.
7253 Garbage collection can happen automatically once this portion of the heap
7254 has been allocated since the last garbage collection.
7255 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7256 Vgc_cons_percentage
= make_float (0.1);
7258 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7259 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7261 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7262 doc
: /* Number of cons cells that have been consed so far. */);
7264 DEFVAR_INT ("floats-consed", floats_consed
,
7265 doc
: /* Number of floats that have been consed so far. */);
7267 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7268 doc
: /* Number of vector cells that have been consed so far. */);
7270 DEFVAR_INT ("symbols-consed", symbols_consed
,
7271 doc
: /* Number of symbols that have been consed so far. */);
7272 symbols_consed
+= ARRAYELTS (lispsym
);
7274 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7275 doc
: /* Number of string characters that have been consed so far. */);
7277 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7278 doc
: /* Number of miscellaneous objects that have been consed so far.
7279 These include markers and overlays, plus certain objects not visible
7282 DEFVAR_INT ("intervals-consed", intervals_consed
,
7283 doc
: /* Number of intervals that have been consed so far. */);
7285 DEFVAR_INT ("strings-consed", strings_consed
,
7286 doc
: /* Number of strings that have been consed so far. */);
7288 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7289 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7290 This means that certain objects should be allocated in shared (pure) space.
7291 It can also be set to a hash-table, in which case this table is used to
7292 do hash-consing of the objects allocated to pure space. */);
7294 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7295 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7296 garbage_collection_messages
= 0;
7298 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7299 doc
: /* Hook run after garbage collection has finished. */);
7300 Vpost_gc_hook
= Qnil
;
7301 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7303 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7304 doc
: /* Precomputed `signal' argument for memory-full error. */);
7305 /* We build this in advance because if we wait until we need it, we might
7306 not be able to allocate the memory to hold it. */
7308 = listn (CONSTYPE_PURE
, 2, Qerror
,
7309 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7311 DEFVAR_LISP ("memory-full", Vmemory_full
,
7312 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7313 Vmemory_full
= Qnil
;
7315 DEFSYM (Qconses
, "conses");
7316 DEFSYM (Qsymbols
, "symbols");
7317 DEFSYM (Qmiscs
, "miscs");
7318 DEFSYM (Qstrings
, "strings");
7319 DEFSYM (Qvectors
, "vectors");
7320 DEFSYM (Qfloats
, "floats");
7321 DEFSYM (Qintervals
, "intervals");
7322 DEFSYM (Qbuffers
, "buffers");
7323 DEFSYM (Qstring_bytes
, "string-bytes");
7324 DEFSYM (Qvector_slots
, "vector-slots");
7325 DEFSYM (Qheap
, "heap");
7326 DEFSYM (Qautomatic_gc
, "Automatic GC");
7328 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7329 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7331 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7332 doc
: /* Accumulated time elapsed in garbage collections.
7333 The time is in seconds as a floating point value. */);
7334 DEFVAR_INT ("gcs-done", gcs_done
,
7335 doc
: /* Accumulated number of garbage collections done. */);
7340 defsubr (&Sbool_vector
);
7341 defsubr (&Smake_byte_code
);
7342 defsubr (&Smake_list
);
7343 defsubr (&Smake_vector
);
7344 defsubr (&Smake_string
);
7345 defsubr (&Smake_bool_vector
);
7346 defsubr (&Smake_symbol
);
7347 defsubr (&Smake_marker
);
7348 defsubr (&Smake_finalizer
);
7349 defsubr (&Spurecopy
);
7350 defsubr (&Sgarbage_collect
);
7351 defsubr (&Smemory_limit
);
7352 defsubr (&Smemory_info
);
7353 defsubr (&Smemory_use_counts
);
7354 defsubr (&Ssuspicious_object
);
7357 /* When compiled with GCC, GDB might say "No enum type named
7358 pvec_type" if we don't have at least one symbol with that type, and
7359 then xbacktrace could fail. Similarly for the other enums and
7360 their values. Some non-GCC compilers don't like these constructs. */
7364 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7365 enum char_table_specials char_table_specials
;
7366 enum char_bits char_bits
;
7367 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7368 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7369 enum Lisp_Bits Lisp_Bits
;
7370 enum Lisp_Compiled Lisp_Compiled
;
7371 enum maxargs maxargs
;
7372 enum MAX_ALLOCA MAX_ALLOCA
;
7373 enum More_Lisp_Bits More_Lisp_Bits
;
7374 enum pvec_type pvec_type
;
7375 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7376 #endif /* __GNUC__ */