1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2018 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 (at
11 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 <https://www.gnu.org/licenses/>. */
26 #include <limits.h> /* For CHAR_BIT. */
27 #include <signal.h> /* For SIGABRT, SIGDANGER. */
34 #include "dispextern.h"
35 #include "intervals.h"
36 #include "ptr-bounds.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
47 #ifdef HAVE_WINDOW_SYSTEM
49 #endif /* HAVE_WINDOW_SYSTEM */
51 #include <flexmember.h>
53 #include <execinfo.h> /* For backtrace. */
55 #ifdef HAVE_LINUX_SYSINFO
56 #include <sys/sysinfo.h>
60 #include "dosfns.h" /* For dos_memory_info. */
67 #if (defined ENABLE_CHECKING \
68 && defined HAVE_VALGRIND_VALGRIND_H \
69 && !defined USE_VALGRIND)
70 # define USE_VALGRIND 1
74 #include <valgrind/valgrind.h>
75 #include <valgrind/memcheck.h>
76 static bool valgrind_p
;
79 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
80 We turn that on by default when ENABLE_CHECKING is defined;
81 define GC_CHECK_MARKED_OBJECTS to zero to disable. */
83 #if defined ENABLE_CHECKING && !defined GC_CHECK_MARKED_OBJECTS
84 # define GC_CHECK_MARKED_OBJECTS 1
87 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
88 memory. Can do this only if using gmalloc.c and if not checking
91 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
92 || defined HYBRID_MALLOC || GC_CHECK_MARKED_OBJECTS)
93 #undef GC_MALLOC_CHECK
100 # include "gtkutil.h"
104 #include "w32heap.h" /* for sbrk */
107 #if defined GNU_LINUX && !defined CANNOT_DUMP
108 /* The address where the heap starts. */
119 #ifdef DOUG_LEA_MALLOC
121 /* Specify maximum number of areas to mmap. It would be nice to use a
122 value that explicitly means "no limit". */
124 #define MMAP_MAX_AREAS 100000000
126 /* A pointer to the memory allocated that copies that static data
127 inside glibc's malloc. */
128 static void *malloc_state_ptr
;
130 /* Restore the dumped malloc state. Because malloc can be invoked
131 even before main (e.g. by the dynamic linker), the dumped malloc
132 state must be restored as early as possible using this special hook. */
134 malloc_initialize_hook (void)
136 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 if (malloc_set_state (malloc_state_ptr
) != 0)
167 # ifndef XMALLOC_OVERRUN_CHECK
168 alloc_unexec_post ();
173 /* Declare the malloc initialization hook, which runs before 'main' starts.
174 EXTERNALLY_VISIBLE works around Bug#22522. */
175 typedef void (*voidfuncptr
) (void);
176 # ifndef __MALLOC_HOOK_VOLATILE
177 # define __MALLOC_HOOK_VOLATILE
179 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
180 = malloc_initialize_hook
;
184 #if defined DOUG_LEA_MALLOC || !defined CANNOT_DUMP
186 /* Allocator-related actions to do just before and after unexec. */
189 alloc_unexec_pre (void)
191 # ifdef DOUG_LEA_MALLOC
192 malloc_state_ptr
= malloc_get_state ();
193 if (!malloc_state_ptr
)
194 fatal ("malloc_get_state: %s", strerror (errno
));
196 # ifdef HYBRID_MALLOC
197 bss_sbrk_did_unexec
= true;
202 alloc_unexec_post (void)
204 # ifdef DOUG_LEA_MALLOC
205 free (malloc_state_ptr
);
207 # ifdef HYBRID_MALLOC
208 bss_sbrk_did_unexec
= false;
213 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
214 to a struct Lisp_String. */
216 #define MARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
217 #define UNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
218 #define STRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
220 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
221 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
222 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
224 /* Default value of gc_cons_threshold (see below). */
226 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
228 /* Global variables. */
229 struct emacs_globals globals
;
231 /* Number of bytes of consing done since the last gc. */
233 EMACS_INT consing_since_gc
;
235 /* Similar minimum, computed from Vgc_cons_percentage. */
237 EMACS_INT gc_relative_threshold
;
239 /* Minimum number of bytes of consing since GC before next GC,
240 when memory is full. */
242 EMACS_INT memory_full_cons_threshold
;
244 /* True during GC. */
248 /* Number of live and free conses etc. */
250 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
251 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
252 static EMACS_INT total_free_floats
, total_floats
;
254 /* Points to memory space allocated as "spare", to be freed if we run
255 out of memory. We keep one large block, four cons-blocks, and
256 two string blocks. */
258 static char *spare_memory
[7];
260 /* Amount of spare memory to keep in large reserve block, or to see
261 whether this much is available when malloc fails on a larger request. */
263 #define SPARE_MEMORY (1 << 14)
265 /* Initialize it to a nonzero value to force it into data space
266 (rather than bss space). That way unexec will remap it into text
267 space (pure), on some systems. We have not implemented the
268 remapping on more recent systems because this is less important
269 nowadays than in the days of small memories and timesharing. */
271 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
272 #define PUREBEG (char *) pure
274 /* Pointer to the pure area, and its size. */
276 static char *purebeg
;
277 static ptrdiff_t pure_size
;
279 /* Number of bytes of pure storage used before pure storage overflowed.
280 If this is non-zero, this implies that an overflow occurred. */
282 static ptrdiff_t pure_bytes_used_before_overflow
;
284 /* Index in pure at which next pure Lisp object will be allocated.. */
286 static ptrdiff_t pure_bytes_used_lisp
;
288 /* Number of bytes allocated for non-Lisp objects in pure storage. */
290 static ptrdiff_t pure_bytes_used_non_lisp
;
292 /* If nonzero, this is a warning delivered by malloc and not yet
295 const char *pending_malloc_warning
;
297 #if 0 /* Normally, pointer sanity only on request... */
298 #ifdef ENABLE_CHECKING
299 #define SUSPICIOUS_OBJECT_CHECKING 1
303 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
304 bug is unresolved. */
305 #define SUSPICIOUS_OBJECT_CHECKING 1
307 #ifdef SUSPICIOUS_OBJECT_CHECKING
308 struct suspicious_free_record
310 void *suspicious_object
;
311 void *backtrace
[128];
313 static void *suspicious_objects
[32];
314 static int suspicious_object_index
;
315 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
316 static int suspicious_free_history_index
;
317 /* Find the first currently-monitored suspicious pointer in range
318 [begin,end) or NULL if no such pointer exists. */
319 static void *find_suspicious_object_in_range (void *begin
, void *end
);
320 static void detect_suspicious_free (void *ptr
);
322 # define find_suspicious_object_in_range(begin, end) NULL
323 # define detect_suspicious_free(ptr) (void)
326 /* Maximum amount of C stack to save when a GC happens. */
328 #ifndef MAX_SAVE_STACK
329 #define MAX_SAVE_STACK 16000
332 /* Buffer in which we save a copy of the C stack at each GC. */
334 #if MAX_SAVE_STACK > 0
335 static char *stack_copy
;
336 static ptrdiff_t stack_copy_size
;
338 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
339 avoiding any address sanitization. */
341 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
342 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
344 if (! ADDRESS_SANITIZER
)
345 return memcpy (dest
, src
, size
);
351 for (i
= 0; i
< size
; i
++)
357 #endif /* MAX_SAVE_STACK > 0 */
359 static void mark_terminals (void);
360 static void gc_sweep (void);
361 static Lisp_Object
make_pure_vector (ptrdiff_t);
362 static void mark_buffer (struct buffer
*);
364 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
365 static void refill_memory_reserve (void);
367 static void compact_small_strings (void);
368 static void free_large_strings (void);
369 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
371 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
372 what memory allocated via lisp_malloc and lisp_align_malloc is intended
373 for what purpose. This enumeration specifies the type of memory. */
384 /* Since all non-bool pseudovectors are small enough to be
385 allocated from vector blocks, this memory type denotes
386 large regular vectors and large bool pseudovectors. */
388 /* Special type to denote vector blocks. */
389 MEM_TYPE_VECTOR_BLOCK
,
390 /* Special type to denote reserved memory. */
394 /* A unique object in pure space used to make some Lisp objects
395 on free lists recognizable in O(1). */
397 static Lisp_Object Vdead
;
398 #define DEADP(x) EQ (x, Vdead)
400 #ifdef GC_MALLOC_CHECK
402 enum mem_type allocated_mem_type
;
404 #endif /* GC_MALLOC_CHECK */
406 /* A node in the red-black tree describing allocated memory containing
407 Lisp data. Each such block is recorded with its start and end
408 address when it is allocated, and removed from the tree when it
411 A red-black tree is a balanced binary tree with the following
414 1. Every node is either red or black.
415 2. Every leaf is black.
416 3. If a node is red, then both of its children are black.
417 4. Every simple path from a node to a descendant leaf contains
418 the same number of black nodes.
419 5. The root is always black.
421 When nodes are inserted into the tree, or deleted from the tree,
422 the tree is "fixed" so that these properties are always true.
424 A red-black tree with N internal nodes has height at most 2
425 log(N+1). Searches, insertions and deletions are done in O(log N).
426 Please see a text book about data structures for a detailed
427 description of red-black trees. Any book worth its salt should
432 /* Children of this node. These pointers are never NULL. When there
433 is no child, the value is MEM_NIL, which points to a dummy node. */
434 struct mem_node
*left
, *right
;
436 /* The parent of this node. In the root node, this is NULL. */
437 struct mem_node
*parent
;
439 /* Start and end of allocated region. */
443 enum {MEM_BLACK
, MEM_RED
} color
;
449 /* Root of the tree describing allocated Lisp memory. */
451 static struct mem_node
*mem_root
;
453 /* Lowest and highest known address in the heap. */
455 static void *min_heap_address
, *max_heap_address
;
457 /* Sentinel node of the tree. */
459 static struct mem_node mem_z
;
460 #define MEM_NIL &mem_z
462 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
463 static void mem_insert_fixup (struct mem_node
*);
464 static void mem_rotate_left (struct mem_node
*);
465 static void mem_rotate_right (struct mem_node
*);
466 static void mem_delete (struct mem_node
*);
467 static void mem_delete_fixup (struct mem_node
*);
468 static struct mem_node
*mem_find (void *);
474 /* Addresses of staticpro'd variables. Initialize it to a nonzero
475 value; otherwise some compilers put it into BSS. */
477 enum { NSTATICS
= 2048 };
478 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
480 /* Index of next unused slot in staticvec. */
482 static int staticidx
;
484 static void *pure_alloc (size_t, int);
486 /* True if N is a power of 2. N should be positive. */
488 #define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
490 /* Return X rounded to the next multiple of Y. Y should be positive,
491 and Y - 1 + X should not overflow. Arguments should not have side
492 effects, as they are evaluated more than once. Tune for Y being a
495 #define ROUNDUP(x, y) (POWER_OF_2 (y) \
496 ? ((y) - 1 + (x)) & ~ ((y) - 1) \
497 : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
499 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
502 pointer_align (void *ptr
, int alignment
)
504 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
507 /* Define PNTR_ADD and XPNTR as functions, which are cleaner and can
508 be used in debuggers. Also, define them as macros if
509 DEFINE_KEY_OPS_AS_MACROS, for performance in that case.
510 The macro_* macros are private to this section of code. */
512 /* Add a pointer P to an integer I without gcc -fsanitize complaining
513 about the result being out of range of the underlying array. */
515 #define macro_PNTR_ADD(p, i) ((p) + (i))
517 static ATTRIBUTE_NO_SANITIZE_UNDEFINED ATTRIBUTE_UNUSED
char *
518 PNTR_ADD (char *p
, EMACS_UINT i
)
520 return macro_PNTR_ADD (p
, i
);
523 #if DEFINE_KEY_OPS_AS_MACROS
524 # define PNTR_ADD(p, i) macro_PNTR_ADD (p, i)
527 /* Extract the pointer hidden within O. */
529 #define macro_XPNTR(o) \
532 ? PNTR_ADD ((char *) lispsym, \
534 - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)))) \
535 : (char *) XLP (o) - (XLI (o) & ~VALMASK)))
537 static ATTRIBUTE_UNUSED
void *
538 XPNTR (Lisp_Object a
)
540 return macro_XPNTR (a
);
543 #if DEFINE_KEY_OPS_AS_MACROS
544 # define XPNTR(a) macro_XPNTR (a)
548 XFLOAT_INIT (Lisp_Object f
, double n
)
550 XFLOAT (f
)->u
.data
= n
;
553 #ifdef DOUG_LEA_MALLOC
555 pointers_fit_in_lispobj_p (void)
557 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
561 mmap_lisp_allowed_p (void)
563 /* If we can't store all memory addresses in our lisp objects, it's
564 risky to let the heap use mmap and give us addresses from all
565 over our address space. We also can't use mmap for lisp objects
566 if we might dump: unexec doesn't preserve the contents of mmapped
568 return pointers_fit_in_lispobj_p () && !might_dump
;
572 /* Head of a circularly-linked list of extant finalizers. */
573 static struct Lisp_Finalizer finalizers
;
575 /* Head of a circularly-linked list of finalizers that must be invoked
576 because we deemed them unreachable. This list must be global, and
577 not a local inside garbage_collect_1, in case we GC again while
578 running finalizers. */
579 static struct Lisp_Finalizer doomed_finalizers
;
582 /************************************************************************
584 ************************************************************************/
586 #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
588 /* Function malloc calls this if it finds we are near exhausting storage. */
591 malloc_warning (const char *str
)
593 pending_malloc_warning
= str
;
598 /* Display an already-pending malloc warning. */
601 display_malloc_warning (void)
603 call3 (intern ("display-warning"),
605 build_string (pending_malloc_warning
),
606 intern ("emergency"));
607 pending_malloc_warning
= 0;
610 /* Called if we can't allocate relocatable space for a buffer. */
613 buffer_memory_full (ptrdiff_t nbytes
)
615 /* If buffers use the relocating allocator, no need to free
616 spare_memory, because we may have plenty of malloc space left
617 that we could get, and if we don't, the malloc that fails will
618 itself cause spare_memory to be freed. If buffers don't use the
619 relocating allocator, treat this like any other failing
623 memory_full (nbytes
);
625 /* This used to call error, but if we've run out of memory, we could
626 get infinite recursion trying to build the string. */
627 xsignal (Qnil
, Vmemory_signal_data
);
631 /* A common multiple of the positive integers A and B. Ideally this
632 would be the least common multiple, but there's no way to do that
633 as a constant expression in C, so do the best that we can easily do. */
634 #define COMMON_MULTIPLE(a, b) \
635 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
637 /* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at
638 least GCALIGNMENT so that pointers can be tagged. It also must be
639 at least as strict as the alignment of all the C types used to
640 implement Lisp objects; since pseudovectors can contain any C type,
641 this is max_align_t. On recent GNU/Linux x86 and x86-64 this can
642 often waste up to 8 bytes, since alignof (max_align_t) is 16 but
643 typical vectors need only an alignment of 8. However, it is not
644 worth the hassle to avoid this waste. */
645 enum { LISP_ALIGNMENT
= alignof (union { max_align_t x
; GCALIGNED_UNION
}) };
646 verify (LISP_ALIGNMENT
% GCALIGNMENT
== 0);
648 /* True if malloc (N) is known to return storage suitably aligned for
649 Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In
650 practice this is true whenever alignof (max_align_t) is also a
651 multiple of LISP_ALIGNMENT. This works even for x86, where some
652 platform combinations (e.g., GCC 7 and later, glibc 2.25 and
653 earlier) have bugs where alignof (max_align_t) is 16 even though
654 the malloc alignment is only 8, and where Emacs still works because
655 it never does anything that requires an alignment of 16. */
656 enum { MALLOC_IS_LISP_ALIGNED
= alignof (max_align_t
) % LISP_ALIGNMENT
== 0 };
658 #ifndef XMALLOC_OVERRUN_CHECK
659 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
662 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
665 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
666 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
667 block size in little-endian order. The trailer consists of
668 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
670 The header is used to detect whether this block has been allocated
671 through these functions, as some low-level libc functions may
672 bypass the malloc hooks. */
674 #define XMALLOC_OVERRUN_CHECK_SIZE 16
675 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
676 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
678 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
679 hold a size_t value and (2) the header size is a multiple of the
680 alignment that Emacs needs for C types and for USE_LSB_TAG. */
681 #define XMALLOC_OVERRUN_SIZE_SIZE \
682 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
683 + LISP_ALIGNMENT - 1) \
684 / LISP_ALIGNMENT * LISP_ALIGNMENT) \
685 - XMALLOC_OVERRUN_CHECK_SIZE)
687 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
688 { '\x9a', '\x9b', '\xae', '\xaf',
689 '\xbf', '\xbe', '\xce', '\xcf',
690 '\xea', '\xeb', '\xec', '\xed',
691 '\xdf', '\xde', '\x9c', '\x9d' };
693 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
694 { '\xaa', '\xab', '\xac', '\xad',
695 '\xba', '\xbb', '\xbc', '\xbd',
696 '\xca', '\xcb', '\xcc', '\xcd',
697 '\xda', '\xdb', '\xdc', '\xdd' };
699 /* Insert and extract the block size in the header. */
702 xmalloc_put_size (unsigned char *ptr
, size_t size
)
705 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
707 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
713 xmalloc_get_size (unsigned char *ptr
)
717 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
718 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
727 /* Like malloc, but wraps allocated block with header and trailer. */
730 overrun_check_malloc (size_t size
)
732 register unsigned char *val
;
733 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
736 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
739 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
740 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
741 xmalloc_put_size (val
, size
);
742 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
743 XMALLOC_OVERRUN_CHECK_SIZE
);
749 /* Like realloc, but checks old block for overrun, and wraps new block
750 with header and trailer. */
753 overrun_check_realloc (void *block
, size_t size
)
755 register unsigned char *val
= (unsigned char *) block
;
756 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
760 && memcmp (xmalloc_overrun_check_header
,
761 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
762 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
764 size_t osize
= xmalloc_get_size (val
);
765 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
766 XMALLOC_OVERRUN_CHECK_SIZE
))
768 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
769 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
770 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
773 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
777 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
778 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
779 xmalloc_put_size (val
, size
);
780 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
781 XMALLOC_OVERRUN_CHECK_SIZE
);
786 /* Like free, but checks block for overrun. */
789 overrun_check_free (void *block
)
791 unsigned char *val
= (unsigned char *) block
;
794 && memcmp (xmalloc_overrun_check_header
,
795 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
796 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
798 size_t osize
= xmalloc_get_size (val
);
799 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
800 XMALLOC_OVERRUN_CHECK_SIZE
))
802 #ifdef XMALLOC_CLEAR_FREE_MEMORY
803 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
804 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
806 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
807 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
808 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
818 #define malloc overrun_check_malloc
819 #define realloc overrun_check_realloc
820 #define free overrun_check_free
823 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
824 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
825 If that variable is set, block input while in one of Emacs's memory
826 allocation functions. There should be no need for this debugging
827 option, since signal handlers do not allocate memory, but Emacs
828 formerly allocated memory in signal handlers and this compile-time
829 option remains as a way to help debug the issue should it rear its
831 #ifdef XMALLOC_BLOCK_INPUT_CHECK
832 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
834 malloc_block_input (void)
836 if (block_input_in_memory_allocators
)
840 malloc_unblock_input (void)
842 if (block_input_in_memory_allocators
)
845 # define MALLOC_BLOCK_INPUT malloc_block_input ()
846 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
848 # define MALLOC_BLOCK_INPUT ((void) 0)
849 # define MALLOC_UNBLOCK_INPUT ((void) 0)
852 #define MALLOC_PROBE(size) \
854 if (profiler_memory_running) \
855 malloc_probe (size); \
858 static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
859 static void *lrealloc (void *, size_t);
861 /* Like malloc but check for no memory and block interrupt input. */
864 xmalloc (size_t size
)
869 val
= lmalloc (size
);
870 MALLOC_UNBLOCK_INPUT
;
878 /* Like the above, but zeroes out the memory just allocated. */
881 xzalloc (size_t size
)
886 val
= lmalloc (size
);
887 MALLOC_UNBLOCK_INPUT
;
891 memset (val
, 0, size
);
896 /* Like realloc but check for no memory and block interrupt input.. */
899 xrealloc (void *block
, size_t size
)
904 /* We must call malloc explicitly when BLOCK is 0, since some
905 reallocs don't do this. */
907 val
= lmalloc (size
);
909 val
= lrealloc (block
, size
);
910 MALLOC_UNBLOCK_INPUT
;
919 /* Like free but block interrupt input. */
928 MALLOC_UNBLOCK_INPUT
;
929 /* We don't call refill_memory_reserve here
930 because in practice the call in r_alloc_free seems to suffice. */
934 /* Other parts of Emacs pass large int values to allocator functions
935 expecting ptrdiff_t. This is portable in practice, but check it to
937 verify (INT_MAX
<= PTRDIFF_MAX
);
940 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
941 Signal an error on memory exhaustion, and block interrupt input. */
944 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
946 eassert (0 <= nitems
&& 0 < item_size
);
948 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
949 memory_full (SIZE_MAX
);
950 return xmalloc (nbytes
);
954 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
955 Signal an error on memory exhaustion, and block interrupt input. */
958 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
960 eassert (0 <= nitems
&& 0 < item_size
);
962 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
963 memory_full (SIZE_MAX
);
964 return xrealloc (pa
, nbytes
);
968 /* Grow PA, which points to an array of *NITEMS items, and return the
969 location of the reallocated array, updating *NITEMS to reflect its
970 new size. The new array will contain at least NITEMS_INCR_MIN more
971 items, but will not contain more than NITEMS_MAX items total.
972 ITEM_SIZE is the size of each item, in bytes.
974 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
975 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
978 If PA is null, then allocate a new array instead of reallocating
981 Block interrupt input as needed. If memory exhaustion occurs, set
982 *NITEMS to zero if PA is null, and signal an error (i.e., do not
985 Thus, to grow an array A without saving its old contents, do
986 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
987 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
988 and signals an error, and later this code is reexecuted and
989 attempts to free A. */
992 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
993 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
995 ptrdiff_t n0
= *nitems
;
996 eassume (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n0
&& -1 <= nitems_max
);
998 /* The approximate size to use for initial small allocation
999 requests. This is the largest "small" request for the GNU C
1001 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
1003 /* If the array is tiny, grow it to about (but no greater than)
1004 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
1005 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
1006 NITEMS_MAX, and what the C language can represent safely. */
1008 ptrdiff_t n
, nbytes
;
1009 if (INT_ADD_WRAPV (n0
, n0
>> 1, &n
))
1011 if (0 <= nitems_max
&& nitems_max
< n
)
1014 ptrdiff_t adjusted_nbytes
1015 = ((INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
1016 ? min (PTRDIFF_MAX
, SIZE_MAX
)
1017 : nbytes
< DEFAULT_MXFAST
? DEFAULT_MXFAST
: 0);
1018 if (adjusted_nbytes
)
1020 n
= adjusted_nbytes
/ item_size
;
1021 nbytes
= adjusted_nbytes
- adjusted_nbytes
% item_size
;
1026 if (n
- n0
< nitems_incr_min
1027 && (INT_ADD_WRAPV (n0
, nitems_incr_min
, &n
)
1028 || (0 <= nitems_max
&& nitems_max
< n
)
1029 || INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
)))
1030 memory_full (SIZE_MAX
);
1031 pa
= xrealloc (pa
, nbytes
);
1037 /* Like strdup, but uses xmalloc. */
1040 xstrdup (const char *s
)
1044 size
= strlen (s
) + 1;
1045 return memcpy (xmalloc (size
), s
, size
);
1048 /* Like above, but duplicates Lisp string to C string. */
1051 xlispstrdup (Lisp_Object string
)
1053 ptrdiff_t size
= SBYTES (string
) + 1;
1054 return memcpy (xmalloc (size
), SSDATA (string
), size
);
1057 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1058 pointed to. If STRING is null, assign it without copying anything.
1059 Allocate before freeing, to avoid a dangling pointer if allocation
1063 dupstring (char **ptr
, char const *string
)
1066 *ptr
= string
? xstrdup (string
) : 0;
1071 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1072 argument is a const pointer. */
1075 xputenv (char const *string
)
1077 if (putenv ((char *) string
) != 0)
1081 /* Return a newly allocated memory block of SIZE bytes, remembering
1082 to free it when unwinding. */
1084 record_xmalloc (size_t size
)
1086 void *p
= xmalloc (size
);
1087 record_unwind_protect_ptr (xfree
, p
);
1092 /* Like malloc but used for allocating Lisp data. NBYTES is the
1093 number of bytes to allocate, TYPE describes the intended use of the
1094 allocated memory block (for strings, for conses, ...). */
1097 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
1101 lisp_malloc (size_t nbytes
, enum mem_type type
)
1107 #ifdef GC_MALLOC_CHECK
1108 allocated_mem_type
= type
;
1111 val
= lmalloc (nbytes
);
1114 /* If the memory just allocated cannot be addressed thru a Lisp
1115 object's pointer, and it needs to be,
1116 that's equivalent to running out of memory. */
1117 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1120 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
1121 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
1123 lisp_malloc_loser
= val
;
1130 #ifndef GC_MALLOC_CHECK
1131 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1132 mem_insert (val
, (char *) val
+ nbytes
, type
);
1135 MALLOC_UNBLOCK_INPUT
;
1137 memory_full (nbytes
);
1138 MALLOC_PROBE (nbytes
);
1142 /* Free BLOCK. This must be called to free memory allocated with a
1143 call to lisp_malloc. */
1146 lisp_free (void *block
)
1150 #ifndef GC_MALLOC_CHECK
1151 mem_delete (mem_find (block
));
1153 MALLOC_UNBLOCK_INPUT
;
1156 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1158 /* The entry point is lisp_align_malloc which returns blocks of at most
1159 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1161 /* Byte alignment of storage blocks. */
1162 #define BLOCK_ALIGN (1 << 10)
1163 verify (POWER_OF_2 (BLOCK_ALIGN
));
1165 /* Use aligned_alloc if it or a simple substitute is available.
1166 Aligned allocation is incompatible with unexmacosx.c, so don't use
1167 it on Darwin unless CANNOT_DUMP. */
1169 #if !defined DARWIN_OS || defined CANNOT_DUMP
1170 # if (defined HAVE_ALIGNED_ALLOC \
1171 || (defined HYBRID_MALLOC \
1172 ? defined HAVE_POSIX_MEMALIGN \
1173 : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
1174 # define USE_ALIGNED_ALLOC 1
1175 # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
1176 # define USE_ALIGNED_ALLOC 1
1177 # define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */
1179 aligned_alloc (size_t alignment
, size_t size
)
1181 /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *).
1182 Verify this for all arguments this function is given. */
1183 verify (BLOCK_ALIGN
% sizeof (void *) == 0
1184 && POWER_OF_2 (BLOCK_ALIGN
/ sizeof (void *)));
1185 verify (MALLOC_IS_LISP_ALIGNED
1186 || (LISP_ALIGNMENT
% sizeof (void *) == 0
1187 && POWER_OF_2 (LISP_ALIGNMENT
/ sizeof (void *))));
1188 eassert (alignment
== BLOCK_ALIGN
1189 || (!MALLOC_IS_LISP_ALIGNED
&& alignment
== LISP_ALIGNMENT
));
1192 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1197 /* Padding to leave at the end of a malloc'd block. This is to give
1198 malloc a chance to minimize the amount of memory wasted to alignment.
1199 It should be tuned to the particular malloc library used.
1200 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1201 aligned_alloc on the other hand would ideally prefer a value of 4
1202 because otherwise, there's 1020 bytes wasted between each ablocks.
1203 In Emacs, testing shows that those 1020 can most of the time be
1204 efficiently used by malloc to place other objects, so a value of 0 can
1205 still preferable unless you have a lot of aligned blocks and virtually
1207 #define BLOCK_PADDING 0
1208 #define BLOCK_BYTES \
1209 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1211 /* Internal data structures and constants. */
1213 #define ABLOCKS_SIZE 16
1215 /* An aligned block of memory. */
1220 char payload
[BLOCK_BYTES
];
1221 struct ablock
*next_free
;
1224 /* ABASE is the aligned base of the ablocks. It is overloaded to
1225 hold a virtual "busy" field that counts twice the number of used
1226 ablock values in the parent ablocks, plus one if the real base of
1227 the parent ablocks is ABASE (if the "busy" field is even, the
1228 word before the first ablock holds a pointer to the real base).
1229 The first ablock has a "busy" ABASE, and the others have an
1230 ordinary pointer ABASE. To tell the difference, the code assumes
1231 that pointers, when cast to uintptr_t, are at least 2 *
1232 ABLOCKS_SIZE + 1. */
1233 struct ablocks
*abase
;
1235 /* The padding of all but the last ablock is unused. The padding of
1236 the last ablock in an ablocks is not allocated. */
1238 char padding
[BLOCK_PADDING
];
1242 /* A bunch of consecutive aligned blocks. */
1245 struct ablock blocks
[ABLOCKS_SIZE
];
1248 /* Size of the block requested from malloc or aligned_alloc. */
1249 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1251 #define ABLOCK_ABASE(block) \
1252 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1253 ? (struct ablocks *) (block) \
1256 /* Virtual `busy' field. */
1257 #define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
1259 /* Pointer to the (not necessarily aligned) malloc block. */
1260 #ifdef USE_ALIGNED_ALLOC
1261 #define ABLOCKS_BASE(abase) (abase)
1263 #define ABLOCKS_BASE(abase) \
1264 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
1267 /* The list of free ablock. */
1268 static struct ablock
*free_ablock
;
1270 /* Allocate an aligned block of nbytes.
1271 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1272 smaller or equal to BLOCK_BYTES. */
1274 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1277 struct ablocks
*abase
;
1279 eassert (nbytes
<= BLOCK_BYTES
);
1283 #ifdef GC_MALLOC_CHECK
1284 allocated_mem_type
= type
;
1292 #ifdef DOUG_LEA_MALLOC
1293 if (!mmap_lisp_allowed_p ())
1294 mallopt (M_MMAP_MAX
, 0);
1297 #ifdef USE_ALIGNED_ALLOC
1298 verify (ABLOCKS_BYTES
% BLOCK_ALIGN
== 0);
1299 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1301 base
= malloc (ABLOCKS_BYTES
);
1302 abase
= pointer_align (base
, BLOCK_ALIGN
);
1307 MALLOC_UNBLOCK_INPUT
;
1308 memory_full (ABLOCKS_BYTES
);
1311 aligned
= (base
== abase
);
1313 ((void **) abase
)[-1] = base
;
1315 #ifdef DOUG_LEA_MALLOC
1316 if (!mmap_lisp_allowed_p ())
1317 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1321 /* If the memory just allocated cannot be addressed thru a Lisp
1322 object's pointer, and it needs to be, that's equivalent to
1323 running out of memory. */
1324 if (type
!= MEM_TYPE_NON_LISP
)
1327 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1328 XSETCONS (tem
, end
);
1329 if ((char *) XCONS (tem
) != end
)
1331 lisp_malloc_loser
= base
;
1333 MALLOC_UNBLOCK_INPUT
;
1334 memory_full (SIZE_MAX
);
1339 /* Initialize the blocks and put them on the free list.
1340 If `base' was not properly aligned, we can't use the last block. */
1341 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1343 abase
->blocks
[i
].abase
= abase
;
1344 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1345 free_ablock
= &abase
->blocks
[i
];
1347 intptr_t ialigned
= aligned
;
1348 ABLOCKS_BUSY (abase
) = (struct ablocks
*) ialigned
;
1350 eassert ((uintptr_t) abase
% BLOCK_ALIGN
== 0);
1351 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1352 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1353 eassert (ABLOCKS_BASE (abase
) == base
);
1354 eassert ((intptr_t) ABLOCKS_BUSY (abase
) == aligned
);
1357 abase
= ABLOCK_ABASE (free_ablock
);
1358 ABLOCKS_BUSY (abase
)
1359 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1361 free_ablock
= free_ablock
->x
.next_free
;
1363 #ifndef GC_MALLOC_CHECK
1364 if (type
!= MEM_TYPE_NON_LISP
)
1365 mem_insert (val
, (char *) val
+ nbytes
, type
);
1368 MALLOC_UNBLOCK_INPUT
;
1370 MALLOC_PROBE (nbytes
);
1372 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1377 lisp_align_free (void *block
)
1379 struct ablock
*ablock
= block
;
1380 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1383 #ifndef GC_MALLOC_CHECK
1384 mem_delete (mem_find (block
));
1386 /* Put on free list. */
1387 ablock
->x
.next_free
= free_ablock
;
1388 free_ablock
= ablock
;
1389 /* Update busy count. */
1390 intptr_t busy
= (intptr_t) ABLOCKS_BUSY (abase
) - 2;
1391 eassume (0 <= busy
&& busy
<= 2 * ABLOCKS_SIZE
- 1);
1392 ABLOCKS_BUSY (abase
) = (struct ablocks
*) busy
;
1395 { /* All the blocks are free. */
1397 bool aligned
= busy
;
1398 struct ablock
**tem
= &free_ablock
;
1399 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1403 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1406 *tem
= (*tem
)->x
.next_free
;
1409 tem
= &(*tem
)->x
.next_free
;
1411 eassert ((aligned
& 1) == aligned
);
1412 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1413 #ifdef USE_POSIX_MEMALIGN
1414 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1416 free (ABLOCKS_BASE (abase
));
1418 MALLOC_UNBLOCK_INPUT
;
1421 /* True if a malloc-returned pointer P is suitably aligned for SIZE,
1422 where Lisp object alignment may be needed if SIZE is a multiple of
1426 laligned (void *p
, size_t size
)
1428 return (MALLOC_IS_LISP_ALIGNED
|| (intptr_t) p
% LISP_ALIGNMENT
== 0
1429 || size
% LISP_ALIGNMENT
!= 0);
1432 /* Like malloc and realloc except that if SIZE is Lisp-aligned, make
1433 sure the result is too, if necessary by reallocating (typically
1434 with larger and larger sizes) until the allocator returns a
1435 Lisp-aligned pointer. Code that needs to allocate C heap memory
1436 for a Lisp object should use one of these functions to obtain a
1437 pointer P; that way, if T is an enum Lisp_Type value and L ==
1438 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
1440 On typical modern platforms these functions' loops do not iterate.
1441 On now-rare (and perhaps nonexistent) platforms, the loops in
1442 theory could repeat forever. If an infinite loop is possible on a
1443 platform, a build would surely loop and the builder can then send
1444 us a bug report. Adding a counter to try to detect any such loop
1445 would complicate the code (and possibly introduce bugs, in code
1446 that's never really exercised) for little benefit. */
1449 lmalloc (size_t size
)
1451 #ifdef USE_ALIGNED_ALLOC
1452 if (! MALLOC_IS_LISP_ALIGNED
&& size
% LISP_ALIGNMENT
== 0)
1453 return aligned_alloc (LISP_ALIGNMENT
, size
);
1458 void *p
= malloc (size
);
1459 if (laligned (p
, size
))
1462 size_t bigger
= size
+ LISP_ALIGNMENT
;
1469 lrealloc (void *p
, size_t size
)
1473 p
= realloc (p
, size
);
1474 if (laligned (p
, size
))
1476 size_t bigger
= size
+ LISP_ALIGNMENT
;
1483 /***********************************************************************
1485 ***********************************************************************/
1487 /* Number of intervals allocated in an interval_block structure.
1488 The 1020 is 1024 minus malloc overhead. */
1490 #define INTERVAL_BLOCK_SIZE \
1491 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1493 /* Intervals are allocated in chunks in the form of an interval_block
1496 struct interval_block
1498 /* Place `intervals' first, to preserve alignment. */
1499 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1500 struct interval_block
*next
;
1503 /* Current interval block. Its `next' pointer points to older
1506 static struct interval_block
*interval_block
;
1508 /* Index in interval_block above of the next unused interval
1511 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1513 /* Number of free and live intervals. */
1515 static EMACS_INT total_free_intervals
, total_intervals
;
1517 /* List of free intervals. */
1519 static INTERVAL interval_free_list
;
1521 /* Return a new interval. */
1524 make_interval (void)
1530 if (interval_free_list
)
1532 val
= interval_free_list
;
1533 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1537 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1539 struct interval_block
*newi
1540 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1542 newi
->next
= interval_block
;
1543 interval_block
= newi
;
1544 interval_block_index
= 0;
1545 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1547 val
= &interval_block
->intervals
[interval_block_index
++];
1550 MALLOC_UNBLOCK_INPUT
;
1552 consing_since_gc
+= sizeof (struct interval
);
1554 total_free_intervals
--;
1555 RESET_INTERVAL (val
);
1561 /* Mark Lisp objects in interval I. */
1564 mark_interval (INTERVAL i
, void *dummy
)
1566 /* Intervals should never be shared. So, if extra internal checking is
1567 enabled, GC aborts if it seems to have visited an interval twice. */
1568 eassert (!i
->gcmarkbit
);
1570 mark_object (i
->plist
);
1573 /* Mark the interval tree rooted in I. */
1575 #define MARK_INTERVAL_TREE(i) \
1577 if (i && !i->gcmarkbit) \
1578 traverse_intervals_noorder (i, mark_interval, NULL); \
1581 /***********************************************************************
1583 ***********************************************************************/
1585 /* Lisp_Strings are allocated in string_block structures. When a new
1586 string_block is allocated, all the Lisp_Strings it contains are
1587 added to a free-list string_free_list. When a new Lisp_String is
1588 needed, it is taken from that list. During the sweep phase of GC,
1589 string_blocks that are entirely free are freed, except two which
1592 String data is allocated from sblock structures. Strings larger
1593 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1594 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1596 Sblocks consist internally of sdata structures, one for each
1597 Lisp_String. The sdata structure points to the Lisp_String it
1598 belongs to. The Lisp_String points back to the `u.data' member of
1599 its sdata structure.
1601 When a Lisp_String is freed during GC, it is put back on
1602 string_free_list, and its `data' member and its sdata's `string'
1603 pointer is set to null. The size of the string is recorded in the
1604 `n.nbytes' member of the sdata. So, sdata structures that are no
1605 longer used, can be easily recognized, and it's easy to compact the
1606 sblocks of small strings which we do in compact_small_strings. */
1608 /* Size in bytes of an sblock structure used for small strings. This
1609 is 8192 minus malloc overhead. */
1611 #define SBLOCK_SIZE 8188
1613 /* Strings larger than this are considered large strings. String data
1614 for large strings is allocated from individual sblocks. */
1616 #define LARGE_STRING_BYTES 1024
1618 /* The SDATA typedef is a struct or union describing string memory
1619 sub-allocated from an sblock. This is where the contents of Lisp
1620 strings are stored. */
1624 /* Back-pointer to the string this sdata belongs to. If null, this
1625 structure is free, and NBYTES (in this structure or in the union below)
1626 contains the string's byte size (the same value that STRING_BYTES
1627 would return if STRING were non-null). If non-null, STRING_BYTES
1628 (STRING) is the size of the data, and DATA contains the string's
1630 struct Lisp_String
*string
;
1632 #ifdef GC_CHECK_STRING_BYTES
1636 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1639 #ifdef GC_CHECK_STRING_BYTES
1641 typedef struct sdata sdata
;
1642 #define SDATA_NBYTES(S) (S)->nbytes
1643 #define SDATA_DATA(S) (S)->data
1649 struct Lisp_String
*string
;
1651 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1652 which has a flexible array member. However, if implemented by
1653 giving this union a member of type 'struct sdata', the union
1654 could not be the last (flexible) member of 'struct sblock',
1655 because C99 prohibits a flexible array member from having a type
1656 that is itself a flexible array. So, comment this member out here,
1657 but remember that the option's there when using this union. */
1662 /* When STRING is null. */
1665 struct Lisp_String
*string
;
1670 #define SDATA_NBYTES(S) (S)->n.nbytes
1671 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1673 #endif /* not GC_CHECK_STRING_BYTES */
1675 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1677 /* Structure describing a block of memory which is sub-allocated to
1678 obtain string data memory for strings. Blocks for small strings
1679 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1680 as large as needed. */
1685 struct sblock
*next
;
1687 /* Pointer to the next free sdata block. This points past the end
1688 of the sblock if there isn't any space left in this block. */
1692 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1695 /* Number of Lisp strings in a string_block structure. The 1020 is
1696 1024 minus malloc overhead. */
1698 #define STRING_BLOCK_SIZE \
1699 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1701 /* Structure describing a block from which Lisp_String structures
1706 /* Place `strings' first, to preserve alignment. */
1707 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1708 struct string_block
*next
;
1711 /* Head and tail of the list of sblock structures holding Lisp string
1712 data. We always allocate from current_sblock. The NEXT pointers
1713 in the sblock structures go from oldest_sblock to current_sblock. */
1715 static struct sblock
*oldest_sblock
, *current_sblock
;
1717 /* List of sblocks for large strings. */
1719 static struct sblock
*large_sblocks
;
1721 /* List of string_block structures. */
1723 static struct string_block
*string_blocks
;
1725 /* Free-list of Lisp_Strings. */
1727 static struct Lisp_String
*string_free_list
;
1729 /* Number of live and free Lisp_Strings. */
1731 static EMACS_INT total_strings
, total_free_strings
;
1733 /* Number of bytes used by live strings. */
1735 static EMACS_INT total_string_bytes
;
1737 /* Given a pointer to a Lisp_String S which is on the free-list
1738 string_free_list, return a pointer to its successor in the
1741 #define NEXT_FREE_LISP_STRING(S) ((S)->u.next)
1743 /* Return a pointer to the sdata structure belonging to Lisp string S.
1744 S must be live, i.e. S->data must not be null. S->data is actually
1745 a pointer to the `u.data' member of its sdata structure; the
1746 structure starts at a constant offset in front of that. */
1748 #define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \
1749 - SDATA_DATA_OFFSET))
1752 #ifdef GC_CHECK_STRING_OVERRUN
1754 /* We check for overrun in string data blocks by appending a small
1755 "cookie" after each allocated string data block, and check for the
1756 presence of this cookie during GC. */
1758 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1759 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1760 { '\xde', '\xad', '\xbe', '\xef' };
1763 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1766 /* Value is the size of an sdata structure large enough to hold NBYTES
1767 bytes of string data. The value returned includes a terminating
1768 NUL byte, the size of the sdata structure, and padding. */
1770 #ifdef GC_CHECK_STRING_BYTES
1772 #define SDATA_SIZE(NBYTES) FLEXSIZEOF (struct sdata, data, (NBYTES) + 1)
1774 #else /* not GC_CHECK_STRING_BYTES */
1776 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1777 less than the size of that member. The 'max' is not needed when
1778 SDATA_DATA_OFFSET is a multiple of FLEXALIGNOF (struct sdata),
1779 because then the alignment code reserves enough space. */
1781 #define SDATA_SIZE(NBYTES) \
1782 ((SDATA_DATA_OFFSET \
1783 + (SDATA_DATA_OFFSET % FLEXALIGNOF (struct sdata) == 0 \
1785 : max (NBYTES, FLEXALIGNOF (struct sdata) - 1)) \
1787 + FLEXALIGNOF (struct sdata) - 1) \
1788 & ~(FLEXALIGNOF (struct sdata) - 1))
1790 #endif /* not GC_CHECK_STRING_BYTES */
1792 /* Extra bytes to allocate for each string. */
1794 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1796 /* Exact bound on the number of bytes in a string, not counting the
1797 terminating null. A string cannot contain more bytes than
1798 STRING_BYTES_BOUND, nor can it be so long that the size_t
1799 arithmetic in allocate_string_data would overflow while it is
1800 calculating a value to be passed to malloc. */
1801 static ptrdiff_t const STRING_BYTES_MAX
=
1802 min (STRING_BYTES_BOUND
,
1803 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1805 - offsetof (struct sblock
, data
)
1806 - SDATA_DATA_OFFSET
)
1807 & ~(sizeof (EMACS_INT
) - 1)));
1809 /* Initialize string allocation. Called from init_alloc_once. */
1814 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1815 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1819 #ifdef GC_CHECK_STRING_BYTES
1821 static int check_string_bytes_count
;
1823 /* Like STRING_BYTES, but with debugging check. Can be
1824 called during GC, so pay attention to the mark bit. */
1827 string_bytes (struct Lisp_String
*s
)
1830 (s
->u
.s
.size_byte
< 0 ? s
->u
.s
.size
& ~ARRAY_MARK_FLAG
: s
->u
.s
.size_byte
);
1832 if (!PURE_P (s
) && s
->u
.s
.data
1833 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1838 /* Check validity of Lisp strings' string_bytes member in B. */
1841 check_sblock (struct sblock
*b
)
1843 sdata
*from
, *end
, *from_end
;
1847 for (from
= b
->data
; from
< end
; from
= from_end
)
1849 /* Compute the next FROM here because copying below may
1850 overwrite data we need to compute it. */
1853 /* Check that the string size recorded in the string is the
1854 same as the one recorded in the sdata structure. */
1855 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1856 : SDATA_NBYTES (from
));
1857 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1862 /* Check validity of Lisp strings' string_bytes member. ALL_P
1863 means check all strings, otherwise check only most
1864 recently allocated strings. Used for hunting a bug. */
1867 check_string_bytes (bool all_p
)
1873 for (b
= large_sblocks
; b
; b
= b
->next
)
1875 struct Lisp_String
*s
= b
->data
[0].string
;
1880 for (b
= oldest_sblock
; b
; b
= b
->next
)
1883 else if (current_sblock
)
1884 check_sblock (current_sblock
);
1887 #else /* not GC_CHECK_STRING_BYTES */
1889 #define check_string_bytes(all) ((void) 0)
1891 #endif /* GC_CHECK_STRING_BYTES */
1893 #ifdef GC_CHECK_STRING_FREE_LIST
1895 /* Walk through the string free list looking for bogus next pointers.
1896 This may catch buffer overrun from a previous string. */
1899 check_string_free_list (void)
1901 struct Lisp_String
*s
;
1903 /* Pop a Lisp_String off the free-list. */
1904 s
= string_free_list
;
1907 if ((uintptr_t) s
< 1024)
1909 s
= NEXT_FREE_LISP_STRING (s
);
1913 #define check_string_free_list()
1916 /* Return a new Lisp_String. */
1918 static struct Lisp_String
*
1919 allocate_string (void)
1921 struct Lisp_String
*s
;
1925 /* If the free-list is empty, allocate a new string_block, and
1926 add all the Lisp_Strings in it to the free-list. */
1927 if (string_free_list
== NULL
)
1929 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1932 b
->next
= string_blocks
;
1935 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1938 /* Every string on a free list should have NULL data pointer. */
1940 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1941 string_free_list
= ptr_bounds_clip (s
, sizeof *s
);
1944 total_free_strings
+= STRING_BLOCK_SIZE
;
1947 check_string_free_list ();
1949 /* Pop a Lisp_String off the free-list. */
1950 s
= string_free_list
;
1951 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1953 MALLOC_UNBLOCK_INPUT
;
1955 --total_free_strings
;
1958 consing_since_gc
+= sizeof *s
;
1960 #ifdef GC_CHECK_STRING_BYTES
1961 if (!noninteractive
)
1963 if (++check_string_bytes_count
== 200)
1965 check_string_bytes_count
= 0;
1966 check_string_bytes (1);
1969 check_string_bytes (0);
1971 #endif /* GC_CHECK_STRING_BYTES */
1977 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1978 plus a NUL byte at the end. Allocate an sdata structure DATA for
1979 S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the
1980 end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte
1981 to NBYTES. Free S->u.s.data if it was initially non-null. */
1984 allocate_string_data (struct Lisp_String
*s
,
1985 EMACS_INT nchars
, EMACS_INT nbytes
)
1987 sdata
*data
, *old_data
;
1989 ptrdiff_t needed
, old_nbytes
;
1991 if (STRING_BYTES_MAX
< nbytes
)
1994 /* Determine the number of bytes needed to store NBYTES bytes
1996 needed
= SDATA_SIZE (nbytes
);
1999 old_data
= SDATA_OF_STRING (s
);
2000 old_nbytes
= STRING_BYTES (s
);
2007 if (nbytes
> LARGE_STRING_BYTES
)
2009 size_t size
= FLEXSIZEOF (struct sblock
, data
, needed
);
2011 #ifdef DOUG_LEA_MALLOC
2012 if (!mmap_lisp_allowed_p ())
2013 mallopt (M_MMAP_MAX
, 0);
2016 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2018 #ifdef DOUG_LEA_MALLOC
2019 if (!mmap_lisp_allowed_p ())
2020 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2024 b
->next
= large_sblocks
;
2025 b
->next_free
= data
;
2028 else if (current_sblock
== NULL
2029 || (((char *) current_sblock
+ SBLOCK_SIZE
2030 - (char *) current_sblock
->next_free
)
2031 < (needed
+ GC_STRING_EXTRA
)))
2033 /* Not enough room in the current sblock. */
2034 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2037 b
->next_free
= data
;
2040 current_sblock
->next
= b
;
2048 data
= b
->next_free
;
2052 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2054 MALLOC_UNBLOCK_INPUT
;
2056 s
->u
.s
.data
= ptr_bounds_clip (SDATA_DATA (data
), nbytes
+ 1);
2057 #ifdef GC_CHECK_STRING_BYTES
2058 SDATA_NBYTES (data
) = nbytes
;
2060 s
->u
.s
.size
= nchars
;
2061 s
->u
.s
.size_byte
= nbytes
;
2062 s
->u
.s
.data
[nbytes
] = '\0';
2063 #ifdef GC_CHECK_STRING_OVERRUN
2064 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2065 GC_STRING_OVERRUN_COOKIE_SIZE
);
2068 /* Note that Faset may call to this function when S has already data
2069 assigned. In this case, mark data as free by setting it's string
2070 back-pointer to null, and record the size of the data in it. */
2073 SDATA_NBYTES (old_data
) = old_nbytes
;
2074 old_data
->string
= NULL
;
2077 consing_since_gc
+= needed
;
2081 /* Sweep and compact strings. */
2083 NO_INLINE
/* For better stack traces */
2085 sweep_strings (void)
2087 struct string_block
*b
, *next
;
2088 struct string_block
*live_blocks
= NULL
;
2090 string_free_list
= NULL
;
2091 total_strings
= total_free_strings
= 0;
2092 total_string_bytes
= 0;
2094 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2095 for (b
= string_blocks
; b
; b
= next
)
2098 struct Lisp_String
*free_list_before
= string_free_list
;
2102 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2104 struct Lisp_String
*s
= b
->strings
+ i
;
2108 /* String was not on free-list before. */
2109 if (STRING_MARKED_P (s
))
2111 /* String is live; unmark it and its intervals. */
2114 /* Do not use string_(set|get)_intervals here. */
2115 s
->u
.s
.intervals
= balance_intervals (s
->u
.s
.intervals
);
2118 total_string_bytes
+= STRING_BYTES (s
);
2122 /* String is dead. Put it on the free-list. */
2123 sdata
*data
= SDATA_OF_STRING (s
);
2125 /* Save the size of S in its sdata so that we know
2126 how large that is. Reset the sdata's string
2127 back-pointer so that we know it's free. */
2128 #ifdef GC_CHECK_STRING_BYTES
2129 if (string_bytes (s
) != SDATA_NBYTES (data
))
2132 data
->n
.nbytes
= STRING_BYTES (s
);
2134 data
->string
= NULL
;
2136 /* Reset the strings's `data' member so that we
2140 /* Put the string on the free-list. */
2141 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2142 string_free_list
= ptr_bounds_clip (s
, sizeof *s
);
2148 /* S was on the free-list before. Put it there again. */
2149 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2150 string_free_list
= ptr_bounds_clip (s
, sizeof *s
);
2155 /* Free blocks that contain free Lisp_Strings only, except
2156 the first two of them. */
2157 if (nfree
== STRING_BLOCK_SIZE
2158 && total_free_strings
> STRING_BLOCK_SIZE
)
2161 string_free_list
= free_list_before
;
2165 total_free_strings
+= nfree
;
2166 b
->next
= live_blocks
;
2171 check_string_free_list ();
2173 string_blocks
= live_blocks
;
2174 free_large_strings ();
2175 compact_small_strings ();
2177 check_string_free_list ();
2181 /* Free dead large strings. */
2184 free_large_strings (void)
2186 struct sblock
*b
, *next
;
2187 struct sblock
*live_blocks
= NULL
;
2189 for (b
= large_sblocks
; b
; b
= next
)
2193 if (b
->data
[0].string
== NULL
)
2197 b
->next
= live_blocks
;
2202 large_sblocks
= live_blocks
;
2206 /* Compact data of small strings. Free sblocks that don't contain
2207 data of live strings after compaction. */
2210 compact_small_strings (void)
2212 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2213 to, and TB_END is the end of TB. */
2214 struct sblock
*tb
= oldest_sblock
;
2217 sdata
*tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2218 sdata
*to
= tb
->data
;
2220 /* Step through the blocks from the oldest to the youngest. We
2221 expect that old blocks will stabilize over time, so that less
2222 copying will happen this way. */
2223 struct sblock
*b
= tb
;
2226 sdata
*end
= b
->next_free
;
2227 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2229 for (sdata
*from
= b
->data
; from
< end
; )
2231 /* Compute the next FROM here because copying below may
2232 overwrite data we need to compute it. */
2234 struct Lisp_String
*s
= from
->string
;
2236 #ifdef GC_CHECK_STRING_BYTES
2237 /* Check that the string size recorded in the string is the
2238 same as the one recorded in the sdata structure. */
2239 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2241 #endif /* GC_CHECK_STRING_BYTES */
2243 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2244 eassert (nbytes
<= LARGE_STRING_BYTES
);
2246 ptrdiff_t size
= SDATA_SIZE (nbytes
);
2247 sdata
*from_end
= (sdata
*) ((char *) from
2248 + size
+ GC_STRING_EXTRA
);
2250 #ifdef GC_CHECK_STRING_OVERRUN
2251 if (memcmp (string_overrun_cookie
,
2252 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2253 GC_STRING_OVERRUN_COOKIE_SIZE
))
2257 /* Non-NULL S means it's alive. Copy its data. */
2260 /* If TB is full, proceed with the next sblock. */
2261 sdata
*to_end
= (sdata
*) ((char *) to
2262 + size
+ GC_STRING_EXTRA
);
2263 if (to_end
> tb_end
)
2267 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2269 to_end
= (sdata
*) ((char *) to
+ size
+ GC_STRING_EXTRA
);
2272 /* Copy, and update the string's `data' pointer. */
2275 eassert (tb
!= b
|| to
< from
);
2276 memmove (to
, from
, size
+ GC_STRING_EXTRA
);
2277 to
->string
->u
.s
.data
2278 = ptr_bounds_clip (SDATA_DATA (to
), nbytes
+ 1);
2281 /* Advance past the sdata we copied to. */
2290 /* The rest of the sblocks following TB don't contain live data, so
2291 we can free them. */
2292 for (b
= tb
->next
; b
; )
2294 struct sblock
*next
= b
->next
;
2303 current_sblock
= tb
;
2307 string_overflow (void)
2309 error ("Maximum string size exceeded");
2312 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 3, 0,
2313 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2314 LENGTH must be an integer.
2315 INIT must be an integer that represents a character.
2316 If optional argument MULTIBYTE is non-nil, the result will be
2317 a multibyte string even if INIT is an ASCII character. */)
2318 (Lisp_Object length
, Lisp_Object init
, Lisp_Object multibyte
)
2320 register Lisp_Object val
;
2324 CHECK_NATNUM (length
);
2325 CHECK_CHARACTER (init
);
2327 c
= XFASTINT (init
);
2328 if (ASCII_CHAR_P (c
) && NILP (multibyte
))
2330 nbytes
= XINT (length
);
2331 val
= make_uninit_string (nbytes
);
2334 memset (SDATA (val
), c
, nbytes
);
2335 SDATA (val
)[nbytes
] = 0;
2340 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2341 ptrdiff_t len
= CHAR_STRING (c
, str
);
2342 EMACS_INT string_len
= XINT (length
);
2343 unsigned char *p
, *beg
, *end
;
2345 if (INT_MULTIPLY_WRAPV (len
, string_len
, &nbytes
))
2347 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2348 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2350 /* First time we just copy `str' to the data of `val'. */
2352 memcpy (p
, str
, len
);
2355 /* Next time we copy largest possible chunk from
2356 initialized to uninitialized part of `val'. */
2357 len
= min (p
- beg
, end
- p
);
2358 memcpy (p
, beg
, len
);
2368 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2372 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2374 EMACS_INT nbits
= bool_vector_size (a
);
2377 unsigned char *data
= bool_vector_uchar_data (a
);
2378 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2379 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2380 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2381 memset (data
, pattern
, nbytes
- 1);
2382 data
[nbytes
- 1] = pattern
& last_mask
;
2387 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2390 make_uninit_bool_vector (EMACS_INT nbits
)
2393 EMACS_INT words
= bool_vector_words (nbits
);
2394 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2395 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2398 struct Lisp_Bool_Vector
*p
2399 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2400 XSETVECTOR (val
, p
);
2401 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2404 /* Clear padding at the end. */
2406 p
->data
[words
- 1] = 0;
2411 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2412 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2413 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2414 (Lisp_Object length
, Lisp_Object init
)
2418 CHECK_NATNUM (length
);
2419 val
= make_uninit_bool_vector (XFASTINT (length
));
2420 return bool_vector_fill (val
, init
);
2423 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2424 doc
: /* Return a new bool-vector with specified arguments as elements.
2425 Any number of arguments, even zero arguments, are allowed.
2426 usage: (bool-vector &rest OBJECTS) */)
2427 (ptrdiff_t nargs
, Lisp_Object
*args
)
2432 vector
= make_uninit_bool_vector (nargs
);
2433 for (i
= 0; i
< nargs
; i
++)
2434 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2439 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2440 of characters from the contents. This string may be unibyte or
2441 multibyte, depending on the contents. */
2444 make_string (const char *contents
, ptrdiff_t nbytes
)
2446 register Lisp_Object val
;
2447 ptrdiff_t nchars
, multibyte_nbytes
;
2449 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2450 &nchars
, &multibyte_nbytes
);
2451 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2452 /* CONTENTS contains no multibyte sequences or contains an invalid
2453 multibyte sequence. We must make unibyte string. */
2454 val
= make_unibyte_string (contents
, nbytes
);
2456 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2460 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2463 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2465 register Lisp_Object val
;
2466 val
= make_uninit_string (length
);
2467 memcpy (SDATA (val
), contents
, length
);
2472 /* Make a multibyte string from NCHARS characters occupying NBYTES
2473 bytes at CONTENTS. */
2476 make_multibyte_string (const char *contents
,
2477 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2479 register Lisp_Object val
;
2480 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2481 memcpy (SDATA (val
), contents
, nbytes
);
2486 /* Make a string from NCHARS characters occupying NBYTES bytes at
2487 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2490 make_string_from_bytes (const char *contents
,
2491 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2493 register Lisp_Object val
;
2494 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2495 memcpy (SDATA (val
), contents
, nbytes
);
2496 if (SBYTES (val
) == SCHARS (val
))
2497 STRING_SET_UNIBYTE (val
);
2502 /* Make a string from NCHARS characters occupying NBYTES bytes at
2503 CONTENTS. The argument MULTIBYTE controls whether to label the
2504 string as multibyte. If NCHARS is negative, it counts the number of
2505 characters by itself. */
2508 make_specified_string (const char *contents
,
2509 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2516 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2521 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2522 memcpy (SDATA (val
), contents
, nbytes
);
2524 STRING_SET_UNIBYTE (val
);
2529 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2530 occupying LENGTH bytes. */
2533 make_uninit_string (EMACS_INT length
)
2538 return empty_unibyte_string
;
2539 val
= make_uninit_multibyte_string (length
, length
);
2540 STRING_SET_UNIBYTE (val
);
2545 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2546 which occupy NBYTES bytes. */
2549 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2552 struct Lisp_String
*s
;
2557 return empty_multibyte_string
;
2559 s
= allocate_string ();
2560 s
->u
.s
.intervals
= NULL
;
2561 allocate_string_data (s
, nchars
, nbytes
);
2562 XSETSTRING (string
, s
);
2563 string_chars_consed
+= nbytes
;
2567 /* Print arguments to BUF according to a FORMAT, then return
2568 a Lisp_String initialized with the data from BUF. */
2571 make_formatted_string (char *buf
, const char *format
, ...)
2576 va_start (ap
, format
);
2577 length
= vsprintf (buf
, format
, ap
);
2579 return make_string (buf
, length
);
2583 /***********************************************************************
2585 ***********************************************************************/
2587 /* We store float cells inside of float_blocks, allocating a new
2588 float_block with malloc whenever necessary. Float cells reclaimed
2589 by GC are put on a free list to be reallocated before allocating
2590 any new float cells from the latest float_block. */
2592 #define FLOAT_BLOCK_SIZE \
2593 (((BLOCK_BYTES - sizeof (struct float_block *) \
2594 /* The compiler might add padding at the end. */ \
2595 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2596 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2598 #define GETMARKBIT(block,n) \
2599 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2600 >> ((n) % BITS_PER_BITS_WORD)) \
2603 #define SETMARKBIT(block,n) \
2604 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2605 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2607 #define UNSETMARKBIT(block,n) \
2608 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2609 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2611 #define FLOAT_BLOCK(fptr) \
2612 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2614 #define FLOAT_INDEX(fptr) \
2615 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2619 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2620 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2621 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2622 struct float_block
*next
;
2625 #define FLOAT_MARKED_P(fptr) \
2626 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2628 #define FLOAT_MARK(fptr) \
2629 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2631 #define FLOAT_UNMARK(fptr) \
2632 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2634 /* Current float_block. */
2636 static struct float_block
*float_block
;
2638 /* Index of first unused Lisp_Float in the current float_block. */
2640 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2642 /* Free-list of Lisp_Floats. */
2644 static struct Lisp_Float
*float_free_list
;
2646 /* Return a new float object with value FLOAT_VALUE. */
2649 make_float (double float_value
)
2651 register Lisp_Object val
;
2655 if (float_free_list
)
2657 /* We use the data field for chaining the free list
2658 so that we won't use the same field that has the mark bit. */
2659 XSETFLOAT (val
, float_free_list
);
2660 float_free_list
= float_free_list
->u
.chain
;
2664 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2666 struct float_block
*new
2667 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2668 new->next
= float_block
;
2669 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2671 float_block_index
= 0;
2672 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2674 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2675 float_block_index
++;
2678 MALLOC_UNBLOCK_INPUT
;
2680 XFLOAT_INIT (val
, float_value
);
2681 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2682 consing_since_gc
+= sizeof (struct Lisp_Float
);
2684 total_free_floats
--;
2690 /***********************************************************************
2692 ***********************************************************************/
2694 /* We store cons cells inside of cons_blocks, allocating a new
2695 cons_block with malloc whenever necessary. Cons cells reclaimed by
2696 GC are put on a free list to be reallocated before allocating
2697 any new cons cells from the latest cons_block. */
2699 #define CONS_BLOCK_SIZE \
2700 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2701 /* The compiler might add padding at the end. */ \
2702 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2703 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2705 #define CONS_BLOCK(fptr) \
2706 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2708 #define CONS_INDEX(fptr) \
2709 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2713 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2714 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2715 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2716 struct cons_block
*next
;
2719 #define CONS_MARKED_P(fptr) \
2720 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2722 #define CONS_MARK(fptr) \
2723 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2725 #define CONS_UNMARK(fptr) \
2726 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2728 /* Current cons_block. */
2730 static struct cons_block
*cons_block
;
2732 /* Index of first unused Lisp_Cons in the current block. */
2734 static int cons_block_index
= CONS_BLOCK_SIZE
;
2736 /* Free-list of Lisp_Cons structures. */
2738 static struct Lisp_Cons
*cons_free_list
;
2740 /* Explicitly free a cons cell by putting it on the free-list. */
2743 free_cons (struct Lisp_Cons
*ptr
)
2745 ptr
->u
.s
.u
.chain
= cons_free_list
;
2746 ptr
->u
.s
.car
= Vdead
;
2747 cons_free_list
= ptr
;
2748 consing_since_gc
-= sizeof *ptr
;
2749 total_free_conses
++;
2752 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2753 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2754 (Lisp_Object car
, Lisp_Object cdr
)
2756 register Lisp_Object val
;
2762 /* We use the cdr for chaining the free list
2763 so that we won't use the same field that has the mark bit. */
2764 XSETCONS (val
, cons_free_list
);
2765 cons_free_list
= cons_free_list
->u
.s
.u
.chain
;
2769 if (cons_block_index
== CONS_BLOCK_SIZE
)
2771 struct cons_block
*new
2772 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2773 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2774 new->next
= cons_block
;
2776 cons_block_index
= 0;
2777 total_free_conses
+= CONS_BLOCK_SIZE
;
2779 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2783 MALLOC_UNBLOCK_INPUT
;
2787 eassert (!CONS_MARKED_P (XCONS (val
)));
2788 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2789 total_free_conses
--;
2790 cons_cells_consed
++;
2794 #ifdef GC_CHECK_CONS_LIST
2795 /* Get an error now if there's any junk in the cons free list. */
2797 check_cons_list (void)
2799 struct Lisp_Cons
*tail
= cons_free_list
;
2802 tail
= tail
->u
.s
.u
.chain
;
2806 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2809 list1 (Lisp_Object arg1
)
2811 return Fcons (arg1
, Qnil
);
2815 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2817 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2822 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2824 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2829 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2831 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2836 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2838 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2839 Fcons (arg5
, Qnil
)))));
2842 /* Make a list of COUNT Lisp_Objects, where ARG is the
2843 first one. Allocate conses from pure space if TYPE
2844 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2847 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2849 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2852 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2853 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2854 default: emacs_abort ();
2857 eassume (0 < count
);
2858 Lisp_Object val
= cons (arg
, Qnil
);
2859 Lisp_Object tail
= val
;
2863 for (ptrdiff_t i
= 1; i
< count
; i
++)
2865 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2866 XSETCDR (tail
, elem
);
2874 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2875 doc
: /* Return a newly created list with specified arguments as elements.
2876 Any number of arguments, even zero arguments, are allowed.
2877 usage: (list &rest OBJECTS) */)
2878 (ptrdiff_t nargs
, Lisp_Object
*args
)
2880 register Lisp_Object val
;
2886 val
= Fcons (args
[nargs
], val
);
2892 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2893 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2894 (Lisp_Object length
, Lisp_Object init
)
2896 Lisp_Object val
= Qnil
;
2897 CHECK_NATNUM (length
);
2899 for (EMACS_INT size
= XFASTINT (length
); 0 < size
; size
--)
2901 val
= Fcons (init
, val
);
2910 /***********************************************************************
2912 ***********************************************************************/
2914 /* Sometimes a vector's contents are merely a pointer internally used
2915 in vector allocation code. On the rare platforms where a null
2916 pointer cannot be tagged, represent it with a Lisp 0.
2917 Usually you don't want to touch this. */
2919 static struct Lisp_Vector
*
2920 next_vector (struct Lisp_Vector
*v
)
2922 return XUNTAG (v
->contents
[0], Lisp_Int0
, struct Lisp_Vector
);
2926 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2928 v
->contents
[0] = make_lisp_ptr (p
, Lisp_Int0
);
2931 /* This value is balanced well enough to avoid too much internal overhead
2932 for the most common cases; it's not required to be a power of two, but
2933 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2935 #define VECTOR_BLOCK_SIZE 4096
2937 /* Vector size requests are a multiple of this. */
2938 enum { roundup_size
= COMMON_MULTIPLE (LISP_ALIGNMENT
, word_size
) };
2940 /* Verify assumptions described above. */
2941 verify (VECTOR_BLOCK_SIZE
% roundup_size
== 0);
2942 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2944 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2945 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2946 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2947 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2949 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2951 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2953 /* Size of the minimal vector allocated from block. */
2955 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2957 /* Size of the largest vector allocated from block. */
2959 #define VBLOCK_BYTES_MAX \
2960 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2962 /* We maintain one free list for each possible block-allocated
2963 vector size, and this is the number of free lists we have. */
2965 #define VECTOR_MAX_FREE_LIST_INDEX \
2966 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2968 /* Common shortcut to advance vector pointer over a block data. */
2970 static struct Lisp_Vector
*
2971 ADVANCE (struct Lisp_Vector
*v
, ptrdiff_t nbytes
)
2975 void *p
= cv
+ nbytes
;
2979 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2982 VINDEX (ptrdiff_t nbytes
)
2984 eassume (VBLOCK_BYTES_MIN
<= nbytes
);
2985 return (nbytes
- VBLOCK_BYTES_MIN
) / roundup_size
;
2988 /* This internal type is used to maintain the list of large vectors
2989 which are allocated at their own, e.g. outside of vector blocks.
2991 struct large_vector itself cannot contain a struct Lisp_Vector, as
2992 the latter contains a flexible array member and C99 does not allow
2993 such structs to be nested. Instead, each struct large_vector
2994 object LV is followed by a struct Lisp_Vector, which is at offset
2995 large_vector_offset from LV, and whose address is therefore
2996 large_vector_vec (&LV). */
3000 struct large_vector
*next
;
3005 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), LISP_ALIGNMENT
)
3008 static struct Lisp_Vector
*
3009 large_vector_vec (struct large_vector
*p
)
3011 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
3014 /* This internal type is used to maintain an underlying storage
3015 for small vectors. */
3019 char data
[VECTOR_BLOCK_BYTES
];
3020 struct vector_block
*next
;
3023 /* Chain of vector blocks. */
3025 static struct vector_block
*vector_blocks
;
3027 /* Vector free lists, where NTH item points to a chain of free
3028 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
3030 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
3032 /* Singly-linked list of large vectors. */
3034 static struct large_vector
*large_vectors
;
3036 /* The only vector with 0 slots, allocated from pure space. */
3038 Lisp_Object zero_vector
;
3040 /* Number of live vectors. */
3042 static EMACS_INT total_vectors
;
3044 /* Total size of live and free vectors, in Lisp_Object units. */
3046 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
3048 /* Common shortcut to setup vector on a free list. */
3051 setup_on_free_list (struct Lisp_Vector
*v
, ptrdiff_t nbytes
)
3053 v
= ptr_bounds_clip (v
, nbytes
);
3054 eassume (header_size
<= nbytes
);
3055 ptrdiff_t nwords
= (nbytes
- header_size
) / word_size
;
3056 XSETPVECTYPESIZE (v
, PVEC_FREE
, 0, nwords
);
3057 eassert (nbytes
% roundup_size
== 0);
3058 ptrdiff_t vindex
= VINDEX (nbytes
);
3059 eassert (vindex
< VECTOR_MAX_FREE_LIST_INDEX
);
3060 set_next_vector (v
, vector_free_lists
[vindex
]);
3061 vector_free_lists
[vindex
] = v
;
3062 total_free_vector_slots
+= nbytes
/ word_size
;
3065 /* Get a new vector block. */
3067 static struct vector_block
*
3068 allocate_vector_block (void)
3070 struct vector_block
*block
= xmalloc (sizeof *block
);
3072 #ifndef GC_MALLOC_CHECK
3073 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
3074 MEM_TYPE_VECTOR_BLOCK
);
3077 block
->next
= vector_blocks
;
3078 vector_blocks
= block
;
3082 /* Called once to initialize vector allocation. */
3087 zero_vector
= make_pure_vector (0);
3090 /* Allocate vector from a vector block. */
3092 static struct Lisp_Vector
*
3093 allocate_vector_from_block (size_t nbytes
)
3095 struct Lisp_Vector
*vector
;
3096 struct vector_block
*block
;
3097 size_t index
, restbytes
;
3099 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
3100 eassert (nbytes
% roundup_size
== 0);
3102 /* First, try to allocate from a free list
3103 containing vectors of the requested size. */
3104 index
= VINDEX (nbytes
);
3105 if (vector_free_lists
[index
])
3107 vector
= vector_free_lists
[index
];
3108 vector_free_lists
[index
] = next_vector (vector
);
3109 total_free_vector_slots
-= nbytes
/ word_size
;
3113 /* Next, check free lists containing larger vectors. Since
3114 we will split the result, we should have remaining space
3115 large enough to use for one-slot vector at least. */
3116 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3117 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3118 if (vector_free_lists
[index
])
3120 /* This vector is larger than requested. */
3121 vector
= vector_free_lists
[index
];
3122 vector_free_lists
[index
] = next_vector (vector
);
3123 total_free_vector_slots
-= nbytes
/ word_size
;
3125 /* Excess bytes are used for the smaller vector,
3126 which should be set on an appropriate free list. */
3127 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3128 eassert (restbytes
% roundup_size
== 0);
3129 setup_on_free_list (ADVANCE (vector
, nbytes
), restbytes
);
3133 /* Finally, need a new vector block. */
3134 block
= allocate_vector_block ();
3136 /* New vector will be at the beginning of this block. */
3137 vector
= (struct Lisp_Vector
*) block
->data
;
3139 /* If the rest of space from this block is large enough
3140 for one-slot vector at least, set up it on a free list. */
3141 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3142 if (restbytes
>= VBLOCK_BYTES_MIN
)
3144 eassert (restbytes
% roundup_size
== 0);
3145 setup_on_free_list (ADVANCE (vector
, nbytes
), restbytes
);
3150 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3152 #define VECTOR_IN_BLOCK(vector, block) \
3153 ((char *) (vector) <= (block)->data \
3154 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3156 /* Return the memory footprint of V in bytes. */
3159 vector_nbytes (struct Lisp_Vector
*v
)
3161 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
3164 if (size
& PSEUDOVECTOR_FLAG
)
3166 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
3168 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
3169 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
3170 * sizeof (bits_word
));
3171 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
3172 verify (header_size
<= bool_header_size
);
3173 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
3176 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
3177 + ((size
& PSEUDOVECTOR_REST_MASK
)
3178 >> PSEUDOVECTOR_SIZE_BITS
));
3182 return vroundup (header_size
+ word_size
* nwords
);
3185 /* Release extra resources still in use by VECTOR, which may be any
3186 vector-like object. */
3189 cleanup_vector (struct Lisp_Vector
*vector
)
3191 detect_suspicious_free (vector
);
3192 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
3193 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
3194 == FONT_OBJECT_MAX
))
3196 struct font_driver
const *drv
= ((struct font
*) vector
)->driver
;
3198 /* The font driver might sometimes be NULL, e.g. if Emacs was
3199 interrupted before it had time to set it up. */
3202 /* Attempt to catch subtle bugs like Bug#16140. */
3203 eassert (valid_font_driver (drv
));
3204 drv
->close ((struct font
*) vector
);
3208 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_THREAD
))
3209 finalize_one_thread ((struct thread_state
*) vector
);
3210 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_MUTEX
))
3211 finalize_one_mutex ((struct Lisp_Mutex
*) vector
);
3212 else if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_CONDVAR
))
3213 finalize_one_condvar ((struct Lisp_CondVar
*) vector
);
3216 /* Reclaim space used by unmarked vectors. */
3218 NO_INLINE
/* For better stack traces */
3220 sweep_vectors (void)
3222 struct vector_block
*block
, **bprev
= &vector_blocks
;
3223 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3224 struct Lisp_Vector
*vector
, *next
;
3226 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3227 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3229 /* Looking through vector blocks. */
3231 for (block
= vector_blocks
; block
; block
= *bprev
)
3233 bool free_this_block
= 0;
3236 for (vector
= (struct Lisp_Vector
*) block
->data
;
3237 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3239 if (VECTOR_MARKED_P (vector
))
3241 VECTOR_UNMARK (vector
);
3243 nbytes
= vector_nbytes (vector
);
3244 total_vector_slots
+= nbytes
/ word_size
;
3245 next
= ADVANCE (vector
, nbytes
);
3249 ptrdiff_t total_bytes
;
3251 cleanup_vector (vector
);
3252 nbytes
= vector_nbytes (vector
);
3253 total_bytes
= nbytes
;
3254 next
= ADVANCE (vector
, nbytes
);
3256 /* While NEXT is not marked, try to coalesce with VECTOR,
3257 thus making VECTOR of the largest possible size. */
3259 while (VECTOR_IN_BLOCK (next
, block
))
3261 if (VECTOR_MARKED_P (next
))
3263 cleanup_vector (next
);
3264 nbytes
= vector_nbytes (next
);
3265 total_bytes
+= nbytes
;
3266 next
= ADVANCE (next
, nbytes
);
3269 eassert (total_bytes
% roundup_size
== 0);
3271 if (vector
== (struct Lisp_Vector
*) block
->data
3272 && !VECTOR_IN_BLOCK (next
, block
))
3273 /* This block should be freed because all of its
3274 space was coalesced into the only free vector. */
3275 free_this_block
= 1;
3277 setup_on_free_list (vector
, total_bytes
);
3281 if (free_this_block
)
3283 *bprev
= block
->next
;
3284 #ifndef GC_MALLOC_CHECK
3285 mem_delete (mem_find (block
->data
));
3290 bprev
= &block
->next
;
3293 /* Sweep large vectors. */
3295 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3297 vector
= large_vector_vec (lv
);
3298 if (VECTOR_MARKED_P (vector
))
3300 VECTOR_UNMARK (vector
);
3302 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3303 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3306 += header_size
/ word_size
+ vector
->header
.size
;
3317 /* Value is a pointer to a newly allocated Lisp_Vector structure
3318 with room for LEN Lisp_Objects. */
3320 static struct Lisp_Vector
*
3321 allocate_vectorlike (ptrdiff_t len
)
3324 return XVECTOR (zero_vector
);
3327 size_t nbytes
= header_size
+ len
* word_size
;
3328 struct Lisp_Vector
*p
;
3332 #ifdef DOUG_LEA_MALLOC
3333 if (!mmap_lisp_allowed_p ())
3334 mallopt (M_MMAP_MAX
, 0);
3337 if (nbytes
<= VBLOCK_BYTES_MAX
)
3338 p
= allocate_vector_from_block (vroundup (nbytes
));
3341 struct large_vector
*lv
3342 = lisp_malloc ((large_vector_offset
+ header_size
3344 MEM_TYPE_VECTORLIKE
);
3345 lv
->next
= large_vectors
;
3347 p
= large_vector_vec (lv
);
3350 #ifdef DOUG_LEA_MALLOC
3351 if (!mmap_lisp_allowed_p ())
3352 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3355 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3358 consing_since_gc
+= nbytes
;
3359 vector_cells_consed
+= len
;
3361 MALLOC_UNBLOCK_INPUT
;
3363 return ptr_bounds_clip (p
, nbytes
);
3368 /* Allocate a vector with LEN slots. */
3370 struct Lisp_Vector
*
3371 allocate_vector (EMACS_INT len
)
3373 struct Lisp_Vector
*v
;
3374 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3376 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3377 memory_full (SIZE_MAX
);
3378 v
= allocate_vectorlike (len
);
3380 v
->header
.size
= len
;
3385 /* Allocate other vector-like structures. */
3387 struct Lisp_Vector
*
3388 allocate_pseudovector (int memlen
, int lisplen
,
3389 int zerolen
, enum pvec_type tag
)
3391 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3393 /* Catch bogus values. */
3394 eassert (0 <= tag
&& tag
<= PVEC_FONT
);
3395 eassert (0 <= lisplen
&& lisplen
<= zerolen
&& zerolen
<= memlen
);
3396 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3397 eassert (lisplen
<= PSEUDOVECTOR_SIZE_MASK
);
3399 /* Only the first LISPLEN slots will be traced normally by the GC. */
3400 memclear (v
->contents
, zerolen
* word_size
);
3401 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3406 allocate_buffer (void)
3408 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3410 BUFFER_PVEC_INIT (b
);
3411 /* Put B on the chain of all buffers including killed ones. */
3412 b
->next
= all_buffers
;
3414 /* Note that the rest fields of B are not initialized. */
3419 /* Allocate a record with COUNT slots. COUNT must be positive, and
3420 includes the type slot. */
3422 static struct Lisp_Vector
*
3423 allocate_record (EMACS_INT count
)
3425 if (count
> PSEUDOVECTOR_SIZE_MASK
)
3426 error ("Attempt to allocate a record of %"pI
"d slots; max is %d",
3427 count
, PSEUDOVECTOR_SIZE_MASK
);
3428 struct Lisp_Vector
*p
= allocate_vectorlike (count
);
3429 p
->header
.size
= count
;
3430 XSETPVECTYPE (p
, PVEC_RECORD
);
3435 DEFUN ("make-record", Fmake_record
, Smake_record
, 3, 3, 0,
3436 doc
: /* Create a new record.
3437 TYPE is its type as returned by `type-of'; it should be either a
3438 symbol or a type descriptor. SLOTS is the number of non-type slots,
3439 each initialized to INIT. */)
3440 (Lisp_Object type
, Lisp_Object slots
, Lisp_Object init
)
3442 CHECK_NATNUM (slots
);
3443 EMACS_INT size
= XFASTINT (slots
) + 1;
3444 struct Lisp_Vector
*p
= allocate_record (size
);
3445 p
->contents
[0] = type
;
3446 for (ptrdiff_t i
= 1; i
< size
; i
++)
3447 p
->contents
[i
] = init
;
3448 return make_lisp_ptr (p
, Lisp_Vectorlike
);
3452 DEFUN ("record", Frecord
, Srecord
, 1, MANY
, 0,
3453 doc
: /* Create a new record.
3454 TYPE is its type as returned by `type-of'; it should be either a
3455 symbol or a type descriptor. SLOTS is used to initialize the record
3456 slots with shallow copies of the arguments.
3457 usage: (record TYPE &rest SLOTS) */)
3458 (ptrdiff_t nargs
, Lisp_Object
*args
)
3460 struct Lisp_Vector
*p
= allocate_record (nargs
);
3461 memcpy (p
->contents
, args
, nargs
* sizeof *args
);
3462 return make_lisp_ptr (p
, Lisp_Vectorlike
);
3466 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3467 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3468 See also the function `vector'. */)
3469 (Lisp_Object length
, Lisp_Object init
)
3471 CHECK_NATNUM (length
);
3472 struct Lisp_Vector
*p
= allocate_vector (XFASTINT (length
));
3473 for (ptrdiff_t i
= 0; i
< XFASTINT (length
); i
++)
3474 p
->contents
[i
] = init
;
3475 return make_lisp_ptr (p
, Lisp_Vectorlike
);
3478 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3479 doc
: /* Return a newly created vector with specified arguments as elements.
3480 Any number of arguments, even zero arguments, are allowed.
3481 usage: (vector &rest OBJECTS) */)
3482 (ptrdiff_t nargs
, Lisp_Object
*args
)
3484 Lisp_Object val
= make_uninit_vector (nargs
);
3485 struct Lisp_Vector
*p
= XVECTOR (val
);
3486 memcpy (p
->contents
, args
, nargs
* sizeof *args
);
3491 make_byte_code (struct Lisp_Vector
*v
)
3493 /* Don't allow the global zero_vector to become a byte code object. */
3494 eassert (0 < v
->header
.size
);
3496 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3497 && STRING_MULTIBYTE (v
->contents
[1]))
3498 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3499 earlier because they produced a raw 8-bit string for byte-code
3500 and now such a byte-code string is loaded as multibyte while
3501 raw 8-bit characters converted to multibyte form. Thus, now we
3502 must convert them back to the original unibyte form. */
3503 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3504 XSETPVECTYPE (v
, PVEC_COMPILED
);
3507 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3508 doc
: /* Create a byte-code object with specified arguments as elements.
3509 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3510 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3511 and (optional) INTERACTIVE-SPEC.
3512 The first four arguments are required; at most six have any
3514 The ARGLIST can be either like the one of `lambda', in which case the arguments
3515 will be dynamically bound before executing the byte code, or it can be an
3516 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3517 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3518 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3519 argument to catch the left-over arguments. If such an integer is used, the
3520 arguments will not be dynamically bound but will be instead pushed on the
3521 stack before executing the byte-code.
3522 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3523 (ptrdiff_t nargs
, Lisp_Object
*args
)
3525 Lisp_Object val
= make_uninit_vector (nargs
);
3526 struct Lisp_Vector
*p
= XVECTOR (val
);
3528 /* We used to purecopy everything here, if purify-flag was set. This worked
3529 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3530 dangerous, since make-byte-code is used during execution to build
3531 closures, so any closure built during the preload phase would end up
3532 copied into pure space, including its free variables, which is sometimes
3533 just wasteful and other times plainly wrong (e.g. those free vars may want
3536 memcpy (p
->contents
, args
, nargs
* sizeof *args
);
3538 XSETCOMPILED (val
, p
);
3544 /***********************************************************************
3546 ***********************************************************************/
3548 /* Each symbol_block is just under 1020 bytes long, since malloc
3549 really allocates in units of powers of two and uses 4 bytes for its
3552 #define SYMBOL_BLOCK_SIZE \
3553 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3557 /* Place `symbols' first, to preserve alignment. */
3558 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3559 struct symbol_block
*next
;
3562 /* Current symbol block and index of first unused Lisp_Symbol
3565 static struct symbol_block
*symbol_block
;
3566 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3567 /* Pointer to the first symbol_block that contains pinned symbols.
3568 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3569 10K of which are pinned (and all but 250 of them are interned in obarray),
3570 whereas a "typical session" has in the order of 30K symbols.
3571 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3572 than 30K to find the 10K symbols we need to mark. */
3573 static struct symbol_block
*symbol_block_pinned
;
3575 /* List of free symbols. */
3577 static struct Lisp_Symbol
*symbol_free_list
;
3580 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3582 XSYMBOL (sym
)->u
.s
.name
= name
;
3586 init_symbol (Lisp_Object val
, Lisp_Object name
)
3588 struct Lisp_Symbol
*p
= XSYMBOL (val
);
3589 set_symbol_name (val
, name
);
3590 set_symbol_plist (val
, Qnil
);
3591 p
->u
.s
.redirect
= SYMBOL_PLAINVAL
;
3592 SET_SYMBOL_VAL (p
, Qunbound
);
3593 set_symbol_function (val
, Qnil
);
3594 set_symbol_next (val
, NULL
);
3595 p
->u
.s
.gcmarkbit
= false;
3596 p
->u
.s
.interned
= SYMBOL_UNINTERNED
;
3597 p
->u
.s
.trapped_write
= SYMBOL_UNTRAPPED_WRITE
;
3598 p
->u
.s
.declared_special
= false;
3599 p
->u
.s
.pinned
= false;
3602 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3603 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3604 Its value is void, and its function definition and property list are nil. */)
3609 CHECK_STRING (name
);
3613 if (symbol_free_list
)
3615 XSETSYMBOL (val
, symbol_free_list
);
3616 symbol_free_list
= symbol_free_list
->u
.s
.next
;
3620 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3622 struct symbol_block
*new
3623 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3624 new->next
= symbol_block
;
3626 symbol_block_index
= 0;
3627 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3629 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3630 symbol_block_index
++;
3633 MALLOC_UNBLOCK_INPUT
;
3635 init_symbol (val
, name
);
3636 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3638 total_free_symbols
--;
3644 /***********************************************************************
3645 Marker (Misc) Allocation
3646 ***********************************************************************/
3648 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3649 the required alignment. */
3651 union aligned_Lisp_Misc
3654 unsigned char c
[(sizeof (union Lisp_Misc
) + LISP_ALIGNMENT
- 1)
3658 /* Allocation of markers and other objects that share that structure.
3659 Works like allocation of conses. */
3661 #define MARKER_BLOCK_SIZE \
3662 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3666 /* Place `markers' first, to preserve alignment. */
3667 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3668 struct marker_block
*next
;
3671 static struct marker_block
*marker_block
;
3672 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3674 static union Lisp_Misc
*misc_free_list
;
3676 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3679 allocate_misc (enum Lisp_Misc_Type type
)
3687 XSETMISC (val
, misc_free_list
);
3688 misc_free_list
= misc_free_list
->u_free
.chain
;
3692 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3694 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3695 new->next
= marker_block
;
3697 marker_block_index
= 0;
3698 total_free_markers
+= MARKER_BLOCK_SIZE
;
3700 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3701 marker_block_index
++;
3704 MALLOC_UNBLOCK_INPUT
;
3706 --total_free_markers
;
3707 consing_since_gc
+= sizeof (union Lisp_Misc
);
3708 misc_objects_consed
++;
3709 XMISCANY (val
)->type
= type
;
3710 XMISCANY (val
)->gcmarkbit
= 0;
3715 make_misc_ptr (void *a
)
3717 Lisp_Object val
= allocate_misc (Lisp_Misc_Ptr
);
3718 XUNTAG (val
, Lisp_Misc
, struct Lisp_Misc_Ptr
)->pointer
= a
;
3722 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3725 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3727 register Lisp_Object overlay
;
3729 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3730 OVERLAY_START (overlay
) = start
;
3731 OVERLAY_END (overlay
) = end
;
3732 set_overlay_plist (overlay
, plist
);
3733 XOVERLAY (overlay
)->next
= NULL
;
3737 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3738 doc
: /* Return a newly allocated marker which does not point at any place. */)
3741 register Lisp_Object val
;
3742 register struct Lisp_Marker
*p
;
3744 val
= allocate_misc (Lisp_Misc_Marker
);
3750 p
->insertion_type
= 0;
3751 p
->need_adjustment
= 0;
3755 /* Return a newly allocated marker which points into BUF
3756 at character position CHARPOS and byte position BYTEPOS. */
3759 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3762 struct Lisp_Marker
*m
;
3764 /* No dead buffers here. */
3765 eassert (BUFFER_LIVE_P (buf
));
3767 /* Every character is at least one byte. */
3768 eassert (charpos
<= bytepos
);
3770 obj
= allocate_misc (Lisp_Misc_Marker
);
3773 m
->charpos
= charpos
;
3774 m
->bytepos
= bytepos
;
3775 m
->insertion_type
= 0;
3776 m
->need_adjustment
= 0;
3777 m
->next
= BUF_MARKERS (buf
);
3778 BUF_MARKERS (buf
) = m
;
3783 /* Return a newly created vector or string with specified arguments as
3784 elements. If all the arguments are characters that can fit
3785 in a string of events, make a string; otherwise, make a vector.
3787 Any number of arguments, even zero arguments, are allowed. */
3790 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3794 for (i
= 0; i
< nargs
; i
++)
3795 /* The things that fit in a string
3796 are characters that are in 0...127,
3797 after discarding the meta bit and all the bits above it. */
3798 if (!INTEGERP (args
[i
])
3799 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3800 return Fvector (nargs
, args
);
3802 /* Since the loop exited, we know that all the things in it are
3803 characters, so we can make a string. */
3807 result
= Fmake_string (make_number (nargs
), make_number (0), Qnil
);
3808 for (i
= 0; i
< nargs
; i
++)
3810 SSET (result
, i
, XINT (args
[i
]));
3811 /* Move the meta bit to the right place for a string char. */
3812 if (XINT (args
[i
]) & CHAR_META
)
3813 SSET (result
, i
, SREF (result
, i
) | 0x80);
3821 /* Create a new module user ptr object. */
3823 make_user_ptr (void (*finalizer
) (void *), void *p
)
3826 struct Lisp_User_Ptr
*uptr
;
3828 obj
= allocate_misc (Lisp_Misc_User_Ptr
);
3829 uptr
= XUSER_PTR (obj
);
3830 uptr
->finalizer
= finalizer
;
3837 init_finalizer_list (struct Lisp_Finalizer
*head
)
3839 head
->prev
= head
->next
= head
;
3842 /* Insert FINALIZER before ELEMENT. */
3845 finalizer_insert (struct Lisp_Finalizer
*element
,
3846 struct Lisp_Finalizer
*finalizer
)
3848 eassert (finalizer
->prev
== NULL
);
3849 eassert (finalizer
->next
== NULL
);
3850 finalizer
->next
= element
;
3851 finalizer
->prev
= element
->prev
;
3852 finalizer
->prev
->next
= finalizer
;
3853 element
->prev
= finalizer
;
3857 unchain_finalizer (struct Lisp_Finalizer
*finalizer
)
3859 if (finalizer
->prev
!= NULL
)
3861 eassert (finalizer
->next
!= NULL
);
3862 finalizer
->prev
->next
= finalizer
->next
;
3863 finalizer
->next
->prev
= finalizer
->prev
;
3864 finalizer
->prev
= finalizer
->next
= NULL
;
3869 mark_finalizer_list (struct Lisp_Finalizer
*head
)
3871 for (struct Lisp_Finalizer
*finalizer
= head
->next
;
3873 finalizer
= finalizer
->next
)
3875 finalizer
->base
.gcmarkbit
= true;
3876 mark_object (finalizer
->function
);
3880 /* Move doomed finalizers to list DEST from list SRC. A doomed
3881 finalizer is one that is not GC-reachable and whose
3882 finalizer->function is non-nil. */
3885 queue_doomed_finalizers (struct Lisp_Finalizer
*dest
,
3886 struct Lisp_Finalizer
*src
)
3888 struct Lisp_Finalizer
*finalizer
= src
->next
;
3889 while (finalizer
!= src
)
3891 struct Lisp_Finalizer
*next
= finalizer
->next
;
3892 if (!finalizer
->base
.gcmarkbit
&& !NILP (finalizer
->function
))
3894 unchain_finalizer (finalizer
);
3895 finalizer_insert (dest
, finalizer
);
3903 run_finalizer_handler (Lisp_Object args
)
3905 add_to_log ("finalizer failed: %S", args
);
3910 run_finalizer_function (Lisp_Object function
)
3912 ptrdiff_t count
= SPECPDL_INDEX ();
3914 specbind (Qinhibit_quit
, Qt
);
3915 internal_condition_case_1 (call0
, function
, Qt
, run_finalizer_handler
);
3916 unbind_to (count
, Qnil
);
3920 run_finalizers (struct Lisp_Finalizer
*finalizers
)
3922 struct Lisp_Finalizer
*finalizer
;
3923 Lisp_Object function
;
3925 while (finalizers
->next
!= finalizers
)
3927 finalizer
= finalizers
->next
;
3928 eassert (finalizer
->base
.type
== Lisp_Misc_Finalizer
);
3929 unchain_finalizer (finalizer
);
3930 function
= finalizer
->function
;
3931 if (!NILP (function
))
3933 finalizer
->function
= Qnil
;
3934 run_finalizer_function (function
);
3939 DEFUN ("make-finalizer", Fmake_finalizer
, Smake_finalizer
, 1, 1, 0,
3940 doc
: /* Make a finalizer that will run FUNCTION.
3941 FUNCTION will be called after garbage collection when the returned
3942 finalizer object becomes unreachable. If the finalizer object is
3943 reachable only through references from finalizer objects, it does not
3944 count as reachable for the purpose of deciding whether to run
3945 FUNCTION. FUNCTION will be run once per finalizer object. */)
3946 (Lisp_Object function
)
3948 Lisp_Object val
= allocate_misc (Lisp_Misc_Finalizer
);
3949 struct Lisp_Finalizer
*finalizer
= XFINALIZER (val
);
3950 finalizer
->function
= function
;
3951 finalizer
->prev
= finalizer
->next
= NULL
;
3952 finalizer_insert (&finalizers
, finalizer
);
3957 /************************************************************************
3958 Memory Full Handling
3959 ************************************************************************/
3962 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3963 there may have been size_t overflow so that malloc was never
3964 called, or perhaps malloc was invoked successfully but the
3965 resulting pointer had problems fitting into a tagged EMACS_INT. In
3966 either case this counts as memory being full even though malloc did
3970 memory_full (size_t nbytes
)
3972 /* Do not go into hysterics merely because a large request failed. */
3973 bool enough_free_memory
= 0;
3974 if (SPARE_MEMORY
< nbytes
)
3979 p
= malloc (SPARE_MEMORY
);
3983 enough_free_memory
= 1;
3985 MALLOC_UNBLOCK_INPUT
;
3988 if (! enough_free_memory
)
3994 memory_full_cons_threshold
= sizeof (struct cons_block
);
3996 /* The first time we get here, free the spare memory. */
3997 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
3998 if (spare_memory
[i
])
4001 free (spare_memory
[i
]);
4002 else if (i
>= 1 && i
<= 4)
4003 lisp_align_free (spare_memory
[i
]);
4005 lisp_free (spare_memory
[i
]);
4006 spare_memory
[i
] = 0;
4010 /* This used to call error, but if we've run out of memory, we could
4011 get infinite recursion trying to build the string. */
4012 xsignal (Qnil
, Vmemory_signal_data
);
4015 /* If we released our reserve (due to running out of memory),
4016 and we have a fair amount free once again,
4017 try to set aside another reserve in case we run out once more.
4019 This is called when a relocatable block is freed in ralloc.c,
4020 and also directly from this file, in case we're not using ralloc.c. */
4023 refill_memory_reserve (void)
4025 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4026 if (spare_memory
[0] == 0)
4027 spare_memory
[0] = malloc (SPARE_MEMORY
);
4028 if (spare_memory
[1] == 0)
4029 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
4031 if (spare_memory
[2] == 0)
4032 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
4034 if (spare_memory
[3] == 0)
4035 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
4037 if (spare_memory
[4] == 0)
4038 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
4040 if (spare_memory
[5] == 0)
4041 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
4043 if (spare_memory
[6] == 0)
4044 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
4046 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
4047 Vmemory_full
= Qnil
;
4051 /************************************************************************
4053 ************************************************************************/
4055 /* Conservative C stack marking requires a method to identify possibly
4056 live Lisp objects given a pointer value. We do this by keeping
4057 track of blocks of Lisp data that are allocated in a red-black tree
4058 (see also the comment of mem_node which is the type of nodes in
4059 that tree). Function lisp_malloc adds information for an allocated
4060 block to the red-black tree with calls to mem_insert, and function
4061 lisp_free removes it with mem_delete. Functions live_string_p etc
4062 call mem_find to lookup information about a given pointer in the
4063 tree, and use that to determine if the pointer points into a Lisp
4066 /* Initialize this part of alloc.c. */
4071 mem_z
.left
= mem_z
.right
= MEM_NIL
;
4072 mem_z
.parent
= NULL
;
4073 mem_z
.color
= MEM_BLACK
;
4074 mem_z
.start
= mem_z
.end
= NULL
;
4079 /* Value is a pointer to the mem_node containing START. Value is
4080 MEM_NIL if there is no node in the tree containing START. */
4082 static struct mem_node
*
4083 mem_find (void *start
)
4087 if (start
< min_heap_address
|| start
> max_heap_address
)
4090 /* Make the search always successful to speed up the loop below. */
4091 mem_z
.start
= start
;
4092 mem_z
.end
= (char *) start
+ 1;
4095 while (start
< p
->start
|| start
>= p
->end
)
4096 p
= start
< p
->start
? p
->left
: p
->right
;
4101 /* Insert a new node into the tree for a block of memory with start
4102 address START, end address END, and type TYPE. Value is a
4103 pointer to the node that was inserted. */
4105 static struct mem_node
*
4106 mem_insert (void *start
, void *end
, enum mem_type type
)
4108 struct mem_node
*c
, *parent
, *x
;
4110 if (min_heap_address
== NULL
|| start
< min_heap_address
)
4111 min_heap_address
= start
;
4112 if (max_heap_address
== NULL
|| end
> max_heap_address
)
4113 max_heap_address
= end
;
4115 /* See where in the tree a node for START belongs. In this
4116 particular application, it shouldn't happen that a node is already
4117 present. For debugging purposes, let's check that. */
4121 while (c
!= MEM_NIL
)
4124 c
= start
< c
->start
? c
->left
: c
->right
;
4127 /* Create a new node. */
4128 #ifdef GC_MALLOC_CHECK
4129 x
= malloc (sizeof *x
);
4133 x
= xmalloc (sizeof *x
);
4139 x
->left
= x
->right
= MEM_NIL
;
4142 /* Insert it as child of PARENT or install it as root. */
4145 if (start
< parent
->start
)
4153 /* Re-establish red-black tree properties. */
4154 mem_insert_fixup (x
);
4160 /* Re-establish the red-black properties of the tree, and thereby
4161 balance the tree, after node X has been inserted; X is always red. */
4164 mem_insert_fixup (struct mem_node
*x
)
4166 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4168 /* X is red and its parent is red. This is a violation of
4169 red-black tree property #3. */
4171 if (x
->parent
== x
->parent
->parent
->left
)
4173 /* We're on the left side of our grandparent, and Y is our
4175 struct mem_node
*y
= x
->parent
->parent
->right
;
4177 if (y
->color
== MEM_RED
)
4179 /* Uncle and parent are red but should be black because
4180 X is red. Change the colors accordingly and proceed
4181 with the grandparent. */
4182 x
->parent
->color
= MEM_BLACK
;
4183 y
->color
= MEM_BLACK
;
4184 x
->parent
->parent
->color
= MEM_RED
;
4185 x
= x
->parent
->parent
;
4189 /* Parent and uncle have different colors; parent is
4190 red, uncle is black. */
4191 if (x
== x
->parent
->right
)
4194 mem_rotate_left (x
);
4197 x
->parent
->color
= MEM_BLACK
;
4198 x
->parent
->parent
->color
= MEM_RED
;
4199 mem_rotate_right (x
->parent
->parent
);
4204 /* This is the symmetrical case of above. */
4205 struct mem_node
*y
= x
->parent
->parent
->left
;
4207 if (y
->color
== MEM_RED
)
4209 x
->parent
->color
= MEM_BLACK
;
4210 y
->color
= MEM_BLACK
;
4211 x
->parent
->parent
->color
= MEM_RED
;
4212 x
= x
->parent
->parent
;
4216 if (x
== x
->parent
->left
)
4219 mem_rotate_right (x
);
4222 x
->parent
->color
= MEM_BLACK
;
4223 x
->parent
->parent
->color
= MEM_RED
;
4224 mem_rotate_left (x
->parent
->parent
);
4229 /* The root may have been changed to red due to the algorithm. Set
4230 it to black so that property #5 is satisfied. */
4231 mem_root
->color
= MEM_BLACK
;
4242 mem_rotate_left (struct mem_node
*x
)
4246 /* Turn y's left sub-tree into x's right sub-tree. */
4249 if (y
->left
!= MEM_NIL
)
4250 y
->left
->parent
= x
;
4252 /* Y's parent was x's parent. */
4254 y
->parent
= x
->parent
;
4256 /* Get the parent to point to y instead of x. */
4259 if (x
== x
->parent
->left
)
4260 x
->parent
->left
= y
;
4262 x
->parent
->right
= y
;
4267 /* Put x on y's left. */
4281 mem_rotate_right (struct mem_node
*x
)
4283 struct mem_node
*y
= x
->left
;
4286 if (y
->right
!= MEM_NIL
)
4287 y
->right
->parent
= x
;
4290 y
->parent
= x
->parent
;
4293 if (x
== x
->parent
->right
)
4294 x
->parent
->right
= y
;
4296 x
->parent
->left
= y
;
4307 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4310 mem_delete (struct mem_node
*z
)
4312 struct mem_node
*x
, *y
;
4314 if (!z
|| z
== MEM_NIL
)
4317 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4322 while (y
->left
!= MEM_NIL
)
4326 if (y
->left
!= MEM_NIL
)
4331 x
->parent
= y
->parent
;
4334 if (y
== y
->parent
->left
)
4335 y
->parent
->left
= x
;
4337 y
->parent
->right
= x
;
4344 z
->start
= y
->start
;
4349 if (y
->color
== MEM_BLACK
)
4350 mem_delete_fixup (x
);
4352 #ifdef GC_MALLOC_CHECK
4360 /* Re-establish the red-black properties of the tree, after a
4364 mem_delete_fixup (struct mem_node
*x
)
4366 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4368 if (x
== x
->parent
->left
)
4370 struct mem_node
*w
= x
->parent
->right
;
4372 if (w
->color
== MEM_RED
)
4374 w
->color
= MEM_BLACK
;
4375 x
->parent
->color
= MEM_RED
;
4376 mem_rotate_left (x
->parent
);
4377 w
= x
->parent
->right
;
4380 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4387 if (w
->right
->color
== MEM_BLACK
)
4389 w
->left
->color
= MEM_BLACK
;
4391 mem_rotate_right (w
);
4392 w
= x
->parent
->right
;
4394 w
->color
= x
->parent
->color
;
4395 x
->parent
->color
= MEM_BLACK
;
4396 w
->right
->color
= MEM_BLACK
;
4397 mem_rotate_left (x
->parent
);
4403 struct mem_node
*w
= x
->parent
->left
;
4405 if (w
->color
== MEM_RED
)
4407 w
->color
= MEM_BLACK
;
4408 x
->parent
->color
= MEM_RED
;
4409 mem_rotate_right (x
->parent
);
4410 w
= x
->parent
->left
;
4413 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4420 if (w
->left
->color
== MEM_BLACK
)
4422 w
->right
->color
= MEM_BLACK
;
4424 mem_rotate_left (w
);
4425 w
= x
->parent
->left
;
4428 w
->color
= x
->parent
->color
;
4429 x
->parent
->color
= MEM_BLACK
;
4430 w
->left
->color
= MEM_BLACK
;
4431 mem_rotate_right (x
->parent
);
4437 x
->color
= MEM_BLACK
;
4441 /* If P is a pointer into a live Lisp string object on the heap,
4442 return the object. Otherwise, return nil. M is a pointer to the
4445 This and other *_holding functions look for a pointer anywhere into
4446 the object, not merely for a pointer to the start of the object,
4447 because some compilers sometimes optimize away the latter. See
4451 live_string_holding (struct mem_node
*m
, void *p
)
4453 if (m
->type
== MEM_TYPE_STRING
)
4455 struct string_block
*b
= m
->start
;
4457 ptrdiff_t offset
= cp
- (char *) &b
->strings
[0];
4459 /* P must point into a Lisp_String structure, and it
4460 must not be on the free-list. */
4461 if (0 <= offset
&& offset
< STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4463 cp
= ptr_bounds_copy (cp
, b
);
4464 struct Lisp_String
*s
= p
= cp
-= offset
% sizeof b
->strings
[0];
4466 return make_lisp_ptr (s
, Lisp_String
);
4473 live_string_p (struct mem_node
*m
, void *p
)
4475 return !NILP (live_string_holding (m
, p
));
4478 /* If P is a pointer into a live Lisp cons object on the heap, return
4479 the object. Otherwise, return nil. M is a pointer to the
4483 live_cons_holding (struct mem_node
*m
, void *p
)
4485 if (m
->type
== MEM_TYPE_CONS
)
4487 struct cons_block
*b
= m
->start
;
4489 ptrdiff_t offset
= cp
- (char *) &b
->conses
[0];
4491 /* P must point into a Lisp_Cons, not be
4492 one of the unused cells in the current cons block,
4493 and not be on the free-list. */
4494 if (0 <= offset
&& offset
< CONS_BLOCK_SIZE
* sizeof b
->conses
[0]
4496 || offset
/ sizeof b
->conses
[0] < cons_block_index
))
4498 cp
= ptr_bounds_copy (cp
, b
);
4499 struct Lisp_Cons
*s
= p
= cp
-= offset
% sizeof b
->conses
[0];
4500 if (!EQ (s
->u
.s
.car
, Vdead
))
4501 return make_lisp_ptr (s
, Lisp_Cons
);
4508 live_cons_p (struct mem_node
*m
, void *p
)
4510 return !NILP (live_cons_holding (m
, p
));
4514 /* If P is a pointer into a live Lisp symbol object on the heap,
4515 return the object. Otherwise, return nil. M is a pointer to the
4519 live_symbol_holding (struct mem_node
*m
, void *p
)
4521 if (m
->type
== MEM_TYPE_SYMBOL
)
4523 struct symbol_block
*b
= m
->start
;
4525 ptrdiff_t offset
= cp
- (char *) &b
->symbols
[0];
4527 /* P must point into the Lisp_Symbol, not be
4528 one of the unused cells in the current symbol block,
4529 and not be on the free-list. */
4530 if (0 <= offset
&& offset
< SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0]
4531 && (b
!= symbol_block
4532 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
))
4534 cp
= ptr_bounds_copy (cp
, b
);
4535 struct Lisp_Symbol
*s
= p
= cp
-= offset
% sizeof b
->symbols
[0];
4536 if (!EQ (s
->u
.s
.function
, Vdead
))
4537 return make_lisp_symbol (s
);
4544 live_symbol_p (struct mem_node
*m
, void *p
)
4546 return !NILP (live_symbol_holding (m
, p
));
4550 /* Return true if P is a pointer to a live Lisp float on
4551 the heap. M is a pointer to the mem_block for P. */
4554 live_float_p (struct mem_node
*m
, void *p
)
4556 if (m
->type
== MEM_TYPE_FLOAT
)
4558 struct float_block
*b
= m
->start
;
4560 ptrdiff_t offset
= cp
- (char *) &b
->floats
[0];
4562 /* P must point to the start of a Lisp_Float and not be
4563 one of the unused cells in the current float block. */
4565 && offset
% sizeof b
->floats
[0] == 0
4566 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4567 && (b
!= float_block
4568 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4575 /* If P is a pointer to a live Lisp Misc on the heap, return the object.
4576 Otherwise, return nil. M is a pointer to the mem_block for P. */
4579 live_misc_holding (struct mem_node
*m
, void *p
)
4581 if (m
->type
== MEM_TYPE_MISC
)
4583 struct marker_block
*b
= m
->start
;
4585 ptrdiff_t offset
= cp
- (char *) &b
->markers
[0];
4587 /* P must point into a Lisp_Misc, not be
4588 one of the unused cells in the current misc block,
4589 and not be on the free-list. */
4590 if (0 <= offset
&& offset
< MARKER_BLOCK_SIZE
* sizeof b
->markers
[0]
4591 && (b
!= marker_block
4592 || offset
/ sizeof b
->markers
[0] < marker_block_index
))
4594 cp
= ptr_bounds_copy (cp
, b
);
4595 union Lisp_Misc
*s
= p
= cp
-= offset
% sizeof b
->markers
[0];
4596 if (s
->u_any
.type
!= Lisp_Misc_Free
)
4597 return make_lisp_ptr (s
, Lisp_Misc
);
4604 live_misc_p (struct mem_node
*m
, void *p
)
4606 return !NILP (live_misc_holding (m
, p
));
4609 /* If P is a pointer to a live vector-like object, return the object.
4610 Otherwise, return nil.
4611 M is a pointer to the mem_block for P. */
4614 live_vector_holding (struct mem_node
*m
, void *p
)
4616 struct Lisp_Vector
*vp
= p
;
4618 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4620 /* This memory node corresponds to a vector block. */
4621 struct vector_block
*block
= m
->start
;
4622 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4624 /* P is in the block's allocation range. Scan the block
4625 up to P and see whether P points to the start of some
4626 vector which is not on a free list. FIXME: check whether
4627 some allocation patterns (probably a lot of short vectors)
4628 may cause a substantial overhead of this loop. */
4629 while (VECTOR_IN_BLOCK (vector
, block
) && vector
<= vp
)
4631 struct Lisp_Vector
*next
= ADVANCE (vector
, vector_nbytes (vector
));
4632 if (vp
< next
&& !PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
))
4633 return make_lisp_ptr (vector
, Lisp_Vectorlike
);
4637 else if (m
->type
== MEM_TYPE_VECTORLIKE
)
4639 /* This memory node corresponds to a large vector. */
4640 struct Lisp_Vector
*vector
= large_vector_vec (m
->start
);
4641 struct Lisp_Vector
*next
= ADVANCE (vector
, vector_nbytes (vector
));
4642 if (vector
<= vp
&& vp
< next
)
4643 return make_lisp_ptr (vector
, Lisp_Vectorlike
);
4649 live_vector_p (struct mem_node
*m
, void *p
)
4651 return !NILP (live_vector_holding (m
, p
));
4654 /* If P is a pointer into a live buffer, return the buffer.
4655 Otherwise, return nil. M is a pointer to the mem_block for P. */
4658 live_buffer_holding (struct mem_node
*m
, void *p
)
4660 /* P must point into the block, and the buffer
4661 must not have been killed. */
4662 if (m
->type
== MEM_TYPE_BUFFER
)
4664 struct buffer
*b
= m
->start
;
4665 char *cb
= m
->start
;
4667 ptrdiff_t offset
= cp
- cb
;
4668 if (0 <= offset
&& offset
< sizeof *b
&& !NILP (b
->name_
))
4671 XSETBUFFER (obj
, b
);
4679 live_buffer_p (struct mem_node
*m
, void *p
)
4681 return !NILP (live_buffer_holding (m
, p
));
4684 /* Mark OBJ if we can prove it's a Lisp_Object. */
4687 mark_maybe_object (Lisp_Object obj
)
4691 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4697 void *po
= XPNTR (obj
);
4698 struct mem_node
*m
= mem_find (po
);
4702 bool mark_p
= false;
4704 switch (XTYPE (obj
))
4707 mark_p
= EQ (obj
, live_string_holding (m
, po
));
4711 mark_p
= EQ (obj
, live_cons_holding (m
, po
));
4715 mark_p
= EQ (obj
, live_symbol_holding (m
, po
));
4719 mark_p
= live_float_p (m
, po
);
4722 case Lisp_Vectorlike
:
4723 mark_p
= (EQ (obj
, live_vector_holding (m
, po
))
4724 || EQ (obj
, live_buffer_holding (m
, po
)));
4728 mark_p
= EQ (obj
, live_misc_holding (m
, po
));
4741 mark_maybe_objects (Lisp_Object
*array
, ptrdiff_t nelts
)
4743 for (Lisp_Object
*lim
= array
+ nelts
; array
< lim
; array
++)
4744 mark_maybe_object (*array
);
4747 /* Return true if P might point to Lisp data that can be garbage
4748 collected, and false otherwise (i.e., false if it is easy to see
4749 that P cannot point to Lisp data that can be garbage collected).
4750 Symbols are implemented via offsets not pointers, but the offsets
4751 are also multiples of LISP_ALIGNMENT. */
4754 maybe_lisp_pointer (void *p
)
4756 return (uintptr_t) p
% LISP_ALIGNMENT
== 0;
4759 #ifndef HAVE_MODULES
4760 enum { HAVE_MODULES
= false };
4763 /* If P points to Lisp data, mark that as live if it isn't already
4767 mark_maybe_pointer (void *p
)
4773 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4776 if (sizeof (Lisp_Object
) == sizeof (void *) || !HAVE_MODULES
)
4778 if (!maybe_lisp_pointer (p
))
4783 /* For the wide-int case, also mark emacs_value tagged pointers,
4784 which can be generated by emacs-module.c's value_to_lisp. */
4785 p
= (void *) ((uintptr_t) p
& ~((1 << GCTYPEBITS
) - 1));
4791 Lisp_Object obj
= Qnil
;
4795 case MEM_TYPE_NON_LISP
:
4796 case MEM_TYPE_SPARE
:
4797 /* Nothing to do; not a pointer to Lisp memory. */
4800 case MEM_TYPE_BUFFER
:
4801 obj
= live_buffer_holding (m
, p
);
4805 obj
= live_cons_holding (m
, p
);
4808 case MEM_TYPE_STRING
:
4809 obj
= live_string_holding (m
, p
);
4813 obj
= live_misc_holding (m
, p
);
4816 case MEM_TYPE_SYMBOL
:
4817 obj
= live_symbol_holding (m
, p
);
4820 case MEM_TYPE_FLOAT
:
4821 if (live_float_p (m
, p
))
4822 obj
= make_lisp_ptr (p
, Lisp_Float
);
4825 case MEM_TYPE_VECTORLIKE
:
4826 case MEM_TYPE_VECTOR_BLOCK
:
4827 obj
= live_vector_holding (m
, p
);
4840 /* Alignment of pointer values. Use alignof, as it sometimes returns
4841 a smaller alignment than GCC's __alignof__ and mark_memory might
4842 miss objects if __alignof__ were used. */
4843 #define GC_POINTER_ALIGNMENT alignof (void *)
4845 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4846 or END+OFFSET..START. */
4848 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4849 mark_memory (void *start
, void *end
)
4853 /* Make START the pointer to the start of the memory region,
4854 if it isn't already. */
4862 eassert (((uintptr_t) start
) % GC_POINTER_ALIGNMENT
== 0);
4864 /* Mark Lisp data pointed to. This is necessary because, in some
4865 situations, the C compiler optimizes Lisp objects away, so that
4866 only a pointer to them remains. Example:
4868 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4871 Lisp_Object obj = build_string ("test");
4872 struct Lisp_String *s = XSTRING (obj);
4873 Fgarbage_collect ();
4874 fprintf (stderr, "test '%s'\n", s->u.s.data);
4878 Here, `obj' isn't really used, and the compiler optimizes it
4879 away. The only reference to the life string is through the
4882 for (pp
= start
; (void *) pp
< end
; pp
+= GC_POINTER_ALIGNMENT
)
4884 mark_maybe_pointer (*(void **) pp
);
4886 verify (alignof (Lisp_Object
) % GC_POINTER_ALIGNMENT
== 0);
4887 if (alignof (Lisp_Object
) == GC_POINTER_ALIGNMENT
4888 || (uintptr_t) pp
% alignof (Lisp_Object
) == 0)
4889 mark_maybe_object (*(Lisp_Object
*) pp
);
4893 #ifndef HAVE___BUILTIN_UNWIND_INIT
4895 # ifdef GC_SETJMP_WORKS
4902 static bool setjmp_tested_p
;
4903 static int longjmps_done
;
4905 # define SETJMP_WILL_LIKELY_WORK "\
4907 Emacs garbage collector has been changed to use conservative stack\n\
4908 marking. Emacs has determined that the method it uses to do the\n\
4909 marking will likely work on your system, but this isn't sure.\n\
4911 If you are a system-programmer, or can get the help of a local wizard\n\
4912 who is, please take a look at the function mark_stack in alloc.c, and\n\
4913 verify that the methods used are appropriate for your system.\n\
4915 Please mail the result to <emacs-devel@gnu.org>.\n\
4918 # define SETJMP_WILL_NOT_WORK "\
4920 Emacs garbage collector has been changed to use conservative stack\n\
4921 marking. Emacs has determined that the default method it uses to do the\n\
4922 marking will not work on your system. We will need a system-dependent\n\
4923 solution for your system.\n\
4925 Please take a look at the function mark_stack in alloc.c, and\n\
4926 try to find a way to make it work on your system.\n\
4928 Note that you may get false negatives, depending on the compiler.\n\
4929 In particular, you need to use -O with GCC for this test.\n\
4931 Please mail the result to <emacs-devel@gnu.org>.\n\
4935 /* Perform a quick check if it looks like setjmp saves registers in a
4936 jmp_buf. Print a message to stderr saying so. When this test
4937 succeeds, this is _not_ a proof that setjmp is sufficient for
4938 conservative stack marking. Only the sources or a disassembly
4944 if (setjmp_tested_p
)
4946 setjmp_tested_p
= true;
4951 /* Arrange for X to be put in a register. */
4957 if (longjmps_done
== 1)
4959 /* Came here after the longjmp at the end of the function.
4961 If x == 1, the longjmp has restored the register to its
4962 value before the setjmp, and we can hope that setjmp
4963 saves all such registers in the jmp_buf, although that
4966 For other values of X, either something really strange is
4967 taking place, or the setjmp just didn't save the register. */
4970 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4973 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4980 if (longjmps_done
== 1)
4981 sys_longjmp (jbuf
, 1);
4983 # endif /* ! GC_SETJMP_WORKS */
4984 #endif /* ! HAVE___BUILTIN_UNWIND_INIT */
4986 /* The type of an object near the stack top, whose address can be used
4987 as a stack scan limit. */
4990 /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT,
4991 jmp_buf may not be aligned enough on darwin-ppc64. */
4993 #ifndef HAVE___BUILTIN_UNWIND_INIT
4999 /* Force callee-saved registers and register windows onto the stack.
5000 Use the platform-defined __builtin_unwind_init if available,
5001 obviating the need for machine dependent methods. */
5002 #ifndef HAVE___BUILTIN_UNWIND_INIT
5004 /* This trick flushes the register windows so that all the state of
5005 the process is contained in the stack.
5006 FreeBSD does not have a ta 3 handler, so handle it specially.
5007 FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
5008 needed on ia64 too. See mach_dep.c, where it also says inline
5009 assembler doesn't work with relevant proprietary compilers. */
5010 # if defined __sparc64__ && defined __FreeBSD__
5011 # define __builtin_unwind_init() asm ("flushw")
5013 # define __builtin_unwind_init() asm ("ta 3")
5016 # define __builtin_unwind_init() ((void) 0)
5020 /* Yield an address close enough to the top of the stack that the
5021 garbage collector need not scan above it. Callers should be
5022 declared NO_INLINE. */
5023 #ifdef HAVE___BUILTIN_FRAME_ADDRESS
5024 # define NEAR_STACK_TOP(addr) ((void) (addr), __builtin_frame_address (0))
5026 # define NEAR_STACK_TOP(addr) (addr)
5029 /* Set *P to the address of the top of the stack. This must be a
5030 macro, not a function, so that it is executed in the caller's
5031 environment. It is not inside a do-while so that its storage
5032 survives the macro. Callers should be declared NO_INLINE. */
5033 #ifdef HAVE___BUILTIN_UNWIND_INIT
5034 # define SET_STACK_TOP_ADDRESS(p) \
5035 stacktop_sentry sentry; \
5036 __builtin_unwind_init (); \
5037 *(p) = NEAR_STACK_TOP (&sentry)
5039 # define SET_STACK_TOP_ADDRESS(p) \
5040 stacktop_sentry sentry; \
5041 __builtin_unwind_init (); \
5043 sys_setjmp (sentry.j); \
5044 *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c))
5047 /* Mark live Lisp objects on the C stack.
5049 There are several system-dependent problems to consider when
5050 porting this to new architectures:
5054 We have to mark Lisp objects in CPU registers that can hold local
5055 variables or are used to pass parameters.
5057 This code assumes that calling setjmp saves registers we need
5058 to see in a jmp_buf which itself lies on the stack. This doesn't
5059 have to be true! It must be verified for each system, possibly
5060 by taking a look at the source code of setjmp.
5062 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
5063 can use it as a machine independent method to store all registers
5064 to the stack. In this case the macros described in the previous
5065 two paragraphs are not used.
5069 Architectures differ in the way their processor stack is organized.
5070 For example, the stack might look like this
5073 | Lisp_Object | size = 4
5075 | something else | size = 2
5077 | Lisp_Object | size = 4
5081 In such a case, not every Lisp_Object will be aligned equally. To
5082 find all Lisp_Object on the stack it won't be sufficient to walk
5083 the stack in steps of 4 bytes. Instead, two passes will be
5084 necessary, one starting at the start of the stack, and a second
5085 pass starting at the start of the stack + 2. Likewise, if the
5086 minimal alignment of Lisp_Objects on the stack is 1, four passes
5087 would be necessary, each one starting with one byte more offset
5088 from the stack start. */
5091 mark_stack (char *bottom
, char *end
)
5093 /* This assumes that the stack is a contiguous region in memory. If
5094 that's not the case, something has to be done here to iterate
5095 over the stack segments. */
5096 mark_memory (bottom
, end
);
5098 /* Allow for marking a secondary stack, like the register stack on the
5100 #ifdef GC_MARK_SECONDARY_STACK
5101 GC_MARK_SECONDARY_STACK ();
5105 /* This is a trampoline function that flushes registers to the stack,
5106 and then calls FUNC. ARG is passed through to FUNC verbatim.
5108 This function must be called whenever Emacs is about to release the
5109 global interpreter lock. This lets the garbage collector easily
5110 find roots in registers on threads that are not actively running
5113 It is invalid to run any Lisp code or to allocate any GC memory
5117 flush_stack_call_func (void (*func
) (void *arg
), void *arg
)
5120 struct thread_state
*self
= current_thread
;
5121 SET_STACK_TOP_ADDRESS (&end
);
5122 self
->stack_top
= end
;
5124 eassert (current_thread
== self
);
5128 c_symbol_p (struct Lisp_Symbol
*sym
)
5130 char *lispsym_ptr
= (char *) lispsym
;
5131 char *sym_ptr
= (char *) sym
;
5132 ptrdiff_t lispsym_offset
= sym_ptr
- lispsym_ptr
;
5133 return 0 <= lispsym_offset
&& lispsym_offset
< sizeof lispsym
;
5136 /* Determine whether it is safe to access memory at address P. */
5138 valid_pointer_p (void *p
)
5141 return w32_valid_pointer_p (p
, 16);
5144 if (ADDRESS_SANITIZER
)
5149 /* Obviously, we cannot just access it (we would SEGV trying), so we
5150 trick the o/s to tell us whether p is a valid pointer.
5151 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
5152 not validate p in that case. */
5154 if (emacs_pipe (fd
) == 0)
5156 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
5157 emacs_close (fd
[1]);
5158 emacs_close (fd
[0]);
5166 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5167 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5168 cannot validate OBJ. This function can be quite slow, and is used
5169 only in debugging. */
5172 valid_lisp_object_p (Lisp_Object obj
)
5177 void *p
= XPNTR (obj
);
5181 if (SYMBOLP (obj
) && c_symbol_p (p
))
5182 return ((char *) p
- (char *) lispsym
) % sizeof lispsym
[0] == 0;
5184 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5187 struct mem_node
*m
= mem_find (p
);
5191 int valid
= valid_pointer_p (p
);
5203 case MEM_TYPE_NON_LISP
:
5204 case MEM_TYPE_SPARE
:
5207 case MEM_TYPE_BUFFER
:
5208 return live_buffer_p (m
, p
) ? 1 : 2;
5211 return live_cons_p (m
, p
);
5213 case MEM_TYPE_STRING
:
5214 return live_string_p (m
, p
);
5217 return live_misc_p (m
, p
);
5219 case MEM_TYPE_SYMBOL
:
5220 return live_symbol_p (m
, p
);
5222 case MEM_TYPE_FLOAT
:
5223 return live_float_p (m
, p
);
5225 case MEM_TYPE_VECTORLIKE
:
5226 case MEM_TYPE_VECTOR_BLOCK
:
5227 return live_vector_p (m
, p
);
5236 /***********************************************************************
5237 Pure Storage Management
5238 ***********************************************************************/
5240 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5241 pointer to it. TYPE is the Lisp type for which the memory is
5242 allocated. TYPE < 0 means it's not used for a Lisp object. */
5245 pure_alloc (size_t size
, int type
)
5252 /* Allocate space for a Lisp object from the beginning of the free
5253 space with taking account of alignment. */
5254 result
= pointer_align (purebeg
+ pure_bytes_used_lisp
, LISP_ALIGNMENT
);
5255 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5259 /* Allocate space for a non-Lisp object from the end of the free
5261 pure_bytes_used_non_lisp
+= size
;
5262 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5264 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5266 if (pure_bytes_used
<= pure_size
)
5267 return ptr_bounds_clip (result
, size
);
5269 /* Don't allocate a large amount here,
5270 because it might get mmap'd and then its address
5271 might not be usable. */
5272 purebeg
= xmalloc (10000);
5274 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5275 pure_bytes_used
= 0;
5276 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5283 /* Print a warning if PURESIZE is too small. */
5286 check_pure_size (void)
5288 if (pure_bytes_used_before_overflow
)
5289 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5291 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5296 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5297 the non-Lisp data pool of the pure storage, and return its start
5298 address. Return NULL if not found. */
5301 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5304 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5305 const unsigned char *p
;
5308 if (pure_bytes_used_non_lisp
<= nbytes
)
5311 /* Set up the Boyer-Moore table. */
5313 for (i
= 0; i
< 256; i
++)
5316 p
= (const unsigned char *) data
;
5318 bm_skip
[*p
++] = skip
;
5320 last_char_skip
= bm_skip
['\0'];
5322 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5323 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5325 /* See the comments in the function `boyer_moore' (search.c) for the
5326 use of `infinity'. */
5327 infinity
= pure_bytes_used_non_lisp
+ 1;
5328 bm_skip
['\0'] = infinity
;
5330 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5334 /* Check the last character (== '\0'). */
5337 start
+= bm_skip
[*(p
+ start
)];
5339 while (start
<= start_max
);
5341 if (start
< infinity
)
5342 /* Couldn't find the last character. */
5345 /* No less than `infinity' means we could find the last
5346 character at `p[start - infinity]'. */
5349 /* Check the remaining characters. */
5350 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5352 return ptr_bounds_clip (non_lisp_beg
+ start
, nbytes
+ 1);
5354 start
+= last_char_skip
;
5356 while (start
<= start_max
);
5362 /* Return a string allocated in pure space. DATA is a buffer holding
5363 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5364 means make the result string multibyte.
5366 Must get an error if pure storage is full, since if it cannot hold
5367 a large string it may be able to hold conses that point to that
5368 string; then the string is not protected from gc. */
5371 make_pure_string (const char *data
,
5372 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5375 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5376 s
->u
.s
.data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5377 if (s
->u
.s
.data
== NULL
)
5379 s
->u
.s
.data
= pure_alloc (nbytes
+ 1, -1);
5380 memcpy (s
->u
.s
.data
, data
, nbytes
);
5381 s
->u
.s
.data
[nbytes
] = '\0';
5383 s
->u
.s
.size
= nchars
;
5384 s
->u
.s
.size_byte
= multibyte
? nbytes
: -1;
5385 s
->u
.s
.intervals
= NULL
;
5386 XSETSTRING (string
, s
);
5390 /* Return a string allocated in pure space. Do not
5391 allocate the string data, just point to DATA. */
5394 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5397 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5398 s
->u
.s
.size
= nchars
;
5399 s
->u
.s
.size_byte
= -1;
5400 s
->u
.s
.data
= (unsigned char *) data
;
5401 s
->u
.s
.intervals
= NULL
;
5402 XSETSTRING (string
, s
);
5406 static Lisp_Object
purecopy (Lisp_Object obj
);
5408 /* Return a cons allocated from pure space. Give it pure copies
5409 of CAR as car and CDR as cdr. */
5412 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5415 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5417 XSETCAR (new, purecopy (car
));
5418 XSETCDR (new, purecopy (cdr
));
5423 /* Value is a float object with value NUM allocated from pure space. */
5426 make_pure_float (double num
)
5429 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5431 XFLOAT_INIT (new, num
);
5436 /* Return a vector with room for LEN Lisp_Objects allocated from
5440 make_pure_vector (ptrdiff_t len
)
5443 size_t size
= header_size
+ len
* word_size
;
5444 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5445 XSETVECTOR (new, p
);
5446 XVECTOR (new)->header
.size
= len
;
5450 /* Copy all contents and parameters of TABLE to a new table allocated
5451 from pure space, return the purified table. */
5452 static struct Lisp_Hash_Table
*
5453 purecopy_hash_table (struct Lisp_Hash_Table
*table
)
5455 eassert (NILP (table
->weak
));
5456 eassert (table
->pure
);
5458 struct Lisp_Hash_Table
*pure
= pure_alloc (sizeof *pure
, Lisp_Vectorlike
);
5459 struct hash_table_test pure_test
= table
->test
;
5461 /* Purecopy the hash table test. */
5462 pure_test
.name
= purecopy (table
->test
.name
);
5463 pure_test
.user_hash_function
= purecopy (table
->test
.user_hash_function
);
5464 pure_test
.user_cmp_function
= purecopy (table
->test
.user_cmp_function
);
5466 pure
->header
= table
->header
;
5467 pure
->weak
= purecopy (Qnil
);
5468 pure
->hash
= purecopy (table
->hash
);
5469 pure
->next
= purecopy (table
->next
);
5470 pure
->index
= purecopy (table
->index
);
5471 pure
->count
= table
->count
;
5472 pure
->next_free
= table
->next_free
;
5473 pure
->pure
= table
->pure
;
5474 pure
->rehash_threshold
= table
->rehash_threshold
;
5475 pure
->rehash_size
= table
->rehash_size
;
5476 pure
->key_and_value
= purecopy (table
->key_and_value
);
5477 pure
->test
= pure_test
;
5482 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5483 doc
: /* Make a copy of object OBJ in pure storage.
5484 Recursively copies contents of vectors and cons cells.
5485 Does not copy symbols. Copies strings without text properties. */)
5486 (register Lisp_Object obj
)
5488 if (NILP (Vpurify_flag
))
5490 else if (MARKERP (obj
) || OVERLAYP (obj
) || SYMBOLP (obj
))
5491 /* Can't purify those. */
5494 return purecopy (obj
);
5497 /* Pinned objects are marked before every GC cycle. */
5498 static struct pinned_object
5501 struct pinned_object
*next
;
5505 purecopy (Lisp_Object obj
)
5508 || (! SYMBOLP (obj
) && PURE_P (XPNTR (obj
)))
5510 return obj
; /* Already pure. */
5512 if (STRINGP (obj
) && XSTRING (obj
)->u
.s
.intervals
)
5513 message_with_string ("Dropping text-properties while making string `%s' pure",
5516 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5518 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5524 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5525 else if (FLOATP (obj
))
5526 obj
= make_pure_float (XFLOAT_DATA (obj
));
5527 else if (STRINGP (obj
))
5528 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5530 STRING_MULTIBYTE (obj
));
5531 else if (HASH_TABLE_P (obj
))
5533 struct Lisp_Hash_Table
*table
= XHASH_TABLE (obj
);
5534 /* Do not purify hash tables which haven't been defined with
5535 :purecopy as non-nil or are weak - they aren't guaranteed to
5537 if (!NILP (table
->weak
) || !table
->pure
)
5539 /* Instead, add the hash table to the list of pinned objects,
5540 so that it will be marked during GC. */
5541 struct pinned_object
*o
= xmalloc (sizeof *o
);
5543 o
->next
= pinned_objects
;
5545 return obj
; /* Don't hash cons it. */
5548 struct Lisp_Hash_Table
*h
= purecopy_hash_table (table
);
5549 XSET_HASH_TABLE (obj
, h
);
5551 else if (COMPILEDP (obj
) || VECTORP (obj
) || RECORDP (obj
))
5553 struct Lisp_Vector
*objp
= XVECTOR (obj
);
5554 ptrdiff_t nbytes
= vector_nbytes (objp
);
5555 struct Lisp_Vector
*vec
= pure_alloc (nbytes
, Lisp_Vectorlike
);
5556 register ptrdiff_t i
;
5557 ptrdiff_t size
= ASIZE (obj
);
5558 if (size
& PSEUDOVECTOR_FLAG
)
5559 size
&= PSEUDOVECTOR_SIZE_MASK
;
5560 memcpy (vec
, objp
, nbytes
);
5561 for (i
= 0; i
< size
; i
++)
5562 vec
->contents
[i
] = purecopy (vec
->contents
[i
]);
5563 XSETVECTOR (obj
, vec
);
5565 else if (SYMBOLP (obj
))
5567 if (!XSYMBOL (obj
)->u
.s
.pinned
&& !c_symbol_p (XSYMBOL (obj
)))
5568 { /* We can't purify them, but they appear in many pure objects.
5569 Mark them as `pinned' so we know to mark them at every GC cycle. */
5570 XSYMBOL (obj
)->u
.s
.pinned
= true;
5571 symbol_block_pinned
= symbol_block
;
5573 /* Don't hash-cons it. */
5578 AUTO_STRING (fmt
, "Don't know how to purify: %S");
5579 Fsignal (Qerror
, list1 (CALLN (Fformat
, fmt
, obj
)));
5582 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5583 Fputhash (obj
, obj
, Vpurify_flag
);
5590 /***********************************************************************
5592 ***********************************************************************/
5594 /* Put an entry in staticvec, pointing at the variable with address
5598 staticpro (Lisp_Object
*varaddress
)
5600 if (staticidx
>= NSTATICS
)
5601 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5602 staticvec
[staticidx
++] = varaddress
;
5606 /***********************************************************************
5608 ***********************************************************************/
5610 /* Temporarily prevent garbage collection. */
5613 inhibit_garbage_collection (void)
5615 ptrdiff_t count
= SPECPDL_INDEX ();
5617 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5621 /* Used to avoid possible overflows when
5622 converting from C to Lisp integers. */
5625 bounded_number (EMACS_INT number
)
5627 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5630 /* Calculate total bytes of live objects. */
5633 total_bytes_of_live_objects (void)
5636 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5637 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5638 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5639 tot
+= total_string_bytes
;
5640 tot
+= total_vector_slots
* word_size
;
5641 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5642 tot
+= total_intervals
* sizeof (struct interval
);
5643 tot
+= total_strings
* sizeof (struct Lisp_String
);
5647 #ifdef HAVE_WINDOW_SYSTEM
5649 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5650 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5653 compact_font_cache_entry (Lisp_Object entry
)
5655 Lisp_Object tail
, *prev
= &entry
;
5657 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5660 Lisp_Object obj
= XCAR (tail
);
5662 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5663 if (CONSP (obj
) && GC_FONT_SPEC_P (XCAR (obj
))
5664 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj
)))
5665 /* Don't use VECTORP here, as that calls ASIZE, which could
5666 hit assertion violation during GC. */
5667 && (VECTORLIKEP (XCDR (obj
))
5668 && ! (gc_asize (XCDR (obj
)) & PSEUDOVECTOR_FLAG
)))
5670 ptrdiff_t i
, size
= gc_asize (XCDR (obj
));
5671 Lisp_Object obj_cdr
= XCDR (obj
);
5673 /* If font-spec is not marked, most likely all font-entities
5674 are not marked too. But we must be sure that nothing is
5675 marked within OBJ before we really drop it. */
5676 for (i
= 0; i
< size
; i
++)
5678 Lisp_Object objlist
;
5680 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr
, i
))))
5683 objlist
= AREF (AREF (obj_cdr
, i
), FONT_OBJLIST_INDEX
);
5684 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
5686 Lisp_Object val
= XCAR (objlist
);
5687 struct font
*font
= GC_XFONT_OBJECT (val
);
5689 if (!NILP (AREF (val
, FONT_TYPE_INDEX
))
5690 && VECTOR_MARKED_P(font
))
5693 if (CONSP (objlist
))
5695 /* Found a marked font, bail out. */
5702 /* No marked fonts were found, so this entire font
5703 entity can be dropped. */
5708 *prev
= XCDR (tail
);
5710 prev
= xcdr_addr (tail
);
5715 /* Compact font caches on all terminals and mark
5716 everything which is still here after compaction. */
5719 compact_font_caches (void)
5723 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5725 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5726 /* Inhibit compacting the caches if the user so wishes. Some of
5727 the users don't mind a larger memory footprint, but do mind
5728 slower redisplay. */
5729 if (!inhibit_compacting_font_caches
5734 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5735 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5737 mark_object (cache
);
5741 #else /* not HAVE_WINDOW_SYSTEM */
5743 #define compact_font_caches() (void)(0)
5745 #endif /* HAVE_WINDOW_SYSTEM */
5747 /* Remove (MARKER . DATA) entries with unmarked MARKER
5748 from buffer undo LIST and return changed list. */
5751 compact_undo_list (Lisp_Object list
)
5753 Lisp_Object tail
, *prev
= &list
;
5755 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5757 if (CONSP (XCAR (tail
))
5758 && MARKERP (XCAR (XCAR (tail
)))
5759 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5760 *prev
= XCDR (tail
);
5762 prev
= xcdr_addr (tail
);
5768 mark_pinned_objects (void)
5770 for (struct pinned_object
*pobj
= pinned_objects
; pobj
; pobj
= pobj
->next
)
5771 mark_object (pobj
->object
);
5775 mark_pinned_symbols (void)
5777 struct symbol_block
*sblk
;
5778 int lim
= (symbol_block_pinned
== symbol_block
5779 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5781 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5783 struct Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5784 for (; sym
< end
; ++sym
)
5785 if (sym
->u
.s
.pinned
)
5786 mark_object (make_lisp_symbol (sym
));
5788 lim
= SYMBOL_BLOCK_SIZE
;
5792 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5793 separate function so that we could limit mark_stack in searching
5794 the stack frames below this function, thus avoiding the rare cases
5795 where mark_stack finds values that look like live Lisp objects on
5796 portions of stack that couldn't possibly contain such live objects.
5797 For more details of this, see the discussion at
5798 https://lists.gnu.org/r/emacs-devel/2014-05/msg00270.html. */
5800 garbage_collect_1 (void *end
)
5802 struct buffer
*nextb
;
5803 char stack_top_variable
;
5806 ptrdiff_t count
= SPECPDL_INDEX ();
5807 struct timespec start
;
5808 Lisp_Object retval
= Qnil
;
5809 size_t tot_before
= 0;
5811 /* Can't GC if pure storage overflowed because we can't determine
5812 if something is a pure object or not. */
5813 if (pure_bytes_used_before_overflow
)
5816 /* Record this function, so it appears on the profiler's backtraces. */
5817 record_in_backtrace (QAutomatic_GC
, 0, 0);
5821 /* Don't keep undo information around forever.
5822 Do this early on, so it is no problem if the user quits. */
5823 FOR_EACH_BUFFER (nextb
)
5824 compact_buffer (nextb
);
5826 if (profiler_memory_running
)
5827 tot_before
= total_bytes_of_live_objects ();
5829 start
= current_timespec ();
5831 /* In case user calls debug_print during GC,
5832 don't let that cause a recursive GC. */
5833 consing_since_gc
= 0;
5835 /* Save what's currently displayed in the echo area. Don't do that
5836 if we are GC'ing because we've run out of memory, since
5837 push_message will cons, and we might have no memory for that. */
5838 if (NILP (Vmemory_full
))
5840 message_p
= push_message ();
5841 record_unwind_protect_void (pop_message_unwind
);
5846 /* Save a copy of the contents of the stack, for debugging. */
5847 #if MAX_SAVE_STACK > 0
5848 if (NILP (Vpurify_flag
))
5851 ptrdiff_t stack_size
;
5852 if (&stack_top_variable
< stack_bottom
)
5854 stack
= &stack_top_variable
;
5855 stack_size
= stack_bottom
- &stack_top_variable
;
5859 stack
= stack_bottom
;
5860 stack_size
= &stack_top_variable
- stack_bottom
;
5862 if (stack_size
<= MAX_SAVE_STACK
)
5864 if (stack_copy_size
< stack_size
)
5866 stack_copy
= xrealloc (stack_copy
, stack_size
);
5867 stack_copy_size
= stack_size
;
5869 stack
= ptr_bounds_set (stack
, stack_size
);
5870 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5873 #endif /* MAX_SAVE_STACK > 0 */
5875 if (garbage_collection_messages
)
5876 message1_nolog ("Garbage collecting...");
5880 shrink_regexp_cache ();
5884 /* Mark all the special slots that serve as the roots of accessibility. */
5886 mark_buffer (&buffer_defaults
);
5887 mark_buffer (&buffer_local_symbols
);
5889 for (i
= 0; i
< ARRAYELTS (lispsym
); i
++)
5890 mark_object (builtin_lisp_symbol (i
));
5892 for (i
= 0; i
< staticidx
; i
++)
5893 mark_object (*staticvec
[i
]);
5895 mark_pinned_objects ();
5896 mark_pinned_symbols ();
5905 #ifdef HAVE_WINDOW_SYSTEM
5906 mark_fringe_data ();
5913 /* Everything is now marked, except for the data in font caches,
5914 undo lists, and finalizers. The first two are compacted by
5915 removing an items which aren't reachable otherwise. */
5917 compact_font_caches ();
5919 FOR_EACH_BUFFER (nextb
)
5921 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5922 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5923 /* Now that we have stripped the elements that need not be
5924 in the undo_list any more, we can finally mark the list. */
5925 mark_object (BVAR (nextb
, undo_list
));
5928 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5929 to doomed_finalizers so we can run their associated functions
5930 after GC. It's important to scan finalizers at this stage so
5931 that we can be sure that unmarked finalizers are really
5932 unreachable except for references from their associated functions
5933 and from other finalizers. */
5935 queue_doomed_finalizers (&doomed_finalizers
, &finalizers
);
5936 mark_finalizer_list (&doomed_finalizers
);
5940 /* Clear the mark bits that we set in certain root slots. */
5941 VECTOR_UNMARK (&buffer_defaults
);
5942 VECTOR_UNMARK (&buffer_local_symbols
);
5950 consing_since_gc
= 0;
5951 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5952 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5954 gc_relative_threshold
= 0;
5955 if (FLOATP (Vgc_cons_percentage
))
5956 { /* Set gc_cons_combined_threshold. */
5957 double tot
= total_bytes_of_live_objects ();
5959 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5962 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5963 gc_relative_threshold
= tot
;
5965 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5969 if (garbage_collection_messages
&& NILP (Vmemory_full
))
5971 if (message_p
|| minibuf_level
> 0)
5974 message1_nolog ("Garbage collecting...done");
5977 unbind_to (count
, Qnil
);
5979 Lisp_Object total
[] = {
5980 list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5981 bounded_number (total_conses
),
5982 bounded_number (total_free_conses
)),
5983 list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5984 bounded_number (total_symbols
),
5985 bounded_number (total_free_symbols
)),
5986 list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5987 bounded_number (total_markers
),
5988 bounded_number (total_free_markers
)),
5989 list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5990 bounded_number (total_strings
),
5991 bounded_number (total_free_strings
)),
5992 list3 (Qstring_bytes
, make_number (1),
5993 bounded_number (total_string_bytes
)),
5995 make_number (header_size
+ sizeof (Lisp_Object
)),
5996 bounded_number (total_vectors
)),
5997 list4 (Qvector_slots
, make_number (word_size
),
5998 bounded_number (total_vector_slots
),
5999 bounded_number (total_free_vector_slots
)),
6000 list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
6001 bounded_number (total_floats
),
6002 bounded_number (total_free_floats
)),
6003 list4 (Qintervals
, make_number (sizeof (struct interval
)),
6004 bounded_number (total_intervals
),
6005 bounded_number (total_free_intervals
)),
6006 list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
6007 bounded_number (total_buffers
)),
6009 #ifdef DOUG_LEA_MALLOC
6010 list4 (Qheap
, make_number (1024),
6011 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
6012 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10)),
6015 retval
= CALLMANY (Flist
, total
);
6017 /* GC is complete: now we can run our finalizer callbacks. */
6018 run_finalizers (&doomed_finalizers
);
6020 if (!NILP (Vpost_gc_hook
))
6022 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6023 safe_run_hooks (Qpost_gc_hook
);
6024 unbind_to (gc_count
, Qnil
);
6027 /* Accumulate statistics. */
6028 if (FLOATP (Vgc_elapsed
))
6030 struct timespec since_start
= timespec_sub (current_timespec (), start
);
6031 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
6032 + timespectod (since_start
));
6037 /* Collect profiling data. */
6038 if (profiler_memory_running
)
6041 size_t tot_after
= total_bytes_of_live_objects ();
6042 if (tot_before
> tot_after
)
6043 swept
= tot_before
- tot_after
;
6044 malloc_probe (swept
);
6050 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
6051 doc
: /* Reclaim storage for Lisp objects no longer needed.
6052 Garbage collection happens automatically if you cons more than
6053 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
6054 `garbage-collect' normally returns a list with info on amount of space in use,
6055 where each entry has the form (NAME SIZE USED FREE), where:
6056 - NAME is a symbol describing the kind of objects this entry represents,
6057 - SIZE is the number of bytes used by each one,
6058 - USED is the number of those objects that were found live in the heap,
6059 - FREE is the number of those objects that are not live but that Emacs
6060 keeps around for future allocations (maybe because it does not know how
6061 to return them to the OS).
6062 However, if there was overflow in pure space, `garbage-collect'
6063 returns nil, because real GC can't be done.
6064 See Info node `(elisp)Garbage Collection'. */
6065 attributes
: noinline
)
6069 SET_STACK_TOP_ADDRESS (&end
);
6070 return garbage_collect_1 (end
);
6073 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
6074 only interesting objects referenced from glyphs are strings. */
6077 mark_glyph_matrix (struct glyph_matrix
*matrix
)
6079 struct glyph_row
*row
= matrix
->rows
;
6080 struct glyph_row
*end
= row
+ matrix
->nrows
;
6082 for (; row
< end
; ++row
)
6086 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
6088 struct glyph
*glyph
= row
->glyphs
[area
];
6089 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
6091 for (; glyph
< end_glyph
; ++glyph
)
6092 if (STRINGP (glyph
->object
)
6093 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
6094 mark_object (glyph
->object
);
6099 enum { LAST_MARKED_SIZE
= 1 << 9 }; /* Must be a power of 2. */
6100 Lisp_Object last_marked
[LAST_MARKED_SIZE
] EXTERNALLY_VISIBLE
;
6101 static int last_marked_index
;
6103 /* For debugging--call abort when we cdr down this many
6104 links of a list, in mark_object. In debugging,
6105 the call to abort will hit a breakpoint.
6106 Normally this is zero and the check never goes off. */
6107 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
6110 mark_vectorlike (struct Lisp_Vector
*ptr
)
6112 ptrdiff_t size
= ptr
->header
.size
;
6115 eassert (!VECTOR_MARKED_P (ptr
));
6116 VECTOR_MARK (ptr
); /* Else mark it. */
6117 if (size
& PSEUDOVECTOR_FLAG
)
6118 size
&= PSEUDOVECTOR_SIZE_MASK
;
6120 /* Note that this size is not the memory-footprint size, but only
6121 the number of Lisp_Object fields that we should trace.
6122 The distinction is used e.g. by Lisp_Process which places extra
6123 non-Lisp_Object fields at the end of the structure... */
6124 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
6125 mark_object (ptr
->contents
[i
]);
6128 /* Like mark_vectorlike but optimized for char-tables (and
6129 sub-char-tables) assuming that the contents are mostly integers or
6133 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
6135 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6136 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
6137 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
6139 eassert (!VECTOR_MARKED_P (ptr
));
6141 for (i
= idx
; i
< size
; i
++)
6143 Lisp_Object val
= ptr
->contents
[i
];
6145 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->u
.s
.gcmarkbit
))
6147 if (SUB_CHAR_TABLE_P (val
))
6149 if (! VECTOR_MARKED_P (XVECTOR (val
)))
6150 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
6157 NO_INLINE
/* To reduce stack depth in mark_object. */
6159 mark_compiled (struct Lisp_Vector
*ptr
)
6161 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6164 for (i
= 0; i
< size
; i
++)
6165 if (i
!= COMPILED_CONSTANTS
)
6166 mark_object (ptr
->contents
[i
]);
6167 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6170 /* Mark the chain of overlays starting at PTR. */
6173 mark_overlay (struct Lisp_Overlay
*ptr
)
6175 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6178 /* These two are always markers and can be marked fast. */
6179 XMARKER (ptr
->start
)->gcmarkbit
= 1;
6180 XMARKER (ptr
->end
)->gcmarkbit
= 1;
6181 mark_object (ptr
->plist
);
6185 /* Mark Lisp_Objects and special pointers in BUFFER. */
6188 mark_buffer (struct buffer
*buffer
)
6190 /* This is handled much like other pseudovectors... */
6191 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6193 /* ...but there are some buffer-specific things. */
6195 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6197 /* For now, we just don't mark the undo_list. It's done later in
6198 a special way just before the sweep phase, and after stripping
6199 some of its elements that are not needed any more. */
6201 mark_overlay (buffer
->overlays_before
);
6202 mark_overlay (buffer
->overlays_after
);
6204 /* If this is an indirect buffer, mark its base buffer. */
6205 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6206 mark_buffer (buffer
->base_buffer
);
6209 /* Mark Lisp faces in the face cache C. */
6211 NO_INLINE
/* To reduce stack depth in mark_object. */
6213 mark_face_cache (struct face_cache
*c
)
6218 for (i
= 0; i
< c
->used
; ++i
)
6220 struct face
*face
= FACE_FROM_ID_OR_NULL (c
->f
, i
);
6224 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6225 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6227 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6228 mark_object (face
->lface
[j
]);
6234 NO_INLINE
/* To reduce stack depth in mark_object. */
6236 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6238 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6239 Lisp_Object where
= blv
->where
;
6240 /* If the value is set up for a killed buffer restore its global binding. */
6241 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
))))
6242 swap_in_global_binding (ptr
);
6243 mark_object (blv
->where
);
6244 mark_object (blv
->valcell
);
6245 mark_object (blv
->defcell
);
6248 /* Remove killed buffers or items whose car is a killed buffer from
6249 LIST, and mark other items. Return changed LIST, which is marked. */
6252 mark_discard_killed_buffers (Lisp_Object list
)
6254 Lisp_Object tail
, *prev
= &list
;
6256 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6259 Lisp_Object tem
= XCAR (tail
);
6262 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6263 *prev
= XCDR (tail
);
6266 CONS_MARK (XCONS (tail
));
6267 mark_object (XCAR (tail
));
6268 prev
= xcdr_addr (tail
);
6275 /* Determine type of generic Lisp_Object and mark it accordingly.
6277 This function implements a straightforward depth-first marking
6278 algorithm and so the recursion depth may be very high (a few
6279 tens of thousands is not uncommon). To minimize stack usage,
6280 a few cold paths are moved out to NO_INLINE functions above.
6281 In general, inlining them doesn't help you to gain more speed. */
6284 mark_object (Lisp_Object arg
)
6286 register Lisp_Object obj
;
6288 #if GC_CHECK_MARKED_OBJECTS
6291 ptrdiff_t cdr_count
= 0;
6300 last_marked
[last_marked_index
++] = obj
;
6301 last_marked_index
&= LAST_MARKED_SIZE
- 1;
6303 /* Perform some sanity checks on the objects marked here. Abort if
6304 we encounter an object we know is bogus. This increases GC time
6306 #if GC_CHECK_MARKED_OBJECTS
6308 /* Check that the object pointed to by PO is known to be a Lisp
6309 structure allocated from the heap. */
6310 #define CHECK_ALLOCATED() \
6312 m = mem_find (po); \
6317 /* Check that the object pointed to by PO is live, using predicate
6319 #define CHECK_LIVE(LIVEP) \
6321 if (!LIVEP (m, po)) \
6325 /* Check both of the above conditions, for non-symbols. */
6326 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6328 CHECK_ALLOCATED (); \
6329 CHECK_LIVE (LIVEP); \
6332 /* Check both of the above conditions, for symbols. */
6333 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6335 if (!c_symbol_p (ptr)) \
6337 CHECK_ALLOCATED (); \
6338 CHECK_LIVE (live_symbol_p); \
6342 #else /* not GC_CHECK_MARKED_OBJECTS */
6344 #define CHECK_LIVE(LIVEP) ((void) 0)
6345 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6346 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6348 #endif /* not GC_CHECK_MARKED_OBJECTS */
6350 switch (XTYPE (obj
))
6354 register struct Lisp_String
*ptr
= XSTRING (obj
);
6355 if (STRING_MARKED_P (ptr
))
6357 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6359 MARK_INTERVAL_TREE (ptr
->u
.s
.intervals
);
6360 #ifdef GC_CHECK_STRING_BYTES
6361 /* Check that the string size recorded in the string is the
6362 same as the one recorded in the sdata structure. */
6364 #endif /* GC_CHECK_STRING_BYTES */
6368 case Lisp_Vectorlike
:
6370 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6372 if (VECTOR_MARKED_P (ptr
))
6375 #if GC_CHECK_MARKED_OBJECTS
6377 if (m
== MEM_NIL
&& !SUBRP (obj
) && !main_thread_p (po
))
6379 #endif /* GC_CHECK_MARKED_OBJECTS */
6381 enum pvec_type pvectype
6382 = PSEUDOVECTOR_TYPE (ptr
);
6384 if (pvectype
!= PVEC_SUBR
6385 && pvectype
!= PVEC_BUFFER
6386 && !main_thread_p (po
))
6387 CHECK_LIVE (live_vector_p
);
6392 #if GC_CHECK_MARKED_OBJECTS
6401 #endif /* GC_CHECK_MARKED_OBJECTS */
6402 mark_buffer ((struct buffer
*) ptr
);
6406 /* Although we could treat this just like a vector, mark_compiled
6407 returns the COMPILED_CONSTANTS element, which is marked at the
6408 next iteration of goto-loop here. This is done to avoid a few
6409 recursive calls to mark_object. */
6410 obj
= mark_compiled (ptr
);
6417 struct frame
*f
= (struct frame
*) ptr
;
6419 mark_vectorlike (ptr
);
6420 mark_face_cache (f
->face_cache
);
6421 #ifdef HAVE_WINDOW_SYSTEM
6422 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6424 struct font
*font
= FRAME_FONT (f
);
6426 if (font
&& !VECTOR_MARKED_P (font
))
6427 mark_vectorlike ((struct Lisp_Vector
*) font
);
6435 struct window
*w
= (struct window
*) ptr
;
6437 mark_vectorlike (ptr
);
6439 /* Mark glyph matrices, if any. Marking window
6440 matrices is sufficient because frame matrices
6441 use the same glyph memory. */
6442 if (w
->current_matrix
)
6444 mark_glyph_matrix (w
->current_matrix
);
6445 mark_glyph_matrix (w
->desired_matrix
);
6448 /* Filter out killed buffers from both buffer lists
6449 in attempt to help GC to reclaim killed buffers faster.
6450 We can do it elsewhere for live windows, but this is the
6451 best place to do it for dead windows. */
6453 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6455 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6459 case PVEC_HASH_TABLE
:
6461 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6463 mark_vectorlike (ptr
);
6464 mark_object (h
->test
.name
);
6465 mark_object (h
->test
.user_hash_function
);
6466 mark_object (h
->test
.user_cmp_function
);
6467 /* If hash table is not weak, mark all keys and values.
6468 For weak tables, mark only the vector. */
6470 mark_object (h
->key_and_value
);
6472 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6476 case PVEC_CHAR_TABLE
:
6477 case PVEC_SUB_CHAR_TABLE
:
6478 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6481 case PVEC_BOOL_VECTOR
:
6482 /* No Lisp_Objects to mark in a bool vector. */
6493 mark_vectorlike (ptr
);
6500 struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6502 if (ptr
->u
.s
.gcmarkbit
)
6504 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6505 ptr
->u
.s
.gcmarkbit
= 1;
6506 /* Attempt to catch bogus objects. */
6507 eassert (valid_lisp_object_p (ptr
->u
.s
.function
));
6508 mark_object (ptr
->u
.s
.function
);
6509 mark_object (ptr
->u
.s
.plist
);
6510 switch (ptr
->u
.s
.redirect
)
6512 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6513 case SYMBOL_VARALIAS
:
6516 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6520 case SYMBOL_LOCALIZED
:
6521 mark_localized_symbol (ptr
);
6523 case SYMBOL_FORWARDED
:
6524 /* If the value is forwarded to a buffer or keyboard field,
6525 these are marked when we see the corresponding object.
6526 And if it's forwarded to a C variable, either it's not
6527 a Lisp_Object var, or it's staticpro'd already. */
6529 default: emacs_abort ();
6531 if (!PURE_P (XSTRING (ptr
->u
.s
.name
)))
6532 MARK_STRING (XSTRING (ptr
->u
.s
.name
));
6533 MARK_INTERVAL_TREE (string_intervals (ptr
->u
.s
.name
));
6534 /* Inner loop to mark next symbol in this bucket, if any. */
6535 po
= ptr
= ptr
->u
.s
.next
;
6542 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6544 if (XMISCANY (obj
)->gcmarkbit
)
6547 switch (XMISCTYPE (obj
))
6549 case Lisp_Misc_Marker
:
6550 /* DO NOT mark thru the marker's chain.
6551 The buffer's markers chain does not preserve markers from gc;
6552 instead, markers are removed from the chain when freed by gc. */
6553 XMISCANY (obj
)->gcmarkbit
= 1;
6557 XMISCANY (obj
)->gcmarkbit
= true;
6560 case Lisp_Misc_Overlay
:
6561 mark_overlay (XOVERLAY (obj
));
6564 case Lisp_Misc_Finalizer
:
6565 XMISCANY (obj
)->gcmarkbit
= true;
6566 mark_object (XFINALIZER (obj
)->function
);
6570 case Lisp_Misc_User_Ptr
:
6571 XMISCANY (obj
)->gcmarkbit
= true;
6582 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6583 if (CONS_MARKED_P (ptr
))
6585 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6587 /* If the cdr is nil, avoid recursion for the car. */
6588 if (EQ (ptr
->u
.s
.u
.cdr
, Qnil
))
6594 mark_object (ptr
->u
.s
.car
);
6595 obj
= ptr
->u
.s
.u
.cdr
;
6597 if (cdr_count
== mark_object_loop_halt
)
6603 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6604 FLOAT_MARK (XFLOAT (obj
));
6615 #undef CHECK_ALLOCATED
6616 #undef CHECK_ALLOCATED_AND_LIVE
6618 /* Mark the Lisp pointers in the terminal objects.
6619 Called by Fgarbage_collect. */
6622 mark_terminals (void)
6625 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6627 eassert (t
->name
!= NULL
);
6628 #ifdef HAVE_WINDOW_SYSTEM
6629 /* If a terminal object is reachable from a stacpro'ed object,
6630 it might have been marked already. Make sure the image cache
6632 mark_image_cache (t
->image_cache
);
6633 #endif /* HAVE_WINDOW_SYSTEM */
6634 if (!VECTOR_MARKED_P (t
))
6635 mark_vectorlike ((struct Lisp_Vector
*)t
);
6641 /* Value is non-zero if OBJ will survive the current GC because it's
6642 either marked or does not need to be marked to survive. */
6645 survives_gc_p (Lisp_Object obj
)
6649 switch (XTYPE (obj
))
6656 survives_p
= XSYMBOL (obj
)->u
.s
.gcmarkbit
;
6660 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6664 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6667 case Lisp_Vectorlike
:
6668 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6672 survives_p
= CONS_MARKED_P (XCONS (obj
));
6676 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6683 return survives_p
|| PURE_P (XPNTR (obj
));
6689 NO_INLINE
/* For better stack traces */
6693 struct cons_block
*cblk
;
6694 struct cons_block
**cprev
= &cons_block
;
6695 int lim
= cons_block_index
;
6696 EMACS_INT num_free
= 0, num_used
= 0;
6700 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6704 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6706 /* Scan the mark bits an int at a time. */
6707 for (i
= 0; i
< ilim
; i
++)
6709 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6711 /* Fast path - all cons cells for this int are marked. */
6712 cblk
->gcmarkbits
[i
] = 0;
6713 num_used
+= BITS_PER_BITS_WORD
;
6717 /* Some cons cells for this int are not marked.
6718 Find which ones, and free them. */
6719 int start
, pos
, stop
;
6721 start
= i
* BITS_PER_BITS_WORD
;
6723 if (stop
> BITS_PER_BITS_WORD
)
6724 stop
= BITS_PER_BITS_WORD
;
6727 for (pos
= start
; pos
< stop
; pos
++)
6729 struct Lisp_Cons
*acons
6730 = ptr_bounds_copy (&cblk
->conses
[pos
], cblk
);
6731 if (!CONS_MARKED_P (acons
))
6734 cblk
->conses
[pos
].u
.s
.u
.chain
= cons_free_list
;
6735 cons_free_list
= &cblk
->conses
[pos
];
6736 cons_free_list
->u
.s
.car
= Vdead
;
6741 CONS_UNMARK (acons
);
6747 lim
= CONS_BLOCK_SIZE
;
6748 /* If this block contains only free conses and we have already
6749 seen more than two blocks worth of free conses then deallocate
6751 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6753 *cprev
= cblk
->next
;
6754 /* Unhook from the free list. */
6755 cons_free_list
= cblk
->conses
[0].u
.s
.u
.chain
;
6756 lisp_align_free (cblk
);
6760 num_free
+= this_free
;
6761 cprev
= &cblk
->next
;
6764 total_conses
= num_used
;
6765 total_free_conses
= num_free
;
6768 NO_INLINE
/* For better stack traces */
6772 register struct float_block
*fblk
;
6773 struct float_block
**fprev
= &float_block
;
6774 register int lim
= float_block_index
;
6775 EMACS_INT num_free
= 0, num_used
= 0;
6777 float_free_list
= 0;
6779 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6783 for (i
= 0; i
< lim
; i
++)
6785 struct Lisp_Float
*afloat
= ptr_bounds_copy (&fblk
->floats
[i
], fblk
);
6786 if (!FLOAT_MARKED_P (afloat
))
6789 fblk
->floats
[i
].u
.chain
= float_free_list
;
6790 float_free_list
= &fblk
->floats
[i
];
6795 FLOAT_UNMARK (afloat
);
6798 lim
= FLOAT_BLOCK_SIZE
;
6799 /* If this block contains only free floats and we have already
6800 seen more than two blocks worth of free floats then deallocate
6802 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6804 *fprev
= fblk
->next
;
6805 /* Unhook from the free list. */
6806 float_free_list
= fblk
->floats
[0].u
.chain
;
6807 lisp_align_free (fblk
);
6811 num_free
+= this_free
;
6812 fprev
= &fblk
->next
;
6815 total_floats
= num_used
;
6816 total_free_floats
= num_free
;
6819 NO_INLINE
/* For better stack traces */
6821 sweep_intervals (void)
6823 register struct interval_block
*iblk
;
6824 struct interval_block
**iprev
= &interval_block
;
6825 register int lim
= interval_block_index
;
6826 EMACS_INT num_free
= 0, num_used
= 0;
6828 interval_free_list
= 0;
6830 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6835 for (i
= 0; i
< lim
; i
++)
6837 if (!iblk
->intervals
[i
].gcmarkbit
)
6839 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6840 interval_free_list
= &iblk
->intervals
[i
];
6846 iblk
->intervals
[i
].gcmarkbit
= 0;
6849 lim
= INTERVAL_BLOCK_SIZE
;
6850 /* If this block contains only free intervals and we have already
6851 seen more than two blocks worth of free intervals then
6852 deallocate this block. */
6853 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6855 *iprev
= iblk
->next
;
6856 /* Unhook from the free list. */
6857 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6862 num_free
+= this_free
;
6863 iprev
= &iblk
->next
;
6866 total_intervals
= num_used
;
6867 total_free_intervals
= num_free
;
6870 NO_INLINE
/* For better stack traces */
6872 sweep_symbols (void)
6874 struct symbol_block
*sblk
;
6875 struct symbol_block
**sprev
= &symbol_block
;
6876 int lim
= symbol_block_index
;
6877 EMACS_INT num_free
= 0, num_used
= ARRAYELTS (lispsym
);
6879 symbol_free_list
= NULL
;
6881 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
6882 lispsym
[i
].u
.s
.gcmarkbit
= 0;
6884 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6887 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6888 struct Lisp_Symbol
*end
= sym
+ lim
;
6890 for (; sym
< end
; ++sym
)
6892 if (!sym
->u
.s
.gcmarkbit
)
6894 if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
)
6896 xfree (SYMBOL_BLV (sym
));
6897 /* At every GC we sweep all symbol_blocks and rebuild the
6898 symbol_free_list, so those symbols which stayed unused
6899 between the two will be re-swept.
6900 So we have to make sure we don't re-free this blv next
6901 time we sweep this symbol_block (bug#29066). */
6902 sym
->u
.s
.redirect
= SYMBOL_PLAINVAL
;
6904 sym
->u
.s
.next
= symbol_free_list
;
6905 symbol_free_list
= sym
;
6906 symbol_free_list
->u
.s
.function
= Vdead
;
6912 sym
->u
.s
.gcmarkbit
= 0;
6913 /* Attempt to catch bogus objects. */
6914 eassert (valid_lisp_object_p (sym
->u
.s
.function
));
6918 lim
= SYMBOL_BLOCK_SIZE
;
6919 /* If this block contains only free symbols and we have already
6920 seen more than two blocks worth of free symbols then deallocate
6922 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6924 *sprev
= sblk
->next
;
6925 /* Unhook from the free list. */
6926 symbol_free_list
= sblk
->symbols
[0].u
.s
.next
;
6931 num_free
+= this_free
;
6932 sprev
= &sblk
->next
;
6935 total_symbols
= num_used
;
6936 total_free_symbols
= num_free
;
6939 NO_INLINE
/* For better stack traces. */
6943 register struct marker_block
*mblk
;
6944 struct marker_block
**mprev
= &marker_block
;
6945 register int lim
= marker_block_index
;
6946 EMACS_INT num_free
= 0, num_used
= 0;
6948 /* Put all unmarked misc's on free list. For a marker, first
6949 unchain it from the buffer it points into. */
6953 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6958 for (i
= 0; i
< lim
; i
++)
6960 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6962 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6963 /* Make sure markers have been unchained from their buffer
6964 in sweep_buffer before we collect them. */
6965 eassert (!mblk
->markers
[i
].m
.u_marker
.buffer
);
6966 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Finalizer
)
6967 unchain_finalizer (&mblk
->markers
[i
].m
.u_finalizer
);
6969 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_User_Ptr
)
6971 struct Lisp_User_Ptr
*uptr
= &mblk
->markers
[i
].m
.u_user_ptr
;
6972 if (uptr
->finalizer
)
6973 uptr
->finalizer (uptr
->p
);
6976 /* Set the type of the freed object to Lisp_Misc_Free.
6977 We could leave the type alone, since nobody checks it,
6978 but this might catch bugs faster. */
6979 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6980 mblk
->markers
[i
].m
.u_free
.chain
= misc_free_list
;
6981 misc_free_list
= &mblk
->markers
[i
].m
;
6987 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6990 lim
= MARKER_BLOCK_SIZE
;
6991 /* If this block contains only free markers and we have already
6992 seen more than two blocks worth of free markers then deallocate
6994 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6996 *mprev
= mblk
->next
;
6997 /* Unhook from the free list. */
6998 misc_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
7003 num_free
+= this_free
;
7004 mprev
= &mblk
->next
;
7008 total_markers
= num_used
;
7009 total_free_markers
= num_free
;
7012 /* Remove BUFFER's markers that are due to be swept. This is needed since
7013 we treat BUF_MARKERS and markers's `next' field as weak pointers. */
7015 unchain_dead_markers (struct buffer
*buffer
)
7017 struct Lisp_Marker
*this, **prev
= &BUF_MARKERS (buffer
);
7019 while ((this = *prev
))
7020 if (this->gcmarkbit
)
7024 this->buffer
= NULL
;
7029 NO_INLINE
/* For better stack traces */
7031 sweep_buffers (void)
7033 register struct buffer
*buffer
, **bprev
= &all_buffers
;
7036 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
7037 if (!VECTOR_MARKED_P (buffer
))
7039 *bprev
= buffer
->next
;
7044 VECTOR_UNMARK (buffer
);
7045 /* Do not use buffer_(set|get)_intervals here. */
7046 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
7047 unchain_dead_markers (buffer
);
7049 bprev
= &buffer
->next
;
7053 /* Sweep: find all structures not marked, and free them. */
7057 /* Remove or mark entries in weak hash tables.
7058 This must be done before any object is unmarked. */
7059 sweep_weak_hash_tables ();
7062 check_string_bytes (!noninteractive
);
7070 check_string_bytes (!noninteractive
);
7073 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
7074 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
7075 All values are in Kbytes. If there is no swap space,
7076 last two values are zero. If the system is not supported
7077 or memory information can't be obtained, return nil. */)
7080 #if defined HAVE_LINUX_SYSINFO
7086 #ifdef LINUX_SYSINFO_UNIT
7087 units
= si
.mem_unit
;
7091 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
7092 (uintmax_t) si
.freeram
* units
/ 1024,
7093 (uintmax_t) si
.totalswap
* units
/ 1024,
7094 (uintmax_t) si
.freeswap
* units
/ 1024);
7095 #elif defined WINDOWSNT
7096 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
7098 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7099 return list4i ((uintmax_t) totalram
/ 1024,
7100 (uintmax_t) freeram
/ 1024,
7101 (uintmax_t) totalswap
/ 1024,
7102 (uintmax_t) freeswap
/ 1024);
7106 unsigned long totalram
, freeram
, totalswap
, freeswap
;
7108 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7109 return list4i ((uintmax_t) totalram
/ 1024,
7110 (uintmax_t) freeram
/ 1024,
7111 (uintmax_t) totalswap
/ 1024,
7112 (uintmax_t) freeswap
/ 1024);
7115 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7116 /* FIXME: add more systems. */
7118 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7121 /* Debugging aids. */
7123 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
7124 doc
: /* Return a list of counters that measure how much consing there has been.
7125 Each of these counters increments for a certain kind of object.
7126 The counters wrap around from the largest positive integer to zero.
7127 Garbage collection does not decrease them.
7128 The elements of the value are as follows:
7129 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
7130 All are in units of 1 = one object consed
7131 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
7133 MISCS include overlays, markers, and some internal types.
7134 Frames, windows, buffers, and subprocesses count as vectors
7135 (but the contents of a buffer's text do not count here). */)
7138 return listn (CONSTYPE_HEAP
, 8,
7139 bounded_number (cons_cells_consed
),
7140 bounded_number (floats_consed
),
7141 bounded_number (vector_cells_consed
),
7142 bounded_number (symbols_consed
),
7143 bounded_number (string_chars_consed
),
7144 bounded_number (misc_objects_consed
),
7145 bounded_number (intervals_consed
),
7146 bounded_number (strings_consed
));
7150 symbol_uses_obj (Lisp_Object symbol
, Lisp_Object obj
)
7152 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
7153 Lisp_Object val
= find_symbol_value (symbol
);
7154 return (EQ (val
, obj
)
7155 || EQ (sym
->u
.s
.function
, obj
)
7156 || (!NILP (sym
->u
.s
.function
)
7157 && COMPILEDP (sym
->u
.s
.function
)
7158 && EQ (AREF (sym
->u
.s
.function
, COMPILED_BYTECODE
), obj
))
7161 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)));
7164 /* Find at most FIND_MAX symbols which have OBJ as their value or
7165 function. This is used in gdbinit's `xwhichsymbols' command. */
7168 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
7170 struct symbol_block
*sblk
;
7171 ptrdiff_t gc_count
= inhibit_garbage_collection ();
7172 Lisp_Object found
= Qnil
;
7176 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
7178 Lisp_Object sym
= builtin_lisp_symbol (i
);
7179 if (symbol_uses_obj (sym
, obj
))
7181 found
= Fcons (sym
, found
);
7182 if (--find_max
== 0)
7187 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7189 struct Lisp_Symbol
*asym
= sblk
->symbols
;
7192 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, asym
++)
7194 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7197 Lisp_Object sym
= make_lisp_symbol (asym
);
7198 if (symbol_uses_obj (sym
, obj
))
7200 found
= Fcons (sym
, found
);
7201 if (--find_max
== 0)
7209 unbind_to (gc_count
, Qnil
);
7213 #ifdef SUSPICIOUS_OBJECT_CHECKING
7216 find_suspicious_object_in_range (void *begin
, void *end
)
7218 char *begin_a
= begin
;
7222 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7224 char *suspicious_object
= suspicious_objects
[i
];
7225 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7226 return suspicious_object
;
7233 note_suspicious_free (void *ptr
)
7235 struct suspicious_free_record
*rec
;
7237 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7238 if (suspicious_free_history_index
==
7239 ARRAYELTS (suspicious_free_history
))
7241 suspicious_free_history_index
= 0;
7244 memset (rec
, 0, sizeof (*rec
));
7245 rec
->suspicious_object
= ptr
;
7246 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7250 detect_suspicious_free (void *ptr
)
7254 eassert (ptr
!= NULL
);
7256 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7257 if (suspicious_objects
[i
] == ptr
)
7259 note_suspicious_free (ptr
);
7260 suspicious_objects
[i
] = NULL
;
7264 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7266 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7267 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7268 If Emacs is compiled with suspicious object checking, capture
7269 a stack trace when OBJ is freed in order to help track down
7270 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7273 #ifdef SUSPICIOUS_OBJECT_CHECKING
7274 /* Right now, we care only about vectors. */
7275 if (VECTORLIKEP (obj
))
7277 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7278 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7279 suspicious_object_index
= 0;
7285 #ifdef ENABLE_CHECKING
7287 bool suppress_checking
;
7290 die (const char *msg
, const char *file
, int line
)
7292 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7294 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7297 #endif /* ENABLE_CHECKING */
7299 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7301 /* Stress alloca with inconveniently sized requests and check
7302 whether all allocated areas may be used for Lisp_Object. */
7304 NO_INLINE
static void
7305 verify_alloca (void)
7308 enum { ALLOCA_CHECK_MAX
= 256 };
7309 /* Start from size of the smallest Lisp object. */
7310 for (i
= sizeof (struct Lisp_Cons
); i
<= ALLOCA_CHECK_MAX
; i
++)
7312 void *ptr
= alloca (i
);
7313 make_lisp_ptr (ptr
, Lisp_Cons
);
7317 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7319 #define verify_alloca() ((void) 0)
7321 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7323 /* Initialization. */
7326 init_alloc_once (void)
7328 /* Even though Qt's contents are not set up, its address is known. */
7332 pure_size
= PURESIZE
;
7335 init_finalizer_list (&finalizers
);
7336 init_finalizer_list (&doomed_finalizers
);
7339 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7341 #ifdef DOUG_LEA_MALLOC
7342 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7343 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7344 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7349 refill_memory_reserve ();
7350 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7356 Vgc_elapsed
= make_float (0.0);
7360 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7365 syms_of_alloc (void)
7367 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7368 doc
: /* Number of bytes of consing between garbage collections.
7369 Garbage collection can happen automatically once this many bytes have been
7370 allocated since the last garbage collection. All data types count.
7372 Garbage collection happens automatically only when `eval' is called.
7374 By binding this temporarily to a large number, you can effectively
7375 prevent garbage collection during a part of the program.
7376 See also `gc-cons-percentage'. */);
7378 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7379 doc
: /* Portion of the heap used for allocation.
7380 Garbage collection can happen automatically once this portion of the heap
7381 has been allocated since the last garbage collection.
7382 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7383 Vgc_cons_percentage
= make_float (0.1);
7385 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7386 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7388 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7389 doc
: /* Number of cons cells that have been consed so far. */);
7391 DEFVAR_INT ("floats-consed", floats_consed
,
7392 doc
: /* Number of floats that have been consed so far. */);
7394 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7395 doc
: /* Number of vector cells that have been consed so far. */);
7397 DEFVAR_INT ("symbols-consed", symbols_consed
,
7398 doc
: /* Number of symbols that have been consed so far. */);
7399 symbols_consed
+= ARRAYELTS (lispsym
);
7401 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7402 doc
: /* Number of string characters that have been consed so far. */);
7404 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7405 doc
: /* Number of miscellaneous objects that have been consed so far.
7406 These include markers and overlays, plus certain objects not visible
7409 DEFVAR_INT ("intervals-consed", intervals_consed
,
7410 doc
: /* Number of intervals that have been consed so far. */);
7412 DEFVAR_INT ("strings-consed", strings_consed
,
7413 doc
: /* Number of strings that have been consed so far. */);
7415 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7416 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7417 This means that certain objects should be allocated in shared (pure) space.
7418 It can also be set to a hash-table, in which case this table is used to
7419 do hash-consing of the objects allocated to pure space. */);
7421 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7422 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7423 garbage_collection_messages
= 0;
7425 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7426 doc
: /* Hook run after garbage collection has finished. */);
7427 Vpost_gc_hook
= Qnil
;
7428 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7430 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7431 doc
: /* Precomputed `signal' argument for memory-full error. */);
7432 /* We build this in advance because if we wait until we need it, we might
7433 not be able to allocate the memory to hold it. */
7435 = listn (CONSTYPE_PURE
, 2, Qerror
,
7436 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7438 DEFVAR_LISP ("memory-full", Vmemory_full
,
7439 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7440 Vmemory_full
= Qnil
;
7442 DEFSYM (Qconses
, "conses");
7443 DEFSYM (Qsymbols
, "symbols");
7444 DEFSYM (Qmiscs
, "miscs");
7445 DEFSYM (Qstrings
, "strings");
7446 DEFSYM (Qvectors
, "vectors");
7447 DEFSYM (Qfloats
, "floats");
7448 DEFSYM (Qintervals
, "intervals");
7449 DEFSYM (Qbuffers
, "buffers");
7450 DEFSYM (Qstring_bytes
, "string-bytes");
7451 DEFSYM (Qvector_slots
, "vector-slots");
7452 DEFSYM (Qheap
, "heap");
7453 DEFSYM (QAutomatic_GC
, "Automatic GC");
7455 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7456 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7458 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7459 doc
: /* Accumulated time elapsed in garbage collections.
7460 The time is in seconds as a floating point value. */);
7461 DEFVAR_INT ("gcs-done", gcs_done
,
7462 doc
: /* Accumulated number of garbage collections done. */);
7468 defsubr (&Sbool_vector
);
7469 defsubr (&Smake_byte_code
);
7470 defsubr (&Smake_list
);
7471 defsubr (&Smake_vector
);
7472 defsubr (&Smake_record
);
7473 defsubr (&Smake_string
);
7474 defsubr (&Smake_bool_vector
);
7475 defsubr (&Smake_symbol
);
7476 defsubr (&Smake_marker
);
7477 defsubr (&Smake_finalizer
);
7478 defsubr (&Spurecopy
);
7479 defsubr (&Sgarbage_collect
);
7480 defsubr (&Smemory_info
);
7481 defsubr (&Smemory_use_counts
);
7482 defsubr (&Ssuspicious_object
);
7485 /* When compiled with GCC, GDB might say "No enum type named
7486 pvec_type" if we don't have at least one symbol with that type, and
7487 then xbacktrace could fail. Similarly for the other enums and
7488 their values. Some non-GCC compilers don't like these constructs. */
7492 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7493 enum char_table_specials char_table_specials
;
7494 enum char_bits char_bits
;
7495 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7496 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7497 enum Lisp_Bits Lisp_Bits
;
7498 enum Lisp_Compiled Lisp_Compiled
;
7499 enum maxargs maxargs
;
7500 enum MAX_ALLOCA MAX_ALLOCA
;
7501 enum More_Lisp_Bits More_Lisp_Bits
;
7502 enum pvec_type pvec_type
;
7503 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7504 #endif /* __GNUC__ */