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. */
26 #ifdef ENABLE_CHECKING
27 #include <signal.h> /* For SIGABRT. */
35 #include "dispextern.h"
36 #include "intervals.h"
39 #include "character.h"
44 #include "blockinput.h"
45 #include "termhooks.h" /* For struct terminal. */
46 #ifdef HAVE_WINDOW_SYSTEM
48 #endif /* HAVE_WINDOW_SYSTEM */
51 #include <execinfo.h> /* For backtrace. */
53 #ifdef HAVE_LINUX_SYSINFO
54 #include <sys/sysinfo.h>
58 #include "dosfns.h" /* For dos_memory_info. */
61 #if (defined ENABLE_CHECKING \
62 && defined HAVE_VALGRIND_VALGRIND_H \
63 && !defined USE_VALGRIND)
64 # define USE_VALGRIND 1
68 #include <valgrind/valgrind.h>
69 #include <valgrind/memcheck.h>
70 static bool valgrind_p
;
73 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */
75 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
76 memory. Can do this only if using gmalloc.c and if not checking
79 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
80 || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
81 #undef GC_MALLOC_CHECK
92 #include "w32heap.h" /* for sbrk */
95 #if defined DOUG_LEA_MALLOC || defined GNU_LINUX
96 /* The address where the heap starts. */
107 #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 /* Get and free this pointer; useful around unexec. */
122 alloc_unexec_pre (void)
124 malloc_state_ptr
= malloc_get_state ();
127 alloc_unexec_post (void)
129 free (malloc_state_ptr
);
132 /* Restore the dumped malloc state. Because malloc can be invoked
133 even before main (e.g. by the dynamic linker), the dumped malloc
134 state must be restored as early as possible using this special hook. */
136 malloc_initialize_hook (void)
138 static bool malloc_using_checking
;
143 malloc_using_checking
= getenv ("MALLOC_CHECK_") != NULL
;
147 if (!malloc_using_checking
)
149 /* Work around a bug in glibc's malloc. MALLOC_CHECK_ must be
150 ignored if the heap to be restored was constructed without
151 malloc checking. Can't use unsetenv, since that calls malloc. */
155 if (strncmp (*p
, "MALLOC_CHECK_=", 14) == 0)
165 malloc_set_state (malloc_state_ptr
);
166 # ifndef XMALLOC_OVERRUN_CHECK
167 alloc_unexec_post ();
172 # ifndef __MALLOC_HOOK_VOLATILE
173 # define __MALLOC_HOOK_VOLATILE
175 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook
176 = malloc_initialize_hook
;
180 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
181 to a struct Lisp_String. */
183 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
184 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
185 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
187 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
188 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
189 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
191 /* Default value of gc_cons_threshold (see below). */
193 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
195 /* Global variables. */
196 struct emacs_globals globals
;
198 /* Number of bytes of consing done since the last gc. */
200 EMACS_INT consing_since_gc
;
202 /* Similar minimum, computed from Vgc_cons_percentage. */
204 EMACS_INT gc_relative_threshold
;
206 /* Minimum number of bytes of consing since GC before next GC,
207 when memory is full. */
209 EMACS_INT memory_full_cons_threshold
;
211 /* True during GC. */
215 /* True means abort if try to GC.
216 This is for code which is written on the assumption that
217 no GC will happen, so as to verify that assumption. */
221 /* Number of live and free conses etc. */
223 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
224 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
225 static EMACS_INT total_free_floats
, total_floats
;
227 /* Points to memory space allocated as "spare", to be freed if we run
228 out of memory. We keep one large block, four cons-blocks, and
229 two string blocks. */
231 static char *spare_memory
[7];
233 /* Amount of spare memory to keep in large reserve block, or to see
234 whether this much is available when malloc fails on a larger request. */
236 #define SPARE_MEMORY (1 << 14)
238 /* Initialize it to a nonzero value to force it into data space
239 (rather than bss space). That way unexec will remap it into text
240 space (pure), on some systems. We have not implemented the
241 remapping on more recent systems because this is less important
242 nowadays than in the days of small memories and timesharing. */
244 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
245 #define PUREBEG (char *) pure
247 /* Pointer to the pure area, and its size. */
249 static char *purebeg
;
250 static ptrdiff_t pure_size
;
252 /* Number of bytes of pure storage used before pure storage overflowed.
253 If this is non-zero, this implies that an overflow occurred. */
255 static ptrdiff_t pure_bytes_used_before_overflow
;
257 /* Index in pure at which next pure Lisp object will be allocated.. */
259 static ptrdiff_t pure_bytes_used_lisp
;
261 /* Number of bytes allocated for non-Lisp objects in pure storage. */
263 static ptrdiff_t pure_bytes_used_non_lisp
;
265 /* If nonzero, this is a warning delivered by malloc and not yet
268 const char *pending_malloc_warning
;
270 #if 0 /* Normally, pointer sanity only on request... */
271 #ifdef ENABLE_CHECKING
272 #define SUSPICIOUS_OBJECT_CHECKING 1
276 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
277 bug is unresolved. */
278 #define SUSPICIOUS_OBJECT_CHECKING 1
280 #ifdef SUSPICIOUS_OBJECT_CHECKING
281 struct suspicious_free_record
283 void *suspicious_object
;
284 void *backtrace
[128];
286 static void *suspicious_objects
[32];
287 static int suspicious_object_index
;
288 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
289 static int suspicious_free_history_index
;
290 /* Find the first currently-monitored suspicious pointer in range
291 [begin,end) or NULL if no such pointer exists. */
292 static void *find_suspicious_object_in_range (void *begin
, void *end
);
293 static void detect_suspicious_free (void *ptr
);
295 # define find_suspicious_object_in_range(begin, end) NULL
296 # define detect_suspicious_free(ptr) (void)
299 /* Maximum amount of C stack to save when a GC happens. */
301 #ifndef MAX_SAVE_STACK
302 #define MAX_SAVE_STACK 16000
305 /* Buffer in which we save a copy of the C stack at each GC. */
307 #if MAX_SAVE_STACK > 0
308 static char *stack_copy
;
309 static ptrdiff_t stack_copy_size
;
311 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
312 avoiding any address sanitization. */
314 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
315 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
317 if (! ADDRESS_SANITIZER
)
318 return memcpy (dest
, src
, size
);
324 for (i
= 0; i
< size
; i
++)
330 #endif /* MAX_SAVE_STACK > 0 */
332 static void mark_terminals (void);
333 static void gc_sweep (void);
334 static Lisp_Object
make_pure_vector (ptrdiff_t);
335 static void mark_buffer (struct buffer
*);
337 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
338 static void refill_memory_reserve (void);
340 static void compact_small_strings (void);
341 static void free_large_strings (void);
342 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
344 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
345 what memory allocated via lisp_malloc and lisp_align_malloc is intended
346 for what purpose. This enumeration specifies the type of memory. */
357 /* Since all non-bool pseudovectors are small enough to be
358 allocated from vector blocks, this memory type denotes
359 large regular vectors and large bool pseudovectors. */
361 /* Special type to denote vector blocks. */
362 MEM_TYPE_VECTOR_BLOCK
,
363 /* Special type to denote reserved memory. */
367 /* A unique object in pure space used to make some Lisp objects
368 on free lists recognizable in O(1). */
370 static Lisp_Object Vdead
;
371 #define DEADP(x) EQ (x, Vdead)
373 #ifdef GC_MALLOC_CHECK
375 enum mem_type allocated_mem_type
;
377 #endif /* GC_MALLOC_CHECK */
379 /* A node in the red-black tree describing allocated memory containing
380 Lisp data. Each such block is recorded with its start and end
381 address when it is allocated, and removed from the tree when it
384 A red-black tree is a balanced binary tree with the following
387 1. Every node is either red or black.
388 2. Every leaf is black.
389 3. If a node is red, then both of its children are black.
390 4. Every simple path from a node to a descendant leaf contains
391 the same number of black nodes.
392 5. The root is always black.
394 When nodes are inserted into the tree, or deleted from the tree,
395 the tree is "fixed" so that these properties are always true.
397 A red-black tree with N internal nodes has height at most 2
398 log(N+1). Searches, insertions and deletions are done in O(log N).
399 Please see a text book about data structures for a detailed
400 description of red-black trees. Any book worth its salt should
405 /* Children of this node. These pointers are never NULL. When there
406 is no child, the value is MEM_NIL, which points to a dummy node. */
407 struct mem_node
*left
, *right
;
409 /* The parent of this node. In the root node, this is NULL. */
410 struct mem_node
*parent
;
412 /* Start and end of allocated region. */
416 enum {MEM_BLACK
, MEM_RED
} color
;
422 /* Base address of stack. Set in main. */
424 Lisp_Object
*stack_base
;
426 /* Root of the tree describing allocated Lisp memory. */
428 static struct mem_node
*mem_root
;
430 /* Lowest and highest known address in the heap. */
432 static void *min_heap_address
, *max_heap_address
;
434 /* Sentinel node of the tree. */
436 static struct mem_node mem_z
;
437 #define MEM_NIL &mem_z
439 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
440 static void mem_insert_fixup (struct mem_node
*);
441 static void mem_rotate_left (struct mem_node
*);
442 static void mem_rotate_right (struct mem_node
*);
443 static void mem_delete (struct mem_node
*);
444 static void mem_delete_fixup (struct mem_node
*);
445 static struct mem_node
*mem_find (void *);
451 /* Addresses of staticpro'd variables. Initialize it to a nonzero
452 value; otherwise some compilers put it into BSS. */
454 enum { NSTATICS
= 2048 };
455 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
457 /* Index of next unused slot in staticvec. */
459 static int staticidx
;
461 static void *pure_alloc (size_t, int);
463 /* Return X rounded to the next multiple of Y. Arguments should not
464 have side effects, as they are evaluated more than once. Assume X
465 + Y - 1 does not overflow. Tune for Y being a power of 2. */
467 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
468 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
469 : ((x) + (y) - 1) & ~ ((y) - 1))
471 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
474 ALIGN (void *ptr
, int alignment
)
476 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
479 /* Extract the pointer hidden within A, if A is not a symbol.
480 If A is a symbol, extract the hidden pointer's offset from lispsym,
481 converted to void *. */
483 #define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
484 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
486 /* Extract the pointer hidden within A. */
488 #define macro_XPNTR(a) \
489 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
490 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
492 /* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
493 functions, as functions are cleaner and can be used in debuggers.
494 Also, define them as macros if being compiled with GCC without
495 optimization, for performance in that case. The macro_* names are
496 private to this section of code. */
498 static ATTRIBUTE_UNUSED
void *
499 XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a
)
501 return macro_XPNTR_OR_SYMBOL_OFFSET (a
);
503 static ATTRIBUTE_UNUSED
void *
504 XPNTR (Lisp_Object a
)
506 return macro_XPNTR (a
);
509 #if DEFINE_KEY_OPS_AS_MACROS
510 # define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
511 # define XPNTR(a) macro_XPNTR (a)
515 XFLOAT_INIT (Lisp_Object f
, double n
)
517 XFLOAT (f
)->u
.data
= n
;
520 #ifdef DOUG_LEA_MALLOC
522 pointers_fit_in_lispobj_p (void)
524 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
528 mmap_lisp_allowed_p (void)
530 /* If we can't store all memory addresses in our lisp objects, it's
531 risky to let the heap use mmap and give us addresses from all
532 over our address space. We also can't use mmap for lisp objects
533 if we might dump: unexec doesn't preserve the contents of mmapped
535 return pointers_fit_in_lispobj_p () && !might_dump
;
539 /* Head of a circularly-linked list of extant finalizers. */
540 static struct Lisp_Finalizer finalizers
;
542 /* Head of a circularly-linked list of finalizers that must be invoked
543 because we deemed them unreachable. This list must be global, and
544 not a local inside garbage_collect_1, in case we GC again while
545 running finalizers. */
546 static struct Lisp_Finalizer doomed_finalizers
;
549 /************************************************************************
551 ************************************************************************/
553 /* Function malloc calls this if it finds we are near exhausting storage. */
556 malloc_warning (const char *str
)
558 pending_malloc_warning
= str
;
562 /* Display an already-pending malloc warning. */
565 display_malloc_warning (void)
567 call3 (intern ("display-warning"),
569 build_string (pending_malloc_warning
),
570 intern ("emergency"));
571 pending_malloc_warning
= 0;
574 /* Called if we can't allocate relocatable space for a buffer. */
577 buffer_memory_full (ptrdiff_t nbytes
)
579 /* If buffers use the relocating allocator, no need to free
580 spare_memory, because we may have plenty of malloc space left
581 that we could get, and if we don't, the malloc that fails will
582 itself cause spare_memory to be freed. If buffers don't use the
583 relocating allocator, treat this like any other failing
587 memory_full (nbytes
);
589 /* This used to call error, but if we've run out of memory, we could
590 get infinite recursion trying to build the string. */
591 xsignal (Qnil
, Vmemory_signal_data
);
595 /* A common multiple of the positive integers A and B. Ideally this
596 would be the least common multiple, but there's no way to do that
597 as a constant expression in C, so do the best that we can easily do. */
598 #define COMMON_MULTIPLE(a, b) \
599 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
601 #ifndef XMALLOC_OVERRUN_CHECK
602 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
605 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
608 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
609 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
610 block size in little-endian order. The trailer consists of
611 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
613 The header is used to detect whether this block has been allocated
614 through these functions, as some low-level libc functions may
615 bypass the malloc hooks. */
617 #define XMALLOC_OVERRUN_CHECK_SIZE 16
618 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
619 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
621 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
622 hold a size_t value and (2) the header size is a multiple of the
623 alignment that Emacs needs for C types and for USE_LSB_TAG. */
624 #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
626 #define XMALLOC_HEADER_ALIGNMENT \
627 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
628 #define XMALLOC_OVERRUN_SIZE_SIZE \
629 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
630 + XMALLOC_HEADER_ALIGNMENT - 1) \
631 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
632 - XMALLOC_OVERRUN_CHECK_SIZE)
634 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
635 { '\x9a', '\x9b', '\xae', '\xaf',
636 '\xbf', '\xbe', '\xce', '\xcf',
637 '\xea', '\xeb', '\xec', '\xed',
638 '\xdf', '\xde', '\x9c', '\x9d' };
640 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
641 { '\xaa', '\xab', '\xac', '\xad',
642 '\xba', '\xbb', '\xbc', '\xbd',
643 '\xca', '\xcb', '\xcc', '\xcd',
644 '\xda', '\xdb', '\xdc', '\xdd' };
646 /* Insert and extract the block size in the header. */
649 xmalloc_put_size (unsigned char *ptr
, size_t size
)
652 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
654 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
660 xmalloc_get_size (unsigned char *ptr
)
664 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
665 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
674 /* Like malloc, but wraps allocated block with header and trailer. */
677 overrun_check_malloc (size_t size
)
679 register unsigned char *val
;
680 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
683 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
686 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
687 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
688 xmalloc_put_size (val
, size
);
689 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
690 XMALLOC_OVERRUN_CHECK_SIZE
);
696 /* Like realloc, but checks old block for overrun, and wraps new block
697 with header and trailer. */
700 overrun_check_realloc (void *block
, size_t size
)
702 register unsigned char *val
= (unsigned char *) block
;
703 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
707 && memcmp (xmalloc_overrun_check_header
,
708 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
709 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
711 size_t osize
= xmalloc_get_size (val
);
712 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
713 XMALLOC_OVERRUN_CHECK_SIZE
))
715 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
716 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
717 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
720 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
724 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
725 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
726 xmalloc_put_size (val
, size
);
727 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
728 XMALLOC_OVERRUN_CHECK_SIZE
);
733 /* Like free, but checks block for overrun. */
736 overrun_check_free (void *block
)
738 unsigned char *val
= (unsigned char *) block
;
741 && memcmp (xmalloc_overrun_check_header
,
742 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
743 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
745 size_t osize
= xmalloc_get_size (val
);
746 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
747 XMALLOC_OVERRUN_CHECK_SIZE
))
749 #ifdef XMALLOC_CLEAR_FREE_MEMORY
750 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
751 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
753 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
754 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
755 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
765 #define malloc overrun_check_malloc
766 #define realloc overrun_check_realloc
767 #define free overrun_check_free
770 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
771 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
772 If that variable is set, block input while in one of Emacs's memory
773 allocation functions. There should be no need for this debugging
774 option, since signal handlers do not allocate memory, but Emacs
775 formerly allocated memory in signal handlers and this compile-time
776 option remains as a way to help debug the issue should it rear its
778 #ifdef XMALLOC_BLOCK_INPUT_CHECK
779 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
781 malloc_block_input (void)
783 if (block_input_in_memory_allocators
)
787 malloc_unblock_input (void)
789 if (block_input_in_memory_allocators
)
792 # define MALLOC_BLOCK_INPUT malloc_block_input ()
793 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
795 # define MALLOC_BLOCK_INPUT ((void) 0)
796 # define MALLOC_UNBLOCK_INPUT ((void) 0)
799 #define MALLOC_PROBE(size) \
801 if (profiler_memory_running) \
802 malloc_probe (size); \
806 /* Like malloc but check for no memory and block interrupt input.. */
809 xmalloc (size_t size
)
815 MALLOC_UNBLOCK_INPUT
;
823 /* Like the above, but zeroes out the memory just allocated. */
826 xzalloc (size_t size
)
832 MALLOC_UNBLOCK_INPUT
;
836 memset (val
, 0, size
);
841 /* Like realloc but check for no memory and block interrupt input.. */
844 xrealloc (void *block
, size_t size
)
849 /* We must call malloc explicitly when BLOCK is 0, since some
850 reallocs don't do this. */
854 val
= realloc (block
, size
);
855 MALLOC_UNBLOCK_INPUT
;
864 /* Like free but block interrupt input. */
873 MALLOC_UNBLOCK_INPUT
;
874 /* We don't call refill_memory_reserve here
875 because in practice the call in r_alloc_free seems to suffice. */
879 /* Other parts of Emacs pass large int values to allocator functions
880 expecting ptrdiff_t. This is portable in practice, but check it to
882 verify (INT_MAX
<= PTRDIFF_MAX
);
885 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
886 Signal an error on memory exhaustion, and block interrupt input. */
889 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
891 eassert (0 <= nitems
&& 0 < item_size
);
893 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
894 memory_full (SIZE_MAX
);
895 return xmalloc (nbytes
);
899 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
900 Signal an error on memory exhaustion, and block interrupt input. */
903 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
905 eassert (0 <= nitems
&& 0 < item_size
);
907 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
908 memory_full (SIZE_MAX
);
909 return xrealloc (pa
, nbytes
);
913 /* Grow PA, which points to an array of *NITEMS items, and return the
914 location of the reallocated array, updating *NITEMS to reflect its
915 new size. The new array will contain at least NITEMS_INCR_MIN more
916 items, but will not contain more than NITEMS_MAX items total.
917 ITEM_SIZE is the size of each item, in bytes.
919 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
920 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
923 If PA is null, then allocate a new array instead of reallocating
926 Block interrupt input as needed. If memory exhaustion occurs, set
927 *NITEMS to zero if PA is null, and signal an error (i.e., do not
930 Thus, to grow an array A without saving its old contents, do
931 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
932 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
933 and signals an error, and later this code is reexecuted and
934 attempts to free A. */
937 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
938 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
940 ptrdiff_t n0
= *nitems
;
941 eassume (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n0
&& -1 <= nitems_max
);
943 /* The approximate size to use for initial small allocation
944 requests. This is the largest "small" request for the GNU C
946 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
948 /* If the array is tiny, grow it to about (but no greater than)
949 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
950 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
951 NITEMS_MAX, and what the C language can represent safely. */
954 if (INT_ADD_WRAPV (n0
, n0
>> 1, &n
))
956 if (0 <= nitems_max
&& nitems_max
< n
)
959 ptrdiff_t adjusted_nbytes
960 = ((INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
961 ? min (PTRDIFF_MAX
, SIZE_MAX
)
962 : nbytes
< DEFAULT_MXFAST
? DEFAULT_MXFAST
: 0);
965 n
= adjusted_nbytes
/ item_size
;
966 nbytes
= adjusted_nbytes
- adjusted_nbytes
% item_size
;
971 if (n
- n0
< nitems_incr_min
972 && (INT_ADD_WRAPV (n0
, nitems_incr_min
, &n
)
973 || (0 <= nitems_max
&& nitems_max
< n
)
974 || INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
)))
975 memory_full (SIZE_MAX
);
976 pa
= xrealloc (pa
, nbytes
);
982 /* Like strdup, but uses xmalloc. */
985 xstrdup (const char *s
)
989 size
= strlen (s
) + 1;
990 return memcpy (xmalloc (size
), s
, size
);
993 /* Like above, but duplicates Lisp string to C string. */
996 xlispstrdup (Lisp_Object string
)
998 ptrdiff_t size
= SBYTES (string
) + 1;
999 return memcpy (xmalloc (size
), SSDATA (string
), size
);
1002 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1003 pointed to. If STRING is null, assign it without copying anything.
1004 Allocate before freeing, to avoid a dangling pointer if allocation
1008 dupstring (char **ptr
, char const *string
)
1011 *ptr
= string
? xstrdup (string
) : 0;
1016 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1017 argument is a const pointer. */
1020 xputenv (char const *string
)
1022 if (putenv ((char *) string
) != 0)
1026 /* Return a newly allocated memory block of SIZE bytes, remembering
1027 to free it when unwinding. */
1029 record_xmalloc (size_t size
)
1031 void *p
= xmalloc (size
);
1032 record_unwind_protect_ptr (xfree
, p
);
1037 /* Like malloc but used for allocating Lisp data. NBYTES is the
1038 number of bytes to allocate, TYPE describes the intended use of the
1039 allocated memory block (for strings, for conses, ...). */
1042 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
1046 lisp_malloc (size_t nbytes
, enum mem_type type
)
1052 #ifdef GC_MALLOC_CHECK
1053 allocated_mem_type
= type
;
1056 val
= malloc (nbytes
);
1059 /* If the memory just allocated cannot be addressed thru a Lisp
1060 object's pointer, and it needs to be,
1061 that's equivalent to running out of memory. */
1062 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1065 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
1066 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
1068 lisp_malloc_loser
= val
;
1075 #ifndef GC_MALLOC_CHECK
1076 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1077 mem_insert (val
, (char *) val
+ nbytes
, type
);
1080 MALLOC_UNBLOCK_INPUT
;
1082 memory_full (nbytes
);
1083 MALLOC_PROBE (nbytes
);
1087 /* Free BLOCK. This must be called to free memory allocated with a
1088 call to lisp_malloc. */
1091 lisp_free (void *block
)
1095 #ifndef GC_MALLOC_CHECK
1096 mem_delete (mem_find (block
));
1098 MALLOC_UNBLOCK_INPUT
;
1101 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1103 /* The entry point is lisp_align_malloc which returns blocks of at most
1104 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1106 /* Use aligned_alloc if it or a simple substitute is available.
1107 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1108 clang 3.3 anyway. Aligned allocation is incompatible with
1109 unexmacosx.c, so don't use it on Darwin. */
1111 #if ! ADDRESS_SANITIZER && !defined DARWIN_OS
1112 # if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
1113 # define USE_ALIGNED_ALLOC 1
1114 # ifndef HAVE_ALIGNED_ALLOC
1115 /* Defined in gmalloc.c. */
1116 void *aligned_alloc (size_t, size_t);
1118 # elif defined HYBRID_MALLOC
1119 # if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
1120 # define USE_ALIGNED_ALLOC 1
1121 # define aligned_alloc hybrid_aligned_alloc
1122 /* Defined in gmalloc.c. */
1123 void *aligned_alloc (size_t, size_t);
1125 # elif defined HAVE_ALIGNED_ALLOC
1126 # define USE_ALIGNED_ALLOC 1
1127 # elif defined HAVE_POSIX_MEMALIGN
1128 # define USE_ALIGNED_ALLOC 1
1130 aligned_alloc (size_t alignment
, size_t size
)
1133 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1138 /* BLOCK_ALIGN has to be a power of 2. */
1139 #define BLOCK_ALIGN (1 << 10)
1141 /* Padding to leave at the end of a malloc'd block. This is to give
1142 malloc a chance to minimize the amount of memory wasted to alignment.
1143 It should be tuned to the particular malloc library used.
1144 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1145 aligned_alloc on the other hand would ideally prefer a value of 4
1146 because otherwise, there's 1020 bytes wasted between each ablocks.
1147 In Emacs, testing shows that those 1020 can most of the time be
1148 efficiently used by malloc to place other objects, so a value of 0 can
1149 still preferable unless you have a lot of aligned blocks and virtually
1151 #define BLOCK_PADDING 0
1152 #define BLOCK_BYTES \
1153 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1155 /* Internal data structures and constants. */
1157 #define ABLOCKS_SIZE 16
1159 /* An aligned block of memory. */
1164 char payload
[BLOCK_BYTES
];
1165 struct ablock
*next_free
;
1167 /* `abase' is the aligned base of the ablocks. */
1168 /* It is overloaded to hold the virtual `busy' field that counts
1169 the number of used ablock in the parent ablocks.
1170 The first ablock has the `busy' field, the others have the `abase'
1171 field. To tell the difference, we assume that pointers will have
1172 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1173 is used to tell whether the real base of the parent ablocks is `abase'
1174 (if not, the word before the first ablock holds a pointer to the
1176 struct ablocks
*abase
;
1177 /* The padding of all but the last ablock is unused. The padding of
1178 the last ablock in an ablocks is not allocated. */
1180 char padding
[BLOCK_PADDING
];
1184 /* A bunch of consecutive aligned blocks. */
1187 struct ablock blocks
[ABLOCKS_SIZE
];
1190 /* Size of the block requested from malloc or aligned_alloc. */
1191 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1193 #define ABLOCK_ABASE(block) \
1194 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1195 ? (struct ablocks *)(block) \
1198 /* Virtual `busy' field. */
1199 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1201 /* Pointer to the (not necessarily aligned) malloc block. */
1202 #ifdef USE_ALIGNED_ALLOC
1203 #define ABLOCKS_BASE(abase) (abase)
1205 #define ABLOCKS_BASE(abase) \
1206 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1209 /* The list of free ablock. */
1210 static struct ablock
*free_ablock
;
1212 /* Allocate an aligned block of nbytes.
1213 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1214 smaller or equal to BLOCK_BYTES. */
1216 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1219 struct ablocks
*abase
;
1221 eassert (nbytes
<= BLOCK_BYTES
);
1225 #ifdef GC_MALLOC_CHECK
1226 allocated_mem_type
= type
;
1232 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1234 #ifdef DOUG_LEA_MALLOC
1235 if (!mmap_lisp_allowed_p ())
1236 mallopt (M_MMAP_MAX
, 0);
1239 #ifdef USE_ALIGNED_ALLOC
1240 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1242 base
= malloc (ABLOCKS_BYTES
);
1243 abase
= ALIGN (base
, BLOCK_ALIGN
);
1248 MALLOC_UNBLOCK_INPUT
;
1249 memory_full (ABLOCKS_BYTES
);
1252 aligned
= (base
== abase
);
1254 ((void **) abase
)[-1] = base
;
1256 #ifdef DOUG_LEA_MALLOC
1257 if (!mmap_lisp_allowed_p ())
1258 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1262 /* If the memory just allocated cannot be addressed thru a Lisp
1263 object's pointer, and it needs to be, that's equivalent to
1264 running out of memory. */
1265 if (type
!= MEM_TYPE_NON_LISP
)
1268 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1269 XSETCONS (tem
, end
);
1270 if ((char *) XCONS (tem
) != end
)
1272 lisp_malloc_loser
= base
;
1274 MALLOC_UNBLOCK_INPUT
;
1275 memory_full (SIZE_MAX
);
1280 /* Initialize the blocks and put them on the free list.
1281 If `base' was not properly aligned, we can't use the last block. */
1282 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1284 abase
->blocks
[i
].abase
= abase
;
1285 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1286 free_ablock
= &abase
->blocks
[i
];
1288 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1290 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1291 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1292 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1293 eassert (ABLOCKS_BASE (abase
) == base
);
1294 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1297 abase
= ABLOCK_ABASE (free_ablock
);
1298 ABLOCKS_BUSY (abase
)
1299 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1301 free_ablock
= free_ablock
->x
.next_free
;
1303 #ifndef GC_MALLOC_CHECK
1304 if (type
!= MEM_TYPE_NON_LISP
)
1305 mem_insert (val
, (char *) val
+ nbytes
, type
);
1308 MALLOC_UNBLOCK_INPUT
;
1310 MALLOC_PROBE (nbytes
);
1312 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1317 lisp_align_free (void *block
)
1319 struct ablock
*ablock
= block
;
1320 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1323 #ifndef GC_MALLOC_CHECK
1324 mem_delete (mem_find (block
));
1326 /* Put on free list. */
1327 ablock
->x
.next_free
= free_ablock
;
1328 free_ablock
= ablock
;
1329 /* Update busy count. */
1330 ABLOCKS_BUSY (abase
)
1331 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1333 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1334 { /* All the blocks are free. */
1335 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1336 struct ablock
**tem
= &free_ablock
;
1337 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1341 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1344 *tem
= (*tem
)->x
.next_free
;
1347 tem
= &(*tem
)->x
.next_free
;
1349 eassert ((aligned
& 1) == aligned
);
1350 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1351 #ifdef USE_POSIX_MEMALIGN
1352 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1354 free (ABLOCKS_BASE (abase
));
1356 MALLOC_UNBLOCK_INPUT
;
1360 /***********************************************************************
1362 ***********************************************************************/
1364 /* Number of intervals allocated in an interval_block structure.
1365 The 1020 is 1024 minus malloc overhead. */
1367 #define INTERVAL_BLOCK_SIZE \
1368 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1370 /* Intervals are allocated in chunks in the form of an interval_block
1373 struct interval_block
1375 /* Place `intervals' first, to preserve alignment. */
1376 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1377 struct interval_block
*next
;
1380 /* Current interval block. Its `next' pointer points to older
1383 static struct interval_block
*interval_block
;
1385 /* Index in interval_block above of the next unused interval
1388 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1390 /* Number of free and live intervals. */
1392 static EMACS_INT total_free_intervals
, total_intervals
;
1394 /* List of free intervals. */
1396 static INTERVAL interval_free_list
;
1398 /* Return a new interval. */
1401 make_interval (void)
1407 if (interval_free_list
)
1409 val
= interval_free_list
;
1410 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1414 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1416 struct interval_block
*newi
1417 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1419 newi
->next
= interval_block
;
1420 interval_block
= newi
;
1421 interval_block_index
= 0;
1422 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1424 val
= &interval_block
->intervals
[interval_block_index
++];
1427 MALLOC_UNBLOCK_INPUT
;
1429 consing_since_gc
+= sizeof (struct interval
);
1431 total_free_intervals
--;
1432 RESET_INTERVAL (val
);
1438 /* Mark Lisp objects in interval I. */
1441 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1443 /* Intervals should never be shared. So, if extra internal checking is
1444 enabled, GC aborts if it seems to have visited an interval twice. */
1445 eassert (!i
->gcmarkbit
);
1447 mark_object (i
->plist
);
1450 /* Mark the interval tree rooted in I. */
1452 #define MARK_INTERVAL_TREE(i) \
1454 if (i && !i->gcmarkbit) \
1455 traverse_intervals_noorder (i, mark_interval, Qnil); \
1458 /***********************************************************************
1460 ***********************************************************************/
1462 /* Lisp_Strings are allocated in string_block structures. When a new
1463 string_block is allocated, all the Lisp_Strings it contains are
1464 added to a free-list string_free_list. When a new Lisp_String is
1465 needed, it is taken from that list. During the sweep phase of GC,
1466 string_blocks that are entirely free are freed, except two which
1469 String data is allocated from sblock structures. Strings larger
1470 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1471 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1473 Sblocks consist internally of sdata structures, one for each
1474 Lisp_String. The sdata structure points to the Lisp_String it
1475 belongs to. The Lisp_String points back to the `u.data' member of
1476 its sdata structure.
1478 When a Lisp_String is freed during GC, it is put back on
1479 string_free_list, and its `data' member and its sdata's `string'
1480 pointer is set to null. The size of the string is recorded in the
1481 `n.nbytes' member of the sdata. So, sdata structures that are no
1482 longer used, can be easily recognized, and it's easy to compact the
1483 sblocks of small strings which we do in compact_small_strings. */
1485 /* Size in bytes of an sblock structure used for small strings. This
1486 is 8192 minus malloc overhead. */
1488 #define SBLOCK_SIZE 8188
1490 /* Strings larger than this are considered large strings. String data
1491 for large strings is allocated from individual sblocks. */
1493 #define LARGE_STRING_BYTES 1024
1495 /* The SDATA typedef is a struct or union describing string memory
1496 sub-allocated from an sblock. This is where the contents of Lisp
1497 strings are stored. */
1501 /* Back-pointer to the string this sdata belongs to. If null, this
1502 structure is free, and NBYTES (in this structure or in the union below)
1503 contains the string's byte size (the same value that STRING_BYTES
1504 would return if STRING were non-null). If non-null, STRING_BYTES
1505 (STRING) is the size of the data, and DATA contains the string's
1507 struct Lisp_String
*string
;
1509 #ifdef GC_CHECK_STRING_BYTES
1513 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1516 #ifdef GC_CHECK_STRING_BYTES
1518 typedef struct sdata sdata
;
1519 #define SDATA_NBYTES(S) (S)->nbytes
1520 #define SDATA_DATA(S) (S)->data
1526 struct Lisp_String
*string
;
1528 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1529 which has a flexible array member. However, if implemented by
1530 giving this union a member of type 'struct sdata', the union
1531 could not be the last (flexible) member of 'struct sblock',
1532 because C99 prohibits a flexible array member from having a type
1533 that is itself a flexible array. So, comment this member out here,
1534 but remember that the option's there when using this union. */
1539 /* When STRING is null. */
1542 struct Lisp_String
*string
;
1547 #define SDATA_NBYTES(S) (S)->n.nbytes
1548 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1550 #endif /* not GC_CHECK_STRING_BYTES */
1552 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1554 /* Structure describing a block of memory which is sub-allocated to
1555 obtain string data memory for strings. Blocks for small strings
1556 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1557 as large as needed. */
1562 struct sblock
*next
;
1564 /* Pointer to the next free sdata block. This points past the end
1565 of the sblock if there isn't any space left in this block. */
1569 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1572 /* Number of Lisp strings in a string_block structure. The 1020 is
1573 1024 minus malloc overhead. */
1575 #define STRING_BLOCK_SIZE \
1576 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1578 /* Structure describing a block from which Lisp_String structures
1583 /* Place `strings' first, to preserve alignment. */
1584 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1585 struct string_block
*next
;
1588 /* Head and tail of the list of sblock structures holding Lisp string
1589 data. We always allocate from current_sblock. The NEXT pointers
1590 in the sblock structures go from oldest_sblock to current_sblock. */
1592 static struct sblock
*oldest_sblock
, *current_sblock
;
1594 /* List of sblocks for large strings. */
1596 static struct sblock
*large_sblocks
;
1598 /* List of string_block structures. */
1600 static struct string_block
*string_blocks
;
1602 /* Free-list of Lisp_Strings. */
1604 static struct Lisp_String
*string_free_list
;
1606 /* Number of live and free Lisp_Strings. */
1608 static EMACS_INT total_strings
, total_free_strings
;
1610 /* Number of bytes used by live strings. */
1612 static EMACS_INT total_string_bytes
;
1614 /* Given a pointer to a Lisp_String S which is on the free-list
1615 string_free_list, return a pointer to its successor in the
1618 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1620 /* Return a pointer to the sdata structure belonging to Lisp string S.
1621 S must be live, i.e. S->data must not be null. S->data is actually
1622 a pointer to the `u.data' member of its sdata structure; the
1623 structure starts at a constant offset in front of that. */
1625 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1628 #ifdef GC_CHECK_STRING_OVERRUN
1630 /* We check for overrun in string data blocks by appending a small
1631 "cookie" after each allocated string data block, and check for the
1632 presence of this cookie during GC. */
1634 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1635 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1636 { '\xde', '\xad', '\xbe', '\xef' };
1639 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1642 /* Value is the size of an sdata structure large enough to hold NBYTES
1643 bytes of string data. The value returned includes a terminating
1644 NUL byte, the size of the sdata structure, and padding. */
1646 #ifdef GC_CHECK_STRING_BYTES
1648 #define SDATA_SIZE(NBYTES) \
1649 ((SDATA_DATA_OFFSET \
1651 + sizeof (ptrdiff_t) - 1) \
1652 & ~(sizeof (ptrdiff_t) - 1))
1654 #else /* not GC_CHECK_STRING_BYTES */
1656 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1657 less than the size of that member. The 'max' is not needed when
1658 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1659 alignment code reserves enough space. */
1661 #define SDATA_SIZE(NBYTES) \
1662 ((SDATA_DATA_OFFSET \
1663 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1665 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1667 + sizeof (ptrdiff_t) - 1) \
1668 & ~(sizeof (ptrdiff_t) - 1))
1670 #endif /* not GC_CHECK_STRING_BYTES */
1672 /* Extra bytes to allocate for each string. */
1674 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1676 /* Exact bound on the number of bytes in a string, not counting the
1677 terminating null. A string cannot contain more bytes than
1678 STRING_BYTES_BOUND, nor can it be so long that the size_t
1679 arithmetic in allocate_string_data would overflow while it is
1680 calculating a value to be passed to malloc. */
1681 static ptrdiff_t const STRING_BYTES_MAX
=
1682 min (STRING_BYTES_BOUND
,
1683 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1685 - offsetof (struct sblock
, data
)
1686 - SDATA_DATA_OFFSET
)
1687 & ~(sizeof (EMACS_INT
) - 1)));
1689 /* Initialize string allocation. Called from init_alloc_once. */
1694 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1695 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1699 #ifdef GC_CHECK_STRING_BYTES
1701 static int check_string_bytes_count
;
1703 /* Like STRING_BYTES, but with debugging check. Can be
1704 called during GC, so pay attention to the mark bit. */
1707 string_bytes (struct Lisp_String
*s
)
1710 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1712 if (!PURE_P (s
) && s
->data
&& nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1717 /* Check validity of Lisp strings' string_bytes member in B. */
1720 check_sblock (struct sblock
*b
)
1722 sdata
*from
, *end
, *from_end
;
1726 for (from
= b
->data
; from
< end
; from
= from_end
)
1728 /* Compute the next FROM here because copying below may
1729 overwrite data we need to compute it. */
1732 /* Check that the string size recorded in the string is the
1733 same as the one recorded in the sdata structure. */
1734 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1735 : SDATA_NBYTES (from
));
1736 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1741 /* Check validity of Lisp strings' string_bytes member. ALL_P
1742 means check all strings, otherwise check only most
1743 recently allocated strings. Used for hunting a bug. */
1746 check_string_bytes (bool all_p
)
1752 for (b
= large_sblocks
; b
; b
= b
->next
)
1754 struct Lisp_String
*s
= b
->data
[0].string
;
1759 for (b
= oldest_sblock
; b
; b
= b
->next
)
1762 else if (current_sblock
)
1763 check_sblock (current_sblock
);
1766 #else /* not GC_CHECK_STRING_BYTES */
1768 #define check_string_bytes(all) ((void) 0)
1770 #endif /* GC_CHECK_STRING_BYTES */
1772 #ifdef GC_CHECK_STRING_FREE_LIST
1774 /* Walk through the string free list looking for bogus next pointers.
1775 This may catch buffer overrun from a previous string. */
1778 check_string_free_list (void)
1780 struct Lisp_String
*s
;
1782 /* Pop a Lisp_String off the free-list. */
1783 s
= string_free_list
;
1786 if ((uintptr_t) s
< 1024)
1788 s
= NEXT_FREE_LISP_STRING (s
);
1792 #define check_string_free_list()
1795 /* Return a new Lisp_String. */
1797 static struct Lisp_String
*
1798 allocate_string (void)
1800 struct Lisp_String
*s
;
1804 /* If the free-list is empty, allocate a new string_block, and
1805 add all the Lisp_Strings in it to the free-list. */
1806 if (string_free_list
== NULL
)
1808 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1811 b
->next
= string_blocks
;
1814 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1817 /* Every string on a free list should have NULL data pointer. */
1819 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1820 string_free_list
= s
;
1823 total_free_strings
+= STRING_BLOCK_SIZE
;
1826 check_string_free_list ();
1828 /* Pop a Lisp_String off the free-list. */
1829 s
= string_free_list
;
1830 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1832 MALLOC_UNBLOCK_INPUT
;
1834 --total_free_strings
;
1837 consing_since_gc
+= sizeof *s
;
1839 #ifdef GC_CHECK_STRING_BYTES
1840 if (!noninteractive
)
1842 if (++check_string_bytes_count
== 200)
1844 check_string_bytes_count
= 0;
1845 check_string_bytes (1);
1848 check_string_bytes (0);
1850 #endif /* GC_CHECK_STRING_BYTES */
1856 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1857 plus a NUL byte at the end. Allocate an sdata structure for S, and
1858 set S->data to its `u.data' member. Store a NUL byte at the end of
1859 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1860 S->data if it was initially non-null. */
1863 allocate_string_data (struct Lisp_String
*s
,
1864 EMACS_INT nchars
, EMACS_INT nbytes
)
1866 sdata
*data
, *old_data
;
1868 ptrdiff_t needed
, old_nbytes
;
1870 if (STRING_BYTES_MAX
< nbytes
)
1873 /* Determine the number of bytes needed to store NBYTES bytes
1875 needed
= SDATA_SIZE (nbytes
);
1878 old_data
= SDATA_OF_STRING (s
);
1879 old_nbytes
= STRING_BYTES (s
);
1886 if (nbytes
> LARGE_STRING_BYTES
)
1888 size_t size
= offsetof (struct sblock
, data
) + needed
;
1890 #ifdef DOUG_LEA_MALLOC
1891 if (!mmap_lisp_allowed_p ())
1892 mallopt (M_MMAP_MAX
, 0);
1895 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1897 #ifdef DOUG_LEA_MALLOC
1898 if (!mmap_lisp_allowed_p ())
1899 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1902 b
->next_free
= b
->data
;
1903 b
->data
[0].string
= NULL
;
1904 b
->next
= large_sblocks
;
1907 else if (current_sblock
== NULL
1908 || (((char *) current_sblock
+ SBLOCK_SIZE
1909 - (char *) current_sblock
->next_free
)
1910 < (needed
+ GC_STRING_EXTRA
)))
1912 /* Not enough room in the current sblock. */
1913 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1914 b
->next_free
= b
->data
;
1915 b
->data
[0].string
= NULL
;
1919 current_sblock
->next
= b
;
1927 data
= b
->next_free
;
1928 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1930 MALLOC_UNBLOCK_INPUT
;
1933 s
->data
= SDATA_DATA (data
);
1934 #ifdef GC_CHECK_STRING_BYTES
1935 SDATA_NBYTES (data
) = nbytes
;
1938 s
->size_byte
= nbytes
;
1939 s
->data
[nbytes
] = '\0';
1940 #ifdef GC_CHECK_STRING_OVERRUN
1941 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1942 GC_STRING_OVERRUN_COOKIE_SIZE
);
1945 /* Note that Faset may call to this function when S has already data
1946 assigned. In this case, mark data as free by setting it's string
1947 back-pointer to null, and record the size of the data in it. */
1950 SDATA_NBYTES (old_data
) = old_nbytes
;
1951 old_data
->string
= NULL
;
1954 consing_since_gc
+= needed
;
1958 /* Sweep and compact strings. */
1960 NO_INLINE
/* For better stack traces */
1962 sweep_strings (void)
1964 struct string_block
*b
, *next
;
1965 struct string_block
*live_blocks
= NULL
;
1967 string_free_list
= NULL
;
1968 total_strings
= total_free_strings
= 0;
1969 total_string_bytes
= 0;
1971 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1972 for (b
= string_blocks
; b
; b
= next
)
1975 struct Lisp_String
*free_list_before
= string_free_list
;
1979 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1981 struct Lisp_String
*s
= b
->strings
+ i
;
1985 /* String was not on free-list before. */
1986 if (STRING_MARKED_P (s
))
1988 /* String is live; unmark it and its intervals. */
1991 /* Do not use string_(set|get)_intervals here. */
1992 s
->intervals
= balance_intervals (s
->intervals
);
1995 total_string_bytes
+= STRING_BYTES (s
);
1999 /* String is dead. Put it on the free-list. */
2000 sdata
*data
= SDATA_OF_STRING (s
);
2002 /* Save the size of S in its sdata so that we know
2003 how large that is. Reset the sdata's string
2004 back-pointer so that we know it's free. */
2005 #ifdef GC_CHECK_STRING_BYTES
2006 if (string_bytes (s
) != SDATA_NBYTES (data
))
2009 data
->n
.nbytes
= STRING_BYTES (s
);
2011 data
->string
= NULL
;
2013 /* Reset the strings's `data' member so that we
2017 /* Put the string on the free-list. */
2018 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2019 string_free_list
= s
;
2025 /* S was on the free-list before. Put it there again. */
2026 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2027 string_free_list
= s
;
2032 /* Free blocks that contain free Lisp_Strings only, except
2033 the first two of them. */
2034 if (nfree
== STRING_BLOCK_SIZE
2035 && total_free_strings
> STRING_BLOCK_SIZE
)
2038 string_free_list
= free_list_before
;
2042 total_free_strings
+= nfree
;
2043 b
->next
= live_blocks
;
2048 check_string_free_list ();
2050 string_blocks
= live_blocks
;
2051 free_large_strings ();
2052 compact_small_strings ();
2054 check_string_free_list ();
2058 /* Free dead large strings. */
2061 free_large_strings (void)
2063 struct sblock
*b
, *next
;
2064 struct sblock
*live_blocks
= NULL
;
2066 for (b
= large_sblocks
; b
; b
= next
)
2070 if (b
->data
[0].string
== NULL
)
2074 b
->next
= live_blocks
;
2079 large_sblocks
= live_blocks
;
2083 /* Compact data of small strings. Free sblocks that don't contain
2084 data of live strings after compaction. */
2087 compact_small_strings (void)
2089 struct sblock
*b
, *tb
, *next
;
2090 sdata
*from
, *to
, *end
, *tb_end
;
2091 sdata
*to_end
, *from_end
;
2093 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2094 to, and TB_END is the end of TB. */
2096 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2099 /* Step through the blocks from the oldest to the youngest. We
2100 expect that old blocks will stabilize over time, so that less
2101 copying will happen this way. */
2102 for (b
= oldest_sblock
; b
; b
= b
->next
)
2105 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2107 for (from
= b
->data
; from
< end
; from
= from_end
)
2109 /* Compute the next FROM here because copying below may
2110 overwrite data we need to compute it. */
2112 struct Lisp_String
*s
= from
->string
;
2114 #ifdef GC_CHECK_STRING_BYTES
2115 /* Check that the string size recorded in the string is the
2116 same as the one recorded in the sdata structure. */
2117 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2119 #endif /* GC_CHECK_STRING_BYTES */
2121 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2122 eassert (nbytes
<= LARGE_STRING_BYTES
);
2124 nbytes
= SDATA_SIZE (nbytes
);
2125 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2127 #ifdef GC_CHECK_STRING_OVERRUN
2128 if (memcmp (string_overrun_cookie
,
2129 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2130 GC_STRING_OVERRUN_COOKIE_SIZE
))
2134 /* Non-NULL S means it's alive. Copy its data. */
2137 /* If TB is full, proceed with the next sblock. */
2138 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2139 if (to_end
> tb_end
)
2143 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2145 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2148 /* Copy, and update the string's `data' pointer. */
2151 eassert (tb
!= b
|| to
< from
);
2152 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2153 to
->string
->data
= SDATA_DATA (to
);
2156 /* Advance past the sdata we copied to. */
2162 /* The rest of the sblocks following TB don't contain live data, so
2163 we can free them. */
2164 for (b
= tb
->next
; b
; b
= next
)
2172 current_sblock
= tb
;
2176 string_overflow (void)
2178 error ("Maximum string size exceeded");
2181 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2182 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2183 LENGTH must be an integer.
2184 INIT must be an integer that represents a character. */)
2185 (Lisp_Object length
, Lisp_Object init
)
2187 register Lisp_Object val
;
2191 CHECK_NATNUM (length
);
2192 CHECK_CHARACTER (init
);
2194 c
= XFASTINT (init
);
2195 if (ASCII_CHAR_P (c
))
2197 nbytes
= XINT (length
);
2198 val
= make_uninit_string (nbytes
);
2201 memset (SDATA (val
), c
, nbytes
);
2202 SDATA (val
)[nbytes
] = 0;
2207 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2208 ptrdiff_t len
= CHAR_STRING (c
, str
);
2209 EMACS_INT string_len
= XINT (length
);
2210 unsigned char *p
, *beg
, *end
;
2212 if (INT_MULTIPLY_WRAPV (len
, string_len
, &nbytes
))
2214 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2215 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2217 /* First time we just copy `str' to the data of `val'. */
2219 memcpy (p
, str
, len
);
2222 /* Next time we copy largest possible chunk from
2223 initialized to uninitialized part of `val'. */
2224 len
= min (p
- beg
, end
- p
);
2225 memcpy (p
, beg
, len
);
2235 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2239 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2241 EMACS_INT nbits
= bool_vector_size (a
);
2244 unsigned char *data
= bool_vector_uchar_data (a
);
2245 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2246 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2247 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2248 memset (data
, pattern
, nbytes
- 1);
2249 data
[nbytes
- 1] = pattern
& last_mask
;
2254 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2257 make_uninit_bool_vector (EMACS_INT nbits
)
2260 EMACS_INT words
= bool_vector_words (nbits
);
2261 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2262 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2265 struct Lisp_Bool_Vector
*p
2266 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2267 XSETVECTOR (val
, p
);
2268 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2271 /* Clear padding at the end. */
2273 p
->data
[words
- 1] = 0;
2278 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2279 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2280 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2281 (Lisp_Object length
, Lisp_Object init
)
2285 CHECK_NATNUM (length
);
2286 val
= make_uninit_bool_vector (XFASTINT (length
));
2287 return bool_vector_fill (val
, init
);
2290 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2291 doc
: /* Return a new bool-vector with specified arguments as elements.
2292 Any number of arguments, even zero arguments, are allowed.
2293 usage: (bool-vector &rest OBJECTS) */)
2294 (ptrdiff_t nargs
, Lisp_Object
*args
)
2299 vector
= make_uninit_bool_vector (nargs
);
2300 for (i
= 0; i
< nargs
; i
++)
2301 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2306 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2307 of characters from the contents. This string may be unibyte or
2308 multibyte, depending on the contents. */
2311 make_string (const char *contents
, ptrdiff_t nbytes
)
2313 register Lisp_Object val
;
2314 ptrdiff_t nchars
, multibyte_nbytes
;
2316 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2317 &nchars
, &multibyte_nbytes
);
2318 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2319 /* CONTENTS contains no multibyte sequences or contains an invalid
2320 multibyte sequence. We must make unibyte string. */
2321 val
= make_unibyte_string (contents
, nbytes
);
2323 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2327 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2330 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2332 register Lisp_Object val
;
2333 val
= make_uninit_string (length
);
2334 memcpy (SDATA (val
), contents
, length
);
2339 /* Make a multibyte string from NCHARS characters occupying NBYTES
2340 bytes at CONTENTS. */
2343 make_multibyte_string (const char *contents
,
2344 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2346 register Lisp_Object val
;
2347 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2348 memcpy (SDATA (val
), contents
, nbytes
);
2353 /* Make a string from NCHARS characters occupying NBYTES bytes at
2354 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2357 make_string_from_bytes (const char *contents
,
2358 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2360 register Lisp_Object val
;
2361 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2362 memcpy (SDATA (val
), contents
, nbytes
);
2363 if (SBYTES (val
) == SCHARS (val
))
2364 STRING_SET_UNIBYTE (val
);
2369 /* Make a string from NCHARS characters occupying NBYTES bytes at
2370 CONTENTS. The argument MULTIBYTE controls whether to label the
2371 string as multibyte. If NCHARS is negative, it counts the number of
2372 characters by itself. */
2375 make_specified_string (const char *contents
,
2376 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2383 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2388 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2389 memcpy (SDATA (val
), contents
, nbytes
);
2391 STRING_SET_UNIBYTE (val
);
2396 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2397 occupying LENGTH bytes. */
2400 make_uninit_string (EMACS_INT length
)
2405 return empty_unibyte_string
;
2406 val
= make_uninit_multibyte_string (length
, length
);
2407 STRING_SET_UNIBYTE (val
);
2412 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2413 which occupy NBYTES bytes. */
2416 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2419 struct Lisp_String
*s
;
2424 return empty_multibyte_string
;
2426 s
= allocate_string ();
2427 s
->intervals
= NULL
;
2428 allocate_string_data (s
, nchars
, nbytes
);
2429 XSETSTRING (string
, s
);
2430 string_chars_consed
+= nbytes
;
2434 /* Print arguments to BUF according to a FORMAT, then return
2435 a Lisp_String initialized with the data from BUF. */
2438 make_formatted_string (char *buf
, const char *format
, ...)
2443 va_start (ap
, format
);
2444 length
= vsprintf (buf
, format
, ap
);
2446 return make_string (buf
, length
);
2450 /***********************************************************************
2452 ***********************************************************************/
2454 /* We store float cells inside of float_blocks, allocating a new
2455 float_block with malloc whenever necessary. Float cells reclaimed
2456 by GC are put on a free list to be reallocated before allocating
2457 any new float cells from the latest float_block. */
2459 #define FLOAT_BLOCK_SIZE \
2460 (((BLOCK_BYTES - sizeof (struct float_block *) \
2461 /* The compiler might add padding at the end. */ \
2462 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2463 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2465 #define GETMARKBIT(block,n) \
2466 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2467 >> ((n) % BITS_PER_BITS_WORD)) \
2470 #define SETMARKBIT(block,n) \
2471 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2472 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2474 #define UNSETMARKBIT(block,n) \
2475 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2476 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2478 #define FLOAT_BLOCK(fptr) \
2479 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2481 #define FLOAT_INDEX(fptr) \
2482 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2486 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2487 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2488 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2489 struct float_block
*next
;
2492 #define FLOAT_MARKED_P(fptr) \
2493 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2495 #define FLOAT_MARK(fptr) \
2496 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2498 #define FLOAT_UNMARK(fptr) \
2499 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2501 /* Current float_block. */
2503 static struct float_block
*float_block
;
2505 /* Index of first unused Lisp_Float in the current float_block. */
2507 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2509 /* Free-list of Lisp_Floats. */
2511 static struct Lisp_Float
*float_free_list
;
2513 /* Return a new float object with value FLOAT_VALUE. */
2516 make_float (double float_value
)
2518 register Lisp_Object val
;
2522 if (float_free_list
)
2524 /* We use the data field for chaining the free list
2525 so that we won't use the same field that has the mark bit. */
2526 XSETFLOAT (val
, float_free_list
);
2527 float_free_list
= float_free_list
->u
.chain
;
2531 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2533 struct float_block
*new
2534 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2535 new->next
= float_block
;
2536 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2538 float_block_index
= 0;
2539 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2541 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2542 float_block_index
++;
2545 MALLOC_UNBLOCK_INPUT
;
2547 XFLOAT_INIT (val
, float_value
);
2548 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2549 consing_since_gc
+= sizeof (struct Lisp_Float
);
2551 total_free_floats
--;
2557 /***********************************************************************
2559 ***********************************************************************/
2561 /* We store cons cells inside of cons_blocks, allocating a new
2562 cons_block with malloc whenever necessary. Cons cells reclaimed by
2563 GC are put on a free list to be reallocated before allocating
2564 any new cons cells from the latest cons_block. */
2566 #define CONS_BLOCK_SIZE \
2567 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2568 /* The compiler might add padding at the end. */ \
2569 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2570 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2572 #define CONS_BLOCK(fptr) \
2573 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2575 #define CONS_INDEX(fptr) \
2576 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2580 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2581 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2582 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2583 struct cons_block
*next
;
2586 #define CONS_MARKED_P(fptr) \
2587 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2589 #define CONS_MARK(fptr) \
2590 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2592 #define CONS_UNMARK(fptr) \
2593 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2595 /* Current cons_block. */
2597 static struct cons_block
*cons_block
;
2599 /* Index of first unused Lisp_Cons in the current block. */
2601 static int cons_block_index
= CONS_BLOCK_SIZE
;
2603 /* Free-list of Lisp_Cons structures. */
2605 static struct Lisp_Cons
*cons_free_list
;
2607 /* Explicitly free a cons cell by putting it on the free-list. */
2610 free_cons (struct Lisp_Cons
*ptr
)
2612 ptr
->u
.chain
= cons_free_list
;
2614 cons_free_list
= ptr
;
2615 consing_since_gc
-= sizeof *ptr
;
2616 total_free_conses
++;
2619 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2620 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2621 (Lisp_Object car
, Lisp_Object cdr
)
2623 register Lisp_Object val
;
2629 /* We use the cdr for chaining the free list
2630 so that we won't use the same field that has the mark bit. */
2631 XSETCONS (val
, cons_free_list
);
2632 cons_free_list
= cons_free_list
->u
.chain
;
2636 if (cons_block_index
== CONS_BLOCK_SIZE
)
2638 struct cons_block
*new
2639 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2640 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2641 new->next
= cons_block
;
2643 cons_block_index
= 0;
2644 total_free_conses
+= CONS_BLOCK_SIZE
;
2646 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2650 MALLOC_UNBLOCK_INPUT
;
2654 eassert (!CONS_MARKED_P (XCONS (val
)));
2655 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2656 total_free_conses
--;
2657 cons_cells_consed
++;
2661 #ifdef GC_CHECK_CONS_LIST
2662 /* Get an error now if there's any junk in the cons free list. */
2664 check_cons_list (void)
2666 struct Lisp_Cons
*tail
= cons_free_list
;
2669 tail
= tail
->u
.chain
;
2673 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2676 list1 (Lisp_Object arg1
)
2678 return Fcons (arg1
, Qnil
);
2682 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2684 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2689 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2691 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2696 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2698 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2703 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2705 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2706 Fcons (arg5
, Qnil
)))));
2709 /* Make a list of COUNT Lisp_Objects, where ARG is the
2710 first one. Allocate conses from pure space if TYPE
2711 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2714 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2716 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2719 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2720 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2721 default: emacs_abort ();
2724 eassume (0 < count
);
2725 Lisp_Object val
= cons (arg
, Qnil
);
2726 Lisp_Object tail
= val
;
2730 for (ptrdiff_t i
= 1; i
< count
; i
++)
2732 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2733 XSETCDR (tail
, elem
);
2741 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2742 doc
: /* Return a newly created list with specified arguments as elements.
2743 Any number of arguments, even zero arguments, are allowed.
2744 usage: (list &rest OBJECTS) */)
2745 (ptrdiff_t nargs
, Lisp_Object
*args
)
2747 register Lisp_Object val
;
2753 val
= Fcons (args
[nargs
], val
);
2759 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2760 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2761 (register Lisp_Object length
, Lisp_Object init
)
2763 register Lisp_Object val
;
2764 register EMACS_INT size
;
2766 CHECK_NATNUM (length
);
2767 size
= XFASTINT (length
);
2772 val
= Fcons (init
, val
);
2777 val
= Fcons (init
, val
);
2782 val
= Fcons (init
, val
);
2787 val
= Fcons (init
, val
);
2792 val
= Fcons (init
, val
);
2807 /***********************************************************************
2809 ***********************************************************************/
2811 /* Sometimes a vector's contents are merely a pointer internally used
2812 in vector allocation code. On the rare platforms where a null
2813 pointer cannot be tagged, represent it with a Lisp 0.
2814 Usually you don't want to touch this. */
2816 static struct Lisp_Vector
*
2817 next_vector (struct Lisp_Vector
*v
)
2819 return XUNTAG (v
->contents
[0], Lisp_Int0
);
2823 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2825 v
->contents
[0] = make_lisp_ptr (p
, Lisp_Int0
);
2828 /* This value is balanced well enough to avoid too much internal overhead
2829 for the most common cases; it's not required to be a power of two, but
2830 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2832 #define VECTOR_BLOCK_SIZE 4096
2836 /* Alignment of struct Lisp_Vector objects. */
2837 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2840 /* Vector size requests are a multiple of this. */
2841 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2844 /* Verify assumptions described above. */
2845 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2846 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2848 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2849 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2850 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2851 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2853 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2855 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2857 /* Size of the minimal vector allocated from block. */
2859 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2861 /* Size of the largest vector allocated from block. */
2863 #define VBLOCK_BYTES_MAX \
2864 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2866 /* We maintain one free list for each possible block-allocated
2867 vector size, and this is the number of free lists we have. */
2869 #define VECTOR_MAX_FREE_LIST_INDEX \
2870 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2872 /* Common shortcut to advance vector pointer over a block data. */
2874 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2876 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2878 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2880 /* Common shortcut to setup vector on a free list. */
2882 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2884 (tmp) = ((nbytes - header_size) / word_size); \
2885 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2886 eassert ((nbytes) % roundup_size == 0); \
2887 (tmp) = VINDEX (nbytes); \
2888 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2889 set_next_vector (v, vector_free_lists[tmp]); \
2890 vector_free_lists[tmp] = (v); \
2891 total_free_vector_slots += (nbytes) / word_size; \
2894 /* This internal type is used to maintain the list of large vectors
2895 which are allocated at their own, e.g. outside of vector blocks.
2897 struct large_vector itself cannot contain a struct Lisp_Vector, as
2898 the latter contains a flexible array member and C99 does not allow
2899 such structs to be nested. Instead, each struct large_vector
2900 object LV is followed by a struct Lisp_Vector, which is at offset
2901 large_vector_offset from LV, and whose address is therefore
2902 large_vector_vec (&LV). */
2906 struct large_vector
*next
;
2911 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2914 static struct Lisp_Vector
*
2915 large_vector_vec (struct large_vector
*p
)
2917 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
2920 /* This internal type is used to maintain an underlying storage
2921 for small vectors. */
2925 char data
[VECTOR_BLOCK_BYTES
];
2926 struct vector_block
*next
;
2929 /* Chain of vector blocks. */
2931 static struct vector_block
*vector_blocks
;
2933 /* Vector free lists, where NTH item points to a chain of free
2934 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2936 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2938 /* Singly-linked list of large vectors. */
2940 static struct large_vector
*large_vectors
;
2942 /* The only vector with 0 slots, allocated from pure space. */
2944 Lisp_Object zero_vector
;
2946 /* Number of live vectors. */
2948 static EMACS_INT total_vectors
;
2950 /* Total size of live and free vectors, in Lisp_Object units. */
2952 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2954 /* Get a new vector block. */
2956 static struct vector_block
*
2957 allocate_vector_block (void)
2959 struct vector_block
*block
= xmalloc (sizeof *block
);
2961 #ifndef GC_MALLOC_CHECK
2962 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2963 MEM_TYPE_VECTOR_BLOCK
);
2966 block
->next
= vector_blocks
;
2967 vector_blocks
= block
;
2971 /* Called once to initialize vector allocation. */
2976 zero_vector
= make_pure_vector (0);
2979 /* Allocate vector from a vector block. */
2981 static struct Lisp_Vector
*
2982 allocate_vector_from_block (size_t nbytes
)
2984 struct Lisp_Vector
*vector
;
2985 struct vector_block
*block
;
2986 size_t index
, restbytes
;
2988 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2989 eassert (nbytes
% roundup_size
== 0);
2991 /* First, try to allocate from a free list
2992 containing vectors of the requested size. */
2993 index
= VINDEX (nbytes
);
2994 if (vector_free_lists
[index
])
2996 vector
= vector_free_lists
[index
];
2997 vector_free_lists
[index
] = next_vector (vector
);
2998 total_free_vector_slots
-= nbytes
/ word_size
;
3002 /* Next, check free lists containing larger vectors. Since
3003 we will split the result, we should have remaining space
3004 large enough to use for one-slot vector at least. */
3005 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3006 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3007 if (vector_free_lists
[index
])
3009 /* This vector is larger than requested. */
3010 vector
= vector_free_lists
[index
];
3011 vector_free_lists
[index
] = next_vector (vector
);
3012 total_free_vector_slots
-= nbytes
/ word_size
;
3014 /* Excess bytes are used for the smaller vector,
3015 which should be set on an appropriate free list. */
3016 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3017 eassert (restbytes
% roundup_size
== 0);
3018 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3022 /* Finally, need a new vector block. */
3023 block
= allocate_vector_block ();
3025 /* New vector will be at the beginning of this block. */
3026 vector
= (struct Lisp_Vector
*) block
->data
;
3028 /* If the rest of space from this block is large enough
3029 for one-slot vector at least, set up it on a free list. */
3030 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3031 if (restbytes
>= VBLOCK_BYTES_MIN
)
3033 eassert (restbytes
% roundup_size
== 0);
3034 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3039 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3041 #define VECTOR_IN_BLOCK(vector, block) \
3042 ((char *) (vector) <= (block)->data \
3043 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3045 /* Return the memory footprint of V in bytes. */
3048 vector_nbytes (struct Lisp_Vector
*v
)
3050 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
3053 if (size
& PSEUDOVECTOR_FLAG
)
3055 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
3057 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
3058 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
3059 * sizeof (bits_word
));
3060 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
3061 verify (header_size
<= bool_header_size
);
3062 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
3065 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
3066 + ((size
& PSEUDOVECTOR_REST_MASK
)
3067 >> PSEUDOVECTOR_SIZE_BITS
));
3071 return vroundup (header_size
+ word_size
* nwords
);
3074 /* Release extra resources still in use by VECTOR, which may be any
3075 vector-like object. For now, this is used just to free data in
3079 cleanup_vector (struct Lisp_Vector
*vector
)
3081 detect_suspicious_free (vector
);
3082 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
3083 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
3084 == FONT_OBJECT_MAX
))
3086 struct font_driver
*drv
= ((struct font
*) vector
)->driver
;
3088 /* The font driver might sometimes be NULL, e.g. if Emacs was
3089 interrupted before it had time to set it up. */
3092 /* Attempt to catch subtle bugs like Bug#16140. */
3093 eassert (valid_font_driver (drv
));
3094 drv
->close ((struct font
*) vector
);
3099 /* Reclaim space used by unmarked vectors. */
3101 NO_INLINE
/* For better stack traces */
3103 sweep_vectors (void)
3105 struct vector_block
*block
, **bprev
= &vector_blocks
;
3106 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3107 struct Lisp_Vector
*vector
, *next
;
3109 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3110 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3112 /* Looking through vector blocks. */
3114 for (block
= vector_blocks
; block
; block
= *bprev
)
3116 bool free_this_block
= 0;
3119 for (vector
= (struct Lisp_Vector
*) block
->data
;
3120 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3122 if (VECTOR_MARKED_P (vector
))
3124 VECTOR_UNMARK (vector
);
3126 nbytes
= vector_nbytes (vector
);
3127 total_vector_slots
+= nbytes
/ word_size
;
3128 next
= ADVANCE (vector
, nbytes
);
3132 ptrdiff_t total_bytes
;
3134 cleanup_vector (vector
);
3135 nbytes
= vector_nbytes (vector
);
3136 total_bytes
= nbytes
;
3137 next
= ADVANCE (vector
, nbytes
);
3139 /* While NEXT is not marked, try to coalesce with VECTOR,
3140 thus making VECTOR of the largest possible size. */
3142 while (VECTOR_IN_BLOCK (next
, block
))
3144 if (VECTOR_MARKED_P (next
))
3146 cleanup_vector (next
);
3147 nbytes
= vector_nbytes (next
);
3148 total_bytes
+= nbytes
;
3149 next
= ADVANCE (next
, nbytes
);
3152 eassert (total_bytes
% roundup_size
== 0);
3154 if (vector
== (struct Lisp_Vector
*) block
->data
3155 && !VECTOR_IN_BLOCK (next
, block
))
3156 /* This block should be freed because all of its
3157 space was coalesced into the only free vector. */
3158 free_this_block
= 1;
3162 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3167 if (free_this_block
)
3169 *bprev
= block
->next
;
3170 #ifndef GC_MALLOC_CHECK
3171 mem_delete (mem_find (block
->data
));
3176 bprev
= &block
->next
;
3179 /* Sweep large vectors. */
3181 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3183 vector
= large_vector_vec (lv
);
3184 if (VECTOR_MARKED_P (vector
))
3186 VECTOR_UNMARK (vector
);
3188 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3190 /* All non-bool pseudovectors are small enough to be allocated
3191 from vector blocks. This code should be redesigned if some
3192 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3193 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3194 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3198 += header_size
/ word_size
+ vector
->header
.size
;
3209 /* Value is a pointer to a newly allocated Lisp_Vector structure
3210 with room for LEN Lisp_Objects. */
3212 static struct Lisp_Vector
*
3213 allocate_vectorlike (ptrdiff_t len
)
3215 struct Lisp_Vector
*p
;
3220 p
= XVECTOR (zero_vector
);
3223 size_t nbytes
= header_size
+ len
* word_size
;
3225 #ifdef DOUG_LEA_MALLOC
3226 if (!mmap_lisp_allowed_p ())
3227 mallopt (M_MMAP_MAX
, 0);
3230 if (nbytes
<= VBLOCK_BYTES_MAX
)
3231 p
= allocate_vector_from_block (vroundup (nbytes
));
3234 struct large_vector
*lv
3235 = lisp_malloc ((large_vector_offset
+ header_size
3237 MEM_TYPE_VECTORLIKE
);
3238 lv
->next
= large_vectors
;
3240 p
= large_vector_vec (lv
);
3243 #ifdef DOUG_LEA_MALLOC
3244 if (!mmap_lisp_allowed_p ())
3245 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3248 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3251 consing_since_gc
+= nbytes
;
3252 vector_cells_consed
+= len
;
3255 MALLOC_UNBLOCK_INPUT
;
3261 /* Allocate a vector with LEN slots. */
3263 struct Lisp_Vector
*
3264 allocate_vector (EMACS_INT len
)
3266 struct Lisp_Vector
*v
;
3267 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3269 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3270 memory_full (SIZE_MAX
);
3271 v
= allocate_vectorlike (len
);
3273 v
->header
.size
= len
;
3278 /* Allocate other vector-like structures. */
3280 struct Lisp_Vector
*
3281 allocate_pseudovector (int memlen
, int lisplen
,
3282 int zerolen
, enum pvec_type tag
)
3284 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3286 /* Catch bogus values. */
3287 eassert (0 <= tag
&& tag
<= PVEC_FONT
);
3288 eassert (0 <= lisplen
&& lisplen
<= zerolen
&& zerolen
<= memlen
);
3289 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3290 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3292 /* Only the first LISPLEN slots will be traced normally by the GC. */
3293 memclear (v
->contents
, zerolen
* word_size
);
3294 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3299 allocate_buffer (void)
3301 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3303 BUFFER_PVEC_INIT (b
);
3304 /* Put B on the chain of all buffers including killed ones. */
3305 b
->next
= all_buffers
;
3307 /* Note that the rest fields of B are not initialized. */
3311 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3312 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3313 See also the function `vector'. */)
3314 (register Lisp_Object length
, Lisp_Object init
)
3317 register ptrdiff_t sizei
;
3318 register ptrdiff_t i
;
3319 register struct Lisp_Vector
*p
;
3321 CHECK_NATNUM (length
);
3323 p
= allocate_vector (XFASTINT (length
));
3324 sizei
= XFASTINT (length
);
3325 for (i
= 0; i
< sizei
; i
++)
3326 p
->contents
[i
] = init
;
3328 XSETVECTOR (vector
, p
);
3332 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3333 doc
: /* Return a newly created vector with specified arguments as elements.
3334 Any number of arguments, even zero arguments, are allowed.
3335 usage: (vector &rest OBJECTS) */)
3336 (ptrdiff_t nargs
, Lisp_Object
*args
)
3339 register Lisp_Object val
= make_uninit_vector (nargs
);
3340 register struct Lisp_Vector
*p
= XVECTOR (val
);
3342 for (i
= 0; i
< nargs
; i
++)
3343 p
->contents
[i
] = args
[i
];
3348 make_byte_code (struct Lisp_Vector
*v
)
3350 /* Don't allow the global zero_vector to become a byte code object. */
3351 eassert (0 < v
->header
.size
);
3353 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3354 && STRING_MULTIBYTE (v
->contents
[1]))
3355 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3356 earlier because they produced a raw 8-bit string for byte-code
3357 and now such a byte-code string is loaded as multibyte while
3358 raw 8-bit characters converted to multibyte form. Thus, now we
3359 must convert them back to the original unibyte form. */
3360 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3361 XSETPVECTYPE (v
, PVEC_COMPILED
);
3364 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3365 doc
: /* Create a byte-code object with specified arguments as elements.
3366 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3367 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3368 and (optional) INTERACTIVE-SPEC.
3369 The first four arguments are required; at most six have any
3371 The ARGLIST can be either like the one of `lambda', in which case the arguments
3372 will be dynamically bound before executing the byte code, or it can be an
3373 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3374 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3375 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3376 argument to catch the left-over arguments. If such an integer is used, the
3377 arguments will not be dynamically bound but will be instead pushed on the
3378 stack before executing the byte-code.
3379 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3380 (ptrdiff_t nargs
, Lisp_Object
*args
)
3383 register Lisp_Object val
= make_uninit_vector (nargs
);
3384 register struct Lisp_Vector
*p
= XVECTOR (val
);
3386 /* We used to purecopy everything here, if purify-flag was set. This worked
3387 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3388 dangerous, since make-byte-code is used during execution to build
3389 closures, so any closure built during the preload phase would end up
3390 copied into pure space, including its free variables, which is sometimes
3391 just wasteful and other times plainly wrong (e.g. those free vars may want
3394 for (i
= 0; i
< nargs
; i
++)
3395 p
->contents
[i
] = args
[i
];
3397 XSETCOMPILED (val
, p
);
3403 /***********************************************************************
3405 ***********************************************************************/
3407 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3408 of the required alignment. */
3410 union aligned_Lisp_Symbol
3412 struct Lisp_Symbol s
;
3413 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3417 /* Each symbol_block is just under 1020 bytes long, since malloc
3418 really allocates in units of powers of two and uses 4 bytes for its
3421 #define SYMBOL_BLOCK_SIZE \
3422 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3426 /* Place `symbols' first, to preserve alignment. */
3427 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3428 struct symbol_block
*next
;
3431 /* Current symbol block and index of first unused Lisp_Symbol
3434 static struct symbol_block
*symbol_block
;
3435 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3436 /* Pointer to the first symbol_block that contains pinned symbols.
3437 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3438 10K of which are pinned (and all but 250 of them are interned in obarray),
3439 whereas a "typical session" has in the order of 30K symbols.
3440 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3441 than 30K to find the 10K symbols we need to mark. */
3442 static struct symbol_block
*symbol_block_pinned
;
3444 /* List of free symbols. */
3446 static struct Lisp_Symbol
*symbol_free_list
;
3449 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3451 XSYMBOL (sym
)->name
= name
;
3455 init_symbol (Lisp_Object val
, Lisp_Object name
)
3457 struct Lisp_Symbol
*p
= XSYMBOL (val
);
3458 set_symbol_name (val
, name
);
3459 set_symbol_plist (val
, Qnil
);
3460 p
->redirect
= SYMBOL_PLAINVAL
;
3461 SET_SYMBOL_VAL (p
, Qunbound
);
3462 set_symbol_function (val
, Qnil
);
3463 set_symbol_next (val
, NULL
);
3464 p
->gcmarkbit
= false;
3465 p
->interned
= SYMBOL_UNINTERNED
;
3467 p
->declared_special
= false;
3471 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3472 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3473 Its value is void, and its function definition and property list are nil. */)
3478 CHECK_STRING (name
);
3482 if (symbol_free_list
)
3484 XSETSYMBOL (val
, symbol_free_list
);
3485 symbol_free_list
= symbol_free_list
->next
;
3489 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3491 struct symbol_block
*new
3492 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3493 new->next
= symbol_block
;
3495 symbol_block_index
= 0;
3496 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3498 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3499 symbol_block_index
++;
3502 MALLOC_UNBLOCK_INPUT
;
3504 init_symbol (val
, name
);
3505 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3507 total_free_symbols
--;
3513 /***********************************************************************
3514 Marker (Misc) Allocation
3515 ***********************************************************************/
3517 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3518 the required alignment. */
3520 union aligned_Lisp_Misc
3523 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3527 /* Allocation of markers and other objects that share that structure.
3528 Works like allocation of conses. */
3530 #define MARKER_BLOCK_SIZE \
3531 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3535 /* Place `markers' first, to preserve alignment. */
3536 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3537 struct marker_block
*next
;
3540 static struct marker_block
*marker_block
;
3541 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3543 static union Lisp_Misc
*marker_free_list
;
3545 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3548 allocate_misc (enum Lisp_Misc_Type type
)
3554 if (marker_free_list
)
3556 XSETMISC (val
, marker_free_list
);
3557 marker_free_list
= marker_free_list
->u_free
.chain
;
3561 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3563 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3564 new->next
= marker_block
;
3566 marker_block_index
= 0;
3567 total_free_markers
+= MARKER_BLOCK_SIZE
;
3569 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3570 marker_block_index
++;
3573 MALLOC_UNBLOCK_INPUT
;
3575 --total_free_markers
;
3576 consing_since_gc
+= sizeof (union Lisp_Misc
);
3577 misc_objects_consed
++;
3578 XMISCANY (val
)->type
= type
;
3579 XMISCANY (val
)->gcmarkbit
= 0;
3583 /* Free a Lisp_Misc object. */
3586 free_misc (Lisp_Object misc
)
3588 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3589 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3590 marker_free_list
= XMISC (misc
);
3591 consing_since_gc
-= sizeof (union Lisp_Misc
);
3592 total_free_markers
++;
3595 /* Verify properties of Lisp_Save_Value's representation
3596 that are assumed here and elsewhere. */
3598 verify (SAVE_UNUSED
== 0);
3599 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3603 /* Return Lisp_Save_Value objects for the various combinations
3604 that callers need. */
3607 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3609 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3610 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3611 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3612 p
->data
[0].integer
= a
;
3613 p
->data
[1].integer
= b
;
3614 p
->data
[2].integer
= c
;
3619 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3622 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3623 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3624 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3625 p
->data
[0].object
= a
;
3626 p
->data
[1].object
= b
;
3627 p
->data
[2].object
= c
;
3628 p
->data
[3].object
= d
;
3633 make_save_ptr (void *a
)
3635 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3636 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3637 p
->save_type
= SAVE_POINTER
;
3638 p
->data
[0].pointer
= a
;
3643 make_save_ptr_int (void *a
, ptrdiff_t b
)
3645 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3646 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3647 p
->save_type
= SAVE_TYPE_PTR_INT
;
3648 p
->data
[0].pointer
= a
;
3649 p
->data
[1].integer
= b
;
3653 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3655 make_save_ptr_ptr (void *a
, void *b
)
3657 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3658 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3659 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3660 p
->data
[0].pointer
= a
;
3661 p
->data
[1].pointer
= b
;
3667 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3669 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3670 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3671 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3672 p
->data
[0].funcpointer
= a
;
3673 p
->data
[1].pointer
= b
;
3674 p
->data
[2].object
= c
;
3678 /* Return a Lisp_Save_Value object that represents an array A
3679 of N Lisp objects. */
3682 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3684 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3685 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3686 p
->save_type
= SAVE_TYPE_MEMORY
;
3687 p
->data
[0].pointer
= a
;
3688 p
->data
[1].integer
= n
;
3692 /* Free a Lisp_Save_Value object. Do not use this function
3693 if SAVE contains pointer other than returned by xmalloc. */
3696 free_save_value (Lisp_Object save
)
3698 xfree (XSAVE_POINTER (save
, 0));
3702 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3705 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3707 register Lisp_Object overlay
;
3709 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3710 OVERLAY_START (overlay
) = start
;
3711 OVERLAY_END (overlay
) = end
;
3712 set_overlay_plist (overlay
, plist
);
3713 XOVERLAY (overlay
)->next
= NULL
;
3717 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3718 doc
: /* Return a newly allocated marker which does not point at any place. */)
3721 register Lisp_Object val
;
3722 register struct Lisp_Marker
*p
;
3724 val
= allocate_misc (Lisp_Misc_Marker
);
3730 p
->insertion_type
= 0;
3731 p
->need_adjustment
= 0;
3735 /* Return a newly allocated marker which points into BUF
3736 at character position CHARPOS and byte position BYTEPOS. */
3739 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3742 struct Lisp_Marker
*m
;
3744 /* No dead buffers here. */
3745 eassert (BUFFER_LIVE_P (buf
));
3747 /* Every character is at least one byte. */
3748 eassert (charpos
<= bytepos
);
3750 obj
= allocate_misc (Lisp_Misc_Marker
);
3753 m
->charpos
= charpos
;
3754 m
->bytepos
= bytepos
;
3755 m
->insertion_type
= 0;
3756 m
->need_adjustment
= 0;
3757 m
->next
= BUF_MARKERS (buf
);
3758 BUF_MARKERS (buf
) = m
;
3762 /* Put MARKER back on the free list after using it temporarily. */
3765 free_marker (Lisp_Object marker
)
3767 unchain_marker (XMARKER (marker
));
3772 /* Return a newly created vector or string with specified arguments as
3773 elements. If all the arguments are characters that can fit
3774 in a string of events, make a string; otherwise, make a vector.
3776 Any number of arguments, even zero arguments, are allowed. */
3779 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3783 for (i
= 0; i
< nargs
; i
++)
3784 /* The things that fit in a string
3785 are characters that are in 0...127,
3786 after discarding the meta bit and all the bits above it. */
3787 if (!INTEGERP (args
[i
])
3788 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3789 return Fvector (nargs
, args
);
3791 /* Since the loop exited, we know that all the things in it are
3792 characters, so we can make a string. */
3796 result
= Fmake_string (make_number (nargs
), make_number (0));
3797 for (i
= 0; i
< nargs
; i
++)
3799 SSET (result
, i
, XINT (args
[i
]));
3800 /* Move the meta bit to the right place for a string char. */
3801 if (XINT (args
[i
]) & CHAR_META
)
3802 SSET (result
, i
, SREF (result
, i
) | 0x80);
3810 /* Create a new module user ptr object. */
3812 make_user_ptr (void (*finalizer
) (void *), void *p
)
3815 struct Lisp_User_Ptr
*uptr
;
3817 obj
= allocate_misc (Lisp_Misc_User_Ptr
);
3818 uptr
= XUSER_PTR (obj
);
3819 uptr
->finalizer
= finalizer
;
3827 init_finalizer_list (struct Lisp_Finalizer
*head
)
3829 head
->prev
= head
->next
= head
;
3832 /* Insert FINALIZER before ELEMENT. */
3835 finalizer_insert (struct Lisp_Finalizer
*element
,
3836 struct Lisp_Finalizer
*finalizer
)
3838 eassert (finalizer
->prev
== NULL
);
3839 eassert (finalizer
->next
== NULL
);
3840 finalizer
->next
= element
;
3841 finalizer
->prev
= element
->prev
;
3842 finalizer
->prev
->next
= finalizer
;
3843 element
->prev
= finalizer
;
3847 unchain_finalizer (struct Lisp_Finalizer
*finalizer
)
3849 if (finalizer
->prev
!= NULL
)
3851 eassert (finalizer
->next
!= NULL
);
3852 finalizer
->prev
->next
= finalizer
->next
;
3853 finalizer
->next
->prev
= finalizer
->prev
;
3854 finalizer
->prev
= finalizer
->next
= NULL
;
3859 mark_finalizer_list (struct Lisp_Finalizer
*head
)
3861 for (struct Lisp_Finalizer
*finalizer
= head
->next
;
3863 finalizer
= finalizer
->next
)
3865 finalizer
->base
.gcmarkbit
= true;
3866 mark_object (finalizer
->function
);
3870 /* Move doomed finalizers to list DEST from list SRC. A doomed
3871 finalizer is one that is not GC-reachable and whose
3872 finalizer->function is non-nil. */
3875 queue_doomed_finalizers (struct Lisp_Finalizer
*dest
,
3876 struct Lisp_Finalizer
*src
)
3878 struct Lisp_Finalizer
*finalizer
= src
->next
;
3879 while (finalizer
!= src
)
3881 struct Lisp_Finalizer
*next
= finalizer
->next
;
3882 if (!finalizer
->base
.gcmarkbit
&& !NILP (finalizer
->function
))
3884 unchain_finalizer (finalizer
);
3885 finalizer_insert (dest
, finalizer
);
3893 run_finalizer_handler (Lisp_Object args
)
3895 add_to_log ("finalizer failed: %S", args
);
3900 run_finalizer_function (Lisp_Object function
)
3902 ptrdiff_t count
= SPECPDL_INDEX ();
3904 specbind (Qinhibit_quit
, Qt
);
3905 internal_condition_case_1 (call0
, function
, Qt
, run_finalizer_handler
);
3906 unbind_to (count
, Qnil
);
3910 run_finalizers (struct Lisp_Finalizer
*finalizers
)
3912 struct Lisp_Finalizer
*finalizer
;
3913 Lisp_Object function
;
3915 while (finalizers
->next
!= finalizers
)
3917 finalizer
= finalizers
->next
;
3918 eassert (finalizer
->base
.type
== Lisp_Misc_Finalizer
);
3919 unchain_finalizer (finalizer
);
3920 function
= finalizer
->function
;
3921 if (!NILP (function
))
3923 finalizer
->function
= Qnil
;
3924 run_finalizer_function (function
);
3929 DEFUN ("make-finalizer", Fmake_finalizer
, Smake_finalizer
, 1, 1, 0,
3930 doc
: /* Make a finalizer that will run FUNCTION.
3931 FUNCTION will be called after garbage collection when the returned
3932 finalizer object becomes unreachable. If the finalizer object is
3933 reachable only through references from finalizer objects, it does not
3934 count as reachable for the purpose of deciding whether to run
3935 FUNCTION. FUNCTION will be run once per finalizer object. */)
3936 (Lisp_Object function
)
3938 Lisp_Object val
= allocate_misc (Lisp_Misc_Finalizer
);
3939 struct Lisp_Finalizer
*finalizer
= XFINALIZER (val
);
3940 finalizer
->function
= function
;
3941 finalizer
->prev
= finalizer
->next
= NULL
;
3942 finalizer_insert (&finalizers
, finalizer
);
3947 /************************************************************************
3948 Memory Full Handling
3949 ************************************************************************/
3952 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3953 there may have been size_t overflow so that malloc was never
3954 called, or perhaps malloc was invoked successfully but the
3955 resulting pointer had problems fitting into a tagged EMACS_INT. In
3956 either case this counts as memory being full even though malloc did
3960 memory_full (size_t nbytes
)
3962 /* Do not go into hysterics merely because a large request failed. */
3963 bool enough_free_memory
= 0;
3964 if (SPARE_MEMORY
< nbytes
)
3969 p
= malloc (SPARE_MEMORY
);
3973 enough_free_memory
= 1;
3975 MALLOC_UNBLOCK_INPUT
;
3978 if (! enough_free_memory
)
3984 memory_full_cons_threshold
= sizeof (struct cons_block
);
3986 /* The first time we get here, free the spare memory. */
3987 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
3988 if (spare_memory
[i
])
3991 free (spare_memory
[i
]);
3992 else if (i
>= 1 && i
<= 4)
3993 lisp_align_free (spare_memory
[i
]);
3995 lisp_free (spare_memory
[i
]);
3996 spare_memory
[i
] = 0;
4000 /* This used to call error, but if we've run out of memory, we could
4001 get infinite recursion trying to build the string. */
4002 xsignal (Qnil
, Vmemory_signal_data
);
4005 /* If we released our reserve (due to running out of memory),
4006 and we have a fair amount free once again,
4007 try to set aside another reserve in case we run out once more.
4009 This is called when a relocatable block is freed in ralloc.c,
4010 and also directly from this file, in case we're not using ralloc.c. */
4013 refill_memory_reserve (void)
4015 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4016 if (spare_memory
[0] == 0)
4017 spare_memory
[0] = malloc (SPARE_MEMORY
);
4018 if (spare_memory
[1] == 0)
4019 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
4021 if (spare_memory
[2] == 0)
4022 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
4024 if (spare_memory
[3] == 0)
4025 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
4027 if (spare_memory
[4] == 0)
4028 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
4030 if (spare_memory
[5] == 0)
4031 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
4033 if (spare_memory
[6] == 0)
4034 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
4036 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
4037 Vmemory_full
= Qnil
;
4041 /************************************************************************
4043 ************************************************************************/
4045 /* Conservative C stack marking requires a method to identify possibly
4046 live Lisp objects given a pointer value. We do this by keeping
4047 track of blocks of Lisp data that are allocated in a red-black tree
4048 (see also the comment of mem_node which is the type of nodes in
4049 that tree). Function lisp_malloc adds information for an allocated
4050 block to the red-black tree with calls to mem_insert, and function
4051 lisp_free removes it with mem_delete. Functions live_string_p etc
4052 call mem_find to lookup information about a given pointer in the
4053 tree, and use that to determine if the pointer points to a Lisp
4056 /* Initialize this part of alloc.c. */
4061 mem_z
.left
= mem_z
.right
= MEM_NIL
;
4062 mem_z
.parent
= NULL
;
4063 mem_z
.color
= MEM_BLACK
;
4064 mem_z
.start
= mem_z
.end
= NULL
;
4069 /* Value is a pointer to the mem_node containing START. Value is
4070 MEM_NIL if there is no node in the tree containing START. */
4072 static struct mem_node
*
4073 mem_find (void *start
)
4077 if (start
< min_heap_address
|| start
> max_heap_address
)
4080 /* Make the search always successful to speed up the loop below. */
4081 mem_z
.start
= start
;
4082 mem_z
.end
= (char *) start
+ 1;
4085 while (start
< p
->start
|| start
>= p
->end
)
4086 p
= start
< p
->start
? p
->left
: p
->right
;
4091 /* Insert a new node into the tree for a block of memory with start
4092 address START, end address END, and type TYPE. Value is a
4093 pointer to the node that was inserted. */
4095 static struct mem_node
*
4096 mem_insert (void *start
, void *end
, enum mem_type type
)
4098 struct mem_node
*c
, *parent
, *x
;
4100 if (min_heap_address
== NULL
|| start
< min_heap_address
)
4101 min_heap_address
= start
;
4102 if (max_heap_address
== NULL
|| end
> max_heap_address
)
4103 max_heap_address
= end
;
4105 /* See where in the tree a node for START belongs. In this
4106 particular application, it shouldn't happen that a node is already
4107 present. For debugging purposes, let's check that. */
4111 while (c
!= MEM_NIL
)
4114 c
= start
< c
->start
? c
->left
: c
->right
;
4117 /* Create a new node. */
4118 #ifdef GC_MALLOC_CHECK
4119 x
= malloc (sizeof *x
);
4123 x
= xmalloc (sizeof *x
);
4129 x
->left
= x
->right
= MEM_NIL
;
4132 /* Insert it as child of PARENT or install it as root. */
4135 if (start
< parent
->start
)
4143 /* Re-establish red-black tree properties. */
4144 mem_insert_fixup (x
);
4150 /* Re-establish the red-black properties of the tree, and thereby
4151 balance the tree, after node X has been inserted; X is always red. */
4154 mem_insert_fixup (struct mem_node
*x
)
4156 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4158 /* X is red and its parent is red. This is a violation of
4159 red-black tree property #3. */
4161 if (x
->parent
== x
->parent
->parent
->left
)
4163 /* We're on the left side of our grandparent, and Y is our
4165 struct mem_node
*y
= x
->parent
->parent
->right
;
4167 if (y
->color
== MEM_RED
)
4169 /* Uncle and parent are red but should be black because
4170 X is red. Change the colors accordingly and proceed
4171 with the grandparent. */
4172 x
->parent
->color
= MEM_BLACK
;
4173 y
->color
= MEM_BLACK
;
4174 x
->parent
->parent
->color
= MEM_RED
;
4175 x
= x
->parent
->parent
;
4179 /* Parent and uncle have different colors; parent is
4180 red, uncle is black. */
4181 if (x
== x
->parent
->right
)
4184 mem_rotate_left (x
);
4187 x
->parent
->color
= MEM_BLACK
;
4188 x
->parent
->parent
->color
= MEM_RED
;
4189 mem_rotate_right (x
->parent
->parent
);
4194 /* This is the symmetrical case of above. */
4195 struct mem_node
*y
= x
->parent
->parent
->left
;
4197 if (y
->color
== MEM_RED
)
4199 x
->parent
->color
= MEM_BLACK
;
4200 y
->color
= MEM_BLACK
;
4201 x
->parent
->parent
->color
= MEM_RED
;
4202 x
= x
->parent
->parent
;
4206 if (x
== x
->parent
->left
)
4209 mem_rotate_right (x
);
4212 x
->parent
->color
= MEM_BLACK
;
4213 x
->parent
->parent
->color
= MEM_RED
;
4214 mem_rotate_left (x
->parent
->parent
);
4219 /* The root may have been changed to red due to the algorithm. Set
4220 it to black so that property #5 is satisfied. */
4221 mem_root
->color
= MEM_BLACK
;
4232 mem_rotate_left (struct mem_node
*x
)
4236 /* Turn y's left sub-tree into x's right sub-tree. */
4239 if (y
->left
!= MEM_NIL
)
4240 y
->left
->parent
= x
;
4242 /* Y's parent was x's parent. */
4244 y
->parent
= x
->parent
;
4246 /* Get the parent to point to y instead of x. */
4249 if (x
== x
->parent
->left
)
4250 x
->parent
->left
= y
;
4252 x
->parent
->right
= y
;
4257 /* Put x on y's left. */
4271 mem_rotate_right (struct mem_node
*x
)
4273 struct mem_node
*y
= x
->left
;
4276 if (y
->right
!= MEM_NIL
)
4277 y
->right
->parent
= x
;
4280 y
->parent
= x
->parent
;
4283 if (x
== x
->parent
->right
)
4284 x
->parent
->right
= y
;
4286 x
->parent
->left
= y
;
4297 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4300 mem_delete (struct mem_node
*z
)
4302 struct mem_node
*x
, *y
;
4304 if (!z
|| z
== MEM_NIL
)
4307 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4312 while (y
->left
!= MEM_NIL
)
4316 if (y
->left
!= MEM_NIL
)
4321 x
->parent
= y
->parent
;
4324 if (y
== y
->parent
->left
)
4325 y
->parent
->left
= x
;
4327 y
->parent
->right
= x
;
4334 z
->start
= y
->start
;
4339 if (y
->color
== MEM_BLACK
)
4340 mem_delete_fixup (x
);
4342 #ifdef GC_MALLOC_CHECK
4350 /* Re-establish the red-black properties of the tree, after a
4354 mem_delete_fixup (struct mem_node
*x
)
4356 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4358 if (x
== x
->parent
->left
)
4360 struct mem_node
*w
= x
->parent
->right
;
4362 if (w
->color
== MEM_RED
)
4364 w
->color
= MEM_BLACK
;
4365 x
->parent
->color
= MEM_RED
;
4366 mem_rotate_left (x
->parent
);
4367 w
= x
->parent
->right
;
4370 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4377 if (w
->right
->color
== MEM_BLACK
)
4379 w
->left
->color
= MEM_BLACK
;
4381 mem_rotate_right (w
);
4382 w
= x
->parent
->right
;
4384 w
->color
= x
->parent
->color
;
4385 x
->parent
->color
= MEM_BLACK
;
4386 w
->right
->color
= MEM_BLACK
;
4387 mem_rotate_left (x
->parent
);
4393 struct mem_node
*w
= x
->parent
->left
;
4395 if (w
->color
== MEM_RED
)
4397 w
->color
= MEM_BLACK
;
4398 x
->parent
->color
= MEM_RED
;
4399 mem_rotate_right (x
->parent
);
4400 w
= x
->parent
->left
;
4403 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4410 if (w
->left
->color
== MEM_BLACK
)
4412 w
->right
->color
= MEM_BLACK
;
4414 mem_rotate_left (w
);
4415 w
= x
->parent
->left
;
4418 w
->color
= x
->parent
->color
;
4419 x
->parent
->color
= MEM_BLACK
;
4420 w
->left
->color
= MEM_BLACK
;
4421 mem_rotate_right (x
->parent
);
4427 x
->color
= MEM_BLACK
;
4431 /* Value is non-zero if P is a pointer to a live Lisp string on
4432 the heap. M is a pointer to the mem_block for P. */
4435 live_string_p (struct mem_node
*m
, void *p
)
4437 if (m
->type
== MEM_TYPE_STRING
)
4439 struct string_block
*b
= m
->start
;
4440 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4442 /* P must point to the start of a Lisp_String structure, and it
4443 must not be on the free-list. */
4445 && offset
% sizeof b
->strings
[0] == 0
4446 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4447 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4454 /* Value is non-zero if P is a pointer to a live Lisp cons on
4455 the heap. M is a pointer to the mem_block for P. */
4458 live_cons_p (struct mem_node
*m
, void *p
)
4460 if (m
->type
== MEM_TYPE_CONS
)
4462 struct cons_block
*b
= m
->start
;
4463 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4465 /* P must point to the start of a Lisp_Cons, not be
4466 one of the unused cells in the current cons block,
4467 and not be on the free-list. */
4469 && offset
% sizeof b
->conses
[0] == 0
4470 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4472 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4473 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4480 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4481 the heap. M is a pointer to the mem_block for P. */
4484 live_symbol_p (struct mem_node
*m
, void *p
)
4486 if (m
->type
== MEM_TYPE_SYMBOL
)
4488 struct symbol_block
*b
= m
->start
;
4489 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4491 /* P must point to the start of a Lisp_Symbol, not be
4492 one of the unused cells in the current symbol block,
4493 and not be on the free-list. */
4495 && offset
% sizeof b
->symbols
[0] == 0
4496 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4497 && (b
!= symbol_block
4498 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4499 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4506 /* Value is non-zero if P is a pointer to a live Lisp float on
4507 the heap. M is a pointer to the mem_block for P. */
4510 live_float_p (struct mem_node
*m
, void *p
)
4512 if (m
->type
== MEM_TYPE_FLOAT
)
4514 struct float_block
*b
= m
->start
;
4515 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4517 /* P must point to the start of a Lisp_Float and not be
4518 one of the unused cells in the current float block. */
4520 && offset
% sizeof b
->floats
[0] == 0
4521 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4522 && (b
!= float_block
4523 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4530 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4531 the heap. M is a pointer to the mem_block for P. */
4534 live_misc_p (struct mem_node
*m
, void *p
)
4536 if (m
->type
== MEM_TYPE_MISC
)
4538 struct marker_block
*b
= m
->start
;
4539 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4541 /* P must point to the start of a Lisp_Misc, not be
4542 one of the unused cells in the current misc block,
4543 and not be on the free-list. */
4545 && offset
% sizeof b
->markers
[0] == 0
4546 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4547 && (b
!= marker_block
4548 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4549 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4556 /* Value is non-zero if P is a pointer to a live vector-like object.
4557 M is a pointer to the mem_block for P. */
4560 live_vector_p (struct mem_node
*m
, void *p
)
4562 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4564 /* This memory node corresponds to a vector block. */
4565 struct vector_block
*block
= m
->start
;
4566 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4568 /* P is in the block's allocation range. Scan the block
4569 up to P and see whether P points to the start of some
4570 vector which is not on a free list. FIXME: check whether
4571 some allocation patterns (probably a lot of short vectors)
4572 may cause a substantial overhead of this loop. */
4573 while (VECTOR_IN_BLOCK (vector
, block
)
4574 && vector
<= (struct Lisp_Vector
*) p
)
4576 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4579 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4582 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4583 /* This memory node corresponds to a large vector. */
4589 /* Value is non-zero if P is a pointer to a live buffer. M is a
4590 pointer to the mem_block for P. */
4593 live_buffer_p (struct mem_node
*m
, void *p
)
4595 /* P must point to the start of the block, and the buffer
4596 must not have been killed. */
4597 return (m
->type
== MEM_TYPE_BUFFER
4599 && !NILP (((struct buffer
*) p
)->name_
));
4602 /* Mark OBJ if we can prove it's a Lisp_Object. */
4605 mark_maybe_object (Lisp_Object obj
)
4609 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4615 void *po
= XPNTR (obj
);
4616 struct mem_node
*m
= mem_find (po
);
4620 bool mark_p
= false;
4622 switch (XTYPE (obj
))
4625 mark_p
= (live_string_p (m
, po
)
4626 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4630 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4634 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4638 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4641 case Lisp_Vectorlike
:
4642 /* Note: can't check BUFFERP before we know it's a
4643 buffer because checking that dereferences the pointer
4644 PO which might point anywhere. */
4645 if (live_vector_p (m
, po
))
4646 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4647 else if (live_buffer_p (m
, po
))
4648 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4652 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4664 /* Return true if P can point to Lisp data, and false otherwise.
4665 Symbols are implemented via offsets not pointers, but the offsets
4666 are also multiples of GCALIGNMENT. */
4669 maybe_lisp_pointer (void *p
)
4671 return (uintptr_t) p
% GCALIGNMENT
== 0;
4674 #ifndef HAVE_MODULES
4675 enum { HAVE_MODULES
= false };
4678 /* If P points to Lisp data, mark that as live if it isn't already
4682 mark_maybe_pointer (void *p
)
4688 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4691 if (sizeof (Lisp_Object
) == sizeof (void *) || !HAVE_MODULES
)
4693 if (!maybe_lisp_pointer (p
))
4698 /* For the wide-int case, also mark emacs_value tagged pointers,
4699 which can be generated by emacs-module.c's value_to_lisp. */
4700 p
= (void *) ((uintptr_t) p
& ~(GCALIGNMENT
- 1));
4706 Lisp_Object obj
= Qnil
;
4710 case MEM_TYPE_NON_LISP
:
4711 case MEM_TYPE_SPARE
:
4712 /* Nothing to do; not a pointer to Lisp memory. */
4715 case MEM_TYPE_BUFFER
:
4716 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4717 XSETVECTOR (obj
, p
);
4721 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4725 case MEM_TYPE_STRING
:
4726 if (live_string_p (m
, p
)
4727 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4728 XSETSTRING (obj
, p
);
4732 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4736 case MEM_TYPE_SYMBOL
:
4737 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4738 XSETSYMBOL (obj
, p
);
4741 case MEM_TYPE_FLOAT
:
4742 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4746 case MEM_TYPE_VECTORLIKE
:
4747 case MEM_TYPE_VECTOR_BLOCK
:
4748 if (live_vector_p (m
, p
))
4751 XSETVECTOR (tem
, p
);
4752 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4767 /* Alignment of pointer values. Use alignof, as it sometimes returns
4768 a smaller alignment than GCC's __alignof__ and mark_memory might
4769 miss objects if __alignof__ were used. */
4770 #define GC_POINTER_ALIGNMENT alignof (void *)
4772 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4773 or END+OFFSET..START. */
4775 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4776 mark_memory (void *start
, void *end
)
4780 /* Make START the pointer to the start of the memory region,
4781 if it isn't already. */
4789 eassert (((uintptr_t) start
) % GC_POINTER_ALIGNMENT
== 0);
4791 /* Mark Lisp data pointed to. This is necessary because, in some
4792 situations, the C compiler optimizes Lisp objects away, so that
4793 only a pointer to them remains. Example:
4795 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4798 Lisp_Object obj = build_string ("test");
4799 struct Lisp_String *s = XSTRING (obj);
4800 Fgarbage_collect ();
4801 fprintf (stderr, "test '%s'\n", s->data);
4805 Here, `obj' isn't really used, and the compiler optimizes it
4806 away. The only reference to the life string is through the
4809 for (pp
= start
; (void *) pp
< end
; pp
+= GC_POINTER_ALIGNMENT
)
4811 mark_maybe_pointer (*(void **) pp
);
4812 mark_maybe_object (*(Lisp_Object
*) pp
);
4816 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4818 static bool setjmp_tested_p
;
4819 static int longjmps_done
;
4821 #define SETJMP_WILL_LIKELY_WORK "\
4823 Emacs garbage collector has been changed to use conservative stack\n\
4824 marking. Emacs has determined that the method it uses to do the\n\
4825 marking will likely work on your system, but this isn't sure.\n\
4827 If you are a system-programmer, or can get the help of a local wizard\n\
4828 who is, please take a look at the function mark_stack in alloc.c, and\n\
4829 verify that the methods used are appropriate for your system.\n\
4831 Please mail the result to <emacs-devel@gnu.org>.\n\
4834 #define SETJMP_WILL_NOT_WORK "\
4836 Emacs garbage collector has been changed to use conservative stack\n\
4837 marking. Emacs has determined that the default method it uses to do the\n\
4838 marking will not work on your system. We will need a system-dependent\n\
4839 solution for your system.\n\
4841 Please take a look at the function mark_stack in alloc.c, and\n\
4842 try to find a way to make it work on your system.\n\
4844 Note that you may get false negatives, depending on the compiler.\n\
4845 In particular, you need to use -O with GCC for this test.\n\
4847 Please mail the result to <emacs-devel@gnu.org>.\n\
4851 /* Perform a quick check if it looks like setjmp saves registers in a
4852 jmp_buf. Print a message to stderr saying so. When this test
4853 succeeds, this is _not_ a proof that setjmp is sufficient for
4854 conservative stack marking. Only the sources or a disassembly
4864 /* Arrange for X to be put in a register. */
4870 if (longjmps_done
== 1)
4872 /* Came here after the longjmp at the end of the function.
4874 If x == 1, the longjmp has restored the register to its
4875 value before the setjmp, and we can hope that setjmp
4876 saves all such registers in the jmp_buf, although that
4879 For other values of X, either something really strange is
4880 taking place, or the setjmp just didn't save the register. */
4883 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4886 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4893 if (longjmps_done
== 1)
4894 sys_longjmp (jbuf
, 1);
4897 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4900 /* Mark live Lisp objects on the C stack.
4902 There are several system-dependent problems to consider when
4903 porting this to new architectures:
4907 We have to mark Lisp objects in CPU registers that can hold local
4908 variables or are used to pass parameters.
4910 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4911 something that either saves relevant registers on the stack, or
4912 calls mark_maybe_object passing it each register's contents.
4914 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4915 implementation assumes that calling setjmp saves registers we need
4916 to see in a jmp_buf which itself lies on the stack. This doesn't
4917 have to be true! It must be verified for each system, possibly
4918 by taking a look at the source code of setjmp.
4920 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4921 can use it as a machine independent method to store all registers
4922 to the stack. In this case the macros described in the previous
4923 two paragraphs are not used.
4927 Architectures differ in the way their processor stack is organized.
4928 For example, the stack might look like this
4931 | Lisp_Object | size = 4
4933 | something else | size = 2
4935 | Lisp_Object | size = 4
4939 In such a case, not every Lisp_Object will be aligned equally. To
4940 find all Lisp_Object on the stack it won't be sufficient to walk
4941 the stack in steps of 4 bytes. Instead, two passes will be
4942 necessary, one starting at the start of the stack, and a second
4943 pass starting at the start of the stack + 2. Likewise, if the
4944 minimal alignment of Lisp_Objects on the stack is 1, four passes
4945 would be necessary, each one starting with one byte more offset
4946 from the stack start. */
4949 mark_stack (void *end
)
4952 /* This assumes that the stack is a contiguous region in memory. If
4953 that's not the case, something has to be done here to iterate
4954 over the stack segments. */
4955 mark_memory (stack_base
, end
);
4957 /* Allow for marking a secondary stack, like the register stack on the
4959 #ifdef GC_MARK_SECONDARY_STACK
4960 GC_MARK_SECONDARY_STACK ();
4965 c_symbol_p (struct Lisp_Symbol
*sym
)
4967 char *lispsym_ptr
= (char *) lispsym
;
4968 char *sym_ptr
= (char *) sym
;
4969 ptrdiff_t lispsym_offset
= sym_ptr
- lispsym_ptr
;
4970 return 0 <= lispsym_offset
&& lispsym_offset
< sizeof lispsym
;
4973 /* Determine whether it is safe to access memory at address P. */
4975 valid_pointer_p (void *p
)
4978 return w32_valid_pointer_p (p
, 16);
4981 if (ADDRESS_SANITIZER
)
4986 /* Obviously, we cannot just access it (we would SEGV trying), so we
4987 trick the o/s to tell us whether p is a valid pointer.
4988 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4989 not validate p in that case. */
4991 if (emacs_pipe (fd
) == 0)
4993 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
4994 emacs_close (fd
[1]);
4995 emacs_close (fd
[0]);
5003 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5004 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5005 cannot validate OBJ. This function can be quite slow, so its primary
5006 use is the manual debugging. The only exception is print_object, where
5007 we use it to check whether the memory referenced by the pointer of
5008 Lisp_Save_Value object contains valid objects. */
5011 valid_lisp_object_p (Lisp_Object obj
)
5016 void *p
= XPNTR (obj
);
5020 if (SYMBOLP (obj
) && c_symbol_p (p
))
5021 return ((char *) p
- (char *) lispsym
) % sizeof lispsym
[0] == 0;
5023 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5026 struct mem_node
*m
= mem_find (p
);
5030 int valid
= valid_pointer_p (p
);
5042 case MEM_TYPE_NON_LISP
:
5043 case MEM_TYPE_SPARE
:
5046 case MEM_TYPE_BUFFER
:
5047 return live_buffer_p (m
, p
) ? 1 : 2;
5050 return live_cons_p (m
, p
);
5052 case MEM_TYPE_STRING
:
5053 return live_string_p (m
, p
);
5056 return live_misc_p (m
, p
);
5058 case MEM_TYPE_SYMBOL
:
5059 return live_symbol_p (m
, p
);
5061 case MEM_TYPE_FLOAT
:
5062 return live_float_p (m
, p
);
5064 case MEM_TYPE_VECTORLIKE
:
5065 case MEM_TYPE_VECTOR_BLOCK
:
5066 return live_vector_p (m
, p
);
5075 /***********************************************************************
5076 Pure Storage Management
5077 ***********************************************************************/
5079 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5080 pointer to it. TYPE is the Lisp type for which the memory is
5081 allocated. TYPE < 0 means it's not used for a Lisp object. */
5084 pure_alloc (size_t size
, int type
)
5091 /* Allocate space for a Lisp object from the beginning of the free
5092 space with taking account of alignment. */
5093 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, GCALIGNMENT
);
5094 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5098 /* Allocate space for a non-Lisp object from the end of the free
5100 pure_bytes_used_non_lisp
+= size
;
5101 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5103 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5105 if (pure_bytes_used
<= pure_size
)
5108 /* Don't allocate a large amount here,
5109 because it might get mmap'd and then its address
5110 might not be usable. */
5111 purebeg
= xmalloc (10000);
5113 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5114 pure_bytes_used
= 0;
5115 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5120 /* Print a warning if PURESIZE is too small. */
5123 check_pure_size (void)
5125 if (pure_bytes_used_before_overflow
)
5126 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5128 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5132 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5133 the non-Lisp data pool of the pure storage, and return its start
5134 address. Return NULL if not found. */
5137 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5140 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5141 const unsigned char *p
;
5144 if (pure_bytes_used_non_lisp
<= nbytes
)
5147 /* Set up the Boyer-Moore table. */
5149 for (i
= 0; i
< 256; i
++)
5152 p
= (const unsigned char *) data
;
5154 bm_skip
[*p
++] = skip
;
5156 last_char_skip
= bm_skip
['\0'];
5158 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5159 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5161 /* See the comments in the function `boyer_moore' (search.c) for the
5162 use of `infinity'. */
5163 infinity
= pure_bytes_used_non_lisp
+ 1;
5164 bm_skip
['\0'] = infinity
;
5166 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5170 /* Check the last character (== '\0'). */
5173 start
+= bm_skip
[*(p
+ start
)];
5175 while (start
<= start_max
);
5177 if (start
< infinity
)
5178 /* Couldn't find the last character. */
5181 /* No less than `infinity' means we could find the last
5182 character at `p[start - infinity]'. */
5185 /* Check the remaining characters. */
5186 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5188 return non_lisp_beg
+ start
;
5190 start
+= last_char_skip
;
5192 while (start
<= start_max
);
5198 /* Return a string allocated in pure space. DATA is a buffer holding
5199 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5200 means make the result string multibyte.
5202 Must get an error if pure storage is full, since if it cannot hold
5203 a large string it may be able to hold conses that point to that
5204 string; then the string is not protected from gc. */
5207 make_pure_string (const char *data
,
5208 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5211 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5212 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5213 if (s
->data
== NULL
)
5215 s
->data
= pure_alloc (nbytes
+ 1, -1);
5216 memcpy (s
->data
, data
, nbytes
);
5217 s
->data
[nbytes
] = '\0';
5220 s
->size_byte
= multibyte
? nbytes
: -1;
5221 s
->intervals
= NULL
;
5222 XSETSTRING (string
, s
);
5226 /* Return a string allocated in pure space. Do not
5227 allocate the string data, just point to DATA. */
5230 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5233 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5236 s
->data
= (unsigned char *) data
;
5237 s
->intervals
= NULL
;
5238 XSETSTRING (string
, s
);
5242 static Lisp_Object
purecopy (Lisp_Object obj
);
5244 /* Return a cons allocated from pure space. Give it pure copies
5245 of CAR as car and CDR as cdr. */
5248 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5251 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5253 XSETCAR (new, purecopy (car
));
5254 XSETCDR (new, purecopy (cdr
));
5259 /* Value is a float object with value NUM allocated from pure space. */
5262 make_pure_float (double num
)
5265 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5267 XFLOAT_INIT (new, num
);
5272 /* Return a vector with room for LEN Lisp_Objects allocated from
5276 make_pure_vector (ptrdiff_t len
)
5279 size_t size
= header_size
+ len
* word_size
;
5280 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5281 XSETVECTOR (new, p
);
5282 XVECTOR (new)->header
.size
= len
;
5286 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5287 doc
: /* Make a copy of object OBJ in pure storage.
5288 Recursively copies contents of vectors and cons cells.
5289 Does not copy symbols. Copies strings without text properties. */)
5290 (register Lisp_Object obj
)
5292 if (NILP (Vpurify_flag
))
5294 else if (MARKERP (obj
) || OVERLAYP (obj
)
5295 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5296 /* Can't purify those. */
5299 return purecopy (obj
);
5303 purecopy (Lisp_Object obj
)
5306 || (! SYMBOLP (obj
) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj
)))
5308 return obj
; /* Already pure. */
5310 if (STRINGP (obj
) && XSTRING (obj
)->intervals
)
5311 message_with_string ("Dropping text-properties while making string `%s' pure",
5314 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5316 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5322 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5323 else if (FLOATP (obj
))
5324 obj
= make_pure_float (XFLOAT_DATA (obj
));
5325 else if (STRINGP (obj
))
5326 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5328 STRING_MULTIBYTE (obj
));
5329 else if (COMPILEDP (obj
) || VECTORP (obj
) || HASH_TABLE_P (obj
))
5331 struct Lisp_Vector
*objp
= XVECTOR (obj
);
5332 ptrdiff_t nbytes
= vector_nbytes (objp
);
5333 struct Lisp_Vector
*vec
= pure_alloc (nbytes
, Lisp_Vectorlike
);
5334 register ptrdiff_t i
;
5335 ptrdiff_t size
= ASIZE (obj
);
5336 if (size
& PSEUDOVECTOR_FLAG
)
5337 size
&= PSEUDOVECTOR_SIZE_MASK
;
5338 memcpy (vec
, objp
, nbytes
);
5339 for (i
= 0; i
< size
; i
++)
5340 vec
->contents
[i
] = purecopy (vec
->contents
[i
]);
5341 XSETVECTOR (obj
, vec
);
5343 else if (SYMBOLP (obj
))
5345 if (!XSYMBOL (obj
)->pinned
&& !c_symbol_p (XSYMBOL (obj
)))
5346 { /* We can't purify them, but they appear in many pure objects.
5347 Mark them as `pinned' so we know to mark them at every GC cycle. */
5348 XSYMBOL (obj
)->pinned
= true;
5349 symbol_block_pinned
= symbol_block
;
5351 /* Don't hash-cons it. */
5356 Lisp_Object fmt
= build_pure_c_string ("Don't know how to purify: %S");
5357 Fsignal (Qerror
, list1 (CALLN (Fformat
, fmt
, obj
)));
5360 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5361 Fputhash (obj
, obj
, Vpurify_flag
);
5368 /***********************************************************************
5370 ***********************************************************************/
5372 /* Put an entry in staticvec, pointing at the variable with address
5376 staticpro (Lisp_Object
*varaddress
)
5378 if (staticidx
>= NSTATICS
)
5379 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5380 staticvec
[staticidx
++] = varaddress
;
5384 /***********************************************************************
5386 ***********************************************************************/
5388 /* Temporarily prevent garbage collection. */
5391 inhibit_garbage_collection (void)
5393 ptrdiff_t count
= SPECPDL_INDEX ();
5395 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5399 /* Used to avoid possible overflows when
5400 converting from C to Lisp integers. */
5403 bounded_number (EMACS_INT number
)
5405 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5408 /* Calculate total bytes of live objects. */
5411 total_bytes_of_live_objects (void)
5414 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5415 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5416 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5417 tot
+= total_string_bytes
;
5418 tot
+= total_vector_slots
* word_size
;
5419 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5420 tot
+= total_intervals
* sizeof (struct interval
);
5421 tot
+= total_strings
* sizeof (struct Lisp_String
);
5425 #ifdef HAVE_WINDOW_SYSTEM
5427 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5428 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5431 compact_font_cache_entry (Lisp_Object entry
)
5433 Lisp_Object tail
, *prev
= &entry
;
5435 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5438 Lisp_Object obj
= XCAR (tail
);
5440 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5441 if (CONSP (obj
) && GC_FONT_SPEC_P (XCAR (obj
))
5442 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj
)))
5443 /* Don't use VECTORP here, as that calls ASIZE, which could
5444 hit assertion violation during GC. */
5445 && (VECTORLIKEP (XCDR (obj
))
5446 && ! (gc_asize (XCDR (obj
)) & PSEUDOVECTOR_FLAG
)))
5448 ptrdiff_t i
, size
= gc_asize (XCDR (obj
));
5449 Lisp_Object obj_cdr
= XCDR (obj
);
5451 /* If font-spec is not marked, most likely all font-entities
5452 are not marked too. But we must be sure that nothing is
5453 marked within OBJ before we really drop it. */
5454 for (i
= 0; i
< size
; i
++)
5456 Lisp_Object objlist
;
5458 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr
, i
))))
5461 objlist
= AREF (AREF (obj_cdr
, i
), FONT_OBJLIST_INDEX
);
5462 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
5464 Lisp_Object val
= XCAR (objlist
);
5465 struct font
*font
= GC_XFONT_OBJECT (val
);
5467 if (!NILP (AREF (val
, FONT_TYPE_INDEX
))
5468 && VECTOR_MARKED_P(font
))
5471 if (CONSP (objlist
))
5473 /* Found a marked font, bail out. */
5480 /* No marked fonts were found, so this entire font
5481 entity can be dropped. */
5486 *prev
= XCDR (tail
);
5488 prev
= xcdr_addr (tail
);
5493 /* Compact font caches on all terminals and mark
5494 everything which is still here after compaction. */
5497 compact_font_caches (void)
5501 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5503 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5508 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5509 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5511 mark_object (cache
);
5515 #else /* not HAVE_WINDOW_SYSTEM */
5517 #define compact_font_caches() (void)(0)
5519 #endif /* HAVE_WINDOW_SYSTEM */
5521 /* Remove (MARKER . DATA) entries with unmarked MARKER
5522 from buffer undo LIST and return changed list. */
5525 compact_undo_list (Lisp_Object list
)
5527 Lisp_Object tail
, *prev
= &list
;
5529 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5531 if (CONSP (XCAR (tail
))
5532 && MARKERP (XCAR (XCAR (tail
)))
5533 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5534 *prev
= XCDR (tail
);
5536 prev
= xcdr_addr (tail
);
5542 mark_pinned_symbols (void)
5544 struct symbol_block
*sblk
;
5545 int lim
= (symbol_block_pinned
== symbol_block
5546 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5548 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5550 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5551 for (; sym
< end
; ++sym
)
5553 mark_object (make_lisp_symbol (&sym
->s
));
5555 lim
= SYMBOL_BLOCK_SIZE
;
5559 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5560 separate function so that we could limit mark_stack in searching
5561 the stack frames below this function, thus avoiding the rare cases
5562 where mark_stack finds values that look like live Lisp objects on
5563 portions of stack that couldn't possibly contain such live objects.
5564 For more details of this, see the discussion at
5565 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5567 garbage_collect_1 (void *end
)
5569 struct buffer
*nextb
;
5570 char stack_top_variable
;
5573 ptrdiff_t count
= SPECPDL_INDEX ();
5574 struct timespec start
;
5575 Lisp_Object retval
= Qnil
;
5576 size_t tot_before
= 0;
5581 /* Can't GC if pure storage overflowed because we can't determine
5582 if something is a pure object or not. */
5583 if (pure_bytes_used_before_overflow
)
5586 /* Record this function, so it appears on the profiler's backtraces. */
5587 record_in_backtrace (Qautomatic_gc
, 0, 0);
5591 /* Don't keep undo information around forever.
5592 Do this early on, so it is no problem if the user quits. */
5593 FOR_EACH_BUFFER (nextb
)
5594 compact_buffer (nextb
);
5596 if (profiler_memory_running
)
5597 tot_before
= total_bytes_of_live_objects ();
5599 start
= current_timespec ();
5601 /* In case user calls debug_print during GC,
5602 don't let that cause a recursive GC. */
5603 consing_since_gc
= 0;
5605 /* Save what's currently displayed in the echo area. Don't do that
5606 if we are GC'ing because we've run out of memory, since
5607 push_message will cons, and we might have no memory for that. */
5608 if (NILP (Vmemory_full
))
5610 message_p
= push_message ();
5611 record_unwind_protect_void (pop_message_unwind
);
5616 /* Save a copy of the contents of the stack, for debugging. */
5617 #if MAX_SAVE_STACK > 0
5618 if (NILP (Vpurify_flag
))
5621 ptrdiff_t stack_size
;
5622 if (&stack_top_variable
< stack_bottom
)
5624 stack
= &stack_top_variable
;
5625 stack_size
= stack_bottom
- &stack_top_variable
;
5629 stack
= stack_bottom
;
5630 stack_size
= &stack_top_variable
- stack_bottom
;
5632 if (stack_size
<= MAX_SAVE_STACK
)
5634 if (stack_copy_size
< stack_size
)
5636 stack_copy
= xrealloc (stack_copy
, stack_size
);
5637 stack_copy_size
= stack_size
;
5639 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5642 #endif /* MAX_SAVE_STACK > 0 */
5644 if (garbage_collection_messages
)
5645 message1_nolog ("Garbage collecting...");
5649 shrink_regexp_cache ();
5653 /* Mark all the special slots that serve as the roots of accessibility. */
5655 mark_buffer (&buffer_defaults
);
5656 mark_buffer (&buffer_local_symbols
);
5658 for (i
= 0; i
< ARRAYELTS (lispsym
); i
++)
5659 mark_object (builtin_lisp_symbol (i
));
5661 for (i
= 0; i
< staticidx
; i
++)
5662 mark_object (*staticvec
[i
]);
5664 mark_pinned_symbols ();
5676 struct handler
*handler
;
5677 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5679 mark_object (handler
->tag_or_ch
);
5680 mark_object (handler
->val
);
5683 #ifdef HAVE_WINDOW_SYSTEM
5684 mark_fringe_data ();
5687 /* Everything is now marked, except for the data in font caches,
5688 undo lists, and finalizers. The first two are compacted by
5689 removing an items which aren't reachable otherwise. */
5691 compact_font_caches ();
5693 FOR_EACH_BUFFER (nextb
)
5695 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5696 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5697 /* Now that we have stripped the elements that need not be
5698 in the undo_list any more, we can finally mark the list. */
5699 mark_object (BVAR (nextb
, undo_list
));
5702 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5703 to doomed_finalizers so we can run their associated functions
5704 after GC. It's important to scan finalizers at this stage so
5705 that we can be sure that unmarked finalizers are really
5706 unreachable except for references from their associated functions
5707 and from other finalizers. */
5709 queue_doomed_finalizers (&doomed_finalizers
, &finalizers
);
5710 mark_finalizer_list (&doomed_finalizers
);
5714 relocate_byte_stack ();
5716 /* Clear the mark bits that we set in certain root slots. */
5717 VECTOR_UNMARK (&buffer_defaults
);
5718 VECTOR_UNMARK (&buffer_local_symbols
);
5726 consing_since_gc
= 0;
5727 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5728 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5730 gc_relative_threshold
= 0;
5731 if (FLOATP (Vgc_cons_percentage
))
5732 { /* Set gc_cons_combined_threshold. */
5733 double tot
= total_bytes_of_live_objects ();
5735 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5738 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5739 gc_relative_threshold
= tot
;
5741 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5745 if (garbage_collection_messages
&& NILP (Vmemory_full
))
5747 if (message_p
|| minibuf_level
> 0)
5750 message1_nolog ("Garbage collecting...done");
5753 unbind_to (count
, Qnil
);
5755 Lisp_Object total
[] = {
5756 list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5757 bounded_number (total_conses
),
5758 bounded_number (total_free_conses
)),
5759 list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5760 bounded_number (total_symbols
),
5761 bounded_number (total_free_symbols
)),
5762 list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5763 bounded_number (total_markers
),
5764 bounded_number (total_free_markers
)),
5765 list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5766 bounded_number (total_strings
),
5767 bounded_number (total_free_strings
)),
5768 list3 (Qstring_bytes
, make_number (1),
5769 bounded_number (total_string_bytes
)),
5771 make_number (header_size
+ sizeof (Lisp_Object
)),
5772 bounded_number (total_vectors
)),
5773 list4 (Qvector_slots
, make_number (word_size
),
5774 bounded_number (total_vector_slots
),
5775 bounded_number (total_free_vector_slots
)),
5776 list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5777 bounded_number (total_floats
),
5778 bounded_number (total_free_floats
)),
5779 list4 (Qintervals
, make_number (sizeof (struct interval
)),
5780 bounded_number (total_intervals
),
5781 bounded_number (total_free_intervals
)),
5782 list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5783 bounded_number (total_buffers
)),
5785 #ifdef DOUG_LEA_MALLOC
5786 list4 (Qheap
, make_number (1024),
5787 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5788 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10)),
5791 retval
= CALLMANY (Flist
, total
);
5793 /* GC is complete: now we can run our finalizer callbacks. */
5794 run_finalizers (&doomed_finalizers
);
5796 if (!NILP (Vpost_gc_hook
))
5798 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5799 safe_run_hooks (Qpost_gc_hook
);
5800 unbind_to (gc_count
, Qnil
);
5803 /* Accumulate statistics. */
5804 if (FLOATP (Vgc_elapsed
))
5806 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5807 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5808 + timespectod (since_start
));
5813 /* Collect profiling data. */
5814 if (profiler_memory_running
)
5817 size_t tot_after
= total_bytes_of_live_objects ();
5818 if (tot_before
> tot_after
)
5819 swept
= tot_before
- tot_after
;
5820 malloc_probe (swept
);
5826 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5827 doc
: /* Reclaim storage for Lisp objects no longer needed.
5828 Garbage collection happens automatically if you cons more than
5829 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5830 `garbage-collect' normally returns a list with info on amount of space in use,
5831 where each entry has the form (NAME SIZE USED FREE), where:
5832 - NAME is a symbol describing the kind of objects this entry represents,
5833 - SIZE is the number of bytes used by each one,
5834 - USED is the number of those objects that were found live in the heap,
5835 - FREE is the number of those objects that are not live but that Emacs
5836 keeps around for future allocations (maybe because it does not know how
5837 to return them to the OS).
5838 However, if there was overflow in pure space, `garbage-collect'
5839 returns nil, because real GC can't be done.
5840 See Info node `(elisp)Garbage Collection'. */)
5845 #ifdef HAVE___BUILTIN_UNWIND_INIT
5846 /* Force callee-saved registers and register windows onto the stack.
5847 This is the preferred method if available, obviating the need for
5848 machine dependent methods. */
5849 __builtin_unwind_init ();
5851 #else /* not HAVE___BUILTIN_UNWIND_INIT */
5852 #ifndef GC_SAVE_REGISTERS_ON_STACK
5853 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5854 union aligned_jmpbuf
{
5858 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
5860 /* This trick flushes the register windows so that all the state of
5861 the process is contained in the stack. */
5862 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5863 needed on ia64 too. See mach_dep.c, where it also says inline
5864 assembler doesn't work with relevant proprietary compilers. */
5866 #if defined (__sparc64__) && defined (__FreeBSD__)
5867 /* FreeBSD does not have a ta 3 handler. */
5874 /* Save registers that we need to see on the stack. We need to see
5875 registers used to hold register variables and registers used to
5877 #ifdef GC_SAVE_REGISTERS_ON_STACK
5878 GC_SAVE_REGISTERS_ON_STACK (end
);
5879 #else /* not GC_SAVE_REGISTERS_ON_STACK */
5881 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5882 setjmp will definitely work, test it
5883 and print a message with the result
5885 if (!setjmp_tested_p
)
5887 setjmp_tested_p
= 1;
5890 #endif /* GC_SETJMP_WORKS */
5893 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
5894 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
5895 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
5896 return garbage_collect_1 (end
);
5899 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5900 only interesting objects referenced from glyphs are strings. */
5903 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5905 struct glyph_row
*row
= matrix
->rows
;
5906 struct glyph_row
*end
= row
+ matrix
->nrows
;
5908 for (; row
< end
; ++row
)
5912 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5914 struct glyph
*glyph
= row
->glyphs
[area
];
5915 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5917 for (; glyph
< end_glyph
; ++glyph
)
5918 if (STRINGP (glyph
->object
)
5919 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5920 mark_object (glyph
->object
);
5925 /* Mark reference to a Lisp_Object.
5926 If the object referred to has not been seen yet, recursively mark
5927 all the references contained in it. */
5929 #define LAST_MARKED_SIZE 500
5930 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5931 static int last_marked_index
;
5933 /* For debugging--call abort when we cdr down this many
5934 links of a list, in mark_object. In debugging,
5935 the call to abort will hit a breakpoint.
5936 Normally this is zero and the check never goes off. */
5937 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5940 mark_vectorlike (struct Lisp_Vector
*ptr
)
5942 ptrdiff_t size
= ptr
->header
.size
;
5945 eassert (!VECTOR_MARKED_P (ptr
));
5946 VECTOR_MARK (ptr
); /* Else mark it. */
5947 if (size
& PSEUDOVECTOR_FLAG
)
5948 size
&= PSEUDOVECTOR_SIZE_MASK
;
5950 /* Note that this size is not the memory-footprint size, but only
5951 the number of Lisp_Object fields that we should trace.
5952 The distinction is used e.g. by Lisp_Process which places extra
5953 non-Lisp_Object fields at the end of the structure... */
5954 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5955 mark_object (ptr
->contents
[i
]);
5958 /* Like mark_vectorlike but optimized for char-tables (and
5959 sub-char-tables) assuming that the contents are mostly integers or
5963 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
5965 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5966 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
5967 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
5969 eassert (!VECTOR_MARKED_P (ptr
));
5971 for (i
= idx
; i
< size
; i
++)
5973 Lisp_Object val
= ptr
->contents
[i
];
5975 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5977 if (SUB_CHAR_TABLE_P (val
))
5979 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5980 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
5987 NO_INLINE
/* To reduce stack depth in mark_object. */
5989 mark_compiled (struct Lisp_Vector
*ptr
)
5991 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5994 for (i
= 0; i
< size
; i
++)
5995 if (i
!= COMPILED_CONSTANTS
)
5996 mark_object (ptr
->contents
[i
]);
5997 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6000 /* Mark the chain of overlays starting at PTR. */
6003 mark_overlay (struct Lisp_Overlay
*ptr
)
6005 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6008 /* These two are always markers and can be marked fast. */
6009 XMARKER (ptr
->start
)->gcmarkbit
= 1;
6010 XMARKER (ptr
->end
)->gcmarkbit
= 1;
6011 mark_object (ptr
->plist
);
6015 /* Mark Lisp_Objects and special pointers in BUFFER. */
6018 mark_buffer (struct buffer
*buffer
)
6020 /* This is handled much like other pseudovectors... */
6021 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6023 /* ...but there are some buffer-specific things. */
6025 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6027 /* For now, we just don't mark the undo_list. It's done later in
6028 a special way just before the sweep phase, and after stripping
6029 some of its elements that are not needed any more. */
6031 mark_overlay (buffer
->overlays_before
);
6032 mark_overlay (buffer
->overlays_after
);
6034 /* If this is an indirect buffer, mark its base buffer. */
6035 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6036 mark_buffer (buffer
->base_buffer
);
6039 /* Mark Lisp faces in the face cache C. */
6041 NO_INLINE
/* To reduce stack depth in mark_object. */
6043 mark_face_cache (struct face_cache
*c
)
6048 for (i
= 0; i
< c
->used
; ++i
)
6050 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
6054 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6055 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6057 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6058 mark_object (face
->lface
[j
]);
6064 NO_INLINE
/* To reduce stack depth in mark_object. */
6066 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6068 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6069 Lisp_Object where
= blv
->where
;
6070 /* If the value is set up for a killed buffer or deleted
6071 frame, restore its global binding. If the value is
6072 forwarded to a C variable, either it's not a Lisp_Object
6073 var, or it's staticpro'd already. */
6074 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6075 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6076 swap_in_global_binding (ptr
);
6077 mark_object (blv
->where
);
6078 mark_object (blv
->valcell
);
6079 mark_object (blv
->defcell
);
6082 NO_INLINE
/* To reduce stack depth in mark_object. */
6084 mark_save_value (struct Lisp_Save_Value
*ptr
)
6086 /* If `save_type' is zero, `data[0].pointer' is the address
6087 of a memory area containing `data[1].integer' potential
6089 if (ptr
->save_type
== SAVE_TYPE_MEMORY
)
6091 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6093 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6094 mark_maybe_object (*p
);
6098 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6100 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6101 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6102 mark_object (ptr
->data
[i
].object
);
6106 /* Remove killed buffers or items whose car is a killed buffer from
6107 LIST, and mark other items. Return changed LIST, which is marked. */
6110 mark_discard_killed_buffers (Lisp_Object list
)
6112 Lisp_Object tail
, *prev
= &list
;
6114 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6117 Lisp_Object tem
= XCAR (tail
);
6120 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6121 *prev
= XCDR (tail
);
6124 CONS_MARK (XCONS (tail
));
6125 mark_object (XCAR (tail
));
6126 prev
= xcdr_addr (tail
);
6133 /* Determine type of generic Lisp_Object and mark it accordingly.
6135 This function implements a straightforward depth-first marking
6136 algorithm and so the recursion depth may be very high (a few
6137 tens of thousands is not uncommon). To minimize stack usage,
6138 a few cold paths are moved out to NO_INLINE functions above.
6139 In general, inlining them doesn't help you to gain more speed. */
6142 mark_object (Lisp_Object arg
)
6144 register Lisp_Object obj
;
6146 #ifdef GC_CHECK_MARKED_OBJECTS
6149 ptrdiff_t cdr_count
= 0;
6158 last_marked
[last_marked_index
++] = obj
;
6159 if (last_marked_index
== LAST_MARKED_SIZE
)
6160 last_marked_index
= 0;
6162 /* Perform some sanity checks on the objects marked here. Abort if
6163 we encounter an object we know is bogus. This increases GC time
6165 #ifdef GC_CHECK_MARKED_OBJECTS
6167 /* Check that the object pointed to by PO is known to be a Lisp
6168 structure allocated from the heap. */
6169 #define CHECK_ALLOCATED() \
6171 m = mem_find (po); \
6176 /* Check that the object pointed to by PO is live, using predicate
6178 #define CHECK_LIVE(LIVEP) \
6180 if (!LIVEP (m, po)) \
6184 /* Check both of the above conditions, for non-symbols. */
6185 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6187 CHECK_ALLOCATED (); \
6188 CHECK_LIVE (LIVEP); \
6191 /* Check both of the above conditions, for symbols. */
6192 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6194 if (!c_symbol_p (ptr)) \
6196 CHECK_ALLOCATED (); \
6197 CHECK_LIVE (live_symbol_p); \
6201 #else /* not GC_CHECK_MARKED_OBJECTS */
6203 #define CHECK_LIVE(LIVEP) ((void) 0)
6204 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6205 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6207 #endif /* not GC_CHECK_MARKED_OBJECTS */
6209 switch (XTYPE (obj
))
6213 register struct Lisp_String
*ptr
= XSTRING (obj
);
6214 if (STRING_MARKED_P (ptr
))
6216 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6218 MARK_INTERVAL_TREE (ptr
->intervals
);
6219 #ifdef GC_CHECK_STRING_BYTES
6220 /* Check that the string size recorded in the string is the
6221 same as the one recorded in the sdata structure. */
6223 #endif /* GC_CHECK_STRING_BYTES */
6227 case Lisp_Vectorlike
:
6229 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6230 register ptrdiff_t pvectype
;
6232 if (VECTOR_MARKED_P (ptr
))
6235 #ifdef GC_CHECK_MARKED_OBJECTS
6237 if (m
== MEM_NIL
&& !SUBRP (obj
))
6239 #endif /* GC_CHECK_MARKED_OBJECTS */
6241 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6242 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6243 >> PSEUDOVECTOR_AREA_BITS
);
6245 pvectype
= PVEC_NORMAL_VECTOR
;
6247 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6248 CHECK_LIVE (live_vector_p
);
6253 #ifdef GC_CHECK_MARKED_OBJECTS
6262 #endif /* GC_CHECK_MARKED_OBJECTS */
6263 mark_buffer ((struct buffer
*) ptr
);
6267 /* Although we could treat this just like a vector, mark_compiled
6268 returns the COMPILED_CONSTANTS element, which is marked at the
6269 next iteration of goto-loop here. This is done to avoid a few
6270 recursive calls to mark_object. */
6271 obj
= mark_compiled (ptr
);
6278 struct frame
*f
= (struct frame
*) ptr
;
6280 mark_vectorlike (ptr
);
6281 mark_face_cache (f
->face_cache
);
6282 #ifdef HAVE_WINDOW_SYSTEM
6283 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6285 struct font
*font
= FRAME_FONT (f
);
6287 if (font
&& !VECTOR_MARKED_P (font
))
6288 mark_vectorlike ((struct Lisp_Vector
*) font
);
6296 struct window
*w
= (struct window
*) ptr
;
6298 mark_vectorlike (ptr
);
6300 /* Mark glyph matrices, if any. Marking window
6301 matrices is sufficient because frame matrices
6302 use the same glyph memory. */
6303 if (w
->current_matrix
)
6305 mark_glyph_matrix (w
->current_matrix
);
6306 mark_glyph_matrix (w
->desired_matrix
);
6309 /* Filter out killed buffers from both buffer lists
6310 in attempt to help GC to reclaim killed buffers faster.
6311 We can do it elsewhere for live windows, but this is the
6312 best place to do it for dead windows. */
6314 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6316 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6320 case PVEC_HASH_TABLE
:
6322 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6324 mark_vectorlike (ptr
);
6325 mark_object (h
->test
.name
);
6326 mark_object (h
->test
.user_hash_function
);
6327 mark_object (h
->test
.user_cmp_function
);
6328 /* If hash table is not weak, mark all keys and values.
6329 For weak tables, mark only the vector. */
6331 mark_object (h
->key_and_value
);
6333 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6337 case PVEC_CHAR_TABLE
:
6338 case PVEC_SUB_CHAR_TABLE
:
6339 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6342 case PVEC_BOOL_VECTOR
:
6343 /* No Lisp_Objects to mark in a bool vector. */
6354 mark_vectorlike (ptr
);
6361 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6365 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6367 /* Attempt to catch bogus objects. */
6368 eassert (valid_lisp_object_p (ptr
->function
));
6369 mark_object (ptr
->function
);
6370 mark_object (ptr
->plist
);
6371 switch (ptr
->redirect
)
6373 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6374 case SYMBOL_VARALIAS
:
6377 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6381 case SYMBOL_LOCALIZED
:
6382 mark_localized_symbol (ptr
);
6384 case SYMBOL_FORWARDED
:
6385 /* If the value is forwarded to a buffer or keyboard field,
6386 these are marked when we see the corresponding object.
6387 And if it's forwarded to a C variable, either it's not
6388 a Lisp_Object var, or it's staticpro'd already. */
6390 default: emacs_abort ();
6392 if (!PURE_P (XSTRING (ptr
->name
)))
6393 MARK_STRING (XSTRING (ptr
->name
));
6394 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6395 /* Inner loop to mark next symbol in this bucket, if any. */
6396 po
= ptr
= ptr
->next
;
6403 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6405 if (XMISCANY (obj
)->gcmarkbit
)
6408 switch (XMISCTYPE (obj
))
6410 case Lisp_Misc_Marker
:
6411 /* DO NOT mark thru the marker's chain.
6412 The buffer's markers chain does not preserve markers from gc;
6413 instead, markers are removed from the chain when freed by gc. */
6414 XMISCANY (obj
)->gcmarkbit
= 1;
6417 case Lisp_Misc_Save_Value
:
6418 XMISCANY (obj
)->gcmarkbit
= 1;
6419 mark_save_value (XSAVE_VALUE (obj
));
6422 case Lisp_Misc_Overlay
:
6423 mark_overlay (XOVERLAY (obj
));
6426 case Lisp_Misc_Finalizer
:
6427 XMISCANY (obj
)->gcmarkbit
= true;
6428 mark_object (XFINALIZER (obj
)->function
);
6432 case Lisp_Misc_User_Ptr
:
6433 XMISCANY (obj
)->gcmarkbit
= true;
6444 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6445 if (CONS_MARKED_P (ptr
))
6447 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6449 /* If the cdr is nil, avoid recursion for the car. */
6450 if (EQ (ptr
->u
.cdr
, Qnil
))
6456 mark_object (ptr
->car
);
6459 if (cdr_count
== mark_object_loop_halt
)
6465 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6466 FLOAT_MARK (XFLOAT (obj
));
6477 #undef CHECK_ALLOCATED
6478 #undef CHECK_ALLOCATED_AND_LIVE
6480 /* Mark the Lisp pointers in the terminal objects.
6481 Called by Fgarbage_collect. */
6484 mark_terminals (void)
6487 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6489 eassert (t
->name
!= NULL
);
6490 #ifdef HAVE_WINDOW_SYSTEM
6491 /* If a terminal object is reachable from a stacpro'ed object,
6492 it might have been marked already. Make sure the image cache
6494 mark_image_cache (t
->image_cache
);
6495 #endif /* HAVE_WINDOW_SYSTEM */
6496 if (!VECTOR_MARKED_P (t
))
6497 mark_vectorlike ((struct Lisp_Vector
*)t
);
6503 /* Value is non-zero if OBJ will survive the current GC because it's
6504 either marked or does not need to be marked to survive. */
6507 survives_gc_p (Lisp_Object obj
)
6511 switch (XTYPE (obj
))
6518 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6522 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6526 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6529 case Lisp_Vectorlike
:
6530 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6534 survives_p
= CONS_MARKED_P (XCONS (obj
));
6538 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6545 return survives_p
|| PURE_P (XPNTR (obj
));
6551 NO_INLINE
/* For better stack traces */
6555 struct cons_block
*cblk
;
6556 struct cons_block
**cprev
= &cons_block
;
6557 int lim
= cons_block_index
;
6558 EMACS_INT num_free
= 0, num_used
= 0;
6562 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6566 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6568 /* Scan the mark bits an int at a time. */
6569 for (i
= 0; i
< ilim
; i
++)
6571 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6573 /* Fast path - all cons cells for this int are marked. */
6574 cblk
->gcmarkbits
[i
] = 0;
6575 num_used
+= BITS_PER_BITS_WORD
;
6579 /* Some cons cells for this int are not marked.
6580 Find which ones, and free them. */
6581 int start
, pos
, stop
;
6583 start
= i
* BITS_PER_BITS_WORD
;
6585 if (stop
> BITS_PER_BITS_WORD
)
6586 stop
= BITS_PER_BITS_WORD
;
6589 for (pos
= start
; pos
< stop
; pos
++)
6591 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6594 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6595 cons_free_list
= &cblk
->conses
[pos
];
6596 cons_free_list
->car
= Vdead
;
6601 CONS_UNMARK (&cblk
->conses
[pos
]);
6607 lim
= CONS_BLOCK_SIZE
;
6608 /* If this block contains only free conses and we have already
6609 seen more than two blocks worth of free conses then deallocate
6611 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6613 *cprev
= cblk
->next
;
6614 /* Unhook from the free list. */
6615 cons_free_list
= cblk
->conses
[0].u
.chain
;
6616 lisp_align_free (cblk
);
6620 num_free
+= this_free
;
6621 cprev
= &cblk
->next
;
6624 total_conses
= num_used
;
6625 total_free_conses
= num_free
;
6628 NO_INLINE
/* For better stack traces */
6632 register struct float_block
*fblk
;
6633 struct float_block
**fprev
= &float_block
;
6634 register int lim
= float_block_index
;
6635 EMACS_INT num_free
= 0, num_used
= 0;
6637 float_free_list
= 0;
6639 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6643 for (i
= 0; i
< lim
; i
++)
6644 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6647 fblk
->floats
[i
].u
.chain
= float_free_list
;
6648 float_free_list
= &fblk
->floats
[i
];
6653 FLOAT_UNMARK (&fblk
->floats
[i
]);
6655 lim
= FLOAT_BLOCK_SIZE
;
6656 /* If this block contains only free floats and we have already
6657 seen more than two blocks worth of free floats then deallocate
6659 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6661 *fprev
= fblk
->next
;
6662 /* Unhook from the free list. */
6663 float_free_list
= fblk
->floats
[0].u
.chain
;
6664 lisp_align_free (fblk
);
6668 num_free
+= this_free
;
6669 fprev
= &fblk
->next
;
6672 total_floats
= num_used
;
6673 total_free_floats
= num_free
;
6676 NO_INLINE
/* For better stack traces */
6678 sweep_intervals (void)
6680 register struct interval_block
*iblk
;
6681 struct interval_block
**iprev
= &interval_block
;
6682 register int lim
= interval_block_index
;
6683 EMACS_INT num_free
= 0, num_used
= 0;
6685 interval_free_list
= 0;
6687 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6692 for (i
= 0; i
< lim
; i
++)
6694 if (!iblk
->intervals
[i
].gcmarkbit
)
6696 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6697 interval_free_list
= &iblk
->intervals
[i
];
6703 iblk
->intervals
[i
].gcmarkbit
= 0;
6706 lim
= INTERVAL_BLOCK_SIZE
;
6707 /* If this block contains only free intervals and we have already
6708 seen more than two blocks worth of free intervals then
6709 deallocate this block. */
6710 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6712 *iprev
= iblk
->next
;
6713 /* Unhook from the free list. */
6714 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6719 num_free
+= this_free
;
6720 iprev
= &iblk
->next
;
6723 total_intervals
= num_used
;
6724 total_free_intervals
= num_free
;
6727 NO_INLINE
/* For better stack traces */
6729 sweep_symbols (void)
6731 struct symbol_block
*sblk
;
6732 struct symbol_block
**sprev
= &symbol_block
;
6733 int lim
= symbol_block_index
;
6734 EMACS_INT num_free
= 0, num_used
= ARRAYELTS (lispsym
);
6736 symbol_free_list
= NULL
;
6738 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
6739 lispsym
[i
].gcmarkbit
= 0;
6741 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6744 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6745 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6747 for (; sym
< end
; ++sym
)
6749 if (!sym
->s
.gcmarkbit
)
6751 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6752 xfree (SYMBOL_BLV (&sym
->s
));
6753 sym
->s
.next
= symbol_free_list
;
6754 symbol_free_list
= &sym
->s
;
6755 symbol_free_list
->function
= Vdead
;
6761 sym
->s
.gcmarkbit
= 0;
6762 /* Attempt to catch bogus objects. */
6763 eassert (valid_lisp_object_p (sym
->s
.function
));
6767 lim
= SYMBOL_BLOCK_SIZE
;
6768 /* If this block contains only free symbols and we have already
6769 seen more than two blocks worth of free symbols then deallocate
6771 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6773 *sprev
= sblk
->next
;
6774 /* Unhook from the free list. */
6775 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6780 num_free
+= this_free
;
6781 sprev
= &sblk
->next
;
6784 total_symbols
= num_used
;
6785 total_free_symbols
= num_free
;
6788 NO_INLINE
/* For better stack traces. */
6792 register struct marker_block
*mblk
;
6793 struct marker_block
**mprev
= &marker_block
;
6794 register int lim
= marker_block_index
;
6795 EMACS_INT num_free
= 0, num_used
= 0;
6797 /* Put all unmarked misc's on free list. For a marker, first
6798 unchain it from the buffer it points into. */
6800 marker_free_list
= 0;
6802 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6807 for (i
= 0; i
< lim
; i
++)
6809 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6811 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6812 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6813 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Finalizer
)
6814 unchain_finalizer (&mblk
->markers
[i
].m
.u_finalizer
);
6816 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_User_Ptr
)
6818 struct Lisp_User_Ptr
*uptr
= &mblk
->markers
[i
].m
.u_user_ptr
;
6819 uptr
->finalizer (uptr
->p
);
6822 /* Set the type of the freed object to Lisp_Misc_Free.
6823 We could leave the type alone, since nobody checks it,
6824 but this might catch bugs faster. */
6825 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6826 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6827 marker_free_list
= &mblk
->markers
[i
].m
;
6833 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6836 lim
= MARKER_BLOCK_SIZE
;
6837 /* If this block contains only free markers and we have already
6838 seen more than two blocks worth of free markers then deallocate
6840 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6842 *mprev
= mblk
->next
;
6843 /* Unhook from the free list. */
6844 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6849 num_free
+= this_free
;
6850 mprev
= &mblk
->next
;
6854 total_markers
= num_used
;
6855 total_free_markers
= num_free
;
6858 NO_INLINE
/* For better stack traces */
6860 sweep_buffers (void)
6862 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6865 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6866 if (!VECTOR_MARKED_P (buffer
))
6868 *bprev
= buffer
->next
;
6873 VECTOR_UNMARK (buffer
);
6874 /* Do not use buffer_(set|get)_intervals here. */
6875 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6877 bprev
= &buffer
->next
;
6881 /* Sweep: find all structures not marked, and free them. */
6885 /* Remove or mark entries in weak hash tables.
6886 This must be done before any object is unmarked. */
6887 sweep_weak_hash_tables ();
6890 check_string_bytes (!noninteractive
);
6898 check_string_bytes (!noninteractive
);
6901 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
6902 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
6903 All values are in Kbytes. If there is no swap space,
6904 last two values are zero. If the system is not supported
6905 or memory information can't be obtained, return nil. */)
6908 #if defined HAVE_LINUX_SYSINFO
6914 #ifdef LINUX_SYSINFO_UNIT
6915 units
= si
.mem_unit
;
6919 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
6920 (uintmax_t) si
.freeram
* units
/ 1024,
6921 (uintmax_t) si
.totalswap
* units
/ 1024,
6922 (uintmax_t) si
.freeswap
* units
/ 1024);
6923 #elif defined WINDOWSNT
6924 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
6926 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6927 return list4i ((uintmax_t) totalram
/ 1024,
6928 (uintmax_t) freeram
/ 1024,
6929 (uintmax_t) totalswap
/ 1024,
6930 (uintmax_t) freeswap
/ 1024);
6934 unsigned long totalram
, freeram
, totalswap
, freeswap
;
6936 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
6937 return list4i ((uintmax_t) totalram
/ 1024,
6938 (uintmax_t) freeram
/ 1024,
6939 (uintmax_t) totalswap
/ 1024,
6940 (uintmax_t) freeswap
/ 1024);
6943 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6944 /* FIXME: add more systems. */
6946 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
6949 /* Debugging aids. */
6951 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6952 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6953 This may be helpful in debugging Emacs's memory usage.
6954 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6960 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
6963 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6969 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6970 doc
: /* Return a list of counters that measure how much consing there has been.
6971 Each of these counters increments for a certain kind of object.
6972 The counters wrap around from the largest positive integer to zero.
6973 Garbage collection does not decrease them.
6974 The elements of the value are as follows:
6975 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6976 All are in units of 1 = one object consed
6977 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6979 MISCS include overlays, markers, and some internal types.
6980 Frames, windows, buffers, and subprocesses count as vectors
6981 (but the contents of a buffer's text do not count here). */)
6984 return listn (CONSTYPE_HEAP
, 8,
6985 bounded_number (cons_cells_consed
),
6986 bounded_number (floats_consed
),
6987 bounded_number (vector_cells_consed
),
6988 bounded_number (symbols_consed
),
6989 bounded_number (string_chars_consed
),
6990 bounded_number (misc_objects_consed
),
6991 bounded_number (intervals_consed
),
6992 bounded_number (strings_consed
));
6996 symbol_uses_obj (Lisp_Object symbol
, Lisp_Object obj
)
6998 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
6999 Lisp_Object val
= find_symbol_value (symbol
);
7000 return (EQ (val
, obj
)
7001 || EQ (sym
->function
, obj
)
7002 || (!NILP (sym
->function
)
7003 && COMPILEDP (sym
->function
)
7004 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
7007 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)));
7010 /* Find at most FIND_MAX symbols which have OBJ as their value or
7011 function. This is used in gdbinit's `xwhichsymbols' command. */
7014 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
7016 struct symbol_block
*sblk
;
7017 ptrdiff_t gc_count
= inhibit_garbage_collection ();
7018 Lisp_Object found
= Qnil
;
7022 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
7024 Lisp_Object sym
= builtin_lisp_symbol (i
);
7025 if (symbol_uses_obj (sym
, obj
))
7027 found
= Fcons (sym
, found
);
7028 if (--find_max
== 0)
7033 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7035 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
7038 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
7040 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7043 Lisp_Object sym
= make_lisp_symbol (&aligned_sym
->s
);
7044 if (symbol_uses_obj (sym
, obj
))
7046 found
= Fcons (sym
, found
);
7047 if (--find_max
== 0)
7055 unbind_to (gc_count
, Qnil
);
7059 #ifdef SUSPICIOUS_OBJECT_CHECKING
7062 find_suspicious_object_in_range (void *begin
, void *end
)
7064 char *begin_a
= begin
;
7068 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7070 char *suspicious_object
= suspicious_objects
[i
];
7071 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7072 return suspicious_object
;
7079 note_suspicious_free (void* ptr
)
7081 struct suspicious_free_record
* rec
;
7083 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7084 if (suspicious_free_history_index
==
7085 ARRAYELTS (suspicious_free_history
))
7087 suspicious_free_history_index
= 0;
7090 memset (rec
, 0, sizeof (*rec
));
7091 rec
->suspicious_object
= ptr
;
7092 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7096 detect_suspicious_free (void* ptr
)
7100 eassert (ptr
!= NULL
);
7102 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7103 if (suspicious_objects
[i
] == ptr
)
7105 note_suspicious_free (ptr
);
7106 suspicious_objects
[i
] = NULL
;
7110 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7112 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7113 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7114 If Emacs is compiled with suspicious object checking, capture
7115 a stack trace when OBJ is freed in order to help track down
7116 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7119 #ifdef SUSPICIOUS_OBJECT_CHECKING
7120 /* Right now, we care only about vectors. */
7121 if (VECTORLIKEP (obj
))
7123 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7124 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7125 suspicious_object_index
= 0;
7131 #ifdef ENABLE_CHECKING
7133 bool suppress_checking
;
7136 die (const char *msg
, const char *file
, int line
)
7138 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7140 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7143 #endif /* ENABLE_CHECKING */
7145 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7147 /* Debugging check whether STR is ASCII-only. */
7150 verify_ascii (const char *str
)
7152 const unsigned char *ptr
= (unsigned char *) str
, *end
= ptr
+ strlen (str
);
7155 int c
= STRING_CHAR_ADVANCE (ptr
);
7156 if (!ASCII_CHAR_P (c
))
7162 /* Stress alloca with inconveniently sized requests and check
7163 whether all allocated areas may be used for Lisp_Object. */
7165 NO_INLINE
static void
7166 verify_alloca (void)
7169 enum { ALLOCA_CHECK_MAX
= 256 };
7170 /* Start from size of the smallest Lisp object. */
7171 for (i
= sizeof (struct Lisp_Cons
); i
<= ALLOCA_CHECK_MAX
; i
++)
7173 void *ptr
= alloca (i
);
7174 make_lisp_ptr (ptr
, Lisp_Cons
);
7178 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7180 #define verify_alloca() ((void) 0)
7182 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7184 /* Initialization. */
7187 init_alloc_once (void)
7189 /* Even though Qt's contents are not set up, its address is known. */
7193 pure_size
= PURESIZE
;
7196 init_finalizer_list (&finalizers
);
7197 init_finalizer_list (&doomed_finalizers
);
7200 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7202 #ifdef DOUG_LEA_MALLOC
7203 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7204 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7205 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7210 refill_memory_reserve ();
7211 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7217 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7218 setjmp_tested_p
= longjmps_done
= 0;
7220 Vgc_elapsed
= make_float (0.0);
7224 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7229 syms_of_alloc (void)
7231 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7232 doc
: /* Number of bytes of consing between garbage collections.
7233 Garbage collection can happen automatically once this many bytes have been
7234 allocated since the last garbage collection. All data types count.
7236 Garbage collection happens automatically only when `eval' is called.
7238 By binding this temporarily to a large number, you can effectively
7239 prevent garbage collection during a part of the program.
7240 See also `gc-cons-percentage'. */);
7242 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7243 doc
: /* Portion of the heap used for allocation.
7244 Garbage collection can happen automatically once this portion of the heap
7245 has been allocated since the last garbage collection.
7246 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7247 Vgc_cons_percentage
= make_float (0.1);
7249 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7250 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7252 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7253 doc
: /* Number of cons cells that have been consed so far. */);
7255 DEFVAR_INT ("floats-consed", floats_consed
,
7256 doc
: /* Number of floats that have been consed so far. */);
7258 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7259 doc
: /* Number of vector cells that have been consed so far. */);
7261 DEFVAR_INT ("symbols-consed", symbols_consed
,
7262 doc
: /* Number of symbols that have been consed so far. */);
7263 symbols_consed
+= ARRAYELTS (lispsym
);
7265 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7266 doc
: /* Number of string characters that have been consed so far. */);
7268 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7269 doc
: /* Number of miscellaneous objects that have been consed so far.
7270 These include markers and overlays, plus certain objects not visible
7273 DEFVAR_INT ("intervals-consed", intervals_consed
,
7274 doc
: /* Number of intervals that have been consed so far. */);
7276 DEFVAR_INT ("strings-consed", strings_consed
,
7277 doc
: /* Number of strings that have been consed so far. */);
7279 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7280 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7281 This means that certain objects should be allocated in shared (pure) space.
7282 It can also be set to a hash-table, in which case this table is used to
7283 do hash-consing of the objects allocated to pure space. */);
7285 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7286 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7287 garbage_collection_messages
= 0;
7289 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7290 doc
: /* Hook run after garbage collection has finished. */);
7291 Vpost_gc_hook
= Qnil
;
7292 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7294 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7295 doc
: /* Precomputed `signal' argument for memory-full error. */);
7296 /* We build this in advance because if we wait until we need it, we might
7297 not be able to allocate the memory to hold it. */
7299 = listn (CONSTYPE_PURE
, 2, Qerror
,
7300 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7302 DEFVAR_LISP ("memory-full", Vmemory_full
,
7303 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7304 Vmemory_full
= Qnil
;
7306 DEFSYM (Qconses
, "conses");
7307 DEFSYM (Qsymbols
, "symbols");
7308 DEFSYM (Qmiscs
, "miscs");
7309 DEFSYM (Qstrings
, "strings");
7310 DEFSYM (Qvectors
, "vectors");
7311 DEFSYM (Qfloats
, "floats");
7312 DEFSYM (Qintervals
, "intervals");
7313 DEFSYM (Qbuffers
, "buffers");
7314 DEFSYM (Qstring_bytes
, "string-bytes");
7315 DEFSYM (Qvector_slots
, "vector-slots");
7316 DEFSYM (Qheap
, "heap");
7317 DEFSYM (Qautomatic_gc
, "Automatic GC");
7319 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7320 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7322 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7323 doc
: /* Accumulated time elapsed in garbage collections.
7324 The time is in seconds as a floating point value. */);
7325 DEFVAR_INT ("gcs-done", gcs_done
,
7326 doc
: /* Accumulated number of garbage collections done. */);
7331 defsubr (&Sbool_vector
);
7332 defsubr (&Smake_byte_code
);
7333 defsubr (&Smake_list
);
7334 defsubr (&Smake_vector
);
7335 defsubr (&Smake_string
);
7336 defsubr (&Smake_bool_vector
);
7337 defsubr (&Smake_symbol
);
7338 defsubr (&Smake_marker
);
7339 defsubr (&Smake_finalizer
);
7340 defsubr (&Spurecopy
);
7341 defsubr (&Sgarbage_collect
);
7342 defsubr (&Smemory_limit
);
7343 defsubr (&Smemory_info
);
7344 defsubr (&Smemory_use_counts
);
7345 defsubr (&Ssuspicious_object
);
7348 /* When compiled with GCC, GDB might say "No enum type named
7349 pvec_type" if we don't have at least one symbol with that type, and
7350 then xbacktrace could fail. Similarly for the other enums and
7351 their values. Some non-GCC compilers don't like these constructs. */
7355 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7356 enum char_table_specials char_table_specials
;
7357 enum char_bits char_bits
;
7358 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7359 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7360 enum Lisp_Bits Lisp_Bits
;
7361 enum Lisp_Compiled Lisp_Compiled
;
7362 enum maxargs maxargs
;
7363 enum MAX_ALLOCA MAX_ALLOCA
;
7364 enum More_Lisp_Bits More_Lisp_Bits
;
7365 enum pvec_type pvec_type
;
7366 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7367 #endif /* __GNUC__ */