1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (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 <http://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"
39 #include "character.h"
44 #include "blockinput.h"
45 #include "termhooks.h" /* For struct terminal. */
46 #ifdef HAVE_WINDOW_SYSTEM
48 #endif /* HAVE_WINDOW_SYSTEM */
50 #include <flexmember.h>
52 #include <execinfo.h> /* For backtrace. */
54 #ifdef HAVE_LINUX_SYSINFO
55 #include <sys/sysinfo.h>
59 #include "dosfns.h" /* For dos_memory_info. */
66 #if (defined ENABLE_CHECKING \
67 && defined HAVE_VALGRIND_VALGRIND_H \
68 && !defined USE_VALGRIND)
69 # define USE_VALGRIND 1
73 #include <valgrind/valgrind.h>
74 #include <valgrind/memcheck.h>
75 static bool valgrind_p
;
78 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */
80 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
81 memory. Can do this only if using gmalloc.c and if not checking
84 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
85 || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
86 #undef GC_MALLOC_CHECK
97 #include "w32heap.h" /* for sbrk */
100 #if defined DOUG_LEA_MALLOC || defined GNU_LINUX
101 /* The address where the heap starts. */
112 #ifdef DOUG_LEA_MALLOC
114 /* Specify maximum number of areas to mmap. It would be nice to use a
115 value that explicitly means "no limit". */
117 #define MMAP_MAX_AREAS 100000000
119 /* A pointer to the memory allocated that copies that static data
120 inside glibc's malloc. */
121 static void *malloc_state_ptr
;
123 /* Restore the dumped malloc state. Because malloc can be invoked
124 even before main (e.g. by the dynamic linker), the dumped malloc
125 state must be restored as early as possible using this special hook. */
127 malloc_initialize_hook (void)
129 static bool malloc_using_checking
;
134 malloc_using_checking
= getenv ("MALLOC_CHECK_") != NULL
;
138 if (!malloc_using_checking
)
140 /* Work around a bug in glibc's malloc. MALLOC_CHECK_ must be
141 ignored if the heap to be restored was constructed without
142 malloc checking. Can't use unsetenv, since that calls malloc. */
146 if (strncmp (*p
, "MALLOC_CHECK_=", 14) == 0)
156 if (malloc_set_state (malloc_state_ptr
) != 0)
158 # ifndef XMALLOC_OVERRUN_CHECK
159 alloc_unexec_post ();
164 /* Declare the malloc initialization hook, which runs before 'main' starts.
165 EXTERNALLY_VISIBLE works around Bug#22522. */
166 # ifndef __MALLOC_HOOK_VOLATILE
167 # define __MALLOC_HOOK_VOLATILE
169 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
170 = malloc_initialize_hook
;
174 /* Allocator-related actions to do just before and after unexec. */
177 alloc_unexec_pre (void)
179 #ifdef DOUG_LEA_MALLOC
180 malloc_state_ptr
= malloc_get_state ();
181 if (!malloc_state_ptr
)
182 fatal ("malloc_get_state: %s", strerror (errno
));
185 bss_sbrk_did_unexec
= true;
190 alloc_unexec_post (void)
192 #ifdef DOUG_LEA_MALLOC
193 free (malloc_state_ptr
);
196 bss_sbrk_did_unexec
= false;
200 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
201 to a struct Lisp_String. */
203 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
204 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
205 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
207 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
208 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
209 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
211 /* Default value of gc_cons_threshold (see below). */
213 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
215 /* Global variables. */
216 struct emacs_globals globals
;
218 /* Number of bytes of consing done since the last gc. */
220 EMACS_INT consing_since_gc
;
222 /* Similar minimum, computed from Vgc_cons_percentage. */
224 EMACS_INT gc_relative_threshold
;
226 /* Minimum number of bytes of consing since GC before next GC,
227 when memory is full. */
229 EMACS_INT memory_full_cons_threshold
;
231 /* True during GC. */
235 /* Number of live and free conses etc. */
237 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
238 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
239 static EMACS_INT total_free_floats
, total_floats
;
241 /* Points to memory space allocated as "spare", to be freed if we run
242 out of memory. We keep one large block, four cons-blocks, and
243 two string blocks. */
245 static char *spare_memory
[7];
247 /* Amount of spare memory to keep in large reserve block, or to see
248 whether this much is available when malloc fails on a larger request. */
250 #define SPARE_MEMORY (1 << 14)
252 /* Initialize it to a nonzero value to force it into data space
253 (rather than bss space). That way unexec will remap it into text
254 space (pure), on some systems. We have not implemented the
255 remapping on more recent systems because this is less important
256 nowadays than in the days of small memories and timesharing. */
258 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
259 #define PUREBEG (char *) pure
261 /* Pointer to the pure area, and its size. */
263 static char *purebeg
;
264 static ptrdiff_t pure_size
;
266 /* Number of bytes of pure storage used before pure storage overflowed.
267 If this is non-zero, this implies that an overflow occurred. */
269 static ptrdiff_t pure_bytes_used_before_overflow
;
271 /* Index in pure at which next pure Lisp object will be allocated.. */
273 static ptrdiff_t pure_bytes_used_lisp
;
275 /* Number of bytes allocated for non-Lisp objects in pure storage. */
277 static ptrdiff_t pure_bytes_used_non_lisp
;
279 /* If nonzero, this is a warning delivered by malloc and not yet
282 const char *pending_malloc_warning
;
284 #if 0 /* Normally, pointer sanity only on request... */
285 #ifdef ENABLE_CHECKING
286 #define SUSPICIOUS_OBJECT_CHECKING 1
290 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
291 bug is unresolved. */
292 #define SUSPICIOUS_OBJECT_CHECKING 1
294 #ifdef SUSPICIOUS_OBJECT_CHECKING
295 struct suspicious_free_record
297 void *suspicious_object
;
298 void *backtrace
[128];
300 static void *suspicious_objects
[32];
301 static int suspicious_object_index
;
302 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
303 static int suspicious_free_history_index
;
304 /* Find the first currently-monitored suspicious pointer in range
305 [begin,end) or NULL if no such pointer exists. */
306 static void *find_suspicious_object_in_range (void *begin
, void *end
);
307 static void detect_suspicious_free (void *ptr
);
309 # define find_suspicious_object_in_range(begin, end) NULL
310 # define detect_suspicious_free(ptr) (void)
313 /* Maximum amount of C stack to save when a GC happens. */
315 #ifndef MAX_SAVE_STACK
316 #define MAX_SAVE_STACK 16000
319 /* Buffer in which we save a copy of the C stack at each GC. */
321 #if MAX_SAVE_STACK > 0
322 static char *stack_copy
;
323 static ptrdiff_t stack_copy_size
;
325 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
326 avoiding any address sanitization. */
328 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
329 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
331 if (! ADDRESS_SANITIZER
)
332 return memcpy (dest
, src
, size
);
338 for (i
= 0; i
< size
; i
++)
344 #endif /* MAX_SAVE_STACK > 0 */
346 static void mark_terminals (void);
347 static void gc_sweep (void);
348 static Lisp_Object
make_pure_vector (ptrdiff_t);
349 static void mark_buffer (struct buffer
*);
351 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
352 static void refill_memory_reserve (void);
354 static void compact_small_strings (void);
355 static void free_large_strings (void);
356 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
358 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
359 what memory allocated via lisp_malloc and lisp_align_malloc is intended
360 for what purpose. This enumeration specifies the type of memory. */
371 /* Since all non-bool pseudovectors are small enough to be
372 allocated from vector blocks, this memory type denotes
373 large regular vectors and large bool pseudovectors. */
375 /* Special type to denote vector blocks. */
376 MEM_TYPE_VECTOR_BLOCK
,
377 /* Special type to denote reserved memory. */
381 /* A unique object in pure space used to make some Lisp objects
382 on free lists recognizable in O(1). */
384 static Lisp_Object Vdead
;
385 #define DEADP(x) EQ (x, Vdead)
387 #ifdef GC_MALLOC_CHECK
389 enum mem_type allocated_mem_type
;
391 #endif /* GC_MALLOC_CHECK */
393 /* A node in the red-black tree describing allocated memory containing
394 Lisp data. Each such block is recorded with its start and end
395 address when it is allocated, and removed from the tree when it
398 A red-black tree is a balanced binary tree with the following
401 1. Every node is either red or black.
402 2. Every leaf is black.
403 3. If a node is red, then both of its children are black.
404 4. Every simple path from a node to a descendant leaf contains
405 the same number of black nodes.
406 5. The root is always black.
408 When nodes are inserted into the tree, or deleted from the tree,
409 the tree is "fixed" so that these properties are always true.
411 A red-black tree with N internal nodes has height at most 2
412 log(N+1). Searches, insertions and deletions are done in O(log N).
413 Please see a text book about data structures for a detailed
414 description of red-black trees. Any book worth its salt should
419 /* Children of this node. These pointers are never NULL. When there
420 is no child, the value is MEM_NIL, which points to a dummy node. */
421 struct mem_node
*left
, *right
;
423 /* The parent of this node. In the root node, this is NULL. */
424 struct mem_node
*parent
;
426 /* Start and end of allocated region. */
430 enum {MEM_BLACK
, MEM_RED
} color
;
436 /* Base address of stack. Set in main. */
438 Lisp_Object
*stack_base
;
440 /* Root of the tree describing allocated Lisp memory. */
442 static struct mem_node
*mem_root
;
444 /* Lowest and highest known address in the heap. */
446 static void *min_heap_address
, *max_heap_address
;
448 /* Sentinel node of the tree. */
450 static struct mem_node mem_z
;
451 #define MEM_NIL &mem_z
453 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
454 static void mem_insert_fixup (struct mem_node
*);
455 static void mem_rotate_left (struct mem_node
*);
456 static void mem_rotate_right (struct mem_node
*);
457 static void mem_delete (struct mem_node
*);
458 static void mem_delete_fixup (struct mem_node
*);
459 static struct mem_node
*mem_find (void *);
465 /* Addresses of staticpro'd variables. Initialize it to a nonzero
466 value; otherwise some compilers put it into BSS. */
468 enum { NSTATICS
= 2048 };
469 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
471 /* Index of next unused slot in staticvec. */
473 static int staticidx
;
475 static void *pure_alloc (size_t, int);
477 /* True if N is a power of 2. N should be positive. */
479 #define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
481 /* Return X rounded to the next multiple of Y. Y should be positive,
482 and Y - 1 + X should not overflow. Arguments should not have side
483 effects, as they are evaluated more than once. Tune for Y being a
486 #define ROUNDUP(x, y) (POWER_OF_2 (y) \
487 ? ((y) - 1 + (x)) & ~ ((y) - 1) \
488 : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
490 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
493 pointer_align (void *ptr
, int alignment
)
495 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
498 /* Extract the pointer hidden within A, if A is not a symbol.
499 If A is a symbol, extract the hidden pointer's offset from lispsym,
500 converted to void *. */
502 #define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
503 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
505 /* Extract the pointer hidden within A. */
507 #define macro_XPNTR(a) \
508 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
509 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
511 /* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
512 functions, as functions are cleaner and can be used in debuggers.
513 Also, define them as macros if being compiled with GCC without
514 optimization, for performance in that case. The macro_* names are
515 private to this section of code. */
517 static ATTRIBUTE_UNUSED
void *
518 XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a
)
520 return macro_XPNTR_OR_SYMBOL_OFFSET (a
);
522 static ATTRIBUTE_UNUSED
void *
523 XPNTR (Lisp_Object a
)
525 return macro_XPNTR (a
);
528 #if DEFINE_KEY_OPS_AS_MACROS
529 # define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
530 # define XPNTR(a) macro_XPNTR (a)
534 XFLOAT_INIT (Lisp_Object f
, double n
)
536 XFLOAT (f
)->u
.data
= n
;
539 #ifdef DOUG_LEA_MALLOC
541 pointers_fit_in_lispobj_p (void)
543 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
547 mmap_lisp_allowed_p (void)
549 /* If we can't store all memory addresses in our lisp objects, it's
550 risky to let the heap use mmap and give us addresses from all
551 over our address space. We also can't use mmap for lisp objects
552 if we might dump: unexec doesn't preserve the contents of mmapped
554 return pointers_fit_in_lispobj_p () && !might_dump
;
558 /* Head of a circularly-linked list of extant finalizers. */
559 static struct Lisp_Finalizer finalizers
;
561 /* Head of a circularly-linked list of finalizers that must be invoked
562 because we deemed them unreachable. This list must be global, and
563 not a local inside garbage_collect_1, in case we GC again while
564 running finalizers. */
565 static struct Lisp_Finalizer doomed_finalizers
;
568 /************************************************************************
570 ************************************************************************/
572 #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
574 /* Function malloc calls this if it finds we are near exhausting storage. */
577 malloc_warning (const char *str
)
579 pending_malloc_warning
= str
;
584 /* Display an already-pending malloc warning. */
587 display_malloc_warning (void)
589 call3 (intern ("display-warning"),
591 build_string (pending_malloc_warning
),
592 intern ("emergency"));
593 pending_malloc_warning
= 0;
596 /* Called if we can't allocate relocatable space for a buffer. */
599 buffer_memory_full (ptrdiff_t nbytes
)
601 /* If buffers use the relocating allocator, no need to free
602 spare_memory, because we may have plenty of malloc space left
603 that we could get, and if we don't, the malloc that fails will
604 itself cause spare_memory to be freed. If buffers don't use the
605 relocating allocator, treat this like any other failing
609 memory_full (nbytes
);
611 /* This used to call error, but if we've run out of memory, we could
612 get infinite recursion trying to build the string. */
613 xsignal (Qnil
, Vmemory_signal_data
);
617 /* A common multiple of the positive integers A and B. Ideally this
618 would be the least common multiple, but there's no way to do that
619 as a constant expression in C, so do the best that we can easily do. */
620 #define COMMON_MULTIPLE(a, b) \
621 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
623 #ifndef XMALLOC_OVERRUN_CHECK
624 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
627 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
630 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
631 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
632 block size in little-endian order. The trailer consists of
633 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
635 The header is used to detect whether this block has been allocated
636 through these functions, as some low-level libc functions may
637 bypass the malloc hooks. */
639 #define XMALLOC_OVERRUN_CHECK_SIZE 16
640 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
641 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
643 #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
645 #define XMALLOC_HEADER_ALIGNMENT \
646 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
648 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
649 hold a size_t value and (2) the header size is a multiple of the
650 alignment that Emacs needs for C types and for USE_LSB_TAG. */
651 #define XMALLOC_OVERRUN_SIZE_SIZE \
652 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
653 + XMALLOC_HEADER_ALIGNMENT - 1) \
654 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
655 - XMALLOC_OVERRUN_CHECK_SIZE)
657 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
658 { '\x9a', '\x9b', '\xae', '\xaf',
659 '\xbf', '\xbe', '\xce', '\xcf',
660 '\xea', '\xeb', '\xec', '\xed',
661 '\xdf', '\xde', '\x9c', '\x9d' };
663 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
664 { '\xaa', '\xab', '\xac', '\xad',
665 '\xba', '\xbb', '\xbc', '\xbd',
666 '\xca', '\xcb', '\xcc', '\xcd',
667 '\xda', '\xdb', '\xdc', '\xdd' };
669 /* Insert and extract the block size in the header. */
672 xmalloc_put_size (unsigned char *ptr
, size_t size
)
675 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
677 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
683 xmalloc_get_size (unsigned char *ptr
)
687 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
688 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
697 /* Like malloc, but wraps allocated block with header and trailer. */
700 overrun_check_malloc (size_t size
)
702 register unsigned char *val
;
703 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
706 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
709 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
710 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
711 xmalloc_put_size (val
, size
);
712 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
713 XMALLOC_OVERRUN_CHECK_SIZE
);
719 /* Like realloc, but checks old block for overrun, and wraps new block
720 with header and trailer. */
723 overrun_check_realloc (void *block
, size_t size
)
725 register unsigned char *val
= (unsigned char *) block
;
726 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
730 && memcmp (xmalloc_overrun_check_header
,
731 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
732 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
734 size_t osize
= xmalloc_get_size (val
);
735 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
736 XMALLOC_OVERRUN_CHECK_SIZE
))
738 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
739 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
740 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
743 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
747 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
748 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
749 xmalloc_put_size (val
, size
);
750 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
751 XMALLOC_OVERRUN_CHECK_SIZE
);
756 /* Like free, but checks block for overrun. */
759 overrun_check_free (void *block
)
761 unsigned char *val
= (unsigned char *) block
;
764 && memcmp (xmalloc_overrun_check_header
,
765 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
766 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
768 size_t osize
= xmalloc_get_size (val
);
769 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
770 XMALLOC_OVERRUN_CHECK_SIZE
))
772 #ifdef XMALLOC_CLEAR_FREE_MEMORY
773 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
774 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
776 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
777 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
778 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
788 #define malloc overrun_check_malloc
789 #define realloc overrun_check_realloc
790 #define free overrun_check_free
793 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
794 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
795 If that variable is set, block input while in one of Emacs's memory
796 allocation functions. There should be no need for this debugging
797 option, since signal handlers do not allocate memory, but Emacs
798 formerly allocated memory in signal handlers and this compile-time
799 option remains as a way to help debug the issue should it rear its
801 #ifdef XMALLOC_BLOCK_INPUT_CHECK
802 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
804 malloc_block_input (void)
806 if (block_input_in_memory_allocators
)
810 malloc_unblock_input (void)
812 if (block_input_in_memory_allocators
)
815 # define MALLOC_BLOCK_INPUT malloc_block_input ()
816 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
818 # define MALLOC_BLOCK_INPUT ((void) 0)
819 # define MALLOC_UNBLOCK_INPUT ((void) 0)
822 #define MALLOC_PROBE(size) \
824 if (profiler_memory_running) \
825 malloc_probe (size); \
828 static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
829 static void *lrealloc (void *, size_t);
831 /* Like malloc but check for no memory and block interrupt input. */
834 xmalloc (size_t size
)
839 val
= lmalloc (size
);
840 MALLOC_UNBLOCK_INPUT
;
848 /* Like the above, but zeroes out the memory just allocated. */
851 xzalloc (size_t size
)
856 val
= lmalloc (size
);
857 MALLOC_UNBLOCK_INPUT
;
861 memset (val
, 0, size
);
866 /* Like realloc but check for no memory and block interrupt input.. */
869 xrealloc (void *block
, size_t size
)
874 /* We must call malloc explicitly when BLOCK is 0, since some
875 reallocs don't do this. */
877 val
= lmalloc (size
);
879 val
= lrealloc (block
, size
);
880 MALLOC_UNBLOCK_INPUT
;
889 /* Like free but block interrupt input. */
898 MALLOC_UNBLOCK_INPUT
;
899 /* We don't call refill_memory_reserve here
900 because in practice the call in r_alloc_free seems to suffice. */
904 /* Other parts of Emacs pass large int values to allocator functions
905 expecting ptrdiff_t. This is portable in practice, but check it to
907 verify (INT_MAX
<= PTRDIFF_MAX
);
910 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
911 Signal an error on memory exhaustion, and block interrupt input. */
914 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
916 eassert (0 <= nitems
&& 0 < item_size
);
918 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
919 memory_full (SIZE_MAX
);
920 return xmalloc (nbytes
);
924 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
925 Signal an error on memory exhaustion, and block interrupt input. */
928 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
930 eassert (0 <= nitems
&& 0 < item_size
);
932 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
933 memory_full (SIZE_MAX
);
934 return xrealloc (pa
, nbytes
);
938 /* Grow PA, which points to an array of *NITEMS items, and return the
939 location of the reallocated array, updating *NITEMS to reflect its
940 new size. The new array will contain at least NITEMS_INCR_MIN more
941 items, but will not contain more than NITEMS_MAX items total.
942 ITEM_SIZE is the size of each item, in bytes.
944 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
945 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
948 If PA is null, then allocate a new array instead of reallocating
951 Block interrupt input as needed. If memory exhaustion occurs, set
952 *NITEMS to zero if PA is null, and signal an error (i.e., do not
955 Thus, to grow an array A without saving its old contents, do
956 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
957 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
958 and signals an error, and later this code is reexecuted and
959 attempts to free A. */
962 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
963 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
965 ptrdiff_t n0
= *nitems
;
966 eassume (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n0
&& -1 <= nitems_max
);
968 /* The approximate size to use for initial small allocation
969 requests. This is the largest "small" request for the GNU C
971 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
973 /* If the array is tiny, grow it to about (but no greater than)
974 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
975 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
976 NITEMS_MAX, and what the C language can represent safely. */
979 if (INT_ADD_WRAPV (n0
, n0
>> 1, &n
))
981 if (0 <= nitems_max
&& nitems_max
< n
)
984 ptrdiff_t adjusted_nbytes
985 = ((INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
986 ? min (PTRDIFF_MAX
, SIZE_MAX
)
987 : nbytes
< DEFAULT_MXFAST
? DEFAULT_MXFAST
: 0);
990 n
= adjusted_nbytes
/ item_size
;
991 nbytes
= adjusted_nbytes
- adjusted_nbytes
% item_size
;
996 if (n
- n0
< nitems_incr_min
997 && (INT_ADD_WRAPV (n0
, nitems_incr_min
, &n
)
998 || (0 <= nitems_max
&& nitems_max
< n
)
999 || INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
)))
1000 memory_full (SIZE_MAX
);
1001 pa
= xrealloc (pa
, nbytes
);
1007 /* Like strdup, but uses xmalloc. */
1010 xstrdup (const char *s
)
1014 size
= strlen (s
) + 1;
1015 return memcpy (xmalloc (size
), s
, size
);
1018 /* Like above, but duplicates Lisp string to C string. */
1021 xlispstrdup (Lisp_Object string
)
1023 ptrdiff_t size
= SBYTES (string
) + 1;
1024 return memcpy (xmalloc (size
), SSDATA (string
), size
);
1027 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1028 pointed to. If STRING is null, assign it without copying anything.
1029 Allocate before freeing, to avoid a dangling pointer if allocation
1033 dupstring (char **ptr
, char const *string
)
1036 *ptr
= string
? xstrdup (string
) : 0;
1041 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1042 argument is a const pointer. */
1045 xputenv (char const *string
)
1047 if (putenv ((char *) string
) != 0)
1051 /* Return a newly allocated memory block of SIZE bytes, remembering
1052 to free it when unwinding. */
1054 record_xmalloc (size_t size
)
1056 void *p
= xmalloc (size
);
1057 record_unwind_protect_ptr (xfree
, p
);
1062 /* Like malloc but used for allocating Lisp data. NBYTES is the
1063 number of bytes to allocate, TYPE describes the intended use of the
1064 allocated memory block (for strings, for conses, ...). */
1067 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
1071 lisp_malloc (size_t nbytes
, enum mem_type type
)
1077 #ifdef GC_MALLOC_CHECK
1078 allocated_mem_type
= type
;
1081 val
= lmalloc (nbytes
);
1084 /* If the memory just allocated cannot be addressed thru a Lisp
1085 object's pointer, and it needs to be,
1086 that's equivalent to running out of memory. */
1087 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1090 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
1091 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
1093 lisp_malloc_loser
= val
;
1100 #ifndef GC_MALLOC_CHECK
1101 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1102 mem_insert (val
, (char *) val
+ nbytes
, type
);
1105 MALLOC_UNBLOCK_INPUT
;
1107 memory_full (nbytes
);
1108 MALLOC_PROBE (nbytes
);
1112 /* Free BLOCK. This must be called to free memory allocated with a
1113 call to lisp_malloc. */
1116 lisp_free (void *block
)
1120 #ifndef GC_MALLOC_CHECK
1121 mem_delete (mem_find (block
));
1123 MALLOC_UNBLOCK_INPUT
;
1126 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1128 /* The entry point is lisp_align_malloc which returns blocks of at most
1129 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1131 /* Byte alignment of storage blocks. */
1132 #define BLOCK_ALIGN (1 << 10)
1133 verify (POWER_OF_2 (BLOCK_ALIGN
));
1135 /* Use aligned_alloc if it or a simple substitute is available.
1136 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1137 clang 3.3 anyway. Aligned allocation is incompatible with
1138 unexmacosx.c, so don't use it on Darwin. */
1140 #if ! ADDRESS_SANITIZER && !defined DARWIN_OS
1141 # if (defined HAVE_ALIGNED_ALLOC \
1142 || (defined HYBRID_MALLOC \
1143 ? defined HAVE_POSIX_MEMALIGN \
1144 : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
1145 # define USE_ALIGNED_ALLOC 1
1146 # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
1147 # define USE_ALIGNED_ALLOC 1
1148 # define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */
1150 aligned_alloc (size_t alignment
, size_t size
)
1152 /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *).
1153 Verify this for all arguments this function is given. */
1154 verify (BLOCK_ALIGN
% sizeof (void *) == 0
1155 && POWER_OF_2 (BLOCK_ALIGN
/ sizeof (void *)));
1156 verify (GCALIGNMENT
% sizeof (void *) == 0
1157 && POWER_OF_2 (GCALIGNMENT
/ sizeof (void *)));
1158 eassert (alignment
== BLOCK_ALIGN
|| alignment
== GCALIGNMENT
);
1161 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1166 /* Padding to leave at the end of a malloc'd block. This is to give
1167 malloc a chance to minimize the amount of memory wasted to alignment.
1168 It should be tuned to the particular malloc library used.
1169 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1170 aligned_alloc on the other hand would ideally prefer a value of 4
1171 because otherwise, there's 1020 bytes wasted between each ablocks.
1172 In Emacs, testing shows that those 1020 can most of the time be
1173 efficiently used by malloc to place other objects, so a value of 0 can
1174 still preferable unless you have a lot of aligned blocks and virtually
1176 #define BLOCK_PADDING 0
1177 #define BLOCK_BYTES \
1178 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1180 /* Internal data structures and constants. */
1182 #define ABLOCKS_SIZE 16
1184 /* An aligned block of memory. */
1189 char payload
[BLOCK_BYTES
];
1190 struct ablock
*next_free
;
1193 /* ABASE is the aligned base of the ablocks. It is overloaded to
1194 hold a virtual "busy" field that counts twice the number of used
1195 ablock values in the parent ablocks, plus one if the real base of
1196 the parent ablocks is ABASE (if the "busy" field is even, the
1197 word before the first ablock holds a pointer to the real base).
1198 The first ablock has a "busy" ABASE, and the others have an
1199 ordinary pointer ABASE. To tell the difference, the code assumes
1200 that pointers, when cast to uintptr_t, are at least 2 *
1201 ABLOCKS_SIZE + 1. */
1202 struct ablocks
*abase
;
1204 /* The padding of all but the last ablock is unused. The padding of
1205 the last ablock in an ablocks is not allocated. */
1207 char padding
[BLOCK_PADDING
];
1211 /* A bunch of consecutive aligned blocks. */
1214 struct ablock blocks
[ABLOCKS_SIZE
];
1217 /* Size of the block requested from malloc or aligned_alloc. */
1218 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1220 #define ABLOCK_ABASE(block) \
1221 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1222 ? (struct ablocks *) (block) \
1225 /* Virtual `busy' field. */
1226 #define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
1228 /* Pointer to the (not necessarily aligned) malloc block. */
1229 #ifdef USE_ALIGNED_ALLOC
1230 #define ABLOCKS_BASE(abase) (abase)
1232 #define ABLOCKS_BASE(abase) \
1233 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
1236 /* The list of free ablock. */
1237 static struct ablock
*free_ablock
;
1239 /* Allocate an aligned block of nbytes.
1240 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1241 smaller or equal to BLOCK_BYTES. */
1243 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1246 struct ablocks
*abase
;
1248 eassert (nbytes
<= BLOCK_BYTES
);
1252 #ifdef GC_MALLOC_CHECK
1253 allocated_mem_type
= type
;
1261 #ifdef DOUG_LEA_MALLOC
1262 if (!mmap_lisp_allowed_p ())
1263 mallopt (M_MMAP_MAX
, 0);
1266 #ifdef USE_ALIGNED_ALLOC
1267 verify (ABLOCKS_BYTES
% BLOCK_ALIGN
== 0);
1268 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1270 base
= malloc (ABLOCKS_BYTES
);
1271 abase
= pointer_align (base
, BLOCK_ALIGN
);
1276 MALLOC_UNBLOCK_INPUT
;
1277 memory_full (ABLOCKS_BYTES
);
1280 aligned
= (base
== abase
);
1282 ((void **) abase
)[-1] = base
;
1284 #ifdef DOUG_LEA_MALLOC
1285 if (!mmap_lisp_allowed_p ())
1286 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1290 /* If the memory just allocated cannot be addressed thru a Lisp
1291 object's pointer, and it needs to be, that's equivalent to
1292 running out of memory. */
1293 if (type
!= MEM_TYPE_NON_LISP
)
1296 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1297 XSETCONS (tem
, end
);
1298 if ((char *) XCONS (tem
) != end
)
1300 lisp_malloc_loser
= base
;
1302 MALLOC_UNBLOCK_INPUT
;
1303 memory_full (SIZE_MAX
);
1308 /* Initialize the blocks and put them on the free list.
1309 If `base' was not properly aligned, we can't use the last block. */
1310 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1312 abase
->blocks
[i
].abase
= abase
;
1313 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1314 free_ablock
= &abase
->blocks
[i
];
1316 intptr_t ialigned
= aligned
;
1317 ABLOCKS_BUSY (abase
) = (struct ablocks
*) ialigned
;
1319 eassert ((uintptr_t) abase
% BLOCK_ALIGN
== 0);
1320 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1321 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1322 eassert (ABLOCKS_BASE (abase
) == base
);
1323 eassert ((intptr_t) ABLOCKS_BUSY (abase
) == aligned
);
1326 abase
= ABLOCK_ABASE (free_ablock
);
1327 ABLOCKS_BUSY (abase
)
1328 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1330 free_ablock
= free_ablock
->x
.next_free
;
1332 #ifndef GC_MALLOC_CHECK
1333 if (type
!= MEM_TYPE_NON_LISP
)
1334 mem_insert (val
, (char *) val
+ nbytes
, type
);
1337 MALLOC_UNBLOCK_INPUT
;
1339 MALLOC_PROBE (nbytes
);
1341 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1346 lisp_align_free (void *block
)
1348 struct ablock
*ablock
= block
;
1349 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1352 #ifndef GC_MALLOC_CHECK
1353 mem_delete (mem_find (block
));
1355 /* Put on free list. */
1356 ablock
->x
.next_free
= free_ablock
;
1357 free_ablock
= ablock
;
1358 /* Update busy count. */
1359 intptr_t busy
= (intptr_t) ABLOCKS_BUSY (abase
) - 2;
1360 eassume (0 <= busy
&& busy
<= 2 * ABLOCKS_SIZE
- 1);
1361 ABLOCKS_BUSY (abase
) = (struct ablocks
*) busy
;
1364 { /* All the blocks are free. */
1366 bool aligned
= busy
;
1367 struct ablock
**tem
= &free_ablock
;
1368 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1372 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1375 *tem
= (*tem
)->x
.next_free
;
1378 tem
= &(*tem
)->x
.next_free
;
1380 eassert ((aligned
& 1) == aligned
);
1381 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1382 #ifdef USE_POSIX_MEMALIGN
1383 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1385 free (ABLOCKS_BASE (abase
));
1387 MALLOC_UNBLOCK_INPUT
;
1390 #if !defined __GNUC__ && !defined __alignof__
1391 # define __alignof__(type) alignof (type)
1394 /* True if malloc (N) is known to return a multiple of GCALIGNMENT
1395 whenever N is also a multiple. In practice this is true if
1396 __alignof__ (max_align_t) is a multiple as well, assuming
1397 GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked
1398 into. Use __alignof__ if available, as otherwise
1399 MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the
1400 alignment is OK there.
1402 This is a macro, not an enum constant, for portability to HP-UX
1403 10.20 cc and AIX 3.2.5 xlc. */
1404 #define MALLOC_IS_GC_ALIGNED \
1405 (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0)
1407 /* True if a malloc-returned pointer P is suitably aligned for SIZE,
1408 where Lisp alignment may be needed if SIZE is Lisp-aligned. */
1411 laligned (void *p
, size_t size
)
1413 return (MALLOC_IS_GC_ALIGNED
|| (intptr_t) p
% GCALIGNMENT
== 0
1414 || size
% GCALIGNMENT
!= 0);
1417 /* Like malloc and realloc except that if SIZE is Lisp-aligned, make
1418 sure the result is too, if necessary by reallocating (typically
1419 with larger and larger sizes) until the allocator returns a
1420 Lisp-aligned pointer. Code that needs to allocate C heap memory
1421 for a Lisp object should use one of these functions to obtain a
1422 pointer P; that way, if T is an enum Lisp_Type value and L ==
1423 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
1425 On typical modern platforms these functions' loops do not iterate.
1426 On now-rare (and perhaps nonexistent) platforms, the loops in
1427 theory could repeat forever. If an infinite loop is possible on a
1428 platform, a build would surely loop and the builder can then send
1429 us a bug report. Adding a counter to try to detect any such loop
1430 would complicate the code (and possibly introduce bugs, in code
1431 that's never really exercised) for little benefit. */
1434 lmalloc (size_t size
)
1436 #if USE_ALIGNED_ALLOC
1437 if (! MALLOC_IS_GC_ALIGNED
&& size
% GCALIGNMENT
== 0)
1438 return aligned_alloc (GCALIGNMENT
, size
);
1443 void *p
= malloc (size
);
1444 if (laligned (p
, size
))
1447 size_t bigger
= size
+ GCALIGNMENT
;
1454 lrealloc (void *p
, size_t size
)
1458 p
= realloc (p
, size
);
1459 if (laligned (p
, size
))
1461 size_t bigger
= size
+ GCALIGNMENT
;
1468 /***********************************************************************
1470 ***********************************************************************/
1472 /* Number of intervals allocated in an interval_block structure.
1473 The 1020 is 1024 minus malloc overhead. */
1475 #define INTERVAL_BLOCK_SIZE \
1476 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1478 /* Intervals are allocated in chunks in the form of an interval_block
1481 struct interval_block
1483 /* Place `intervals' first, to preserve alignment. */
1484 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1485 struct interval_block
*next
;
1488 /* Current interval block. Its `next' pointer points to older
1491 static struct interval_block
*interval_block
;
1493 /* Index in interval_block above of the next unused interval
1496 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1498 /* Number of free and live intervals. */
1500 static EMACS_INT total_free_intervals
, total_intervals
;
1502 /* List of free intervals. */
1504 static INTERVAL interval_free_list
;
1506 /* Return a new interval. */
1509 make_interval (void)
1515 if (interval_free_list
)
1517 val
= interval_free_list
;
1518 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1522 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1524 struct interval_block
*newi
1525 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1527 newi
->next
= interval_block
;
1528 interval_block
= newi
;
1529 interval_block_index
= 0;
1530 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1532 val
= &interval_block
->intervals
[interval_block_index
++];
1535 MALLOC_UNBLOCK_INPUT
;
1537 consing_since_gc
+= sizeof (struct interval
);
1539 total_free_intervals
--;
1540 RESET_INTERVAL (val
);
1546 /* Mark Lisp objects in interval I. */
1549 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1551 /* Intervals should never be shared. So, if extra internal checking is
1552 enabled, GC aborts if it seems to have visited an interval twice. */
1553 eassert (!i
->gcmarkbit
);
1555 mark_object (i
->plist
);
1558 /* Mark the interval tree rooted in I. */
1560 #define MARK_INTERVAL_TREE(i) \
1562 if (i && !i->gcmarkbit) \
1563 traverse_intervals_noorder (i, mark_interval, Qnil); \
1566 /***********************************************************************
1568 ***********************************************************************/
1570 /* Lisp_Strings are allocated in string_block structures. When a new
1571 string_block is allocated, all the Lisp_Strings it contains are
1572 added to a free-list string_free_list. When a new Lisp_String is
1573 needed, it is taken from that list. During the sweep phase of GC,
1574 string_blocks that are entirely free are freed, except two which
1577 String data is allocated from sblock structures. Strings larger
1578 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1579 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1581 Sblocks consist internally of sdata structures, one for each
1582 Lisp_String. The sdata structure points to the Lisp_String it
1583 belongs to. The Lisp_String points back to the `u.data' member of
1584 its sdata structure.
1586 When a Lisp_String is freed during GC, it is put back on
1587 string_free_list, and its `data' member and its sdata's `string'
1588 pointer is set to null. The size of the string is recorded in the
1589 `n.nbytes' member of the sdata. So, sdata structures that are no
1590 longer used, can be easily recognized, and it's easy to compact the
1591 sblocks of small strings which we do in compact_small_strings. */
1593 /* Size in bytes of an sblock structure used for small strings. This
1594 is 8192 minus malloc overhead. */
1596 #define SBLOCK_SIZE 8188
1598 /* Strings larger than this are considered large strings. String data
1599 for large strings is allocated from individual sblocks. */
1601 #define LARGE_STRING_BYTES 1024
1603 /* The SDATA typedef is a struct or union describing string memory
1604 sub-allocated from an sblock. This is where the contents of Lisp
1605 strings are stored. */
1609 /* Back-pointer to the string this sdata belongs to. If null, this
1610 structure is free, and NBYTES (in this structure or in the union below)
1611 contains the string's byte size (the same value that STRING_BYTES
1612 would return if STRING were non-null). If non-null, STRING_BYTES
1613 (STRING) is the size of the data, and DATA contains the string's
1615 struct Lisp_String
*string
;
1617 #ifdef GC_CHECK_STRING_BYTES
1621 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1624 #ifdef GC_CHECK_STRING_BYTES
1626 typedef struct sdata sdata
;
1627 #define SDATA_NBYTES(S) (S)->nbytes
1628 #define SDATA_DATA(S) (S)->data
1634 struct Lisp_String
*string
;
1636 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1637 which has a flexible array member. However, if implemented by
1638 giving this union a member of type 'struct sdata', the union
1639 could not be the last (flexible) member of 'struct sblock',
1640 because C99 prohibits a flexible array member from having a type
1641 that is itself a flexible array. So, comment this member out here,
1642 but remember that the option's there when using this union. */
1647 /* When STRING is null. */
1650 struct Lisp_String
*string
;
1655 #define SDATA_NBYTES(S) (S)->n.nbytes
1656 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1658 #endif /* not GC_CHECK_STRING_BYTES */
1660 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1662 /* Structure describing a block of memory which is sub-allocated to
1663 obtain string data memory for strings. Blocks for small strings
1664 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1665 as large as needed. */
1670 struct sblock
*next
;
1672 /* Pointer to the next free sdata block. This points past the end
1673 of the sblock if there isn't any space left in this block. */
1677 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1680 /* Number of Lisp strings in a string_block structure. The 1020 is
1681 1024 minus malloc overhead. */
1683 #define STRING_BLOCK_SIZE \
1684 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1686 /* Structure describing a block from which Lisp_String structures
1691 /* Place `strings' first, to preserve alignment. */
1692 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1693 struct string_block
*next
;
1696 /* Head and tail of the list of sblock structures holding Lisp string
1697 data. We always allocate from current_sblock. The NEXT pointers
1698 in the sblock structures go from oldest_sblock to current_sblock. */
1700 static struct sblock
*oldest_sblock
, *current_sblock
;
1702 /* List of sblocks for large strings. */
1704 static struct sblock
*large_sblocks
;
1706 /* List of string_block structures. */
1708 static struct string_block
*string_blocks
;
1710 /* Free-list of Lisp_Strings. */
1712 static struct Lisp_String
*string_free_list
;
1714 /* Number of live and free Lisp_Strings. */
1716 static EMACS_INT total_strings
, total_free_strings
;
1718 /* Number of bytes used by live strings. */
1720 static EMACS_INT total_string_bytes
;
1722 /* Given a pointer to a Lisp_String S which is on the free-list
1723 string_free_list, return a pointer to its successor in the
1726 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1728 /* Return a pointer to the sdata structure belonging to Lisp string S.
1729 S must be live, i.e. S->data must not be null. S->data is actually
1730 a pointer to the `u.data' member of its sdata structure; the
1731 structure starts at a constant offset in front of that. */
1733 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1736 #ifdef GC_CHECK_STRING_OVERRUN
1738 /* We check for overrun in string data blocks by appending a small
1739 "cookie" after each allocated string data block, and check for the
1740 presence of this cookie during GC. */
1742 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1743 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1744 { '\xde', '\xad', '\xbe', '\xef' };
1747 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1750 /* Value is the size of an sdata structure large enough to hold NBYTES
1751 bytes of string data. The value returned includes a terminating
1752 NUL byte, the size of the sdata structure, and padding. */
1754 #ifdef GC_CHECK_STRING_BYTES
1756 #define SDATA_SIZE(NBYTES) FLEXSIZEOF (struct sdata, data, NBYTES)
1758 #else /* not GC_CHECK_STRING_BYTES */
1760 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1761 less than the size of that member. The 'max' is not needed when
1762 SDATA_DATA_OFFSET is a multiple of FLEXALIGNOF (struct sdata),
1763 because then the alignment code reserves enough space. */
1765 #define SDATA_SIZE(NBYTES) \
1766 ((SDATA_DATA_OFFSET \
1767 + (SDATA_DATA_OFFSET % FLEXALIGNOF (struct sdata) == 0 \
1769 : max (NBYTES, FLEXALIGNOF (struct sdata) - 1)) \
1771 + FLEXALIGNOF (struct sdata) - 1) \
1772 & ~(FLEXALIGNOF (struct sdata) - 1))
1774 #endif /* not GC_CHECK_STRING_BYTES */
1776 /* Extra bytes to allocate for each string. */
1778 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1780 /* Exact bound on the number of bytes in a string, not counting the
1781 terminating null. A string cannot contain more bytes than
1782 STRING_BYTES_BOUND, nor can it be so long that the size_t
1783 arithmetic in allocate_string_data would overflow while it is
1784 calculating a value to be passed to malloc. */
1785 static ptrdiff_t const STRING_BYTES_MAX
=
1786 min (STRING_BYTES_BOUND
,
1787 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1789 - offsetof (struct sblock
, data
)
1790 - SDATA_DATA_OFFSET
)
1791 & ~(sizeof (EMACS_INT
) - 1)));
1793 /* Initialize string allocation. Called from init_alloc_once. */
1798 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1799 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1803 #ifdef GC_CHECK_STRING_BYTES
1805 static int check_string_bytes_count
;
1807 /* Like STRING_BYTES, but with debugging check. Can be
1808 called during GC, so pay attention to the mark bit. */
1811 string_bytes (struct Lisp_String
*s
)
1814 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1816 if (!PURE_P (s
) && s
->data
&& nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1821 /* Check validity of Lisp strings' string_bytes member in B. */
1824 check_sblock (struct sblock
*b
)
1826 sdata
*from
, *end
, *from_end
;
1830 for (from
= b
->data
; from
< end
; from
= from_end
)
1832 /* Compute the next FROM here because copying below may
1833 overwrite data we need to compute it. */
1836 /* Check that the string size recorded in the string is the
1837 same as the one recorded in the sdata structure. */
1838 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1839 : SDATA_NBYTES (from
));
1840 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1845 /* Check validity of Lisp strings' string_bytes member. ALL_P
1846 means check all strings, otherwise check only most
1847 recently allocated strings. Used for hunting a bug. */
1850 check_string_bytes (bool all_p
)
1856 for (b
= large_sblocks
; b
; b
= b
->next
)
1858 struct Lisp_String
*s
= b
->data
[0].string
;
1863 for (b
= oldest_sblock
; b
; b
= b
->next
)
1866 else if (current_sblock
)
1867 check_sblock (current_sblock
);
1870 #else /* not GC_CHECK_STRING_BYTES */
1872 #define check_string_bytes(all) ((void) 0)
1874 #endif /* GC_CHECK_STRING_BYTES */
1876 #ifdef GC_CHECK_STRING_FREE_LIST
1878 /* Walk through the string free list looking for bogus next pointers.
1879 This may catch buffer overrun from a previous string. */
1882 check_string_free_list (void)
1884 struct Lisp_String
*s
;
1886 /* Pop a Lisp_String off the free-list. */
1887 s
= string_free_list
;
1890 if ((uintptr_t) s
< 1024)
1892 s
= NEXT_FREE_LISP_STRING (s
);
1896 #define check_string_free_list()
1899 /* Return a new Lisp_String. */
1901 static struct Lisp_String
*
1902 allocate_string (void)
1904 struct Lisp_String
*s
;
1908 /* If the free-list is empty, allocate a new string_block, and
1909 add all the Lisp_Strings in it to the free-list. */
1910 if (string_free_list
== NULL
)
1912 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1915 b
->next
= string_blocks
;
1918 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1921 /* Every string on a free list should have NULL data pointer. */
1923 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1924 string_free_list
= s
;
1927 total_free_strings
+= STRING_BLOCK_SIZE
;
1930 check_string_free_list ();
1932 /* Pop a Lisp_String off the free-list. */
1933 s
= string_free_list
;
1934 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1936 MALLOC_UNBLOCK_INPUT
;
1938 --total_free_strings
;
1941 consing_since_gc
+= sizeof *s
;
1943 #ifdef GC_CHECK_STRING_BYTES
1944 if (!noninteractive
)
1946 if (++check_string_bytes_count
== 200)
1948 check_string_bytes_count
= 0;
1949 check_string_bytes (1);
1952 check_string_bytes (0);
1954 #endif /* GC_CHECK_STRING_BYTES */
1960 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1961 plus a NUL byte at the end. Allocate an sdata structure for S, and
1962 set S->data to its `u.data' member. Store a NUL byte at the end of
1963 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1964 S->data if it was initially non-null. */
1967 allocate_string_data (struct Lisp_String
*s
,
1968 EMACS_INT nchars
, EMACS_INT nbytes
)
1970 sdata
*data
, *old_data
;
1972 ptrdiff_t needed
, old_nbytes
;
1974 if (STRING_BYTES_MAX
< nbytes
)
1977 /* Determine the number of bytes needed to store NBYTES bytes
1979 needed
= SDATA_SIZE (nbytes
);
1982 old_data
= SDATA_OF_STRING (s
);
1983 old_nbytes
= STRING_BYTES (s
);
1990 if (nbytes
> LARGE_STRING_BYTES
)
1992 size_t size
= FLEXSIZEOF (struct sblock
, data
, needed
);
1994 #ifdef DOUG_LEA_MALLOC
1995 if (!mmap_lisp_allowed_p ())
1996 mallopt (M_MMAP_MAX
, 0);
1999 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2001 #ifdef DOUG_LEA_MALLOC
2002 if (!mmap_lisp_allowed_p ())
2003 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2007 b
->next
= large_sblocks
;
2008 b
->next_free
= data
;
2011 else if (current_sblock
== NULL
2012 || (((char *) current_sblock
+ SBLOCK_SIZE
2013 - (char *) current_sblock
->next_free
)
2014 < (needed
+ GC_STRING_EXTRA
)))
2016 /* Not enough room in the current sblock. */
2017 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2020 b
->next_free
= data
;
2023 current_sblock
->next
= b
;
2031 data
= b
->next_free
;
2035 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2037 MALLOC_UNBLOCK_INPUT
;
2039 s
->data
= SDATA_DATA (data
);
2040 #ifdef GC_CHECK_STRING_BYTES
2041 SDATA_NBYTES (data
) = nbytes
;
2044 s
->size_byte
= nbytes
;
2045 s
->data
[nbytes
] = '\0';
2046 #ifdef GC_CHECK_STRING_OVERRUN
2047 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2048 GC_STRING_OVERRUN_COOKIE_SIZE
);
2051 /* Note that Faset may call to this function when S has already data
2052 assigned. In this case, mark data as free by setting it's string
2053 back-pointer to null, and record the size of the data in it. */
2056 SDATA_NBYTES (old_data
) = old_nbytes
;
2057 old_data
->string
= NULL
;
2060 consing_since_gc
+= needed
;
2064 /* Sweep and compact strings. */
2066 NO_INLINE
/* For better stack traces */
2068 sweep_strings (void)
2070 struct string_block
*b
, *next
;
2071 struct string_block
*live_blocks
= NULL
;
2073 string_free_list
= NULL
;
2074 total_strings
= total_free_strings
= 0;
2075 total_string_bytes
= 0;
2077 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2078 for (b
= string_blocks
; b
; b
= next
)
2081 struct Lisp_String
*free_list_before
= string_free_list
;
2085 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2087 struct Lisp_String
*s
= b
->strings
+ i
;
2091 /* String was not on free-list before. */
2092 if (STRING_MARKED_P (s
))
2094 /* String is live; unmark it and its intervals. */
2097 /* Do not use string_(set|get)_intervals here. */
2098 s
->intervals
= balance_intervals (s
->intervals
);
2101 total_string_bytes
+= STRING_BYTES (s
);
2105 /* String is dead. Put it on the free-list. */
2106 sdata
*data
= SDATA_OF_STRING (s
);
2108 /* Save the size of S in its sdata so that we know
2109 how large that is. Reset the sdata's string
2110 back-pointer so that we know it's free. */
2111 #ifdef GC_CHECK_STRING_BYTES
2112 if (string_bytes (s
) != SDATA_NBYTES (data
))
2115 data
->n
.nbytes
= STRING_BYTES (s
);
2117 data
->string
= NULL
;
2119 /* Reset the strings's `data' member so that we
2123 /* Put the string on the free-list. */
2124 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2125 string_free_list
= s
;
2131 /* S was on the free-list before. Put it there again. */
2132 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2133 string_free_list
= s
;
2138 /* Free blocks that contain free Lisp_Strings only, except
2139 the first two of them. */
2140 if (nfree
== STRING_BLOCK_SIZE
2141 && total_free_strings
> STRING_BLOCK_SIZE
)
2144 string_free_list
= free_list_before
;
2148 total_free_strings
+= nfree
;
2149 b
->next
= live_blocks
;
2154 check_string_free_list ();
2156 string_blocks
= live_blocks
;
2157 free_large_strings ();
2158 compact_small_strings ();
2160 check_string_free_list ();
2164 /* Free dead large strings. */
2167 free_large_strings (void)
2169 struct sblock
*b
, *next
;
2170 struct sblock
*live_blocks
= NULL
;
2172 for (b
= large_sblocks
; b
; b
= next
)
2176 if (b
->data
[0].string
== NULL
)
2180 b
->next
= live_blocks
;
2185 large_sblocks
= live_blocks
;
2189 /* Compact data of small strings. Free sblocks that don't contain
2190 data of live strings after compaction. */
2193 compact_small_strings (void)
2195 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2196 to, and TB_END is the end of TB. */
2197 struct sblock
*tb
= oldest_sblock
;
2200 sdata
*tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2201 sdata
*to
= tb
->data
;
2203 /* Step through the blocks from the oldest to the youngest. We
2204 expect that old blocks will stabilize over time, so that less
2205 copying will happen this way. */
2206 struct sblock
*b
= tb
;
2209 sdata
*end
= b
->next_free
;
2210 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2212 for (sdata
*from
= b
->data
; from
< end
; )
2214 /* Compute the next FROM here because copying below may
2215 overwrite data we need to compute it. */
2217 struct Lisp_String
*s
= from
->string
;
2219 #ifdef GC_CHECK_STRING_BYTES
2220 /* Check that the string size recorded in the string is the
2221 same as the one recorded in the sdata structure. */
2222 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2224 #endif /* GC_CHECK_STRING_BYTES */
2226 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2227 eassert (nbytes
<= LARGE_STRING_BYTES
);
2229 nbytes
= SDATA_SIZE (nbytes
);
2230 sdata
*from_end
= (sdata
*) ((char *) from
2231 + nbytes
+ GC_STRING_EXTRA
);
2233 #ifdef GC_CHECK_STRING_OVERRUN
2234 if (memcmp (string_overrun_cookie
,
2235 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2236 GC_STRING_OVERRUN_COOKIE_SIZE
))
2240 /* Non-NULL S means it's alive. Copy its data. */
2243 /* If TB is full, proceed with the next sblock. */
2244 sdata
*to_end
= (sdata
*) ((char *) to
2245 + nbytes
+ GC_STRING_EXTRA
);
2246 if (to_end
> tb_end
)
2250 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2252 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2255 /* Copy, and update the string's `data' pointer. */
2258 eassert (tb
!= b
|| to
< from
);
2259 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2260 to
->string
->data
= SDATA_DATA (to
);
2263 /* Advance past the sdata we copied to. */
2272 /* The rest of the sblocks following TB don't contain live data, so
2273 we can free them. */
2274 for (b
= tb
->next
; b
; )
2276 struct sblock
*next
= b
->next
;
2285 current_sblock
= tb
;
2289 string_overflow (void)
2291 error ("Maximum string size exceeded");
2294 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2295 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2296 LENGTH must be an integer.
2297 INIT must be an integer that represents a character. */)
2298 (Lisp_Object length
, Lisp_Object init
)
2300 register Lisp_Object val
;
2304 CHECK_NATNUM (length
);
2305 CHECK_CHARACTER (init
);
2307 c
= XFASTINT (init
);
2308 if (ASCII_CHAR_P (c
))
2310 nbytes
= XINT (length
);
2311 val
= make_uninit_string (nbytes
);
2314 memset (SDATA (val
), c
, nbytes
);
2315 SDATA (val
)[nbytes
] = 0;
2320 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2321 ptrdiff_t len
= CHAR_STRING (c
, str
);
2322 EMACS_INT string_len
= XINT (length
);
2323 unsigned char *p
, *beg
, *end
;
2325 if (INT_MULTIPLY_WRAPV (len
, string_len
, &nbytes
))
2327 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2328 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2330 /* First time we just copy `str' to the data of `val'. */
2332 memcpy (p
, str
, len
);
2335 /* Next time we copy largest possible chunk from
2336 initialized to uninitialized part of `val'. */
2337 len
= min (p
- beg
, end
- p
);
2338 memcpy (p
, beg
, len
);
2348 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2352 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2354 EMACS_INT nbits
= bool_vector_size (a
);
2357 unsigned char *data
= bool_vector_uchar_data (a
);
2358 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2359 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2360 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2361 memset (data
, pattern
, nbytes
- 1);
2362 data
[nbytes
- 1] = pattern
& last_mask
;
2367 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2370 make_uninit_bool_vector (EMACS_INT nbits
)
2373 EMACS_INT words
= bool_vector_words (nbits
);
2374 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2375 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2378 struct Lisp_Bool_Vector
*p
2379 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2380 XSETVECTOR (val
, p
);
2381 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2384 /* Clear padding at the end. */
2386 p
->data
[words
- 1] = 0;
2391 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2392 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2393 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2394 (Lisp_Object length
, Lisp_Object init
)
2398 CHECK_NATNUM (length
);
2399 val
= make_uninit_bool_vector (XFASTINT (length
));
2400 return bool_vector_fill (val
, init
);
2403 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2404 doc
: /* Return a new bool-vector with specified arguments as elements.
2405 Any number of arguments, even zero arguments, are allowed.
2406 usage: (bool-vector &rest OBJECTS) */)
2407 (ptrdiff_t nargs
, Lisp_Object
*args
)
2412 vector
= make_uninit_bool_vector (nargs
);
2413 for (i
= 0; i
< nargs
; i
++)
2414 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2419 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2420 of characters from the contents. This string may be unibyte or
2421 multibyte, depending on the contents. */
2424 make_string (const char *contents
, ptrdiff_t nbytes
)
2426 register Lisp_Object val
;
2427 ptrdiff_t nchars
, multibyte_nbytes
;
2429 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2430 &nchars
, &multibyte_nbytes
);
2431 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2432 /* CONTENTS contains no multibyte sequences or contains an invalid
2433 multibyte sequence. We must make unibyte string. */
2434 val
= make_unibyte_string (contents
, nbytes
);
2436 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2440 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2443 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2445 register Lisp_Object val
;
2446 val
= make_uninit_string (length
);
2447 memcpy (SDATA (val
), contents
, length
);
2452 /* Make a multibyte string from NCHARS characters occupying NBYTES
2453 bytes at CONTENTS. */
2456 make_multibyte_string (const char *contents
,
2457 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2459 register Lisp_Object val
;
2460 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2461 memcpy (SDATA (val
), contents
, nbytes
);
2466 /* Make a string from NCHARS characters occupying NBYTES bytes at
2467 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2470 make_string_from_bytes (const char *contents
,
2471 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2473 register Lisp_Object val
;
2474 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2475 memcpy (SDATA (val
), contents
, nbytes
);
2476 if (SBYTES (val
) == SCHARS (val
))
2477 STRING_SET_UNIBYTE (val
);
2482 /* Make a string from NCHARS characters occupying NBYTES bytes at
2483 CONTENTS. The argument MULTIBYTE controls whether to label the
2484 string as multibyte. If NCHARS is negative, it counts the number of
2485 characters by itself. */
2488 make_specified_string (const char *contents
,
2489 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2496 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2501 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2502 memcpy (SDATA (val
), contents
, nbytes
);
2504 STRING_SET_UNIBYTE (val
);
2509 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2510 occupying LENGTH bytes. */
2513 make_uninit_string (EMACS_INT length
)
2518 return empty_unibyte_string
;
2519 val
= make_uninit_multibyte_string (length
, length
);
2520 STRING_SET_UNIBYTE (val
);
2525 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2526 which occupy NBYTES bytes. */
2529 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2532 struct Lisp_String
*s
;
2537 return empty_multibyte_string
;
2539 s
= allocate_string ();
2540 s
->intervals
= NULL
;
2541 allocate_string_data (s
, nchars
, nbytes
);
2542 XSETSTRING (string
, s
);
2543 string_chars_consed
+= nbytes
;
2547 /* Print arguments to BUF according to a FORMAT, then return
2548 a Lisp_String initialized with the data from BUF. */
2551 make_formatted_string (char *buf
, const char *format
, ...)
2556 va_start (ap
, format
);
2557 length
= vsprintf (buf
, format
, ap
);
2559 return make_string (buf
, length
);
2563 /***********************************************************************
2565 ***********************************************************************/
2567 /* We store float cells inside of float_blocks, allocating a new
2568 float_block with malloc whenever necessary. Float cells reclaimed
2569 by GC are put on a free list to be reallocated before allocating
2570 any new float cells from the latest float_block. */
2572 #define FLOAT_BLOCK_SIZE \
2573 (((BLOCK_BYTES - sizeof (struct float_block *) \
2574 /* The compiler might add padding at the end. */ \
2575 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2576 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2578 #define GETMARKBIT(block,n) \
2579 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2580 >> ((n) % BITS_PER_BITS_WORD)) \
2583 #define SETMARKBIT(block,n) \
2584 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2585 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2587 #define UNSETMARKBIT(block,n) \
2588 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2589 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2591 #define FLOAT_BLOCK(fptr) \
2592 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2594 #define FLOAT_INDEX(fptr) \
2595 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2599 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2600 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2601 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2602 struct float_block
*next
;
2605 #define FLOAT_MARKED_P(fptr) \
2606 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2608 #define FLOAT_MARK(fptr) \
2609 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2611 #define FLOAT_UNMARK(fptr) \
2612 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2614 /* Current float_block. */
2616 static struct float_block
*float_block
;
2618 /* Index of first unused Lisp_Float in the current float_block. */
2620 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2622 /* Free-list of Lisp_Floats. */
2624 static struct Lisp_Float
*float_free_list
;
2626 /* Return a new float object with value FLOAT_VALUE. */
2629 make_float (double float_value
)
2631 register Lisp_Object val
;
2635 if (float_free_list
)
2637 /* We use the data field for chaining the free list
2638 so that we won't use the same field that has the mark bit. */
2639 XSETFLOAT (val
, float_free_list
);
2640 float_free_list
= float_free_list
->u
.chain
;
2644 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2646 struct float_block
*new
2647 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2648 new->next
= float_block
;
2649 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2651 float_block_index
= 0;
2652 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2654 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2655 float_block_index
++;
2658 MALLOC_UNBLOCK_INPUT
;
2660 XFLOAT_INIT (val
, float_value
);
2661 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2662 consing_since_gc
+= sizeof (struct Lisp_Float
);
2664 total_free_floats
--;
2670 /***********************************************************************
2672 ***********************************************************************/
2674 /* We store cons cells inside of cons_blocks, allocating a new
2675 cons_block with malloc whenever necessary. Cons cells reclaimed by
2676 GC are put on a free list to be reallocated before allocating
2677 any new cons cells from the latest cons_block. */
2679 #define CONS_BLOCK_SIZE \
2680 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2681 /* The compiler might add padding at the end. */ \
2682 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2683 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2685 #define CONS_BLOCK(fptr) \
2686 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2688 #define CONS_INDEX(fptr) \
2689 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2693 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2694 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2695 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2696 struct cons_block
*next
;
2699 #define CONS_MARKED_P(fptr) \
2700 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2702 #define CONS_MARK(fptr) \
2703 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2705 #define CONS_UNMARK(fptr) \
2706 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2708 /* Current cons_block. */
2710 static struct cons_block
*cons_block
;
2712 /* Index of first unused Lisp_Cons in the current block. */
2714 static int cons_block_index
= CONS_BLOCK_SIZE
;
2716 /* Free-list of Lisp_Cons structures. */
2718 static struct Lisp_Cons
*cons_free_list
;
2720 /* Explicitly free a cons cell by putting it on the free-list. */
2723 free_cons (struct Lisp_Cons
*ptr
)
2725 ptr
->u
.chain
= cons_free_list
;
2727 cons_free_list
= ptr
;
2728 consing_since_gc
-= sizeof *ptr
;
2729 total_free_conses
++;
2732 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2733 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2734 (Lisp_Object car
, Lisp_Object cdr
)
2736 register Lisp_Object val
;
2742 /* We use the cdr for chaining the free list
2743 so that we won't use the same field that has the mark bit. */
2744 XSETCONS (val
, cons_free_list
);
2745 cons_free_list
= cons_free_list
->u
.chain
;
2749 if (cons_block_index
== CONS_BLOCK_SIZE
)
2751 struct cons_block
*new
2752 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2753 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2754 new->next
= cons_block
;
2756 cons_block_index
= 0;
2757 total_free_conses
+= CONS_BLOCK_SIZE
;
2759 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2763 MALLOC_UNBLOCK_INPUT
;
2767 eassert (!CONS_MARKED_P (XCONS (val
)));
2768 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2769 total_free_conses
--;
2770 cons_cells_consed
++;
2774 #ifdef GC_CHECK_CONS_LIST
2775 /* Get an error now if there's any junk in the cons free list. */
2777 check_cons_list (void)
2779 struct Lisp_Cons
*tail
= cons_free_list
;
2782 tail
= tail
->u
.chain
;
2786 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2789 list1 (Lisp_Object arg1
)
2791 return Fcons (arg1
, Qnil
);
2795 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2797 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2802 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2804 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2809 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2811 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2816 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2818 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2819 Fcons (arg5
, Qnil
)))));
2822 /* Make a list of COUNT Lisp_Objects, where ARG is the
2823 first one. Allocate conses from pure space if TYPE
2824 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2827 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2829 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2832 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2833 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2834 default: emacs_abort ();
2837 eassume (0 < count
);
2838 Lisp_Object val
= cons (arg
, Qnil
);
2839 Lisp_Object tail
= val
;
2843 for (ptrdiff_t i
= 1; i
< count
; i
++)
2845 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2846 XSETCDR (tail
, elem
);
2854 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2855 doc
: /* Return a newly created list with specified arguments as elements.
2856 Any number of arguments, even zero arguments, are allowed.
2857 usage: (list &rest OBJECTS) */)
2858 (ptrdiff_t nargs
, Lisp_Object
*args
)
2860 register Lisp_Object val
;
2866 val
= Fcons (args
[nargs
], val
);
2872 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2873 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2874 (register Lisp_Object length
, Lisp_Object init
)
2876 register Lisp_Object val
;
2877 register EMACS_INT size
;
2879 CHECK_NATNUM (length
);
2880 size
= XFASTINT (length
);
2885 val
= Fcons (init
, val
);
2890 val
= Fcons (init
, val
);
2895 val
= Fcons (init
, val
);
2900 val
= Fcons (init
, val
);
2905 val
= Fcons (init
, val
);
2920 /***********************************************************************
2922 ***********************************************************************/
2924 /* Sometimes a vector's contents are merely a pointer internally used
2925 in vector allocation code. On the rare platforms where a null
2926 pointer cannot be tagged, represent it with a Lisp 0.
2927 Usually you don't want to touch this. */
2929 static struct Lisp_Vector
*
2930 next_vector (struct Lisp_Vector
*v
)
2932 return XUNTAG (v
->contents
[0], Lisp_Int0
);
2936 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2938 v
->contents
[0] = make_lisp_ptr (p
, Lisp_Int0
);
2941 /* This value is balanced well enough to avoid too much internal overhead
2942 for the most common cases; it's not required to be a power of two, but
2943 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2945 #define VECTOR_BLOCK_SIZE 4096
2949 /* Alignment of struct Lisp_Vector objects. */
2950 vector_alignment
= COMMON_MULTIPLE (FLEXALIGNOF (struct Lisp_Vector
),
2953 /* Vector size requests are a multiple of this. */
2954 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2957 /* Verify assumptions described above. */
2958 verify (VECTOR_BLOCK_SIZE
% roundup_size
== 0);
2959 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2961 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2962 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2963 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2964 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2966 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2968 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2970 /* Size of the minimal vector allocated from block. */
2972 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2974 /* Size of the largest vector allocated from block. */
2976 #define VBLOCK_BYTES_MAX \
2977 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2979 /* We maintain one free list for each possible block-allocated
2980 vector size, and this is the number of free lists we have. */
2982 #define VECTOR_MAX_FREE_LIST_INDEX \
2983 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2985 /* Common shortcut to advance vector pointer over a block data. */
2987 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2989 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2991 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2993 /* Common shortcut to setup vector on a free list. */
2995 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2997 (tmp) = ((nbytes - header_size) / word_size); \
2998 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2999 eassert ((nbytes) % roundup_size == 0); \
3000 (tmp) = VINDEX (nbytes); \
3001 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
3002 set_next_vector (v, vector_free_lists[tmp]); \
3003 vector_free_lists[tmp] = (v); \
3004 total_free_vector_slots += (nbytes) / word_size; \
3007 /* This internal type is used to maintain the list of large vectors
3008 which are allocated at their own, e.g. outside of vector blocks.
3010 struct large_vector itself cannot contain a struct Lisp_Vector, as
3011 the latter contains a flexible array member and C99 does not allow
3012 such structs to be nested. Instead, each struct large_vector
3013 object LV is followed by a struct Lisp_Vector, which is at offset
3014 large_vector_offset from LV, and whose address is therefore
3015 large_vector_vec (&LV). */
3019 struct large_vector
*next
;
3024 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
3027 static struct Lisp_Vector
*
3028 large_vector_vec (struct large_vector
*p
)
3030 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
3033 /* This internal type is used to maintain an underlying storage
3034 for small vectors. */
3038 char data
[VECTOR_BLOCK_BYTES
];
3039 struct vector_block
*next
;
3042 /* Chain of vector blocks. */
3044 static struct vector_block
*vector_blocks
;
3046 /* Vector free lists, where NTH item points to a chain of free
3047 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
3049 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
3051 /* Singly-linked list of large vectors. */
3053 static struct large_vector
*large_vectors
;
3055 /* The only vector with 0 slots, allocated from pure space. */
3057 Lisp_Object zero_vector
;
3059 /* Number of live vectors. */
3061 static EMACS_INT total_vectors
;
3063 /* Total size of live and free vectors, in Lisp_Object units. */
3065 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
3067 /* Get a new vector block. */
3069 static struct vector_block
*
3070 allocate_vector_block (void)
3072 struct vector_block
*block
= xmalloc (sizeof *block
);
3074 #ifndef GC_MALLOC_CHECK
3075 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
3076 MEM_TYPE_VECTOR_BLOCK
);
3079 block
->next
= vector_blocks
;
3080 vector_blocks
= block
;
3084 /* Called once to initialize vector allocation. */
3089 zero_vector
= make_pure_vector (0);
3092 /* Allocate vector from a vector block. */
3094 static struct Lisp_Vector
*
3095 allocate_vector_from_block (size_t nbytes
)
3097 struct Lisp_Vector
*vector
;
3098 struct vector_block
*block
;
3099 size_t index
, restbytes
;
3101 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
3102 eassert (nbytes
% roundup_size
== 0);
3104 /* First, try to allocate from a free list
3105 containing vectors of the requested size. */
3106 index
= VINDEX (nbytes
);
3107 if (vector_free_lists
[index
])
3109 vector
= vector_free_lists
[index
];
3110 vector_free_lists
[index
] = next_vector (vector
);
3111 total_free_vector_slots
-= nbytes
/ word_size
;
3115 /* Next, check free lists containing larger vectors. Since
3116 we will split the result, we should have remaining space
3117 large enough to use for one-slot vector at least. */
3118 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3119 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3120 if (vector_free_lists
[index
])
3122 /* This vector is larger than requested. */
3123 vector
= vector_free_lists
[index
];
3124 vector_free_lists
[index
] = next_vector (vector
);
3125 total_free_vector_slots
-= nbytes
/ word_size
;
3127 /* Excess bytes are used for the smaller vector,
3128 which should be set on an appropriate free list. */
3129 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3130 eassert (restbytes
% roundup_size
== 0);
3131 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3135 /* Finally, need a new vector block. */
3136 block
= allocate_vector_block ();
3138 /* New vector will be at the beginning of this block. */
3139 vector
= (struct Lisp_Vector
*) block
->data
;
3141 /* If the rest of space from this block is large enough
3142 for one-slot vector at least, set up it on a free list. */
3143 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3144 if (restbytes
>= VBLOCK_BYTES_MIN
)
3146 eassert (restbytes
% roundup_size
== 0);
3147 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3152 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3154 #define VECTOR_IN_BLOCK(vector, block) \
3155 ((char *) (vector) <= (block)->data \
3156 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3158 /* Return the memory footprint of V in bytes. */
3161 vector_nbytes (struct Lisp_Vector
*v
)
3163 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
3166 if (size
& PSEUDOVECTOR_FLAG
)
3168 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
3170 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
3171 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
3172 * sizeof (bits_word
));
3173 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
3174 verify (header_size
<= bool_header_size
);
3175 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
3178 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
3179 + ((size
& PSEUDOVECTOR_REST_MASK
)
3180 >> PSEUDOVECTOR_SIZE_BITS
));
3184 return vroundup (header_size
+ word_size
* nwords
);
3187 /* Release extra resources still in use by VECTOR, which may be any
3188 vector-like object. For now, this is used just to free data in
3192 cleanup_vector (struct Lisp_Vector
*vector
)
3194 detect_suspicious_free (vector
);
3195 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
3196 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
3197 == FONT_OBJECT_MAX
))
3199 struct font_driver
*drv
= ((struct font
*) vector
)->driver
;
3201 /* The font driver might sometimes be NULL, e.g. if Emacs was
3202 interrupted before it had time to set it up. */
3205 /* Attempt to catch subtle bugs like Bug#16140. */
3206 eassert (valid_font_driver (drv
));
3207 drv
->close ((struct font
*) vector
);
3212 /* Reclaim space used by unmarked vectors. */
3214 NO_INLINE
/* For better stack traces */
3216 sweep_vectors (void)
3218 struct vector_block
*block
, **bprev
= &vector_blocks
;
3219 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3220 struct Lisp_Vector
*vector
, *next
;
3222 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3223 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3225 /* Looking through vector blocks. */
3227 for (block
= vector_blocks
; block
; block
= *bprev
)
3229 bool free_this_block
= 0;
3232 for (vector
= (struct Lisp_Vector
*) block
->data
;
3233 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3235 if (VECTOR_MARKED_P (vector
))
3237 VECTOR_UNMARK (vector
);
3239 nbytes
= vector_nbytes (vector
);
3240 total_vector_slots
+= nbytes
/ word_size
;
3241 next
= ADVANCE (vector
, nbytes
);
3245 ptrdiff_t total_bytes
;
3247 cleanup_vector (vector
);
3248 nbytes
= vector_nbytes (vector
);
3249 total_bytes
= nbytes
;
3250 next
= ADVANCE (vector
, nbytes
);
3252 /* While NEXT is not marked, try to coalesce with VECTOR,
3253 thus making VECTOR of the largest possible size. */
3255 while (VECTOR_IN_BLOCK (next
, block
))
3257 if (VECTOR_MARKED_P (next
))
3259 cleanup_vector (next
);
3260 nbytes
= vector_nbytes (next
);
3261 total_bytes
+= nbytes
;
3262 next
= ADVANCE (next
, nbytes
);
3265 eassert (total_bytes
% roundup_size
== 0);
3267 if (vector
== (struct Lisp_Vector
*) block
->data
3268 && !VECTOR_IN_BLOCK (next
, block
))
3269 /* This block should be freed because all of its
3270 space was coalesced into the only free vector. */
3271 free_this_block
= 1;
3275 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3280 if (free_this_block
)
3282 *bprev
= block
->next
;
3283 #ifndef GC_MALLOC_CHECK
3284 mem_delete (mem_find (block
->data
));
3289 bprev
= &block
->next
;
3292 /* Sweep large vectors. */
3294 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3296 vector
= large_vector_vec (lv
);
3297 if (VECTOR_MARKED_P (vector
))
3299 VECTOR_UNMARK (vector
);
3301 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3303 /* All non-bool pseudovectors are small enough to be allocated
3304 from vector blocks. This code should be redesigned if some
3305 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3306 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3307 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3311 += header_size
/ word_size
+ vector
->header
.size
;
3322 /* Value is a pointer to a newly allocated Lisp_Vector structure
3323 with room for LEN Lisp_Objects. */
3325 static struct Lisp_Vector
*
3326 allocate_vectorlike (ptrdiff_t len
)
3328 struct Lisp_Vector
*p
;
3333 p
= XVECTOR (zero_vector
);
3336 size_t nbytes
= header_size
+ len
* word_size
;
3338 #ifdef DOUG_LEA_MALLOC
3339 if (!mmap_lisp_allowed_p ())
3340 mallopt (M_MMAP_MAX
, 0);
3343 if (nbytes
<= VBLOCK_BYTES_MAX
)
3344 p
= allocate_vector_from_block (vroundup (nbytes
));
3347 struct large_vector
*lv
3348 = lisp_malloc ((large_vector_offset
+ header_size
3350 MEM_TYPE_VECTORLIKE
);
3351 lv
->next
= large_vectors
;
3353 p
= large_vector_vec (lv
);
3356 #ifdef DOUG_LEA_MALLOC
3357 if (!mmap_lisp_allowed_p ())
3358 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3361 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3364 consing_since_gc
+= nbytes
;
3365 vector_cells_consed
+= len
;
3368 MALLOC_UNBLOCK_INPUT
;
3374 /* Allocate a vector with LEN slots. */
3376 struct Lisp_Vector
*
3377 allocate_vector (EMACS_INT len
)
3379 struct Lisp_Vector
*v
;
3380 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3382 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3383 memory_full (SIZE_MAX
);
3384 v
= allocate_vectorlike (len
);
3386 v
->header
.size
= len
;
3391 /* Allocate other vector-like structures. */
3393 struct Lisp_Vector
*
3394 allocate_pseudovector (int memlen
, int lisplen
,
3395 int zerolen
, enum pvec_type tag
)
3397 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3399 /* Catch bogus values. */
3400 eassert (0 <= tag
&& tag
<= PVEC_FONT
);
3401 eassert (0 <= lisplen
&& lisplen
<= zerolen
&& zerolen
<= memlen
);
3402 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3403 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3405 /* Only the first LISPLEN slots will be traced normally by the GC. */
3406 memclear (v
->contents
, zerolen
* word_size
);
3407 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3412 allocate_buffer (void)
3414 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3416 BUFFER_PVEC_INIT (b
);
3417 /* Put B on the chain of all buffers including killed ones. */
3418 b
->next
= all_buffers
;
3420 /* Note that the rest fields of B are not initialized. */
3424 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3425 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3426 See also the function `vector'. */)
3427 (Lisp_Object length
, Lisp_Object init
)
3429 CHECK_NATNUM (length
);
3430 struct Lisp_Vector
*p
= allocate_vector (XFASTINT (length
));
3431 for (ptrdiff_t i
= 0; i
< XFASTINT (length
); i
++)
3432 p
->contents
[i
] = init
;
3433 return make_lisp_ptr (p
, Lisp_Vectorlike
);
3436 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3437 doc
: /* Return a newly created vector with specified arguments as elements.
3438 Any number of arguments, even zero arguments, are allowed.
3439 usage: (vector &rest OBJECTS) */)
3440 (ptrdiff_t nargs
, Lisp_Object
*args
)
3442 Lisp_Object val
= make_uninit_vector (nargs
);
3443 struct Lisp_Vector
*p
= XVECTOR (val
);
3444 memcpy (p
->contents
, args
, nargs
* sizeof *args
);
3449 make_byte_code (struct Lisp_Vector
*v
)
3451 /* Don't allow the global zero_vector to become a byte code object. */
3452 eassert (0 < v
->header
.size
);
3454 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3455 && STRING_MULTIBYTE (v
->contents
[1]))
3456 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3457 earlier because they produced a raw 8-bit string for byte-code
3458 and now such a byte-code string is loaded as multibyte while
3459 raw 8-bit characters converted to multibyte form. Thus, now we
3460 must convert them back to the original unibyte form. */
3461 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3462 XSETPVECTYPE (v
, PVEC_COMPILED
);
3465 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3466 doc
: /* Create a byte-code object with specified arguments as elements.
3467 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3468 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3469 and (optional) INTERACTIVE-SPEC.
3470 The first four arguments are required; at most six have any
3472 The ARGLIST can be either like the one of `lambda', in which case the arguments
3473 will be dynamically bound before executing the byte code, or it can be an
3474 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3475 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3476 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3477 argument to catch the left-over arguments. If such an integer is used, the
3478 arguments will not be dynamically bound but will be instead pushed on the
3479 stack before executing the byte-code.
3480 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3481 (ptrdiff_t nargs
, Lisp_Object
*args
)
3483 Lisp_Object val
= make_uninit_vector (nargs
);
3484 struct Lisp_Vector
*p
= XVECTOR (val
);
3486 /* We used to purecopy everything here, if purify-flag was set. This worked
3487 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3488 dangerous, since make-byte-code is used during execution to build
3489 closures, so any closure built during the preload phase would end up
3490 copied into pure space, including its free variables, which is sometimes
3491 just wasteful and other times plainly wrong (e.g. those free vars may want
3494 memcpy (p
->contents
, args
, nargs
* sizeof *args
);
3496 XSETCOMPILED (val
, p
);
3502 /***********************************************************************
3504 ***********************************************************************/
3506 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3507 of the required alignment. */
3509 union aligned_Lisp_Symbol
3511 struct Lisp_Symbol s
;
3512 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3516 /* Each symbol_block is just under 1020 bytes long, since malloc
3517 really allocates in units of powers of two and uses 4 bytes for its
3520 #define SYMBOL_BLOCK_SIZE \
3521 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3525 /* Place `symbols' first, to preserve alignment. */
3526 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3527 struct symbol_block
*next
;
3530 /* Current symbol block and index of first unused Lisp_Symbol
3533 static struct symbol_block
*symbol_block
;
3534 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3535 /* Pointer to the first symbol_block that contains pinned symbols.
3536 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3537 10K of which are pinned (and all but 250 of them are interned in obarray),
3538 whereas a "typical session" has in the order of 30K symbols.
3539 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3540 than 30K to find the 10K symbols we need to mark. */
3541 static struct symbol_block
*symbol_block_pinned
;
3543 /* List of free symbols. */
3545 static struct Lisp_Symbol
*symbol_free_list
;
3548 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3550 XSYMBOL (sym
)->name
= name
;
3554 init_symbol (Lisp_Object val
, Lisp_Object name
)
3556 struct Lisp_Symbol
*p
= XSYMBOL (val
);
3557 set_symbol_name (val
, name
);
3558 set_symbol_plist (val
, Qnil
);
3559 p
->redirect
= SYMBOL_PLAINVAL
;
3560 SET_SYMBOL_VAL (p
, Qunbound
);
3561 set_symbol_function (val
, Qnil
);
3562 set_symbol_next (val
, NULL
);
3563 p
->gcmarkbit
= false;
3564 p
->interned
= SYMBOL_UNINTERNED
;
3566 p
->declared_special
= false;
3570 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3571 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3572 Its value is void, and its function definition and property list are nil. */)
3577 CHECK_STRING (name
);
3581 if (symbol_free_list
)
3583 XSETSYMBOL (val
, symbol_free_list
);
3584 symbol_free_list
= symbol_free_list
->next
;
3588 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3590 struct symbol_block
*new
3591 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3592 new->next
= symbol_block
;
3594 symbol_block_index
= 0;
3595 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3597 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3598 symbol_block_index
++;
3601 MALLOC_UNBLOCK_INPUT
;
3603 init_symbol (val
, name
);
3604 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3606 total_free_symbols
--;
3612 /***********************************************************************
3613 Marker (Misc) Allocation
3614 ***********************************************************************/
3616 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3617 the required alignment. */
3619 union aligned_Lisp_Misc
3622 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3626 /* Allocation of markers and other objects that share that structure.
3627 Works like allocation of conses. */
3629 #define MARKER_BLOCK_SIZE \
3630 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3634 /* Place `markers' first, to preserve alignment. */
3635 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3636 struct marker_block
*next
;
3639 static struct marker_block
*marker_block
;
3640 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3642 static union Lisp_Misc
*marker_free_list
;
3644 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3647 allocate_misc (enum Lisp_Misc_Type type
)
3653 if (marker_free_list
)
3655 XSETMISC (val
, marker_free_list
);
3656 marker_free_list
= marker_free_list
->u_free
.chain
;
3660 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3662 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3663 new->next
= marker_block
;
3665 marker_block_index
= 0;
3666 total_free_markers
+= MARKER_BLOCK_SIZE
;
3668 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3669 marker_block_index
++;
3672 MALLOC_UNBLOCK_INPUT
;
3674 --total_free_markers
;
3675 consing_since_gc
+= sizeof (union Lisp_Misc
);
3676 misc_objects_consed
++;
3677 XMISCANY (val
)->type
= type
;
3678 XMISCANY (val
)->gcmarkbit
= 0;
3682 /* Free a Lisp_Misc object. */
3685 free_misc (Lisp_Object misc
)
3687 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3688 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3689 marker_free_list
= XMISC (misc
);
3690 consing_since_gc
-= sizeof (union Lisp_Misc
);
3691 total_free_markers
++;
3694 /* Verify properties of Lisp_Save_Value's representation
3695 that are assumed here and elsewhere. */
3697 verify (SAVE_UNUSED
== 0);
3698 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3702 /* Return Lisp_Save_Value objects for the various combinations
3703 that callers need. */
3706 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3708 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3709 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3710 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3711 p
->data
[0].integer
= a
;
3712 p
->data
[1].integer
= b
;
3713 p
->data
[2].integer
= c
;
3718 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3721 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3722 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3723 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3724 p
->data
[0].object
= a
;
3725 p
->data
[1].object
= b
;
3726 p
->data
[2].object
= c
;
3727 p
->data
[3].object
= d
;
3732 make_save_ptr (void *a
)
3734 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3735 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3736 p
->save_type
= SAVE_POINTER
;
3737 p
->data
[0].pointer
= a
;
3742 make_save_ptr_int (void *a
, ptrdiff_t b
)
3744 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3745 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3746 p
->save_type
= SAVE_TYPE_PTR_INT
;
3747 p
->data
[0].pointer
= a
;
3748 p
->data
[1].integer
= b
;
3753 make_save_ptr_ptr (void *a
, void *b
)
3755 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3756 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3757 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3758 p
->data
[0].pointer
= a
;
3759 p
->data
[1].pointer
= b
;
3764 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3766 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3767 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3768 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3769 p
->data
[0].funcpointer
= a
;
3770 p
->data
[1].pointer
= b
;
3771 p
->data
[2].object
= c
;
3775 /* Return a Lisp_Save_Value object that represents an array A
3776 of N Lisp objects. */
3779 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3781 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3782 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3783 p
->save_type
= SAVE_TYPE_MEMORY
;
3784 p
->data
[0].pointer
= a
;
3785 p
->data
[1].integer
= n
;
3789 /* Free a Lisp_Save_Value object. Do not use this function
3790 if SAVE contains pointer other than returned by xmalloc. */
3793 free_save_value (Lisp_Object save
)
3795 xfree (XSAVE_POINTER (save
, 0));
3799 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3802 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3804 register Lisp_Object overlay
;
3806 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3807 OVERLAY_START (overlay
) = start
;
3808 OVERLAY_END (overlay
) = end
;
3809 set_overlay_plist (overlay
, plist
);
3810 XOVERLAY (overlay
)->next
= NULL
;
3814 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3815 doc
: /* Return a newly allocated marker which does not point at any place. */)
3818 register Lisp_Object val
;
3819 register struct Lisp_Marker
*p
;
3821 val
= allocate_misc (Lisp_Misc_Marker
);
3827 p
->insertion_type
= 0;
3828 p
->need_adjustment
= 0;
3832 /* Return a newly allocated marker which points into BUF
3833 at character position CHARPOS and byte position BYTEPOS. */
3836 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3839 struct Lisp_Marker
*m
;
3841 /* No dead buffers here. */
3842 eassert (BUFFER_LIVE_P (buf
));
3844 /* Every character is at least one byte. */
3845 eassert (charpos
<= bytepos
);
3847 obj
= allocate_misc (Lisp_Misc_Marker
);
3850 m
->charpos
= charpos
;
3851 m
->bytepos
= bytepos
;
3852 m
->insertion_type
= 0;
3853 m
->need_adjustment
= 0;
3854 m
->next
= BUF_MARKERS (buf
);
3855 BUF_MARKERS (buf
) = m
;
3859 /* Put MARKER back on the free list after using it temporarily. */
3862 free_marker (Lisp_Object marker
)
3864 unchain_marker (XMARKER (marker
));
3869 /* Return a newly created vector or string with specified arguments as
3870 elements. If all the arguments are characters that can fit
3871 in a string of events, make a string; otherwise, make a vector.
3873 Any number of arguments, even zero arguments, are allowed. */
3876 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3880 for (i
= 0; i
< nargs
; i
++)
3881 /* The things that fit in a string
3882 are characters that are in 0...127,
3883 after discarding the meta bit and all the bits above it. */
3884 if (!INTEGERP (args
[i
])
3885 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3886 return Fvector (nargs
, args
);
3888 /* Since the loop exited, we know that all the things in it are
3889 characters, so we can make a string. */
3893 result
= Fmake_string (make_number (nargs
), make_number (0));
3894 for (i
= 0; i
< nargs
; i
++)
3896 SSET (result
, i
, XINT (args
[i
]));
3897 /* Move the meta bit to the right place for a string char. */
3898 if (XINT (args
[i
]) & CHAR_META
)
3899 SSET (result
, i
, SREF (result
, i
) | 0x80);
3907 /* Create a new module user ptr object. */
3909 make_user_ptr (void (*finalizer
) (void *), void *p
)
3912 struct Lisp_User_Ptr
*uptr
;
3914 obj
= allocate_misc (Lisp_Misc_User_Ptr
);
3915 uptr
= XUSER_PTR (obj
);
3916 uptr
->finalizer
= finalizer
;
3924 init_finalizer_list (struct Lisp_Finalizer
*head
)
3926 head
->prev
= head
->next
= head
;
3929 /* Insert FINALIZER before ELEMENT. */
3932 finalizer_insert (struct Lisp_Finalizer
*element
,
3933 struct Lisp_Finalizer
*finalizer
)
3935 eassert (finalizer
->prev
== NULL
);
3936 eassert (finalizer
->next
== NULL
);
3937 finalizer
->next
= element
;
3938 finalizer
->prev
= element
->prev
;
3939 finalizer
->prev
->next
= finalizer
;
3940 element
->prev
= finalizer
;
3944 unchain_finalizer (struct Lisp_Finalizer
*finalizer
)
3946 if (finalizer
->prev
!= NULL
)
3948 eassert (finalizer
->next
!= NULL
);
3949 finalizer
->prev
->next
= finalizer
->next
;
3950 finalizer
->next
->prev
= finalizer
->prev
;
3951 finalizer
->prev
= finalizer
->next
= NULL
;
3956 mark_finalizer_list (struct Lisp_Finalizer
*head
)
3958 for (struct Lisp_Finalizer
*finalizer
= head
->next
;
3960 finalizer
= finalizer
->next
)
3962 finalizer
->base
.gcmarkbit
= true;
3963 mark_object (finalizer
->function
);
3967 /* Move doomed finalizers to list DEST from list SRC. A doomed
3968 finalizer is one that is not GC-reachable and whose
3969 finalizer->function is non-nil. */
3972 queue_doomed_finalizers (struct Lisp_Finalizer
*dest
,
3973 struct Lisp_Finalizer
*src
)
3975 struct Lisp_Finalizer
*finalizer
= src
->next
;
3976 while (finalizer
!= src
)
3978 struct Lisp_Finalizer
*next
= finalizer
->next
;
3979 if (!finalizer
->base
.gcmarkbit
&& !NILP (finalizer
->function
))
3981 unchain_finalizer (finalizer
);
3982 finalizer_insert (dest
, finalizer
);
3990 run_finalizer_handler (Lisp_Object args
)
3992 add_to_log ("finalizer failed: %S", args
);
3997 run_finalizer_function (Lisp_Object function
)
3999 ptrdiff_t count
= SPECPDL_INDEX ();
4001 specbind (Qinhibit_quit
, Qt
);
4002 internal_condition_case_1 (call0
, function
, Qt
, run_finalizer_handler
);
4003 unbind_to (count
, Qnil
);
4007 run_finalizers (struct Lisp_Finalizer
*finalizers
)
4009 struct Lisp_Finalizer
*finalizer
;
4010 Lisp_Object function
;
4012 while (finalizers
->next
!= finalizers
)
4014 finalizer
= finalizers
->next
;
4015 eassert (finalizer
->base
.type
== Lisp_Misc_Finalizer
);
4016 unchain_finalizer (finalizer
);
4017 function
= finalizer
->function
;
4018 if (!NILP (function
))
4020 finalizer
->function
= Qnil
;
4021 run_finalizer_function (function
);
4026 DEFUN ("make-finalizer", Fmake_finalizer
, Smake_finalizer
, 1, 1, 0,
4027 doc
: /* Make a finalizer that will run FUNCTION.
4028 FUNCTION will be called after garbage collection when the returned
4029 finalizer object becomes unreachable. If the finalizer object is
4030 reachable only through references from finalizer objects, it does not
4031 count as reachable for the purpose of deciding whether to run
4032 FUNCTION. FUNCTION will be run once per finalizer object. */)
4033 (Lisp_Object function
)
4035 Lisp_Object val
= allocate_misc (Lisp_Misc_Finalizer
);
4036 struct Lisp_Finalizer
*finalizer
= XFINALIZER (val
);
4037 finalizer
->function
= function
;
4038 finalizer
->prev
= finalizer
->next
= NULL
;
4039 finalizer_insert (&finalizers
, finalizer
);
4044 /************************************************************************
4045 Memory Full Handling
4046 ************************************************************************/
4049 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
4050 there may have been size_t overflow so that malloc was never
4051 called, or perhaps malloc was invoked successfully but the
4052 resulting pointer had problems fitting into a tagged EMACS_INT. In
4053 either case this counts as memory being full even though malloc did
4057 memory_full (size_t nbytes
)
4059 /* Do not go into hysterics merely because a large request failed. */
4060 bool enough_free_memory
= 0;
4061 if (SPARE_MEMORY
< nbytes
)
4066 p
= malloc (SPARE_MEMORY
);
4070 enough_free_memory
= 1;
4072 MALLOC_UNBLOCK_INPUT
;
4075 if (! enough_free_memory
)
4081 memory_full_cons_threshold
= sizeof (struct cons_block
);
4083 /* The first time we get here, free the spare memory. */
4084 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
4085 if (spare_memory
[i
])
4088 free (spare_memory
[i
]);
4089 else if (i
>= 1 && i
<= 4)
4090 lisp_align_free (spare_memory
[i
]);
4092 lisp_free (spare_memory
[i
]);
4093 spare_memory
[i
] = 0;
4097 /* This used to call error, but if we've run out of memory, we could
4098 get infinite recursion trying to build the string. */
4099 xsignal (Qnil
, Vmemory_signal_data
);
4102 /* If we released our reserve (due to running out of memory),
4103 and we have a fair amount free once again,
4104 try to set aside another reserve in case we run out once more.
4106 This is called when a relocatable block is freed in ralloc.c,
4107 and also directly from this file, in case we're not using ralloc.c. */
4110 refill_memory_reserve (void)
4112 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4113 if (spare_memory
[0] == 0)
4114 spare_memory
[0] = malloc (SPARE_MEMORY
);
4115 if (spare_memory
[1] == 0)
4116 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
4118 if (spare_memory
[2] == 0)
4119 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
4121 if (spare_memory
[3] == 0)
4122 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
4124 if (spare_memory
[4] == 0)
4125 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
4127 if (spare_memory
[5] == 0)
4128 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
4130 if (spare_memory
[6] == 0)
4131 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
4133 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
4134 Vmemory_full
= Qnil
;
4138 /************************************************************************
4140 ************************************************************************/
4142 /* Conservative C stack marking requires a method to identify possibly
4143 live Lisp objects given a pointer value. We do this by keeping
4144 track of blocks of Lisp data that are allocated in a red-black tree
4145 (see also the comment of mem_node which is the type of nodes in
4146 that tree). Function lisp_malloc adds information for an allocated
4147 block to the red-black tree with calls to mem_insert, and function
4148 lisp_free removes it with mem_delete. Functions live_string_p etc
4149 call mem_find to lookup information about a given pointer in the
4150 tree, and use that to determine if the pointer points to a Lisp
4153 /* Initialize this part of alloc.c. */
4158 mem_z
.left
= mem_z
.right
= MEM_NIL
;
4159 mem_z
.parent
= NULL
;
4160 mem_z
.color
= MEM_BLACK
;
4161 mem_z
.start
= mem_z
.end
= NULL
;
4166 /* Value is a pointer to the mem_node containing START. Value is
4167 MEM_NIL if there is no node in the tree containing START. */
4169 static struct mem_node
*
4170 mem_find (void *start
)
4174 if (start
< min_heap_address
|| start
> max_heap_address
)
4177 /* Make the search always successful to speed up the loop below. */
4178 mem_z
.start
= start
;
4179 mem_z
.end
= (char *) start
+ 1;
4182 while (start
< p
->start
|| start
>= p
->end
)
4183 p
= start
< p
->start
? p
->left
: p
->right
;
4188 /* Insert a new node into the tree for a block of memory with start
4189 address START, end address END, and type TYPE. Value is a
4190 pointer to the node that was inserted. */
4192 static struct mem_node
*
4193 mem_insert (void *start
, void *end
, enum mem_type type
)
4195 struct mem_node
*c
, *parent
, *x
;
4197 if (min_heap_address
== NULL
|| start
< min_heap_address
)
4198 min_heap_address
= start
;
4199 if (max_heap_address
== NULL
|| end
> max_heap_address
)
4200 max_heap_address
= end
;
4202 /* See where in the tree a node for START belongs. In this
4203 particular application, it shouldn't happen that a node is already
4204 present. For debugging purposes, let's check that. */
4208 while (c
!= MEM_NIL
)
4211 c
= start
< c
->start
? c
->left
: c
->right
;
4214 /* Create a new node. */
4215 #ifdef GC_MALLOC_CHECK
4216 x
= malloc (sizeof *x
);
4220 x
= xmalloc (sizeof *x
);
4226 x
->left
= x
->right
= MEM_NIL
;
4229 /* Insert it as child of PARENT or install it as root. */
4232 if (start
< parent
->start
)
4240 /* Re-establish red-black tree properties. */
4241 mem_insert_fixup (x
);
4247 /* Re-establish the red-black properties of the tree, and thereby
4248 balance the tree, after node X has been inserted; X is always red. */
4251 mem_insert_fixup (struct mem_node
*x
)
4253 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4255 /* X is red and its parent is red. This is a violation of
4256 red-black tree property #3. */
4258 if (x
->parent
== x
->parent
->parent
->left
)
4260 /* We're on the left side of our grandparent, and Y is our
4262 struct mem_node
*y
= x
->parent
->parent
->right
;
4264 if (y
->color
== MEM_RED
)
4266 /* Uncle and parent are red but should be black because
4267 X is red. Change the colors accordingly and proceed
4268 with the grandparent. */
4269 x
->parent
->color
= MEM_BLACK
;
4270 y
->color
= MEM_BLACK
;
4271 x
->parent
->parent
->color
= MEM_RED
;
4272 x
= x
->parent
->parent
;
4276 /* Parent and uncle have different colors; parent is
4277 red, uncle is black. */
4278 if (x
== x
->parent
->right
)
4281 mem_rotate_left (x
);
4284 x
->parent
->color
= MEM_BLACK
;
4285 x
->parent
->parent
->color
= MEM_RED
;
4286 mem_rotate_right (x
->parent
->parent
);
4291 /* This is the symmetrical case of above. */
4292 struct mem_node
*y
= x
->parent
->parent
->left
;
4294 if (y
->color
== MEM_RED
)
4296 x
->parent
->color
= MEM_BLACK
;
4297 y
->color
= MEM_BLACK
;
4298 x
->parent
->parent
->color
= MEM_RED
;
4299 x
= x
->parent
->parent
;
4303 if (x
== x
->parent
->left
)
4306 mem_rotate_right (x
);
4309 x
->parent
->color
= MEM_BLACK
;
4310 x
->parent
->parent
->color
= MEM_RED
;
4311 mem_rotate_left (x
->parent
->parent
);
4316 /* The root may have been changed to red due to the algorithm. Set
4317 it to black so that property #5 is satisfied. */
4318 mem_root
->color
= MEM_BLACK
;
4329 mem_rotate_left (struct mem_node
*x
)
4333 /* Turn y's left sub-tree into x's right sub-tree. */
4336 if (y
->left
!= MEM_NIL
)
4337 y
->left
->parent
= x
;
4339 /* Y's parent was x's parent. */
4341 y
->parent
= x
->parent
;
4343 /* Get the parent to point to y instead of x. */
4346 if (x
== x
->parent
->left
)
4347 x
->parent
->left
= y
;
4349 x
->parent
->right
= y
;
4354 /* Put x on y's left. */
4368 mem_rotate_right (struct mem_node
*x
)
4370 struct mem_node
*y
= x
->left
;
4373 if (y
->right
!= MEM_NIL
)
4374 y
->right
->parent
= x
;
4377 y
->parent
= x
->parent
;
4380 if (x
== x
->parent
->right
)
4381 x
->parent
->right
= y
;
4383 x
->parent
->left
= y
;
4394 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4397 mem_delete (struct mem_node
*z
)
4399 struct mem_node
*x
, *y
;
4401 if (!z
|| z
== MEM_NIL
)
4404 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4409 while (y
->left
!= MEM_NIL
)
4413 if (y
->left
!= MEM_NIL
)
4418 x
->parent
= y
->parent
;
4421 if (y
== y
->parent
->left
)
4422 y
->parent
->left
= x
;
4424 y
->parent
->right
= x
;
4431 z
->start
= y
->start
;
4436 if (y
->color
== MEM_BLACK
)
4437 mem_delete_fixup (x
);
4439 #ifdef GC_MALLOC_CHECK
4447 /* Re-establish the red-black properties of the tree, after a
4451 mem_delete_fixup (struct mem_node
*x
)
4453 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4455 if (x
== x
->parent
->left
)
4457 struct mem_node
*w
= x
->parent
->right
;
4459 if (w
->color
== MEM_RED
)
4461 w
->color
= MEM_BLACK
;
4462 x
->parent
->color
= MEM_RED
;
4463 mem_rotate_left (x
->parent
);
4464 w
= x
->parent
->right
;
4467 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4474 if (w
->right
->color
== MEM_BLACK
)
4476 w
->left
->color
= MEM_BLACK
;
4478 mem_rotate_right (w
);
4479 w
= x
->parent
->right
;
4481 w
->color
= x
->parent
->color
;
4482 x
->parent
->color
= MEM_BLACK
;
4483 w
->right
->color
= MEM_BLACK
;
4484 mem_rotate_left (x
->parent
);
4490 struct mem_node
*w
= x
->parent
->left
;
4492 if (w
->color
== MEM_RED
)
4494 w
->color
= MEM_BLACK
;
4495 x
->parent
->color
= MEM_RED
;
4496 mem_rotate_right (x
->parent
);
4497 w
= x
->parent
->left
;
4500 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4507 if (w
->left
->color
== MEM_BLACK
)
4509 w
->right
->color
= MEM_BLACK
;
4511 mem_rotate_left (w
);
4512 w
= x
->parent
->left
;
4515 w
->color
= x
->parent
->color
;
4516 x
->parent
->color
= MEM_BLACK
;
4517 w
->left
->color
= MEM_BLACK
;
4518 mem_rotate_right (x
->parent
);
4524 x
->color
= MEM_BLACK
;
4528 /* Value is non-zero if P is a pointer to a live Lisp string on
4529 the heap. M is a pointer to the mem_block for P. */
4532 live_string_p (struct mem_node
*m
, void *p
)
4534 if (m
->type
== MEM_TYPE_STRING
)
4536 struct string_block
*b
= m
->start
;
4537 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4539 /* P must point to the start of a Lisp_String structure, and it
4540 must not be on the free-list. */
4542 && offset
% sizeof b
->strings
[0] == 0
4543 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4544 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4551 /* Value is non-zero if P is a pointer to a live Lisp cons on
4552 the heap. M is a pointer to the mem_block for P. */
4555 live_cons_p (struct mem_node
*m
, void *p
)
4557 if (m
->type
== MEM_TYPE_CONS
)
4559 struct cons_block
*b
= m
->start
;
4560 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4562 /* P must point to the start of a Lisp_Cons, not be
4563 one of the unused cells in the current cons block,
4564 and not be on the free-list. */
4566 && offset
% sizeof b
->conses
[0] == 0
4567 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4569 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4570 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4577 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4578 the heap. M is a pointer to the mem_block for P. */
4581 live_symbol_p (struct mem_node
*m
, void *p
)
4583 if (m
->type
== MEM_TYPE_SYMBOL
)
4585 struct symbol_block
*b
= m
->start
;
4586 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4588 /* P must point to the start of a Lisp_Symbol, not be
4589 one of the unused cells in the current symbol block,
4590 and not be on the free-list. */
4592 && offset
% sizeof b
->symbols
[0] == 0
4593 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4594 && (b
!= symbol_block
4595 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4596 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4603 /* Value is non-zero if P is a pointer to a live Lisp float on
4604 the heap. M is a pointer to the mem_block for P. */
4607 live_float_p (struct mem_node
*m
, void *p
)
4609 if (m
->type
== MEM_TYPE_FLOAT
)
4611 struct float_block
*b
= m
->start
;
4612 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4614 /* P must point to the start of a Lisp_Float and not be
4615 one of the unused cells in the current float block. */
4617 && offset
% sizeof b
->floats
[0] == 0
4618 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4619 && (b
!= float_block
4620 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4627 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4628 the heap. M is a pointer to the mem_block for P. */
4631 live_misc_p (struct mem_node
*m
, void *p
)
4633 if (m
->type
== MEM_TYPE_MISC
)
4635 struct marker_block
*b
= m
->start
;
4636 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4638 /* P must point to the start of a Lisp_Misc, not be
4639 one of the unused cells in the current misc block,
4640 and not be on the free-list. */
4642 && offset
% sizeof b
->markers
[0] == 0
4643 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4644 && (b
!= marker_block
4645 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4646 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4653 /* Value is non-zero if P is a pointer to a live vector-like object.
4654 M is a pointer to the mem_block for P. */
4657 live_vector_p (struct mem_node
*m
, void *p
)
4659 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4661 /* This memory node corresponds to a vector block. */
4662 struct vector_block
*block
= m
->start
;
4663 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4665 /* P is in the block's allocation range. Scan the block
4666 up to P and see whether P points to the start of some
4667 vector which is not on a free list. FIXME: check whether
4668 some allocation patterns (probably a lot of short vectors)
4669 may cause a substantial overhead of this loop. */
4670 while (VECTOR_IN_BLOCK (vector
, block
)
4671 && vector
<= (struct Lisp_Vector
*) p
)
4673 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4676 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4679 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4680 /* This memory node corresponds to a large vector. */
4686 /* Value is non-zero if P is a pointer to a live buffer. M is a
4687 pointer to the mem_block for P. */
4690 live_buffer_p (struct mem_node
*m
, void *p
)
4692 /* P must point to the start of the block, and the buffer
4693 must not have been killed. */
4694 return (m
->type
== MEM_TYPE_BUFFER
4696 && !NILP (((struct buffer
*) p
)->name_
));
4699 /* Mark OBJ if we can prove it's a Lisp_Object. */
4702 mark_maybe_object (Lisp_Object obj
)
4706 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4712 void *po
= XPNTR (obj
);
4713 struct mem_node
*m
= mem_find (po
);
4717 bool mark_p
= false;
4719 switch (XTYPE (obj
))
4722 mark_p
= (live_string_p (m
, po
)
4723 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4727 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4731 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4735 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4738 case Lisp_Vectorlike
:
4739 /* Note: can't check BUFFERP before we know it's a
4740 buffer because checking that dereferences the pointer
4741 PO which might point anywhere. */
4742 if (live_vector_p (m
, po
))
4743 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4744 else if (live_buffer_p (m
, po
))
4745 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4749 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4761 /* Return true if P can point to Lisp data, and false otherwise.
4762 Symbols are implemented via offsets not pointers, but the offsets
4763 are also multiples of GCALIGNMENT. */
4766 maybe_lisp_pointer (void *p
)
4768 return (uintptr_t) p
% GCALIGNMENT
== 0;
4771 #ifndef HAVE_MODULES
4772 enum { HAVE_MODULES
= false };
4775 /* If P points to Lisp data, mark that as live if it isn't already
4779 mark_maybe_pointer (void *p
)
4785 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4788 if (sizeof (Lisp_Object
) == sizeof (void *) || !HAVE_MODULES
)
4790 if (!maybe_lisp_pointer (p
))
4795 /* For the wide-int case, also mark emacs_value tagged pointers,
4796 which can be generated by emacs-module.c's value_to_lisp. */
4797 p
= (void *) ((uintptr_t) p
& ~(GCALIGNMENT
- 1));
4803 Lisp_Object obj
= Qnil
;
4807 case MEM_TYPE_NON_LISP
:
4808 case MEM_TYPE_SPARE
:
4809 /* Nothing to do; not a pointer to Lisp memory. */
4812 case MEM_TYPE_BUFFER
:
4813 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4814 XSETVECTOR (obj
, p
);
4818 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4822 case MEM_TYPE_STRING
:
4823 if (live_string_p (m
, p
)
4824 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4825 XSETSTRING (obj
, p
);
4829 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4833 case MEM_TYPE_SYMBOL
:
4834 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4835 XSETSYMBOL (obj
, p
);
4838 case MEM_TYPE_FLOAT
:
4839 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4843 case MEM_TYPE_VECTORLIKE
:
4844 case MEM_TYPE_VECTOR_BLOCK
:
4845 if (live_vector_p (m
, p
))
4848 XSETVECTOR (tem
, p
);
4849 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4864 /* Alignment of pointer values. Use alignof, as it sometimes returns
4865 a smaller alignment than GCC's __alignof__ and mark_memory might
4866 miss objects if __alignof__ were used. */
4867 #define GC_POINTER_ALIGNMENT alignof (void *)
4869 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4870 or END+OFFSET..START. */
4872 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4873 mark_memory (void *start
, void *end
)
4877 /* Make START the pointer to the start of the memory region,
4878 if it isn't already. */
4886 eassert (((uintptr_t) start
) % GC_POINTER_ALIGNMENT
== 0);
4888 /* Mark Lisp data pointed to. This is necessary because, in some
4889 situations, the C compiler optimizes Lisp objects away, so that
4890 only a pointer to them remains. Example:
4892 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4895 Lisp_Object obj = build_string ("test");
4896 struct Lisp_String *s = XSTRING (obj);
4897 Fgarbage_collect ();
4898 fprintf (stderr, "test '%s'\n", s->data);
4902 Here, `obj' isn't really used, and the compiler optimizes it
4903 away. The only reference to the life string is through the
4906 for (pp
= start
; (void *) pp
< end
; pp
+= GC_POINTER_ALIGNMENT
)
4908 mark_maybe_pointer (*(void **) pp
);
4909 mark_maybe_object (*(Lisp_Object
*) pp
);
4913 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4915 static bool setjmp_tested_p
;
4916 static int longjmps_done
;
4918 #define SETJMP_WILL_LIKELY_WORK "\
4920 Emacs garbage collector has been changed to use conservative stack\n\
4921 marking. Emacs has determined that the method it uses to do the\n\
4922 marking will likely work on your system, but this isn't sure.\n\
4924 If you are a system-programmer, or can get the help of a local wizard\n\
4925 who is, please take a look at the function mark_stack in alloc.c, and\n\
4926 verify that the methods used are appropriate for your system.\n\
4928 Please mail the result to <emacs-devel@gnu.org>.\n\
4931 #define SETJMP_WILL_NOT_WORK "\
4933 Emacs garbage collector has been changed to use conservative stack\n\
4934 marking. Emacs has determined that the default method it uses to do the\n\
4935 marking will not work on your system. We will need a system-dependent\n\
4936 solution for your system.\n\
4938 Please take a look at the function mark_stack in alloc.c, and\n\
4939 try to find a way to make it work on your system.\n\
4941 Note that you may get false negatives, depending on the compiler.\n\
4942 In particular, you need to use -O with GCC for this test.\n\
4944 Please mail the result to <emacs-devel@gnu.org>.\n\
4948 /* Perform a quick check if it looks like setjmp saves registers in a
4949 jmp_buf. Print a message to stderr saying so. When this test
4950 succeeds, this is _not_ a proof that setjmp is sufficient for
4951 conservative stack marking. Only the sources or a disassembly
4961 /* Arrange for X to be put in a register. */
4967 if (longjmps_done
== 1)
4969 /* Came here after the longjmp at the end of the function.
4971 If x == 1, the longjmp has restored the register to its
4972 value before the setjmp, and we can hope that setjmp
4973 saves all such registers in the jmp_buf, although that
4976 For other values of X, either something really strange is
4977 taking place, or the setjmp just didn't save the register. */
4980 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4983 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4990 if (longjmps_done
== 1)
4991 sys_longjmp (jbuf
, 1);
4994 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4997 /* Mark live Lisp objects on the C stack.
4999 There are several system-dependent problems to consider when
5000 porting this to new architectures:
5004 We have to mark Lisp objects in CPU registers that can hold local
5005 variables or are used to pass parameters.
5007 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
5008 something that either saves relevant registers on the stack, or
5009 calls mark_maybe_object passing it each register's contents.
5011 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
5012 implementation assumes that calling setjmp saves registers we need
5013 to see in a jmp_buf which itself lies on the stack. This doesn't
5014 have to be true! It must be verified for each system, possibly
5015 by taking a look at the source code of setjmp.
5017 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
5018 can use it as a machine independent method to store all registers
5019 to the stack. In this case the macros described in the previous
5020 two paragraphs are not used.
5024 Architectures differ in the way their processor stack is organized.
5025 For example, the stack might look like this
5028 | Lisp_Object | size = 4
5030 | something else | size = 2
5032 | Lisp_Object | size = 4
5036 In such a case, not every Lisp_Object will be aligned equally. To
5037 find all Lisp_Object on the stack it won't be sufficient to walk
5038 the stack in steps of 4 bytes. Instead, two passes will be
5039 necessary, one starting at the start of the stack, and a second
5040 pass starting at the start of the stack + 2. Likewise, if the
5041 minimal alignment of Lisp_Objects on the stack is 1, four passes
5042 would be necessary, each one starting with one byte more offset
5043 from the stack start. */
5046 mark_stack (void *end
)
5049 /* This assumes that the stack is a contiguous region in memory. If
5050 that's not the case, something has to be done here to iterate
5051 over the stack segments. */
5052 mark_memory (stack_base
, end
);
5054 /* Allow for marking a secondary stack, like the register stack on the
5056 #ifdef GC_MARK_SECONDARY_STACK
5057 GC_MARK_SECONDARY_STACK ();
5062 c_symbol_p (struct Lisp_Symbol
*sym
)
5064 char *lispsym_ptr
= (char *) lispsym
;
5065 char *sym_ptr
= (char *) sym
;
5066 ptrdiff_t lispsym_offset
= sym_ptr
- lispsym_ptr
;
5067 return 0 <= lispsym_offset
&& lispsym_offset
< sizeof lispsym
;
5070 /* Determine whether it is safe to access memory at address P. */
5072 valid_pointer_p (void *p
)
5075 return w32_valid_pointer_p (p
, 16);
5078 if (ADDRESS_SANITIZER
)
5083 /* Obviously, we cannot just access it (we would SEGV trying), so we
5084 trick the o/s to tell us whether p is a valid pointer.
5085 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
5086 not validate p in that case. */
5088 if (emacs_pipe (fd
) == 0)
5090 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
5091 emacs_close (fd
[1]);
5092 emacs_close (fd
[0]);
5100 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5101 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5102 cannot validate OBJ. This function can be quite slow, so its primary
5103 use is the manual debugging. The only exception is print_object, where
5104 we use it to check whether the memory referenced by the pointer of
5105 Lisp_Save_Value object contains valid objects. */
5108 valid_lisp_object_p (Lisp_Object obj
)
5113 void *p
= XPNTR (obj
);
5117 if (SYMBOLP (obj
) && c_symbol_p (p
))
5118 return ((char *) p
- (char *) lispsym
) % sizeof lispsym
[0] == 0;
5120 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5123 struct mem_node
*m
= mem_find (p
);
5127 int valid
= valid_pointer_p (p
);
5139 case MEM_TYPE_NON_LISP
:
5140 case MEM_TYPE_SPARE
:
5143 case MEM_TYPE_BUFFER
:
5144 return live_buffer_p (m
, p
) ? 1 : 2;
5147 return live_cons_p (m
, p
);
5149 case MEM_TYPE_STRING
:
5150 return live_string_p (m
, p
);
5153 return live_misc_p (m
, p
);
5155 case MEM_TYPE_SYMBOL
:
5156 return live_symbol_p (m
, p
);
5158 case MEM_TYPE_FLOAT
:
5159 return live_float_p (m
, p
);
5161 case MEM_TYPE_VECTORLIKE
:
5162 case MEM_TYPE_VECTOR_BLOCK
:
5163 return live_vector_p (m
, p
);
5172 /***********************************************************************
5173 Pure Storage Management
5174 ***********************************************************************/
5176 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5177 pointer to it. TYPE is the Lisp type for which the memory is
5178 allocated. TYPE < 0 means it's not used for a Lisp object. */
5181 pure_alloc (size_t size
, int type
)
5188 /* Allocate space for a Lisp object from the beginning of the free
5189 space with taking account of alignment. */
5190 result
= pointer_align (purebeg
+ pure_bytes_used_lisp
, GCALIGNMENT
);
5191 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5195 /* Allocate space for a non-Lisp object from the end of the free
5197 pure_bytes_used_non_lisp
+= size
;
5198 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5200 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5202 if (pure_bytes_used
<= pure_size
)
5205 /* Don't allocate a large amount here,
5206 because it might get mmap'd and then its address
5207 might not be usable. */
5208 purebeg
= xmalloc (10000);
5210 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5211 pure_bytes_used
= 0;
5212 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5217 /* Print a warning if PURESIZE is too small. */
5220 check_pure_size (void)
5222 if (pure_bytes_used_before_overflow
)
5223 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5225 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5229 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5230 the non-Lisp data pool of the pure storage, and return its start
5231 address. Return NULL if not found. */
5234 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5237 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5238 const unsigned char *p
;
5241 if (pure_bytes_used_non_lisp
<= nbytes
)
5244 /* Set up the Boyer-Moore table. */
5246 for (i
= 0; i
< 256; i
++)
5249 p
= (const unsigned char *) data
;
5251 bm_skip
[*p
++] = skip
;
5253 last_char_skip
= bm_skip
['\0'];
5255 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5256 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5258 /* See the comments in the function `boyer_moore' (search.c) for the
5259 use of `infinity'. */
5260 infinity
= pure_bytes_used_non_lisp
+ 1;
5261 bm_skip
['\0'] = infinity
;
5263 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5267 /* Check the last character (== '\0'). */
5270 start
+= bm_skip
[*(p
+ start
)];
5272 while (start
<= start_max
);
5274 if (start
< infinity
)
5275 /* Couldn't find the last character. */
5278 /* No less than `infinity' means we could find the last
5279 character at `p[start - infinity]'. */
5282 /* Check the remaining characters. */
5283 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5285 return non_lisp_beg
+ start
;
5287 start
+= last_char_skip
;
5289 while (start
<= start_max
);
5295 /* Return a string allocated in pure space. DATA is a buffer holding
5296 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5297 means make the result string multibyte.
5299 Must get an error if pure storage is full, since if it cannot hold
5300 a large string it may be able to hold conses that point to that
5301 string; then the string is not protected from gc. */
5304 make_pure_string (const char *data
,
5305 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5308 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5309 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5310 if (s
->data
== NULL
)
5312 s
->data
= pure_alloc (nbytes
+ 1, -1);
5313 memcpy (s
->data
, data
, nbytes
);
5314 s
->data
[nbytes
] = '\0';
5317 s
->size_byte
= multibyte
? nbytes
: -1;
5318 s
->intervals
= NULL
;
5319 XSETSTRING (string
, s
);
5323 /* Return a string allocated in pure space. Do not
5324 allocate the string data, just point to DATA. */
5327 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5330 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5333 s
->data
= (unsigned char *) data
;
5334 s
->intervals
= NULL
;
5335 XSETSTRING (string
, s
);
5339 static Lisp_Object
purecopy (Lisp_Object obj
);
5341 /* Return a cons allocated from pure space. Give it pure copies
5342 of CAR as car and CDR as cdr. */
5345 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5348 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5350 XSETCAR (new, purecopy (car
));
5351 XSETCDR (new, purecopy (cdr
));
5356 /* Value is a float object with value NUM allocated from pure space. */
5359 make_pure_float (double num
)
5362 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5364 XFLOAT_INIT (new, num
);
5369 /* Return a vector with room for LEN Lisp_Objects allocated from
5373 make_pure_vector (ptrdiff_t len
)
5376 size_t size
= header_size
+ len
* word_size
;
5377 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5378 XSETVECTOR (new, p
);
5379 XVECTOR (new)->header
.size
= len
;
5383 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5384 doc
: /* Make a copy of object OBJ in pure storage.
5385 Recursively copies contents of vectors and cons cells.
5386 Does not copy symbols. Copies strings without text properties. */)
5387 (register Lisp_Object obj
)
5389 if (NILP (Vpurify_flag
))
5391 else if (MARKERP (obj
) || OVERLAYP (obj
)
5392 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5393 /* Can't purify those. */
5396 return purecopy (obj
);
5400 purecopy (Lisp_Object obj
)
5403 || (! SYMBOLP (obj
) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj
)))
5405 return obj
; /* Already pure. */
5407 if (STRINGP (obj
) && XSTRING (obj
)->intervals
)
5408 message_with_string ("Dropping text-properties while making string `%s' pure",
5411 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5413 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5419 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5420 else if (FLOATP (obj
))
5421 obj
= make_pure_float (XFLOAT_DATA (obj
));
5422 else if (STRINGP (obj
))
5423 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5425 STRING_MULTIBYTE (obj
));
5426 else if (COMPILEDP (obj
) || VECTORP (obj
) || HASH_TABLE_P (obj
))
5428 struct Lisp_Vector
*objp
= XVECTOR (obj
);
5429 ptrdiff_t nbytes
= vector_nbytes (objp
);
5430 struct Lisp_Vector
*vec
= pure_alloc (nbytes
, Lisp_Vectorlike
);
5431 register ptrdiff_t i
;
5432 ptrdiff_t size
= ASIZE (obj
);
5433 if (size
& PSEUDOVECTOR_FLAG
)
5434 size
&= PSEUDOVECTOR_SIZE_MASK
;
5435 memcpy (vec
, objp
, nbytes
);
5436 for (i
= 0; i
< size
; i
++)
5437 vec
->contents
[i
] = purecopy (vec
->contents
[i
]);
5438 XSETVECTOR (obj
, vec
);
5440 else if (SYMBOLP (obj
))
5442 if (!XSYMBOL (obj
)->pinned
&& !c_symbol_p (XSYMBOL (obj
)))
5443 { /* We can't purify them, but they appear in many pure objects.
5444 Mark them as `pinned' so we know to mark them at every GC cycle. */
5445 XSYMBOL (obj
)->pinned
= true;
5446 symbol_block_pinned
= symbol_block
;
5448 /* Don't hash-cons it. */
5453 AUTO_STRING (fmt
, "Don't know how to purify: %S");
5454 Fsignal (Qerror
, list1 (CALLN (Fformat
, fmt
, obj
)));
5457 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5458 Fputhash (obj
, obj
, Vpurify_flag
);
5465 /***********************************************************************
5467 ***********************************************************************/
5469 /* Put an entry in staticvec, pointing at the variable with address
5473 staticpro (Lisp_Object
*varaddress
)
5475 if (staticidx
>= NSTATICS
)
5476 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5477 staticvec
[staticidx
++] = varaddress
;
5481 /***********************************************************************
5483 ***********************************************************************/
5485 /* Temporarily prevent garbage collection. */
5488 inhibit_garbage_collection (void)
5490 ptrdiff_t count
= SPECPDL_INDEX ();
5492 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5496 /* Used to avoid possible overflows when
5497 converting from C to Lisp integers. */
5500 bounded_number (EMACS_INT number
)
5502 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5505 /* Calculate total bytes of live objects. */
5508 total_bytes_of_live_objects (void)
5511 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5512 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5513 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5514 tot
+= total_string_bytes
;
5515 tot
+= total_vector_slots
* word_size
;
5516 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5517 tot
+= total_intervals
* sizeof (struct interval
);
5518 tot
+= total_strings
* sizeof (struct Lisp_String
);
5522 #ifdef HAVE_WINDOW_SYSTEM
5524 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5525 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5528 compact_font_cache_entry (Lisp_Object entry
)
5530 Lisp_Object tail
, *prev
= &entry
;
5532 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5535 Lisp_Object obj
= XCAR (tail
);
5537 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5538 if (CONSP (obj
) && GC_FONT_SPEC_P (XCAR (obj
))
5539 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj
)))
5540 /* Don't use VECTORP here, as that calls ASIZE, which could
5541 hit assertion violation during GC. */
5542 && (VECTORLIKEP (XCDR (obj
))
5543 && ! (gc_asize (XCDR (obj
)) & PSEUDOVECTOR_FLAG
)))
5545 ptrdiff_t i
, size
= gc_asize (XCDR (obj
));
5546 Lisp_Object obj_cdr
= XCDR (obj
);
5548 /* If font-spec is not marked, most likely all font-entities
5549 are not marked too. But we must be sure that nothing is
5550 marked within OBJ before we really drop it. */
5551 for (i
= 0; i
< size
; i
++)
5553 Lisp_Object objlist
;
5555 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr
, i
))))
5558 objlist
= AREF (AREF (obj_cdr
, i
), FONT_OBJLIST_INDEX
);
5559 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
5561 Lisp_Object val
= XCAR (objlist
);
5562 struct font
*font
= GC_XFONT_OBJECT (val
);
5564 if (!NILP (AREF (val
, FONT_TYPE_INDEX
))
5565 && VECTOR_MARKED_P(font
))
5568 if (CONSP (objlist
))
5570 /* Found a marked font, bail out. */
5577 /* No marked fonts were found, so this entire font
5578 entity can be dropped. */
5583 *prev
= XCDR (tail
);
5585 prev
= xcdr_addr (tail
);
5590 /* Compact font caches on all terminals and mark
5591 everything which is still here after compaction. */
5594 compact_font_caches (void)
5598 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5600 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5601 /* Inhibit compacting the caches if the user so wishes. Some of
5602 the users don't mind a larger memory footprint, but do mind
5603 slower redisplay. */
5604 if (!inhibit_compacting_font_caches
5609 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5610 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5612 mark_object (cache
);
5616 #else /* not HAVE_WINDOW_SYSTEM */
5618 #define compact_font_caches() (void)(0)
5620 #endif /* HAVE_WINDOW_SYSTEM */
5622 /* Remove (MARKER . DATA) entries with unmarked MARKER
5623 from buffer undo LIST and return changed list. */
5626 compact_undo_list (Lisp_Object list
)
5628 Lisp_Object tail
, *prev
= &list
;
5630 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5632 if (CONSP (XCAR (tail
))
5633 && MARKERP (XCAR (XCAR (tail
)))
5634 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5635 *prev
= XCDR (tail
);
5637 prev
= xcdr_addr (tail
);
5643 mark_pinned_symbols (void)
5645 struct symbol_block
*sblk
;
5646 int lim
= (symbol_block_pinned
== symbol_block
5647 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5649 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5651 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5652 for (; sym
< end
; ++sym
)
5654 mark_object (make_lisp_symbol (&sym
->s
));
5656 lim
= SYMBOL_BLOCK_SIZE
;
5660 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5661 separate function so that we could limit mark_stack in searching
5662 the stack frames below this function, thus avoiding the rare cases
5663 where mark_stack finds values that look like live Lisp objects on
5664 portions of stack that couldn't possibly contain such live objects.
5665 For more details of this, see the discussion at
5666 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5668 garbage_collect_1 (void *end
)
5670 struct buffer
*nextb
;
5671 char stack_top_variable
;
5674 ptrdiff_t count
= SPECPDL_INDEX ();
5675 struct timespec start
;
5676 Lisp_Object retval
= Qnil
;
5677 size_t tot_before
= 0;
5679 /* Can't GC if pure storage overflowed because we can't determine
5680 if something is a pure object or not. */
5681 if (pure_bytes_used_before_overflow
)
5684 /* Record this function, so it appears on the profiler's backtraces. */
5685 record_in_backtrace (QAutomatic_GC
, 0, 0);
5689 /* Don't keep undo information around forever.
5690 Do this early on, so it is no problem if the user quits. */
5691 FOR_EACH_BUFFER (nextb
)
5692 compact_buffer (nextb
);
5694 if (profiler_memory_running
)
5695 tot_before
= total_bytes_of_live_objects ();
5697 start
= current_timespec ();
5699 /* In case user calls debug_print during GC,
5700 don't let that cause a recursive GC. */
5701 consing_since_gc
= 0;
5703 /* Save what's currently displayed in the echo area. Don't do that
5704 if we are GC'ing because we've run out of memory, since
5705 push_message will cons, and we might have no memory for that. */
5706 if (NILP (Vmemory_full
))
5708 message_p
= push_message ();
5709 record_unwind_protect_void (pop_message_unwind
);
5714 /* Save a copy of the contents of the stack, for debugging. */
5715 #if MAX_SAVE_STACK > 0
5716 if (NILP (Vpurify_flag
))
5719 ptrdiff_t stack_size
;
5720 if (&stack_top_variable
< stack_bottom
)
5722 stack
= &stack_top_variable
;
5723 stack_size
= stack_bottom
- &stack_top_variable
;
5727 stack
= stack_bottom
;
5728 stack_size
= &stack_top_variable
- stack_bottom
;
5730 if (stack_size
<= MAX_SAVE_STACK
)
5732 if (stack_copy_size
< stack_size
)
5734 stack_copy
= xrealloc (stack_copy
, stack_size
);
5735 stack_copy_size
= stack_size
;
5737 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5740 #endif /* MAX_SAVE_STACK > 0 */
5742 if (garbage_collection_messages
)
5743 message1_nolog ("Garbage collecting...");
5747 shrink_regexp_cache ();
5751 /* Mark all the special slots that serve as the roots of accessibility. */
5753 mark_buffer (&buffer_defaults
);
5754 mark_buffer (&buffer_local_symbols
);
5756 for (i
= 0; i
< ARRAYELTS (lispsym
); i
++)
5757 mark_object (builtin_lisp_symbol (i
));
5759 for (i
= 0; i
< staticidx
; i
++)
5760 mark_object (*staticvec
[i
]);
5762 mark_pinned_symbols ();
5774 struct handler
*handler
;
5775 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5777 mark_object (handler
->tag_or_ch
);
5778 mark_object (handler
->val
);
5781 #ifdef HAVE_WINDOW_SYSTEM
5782 mark_fringe_data ();
5785 /* Everything is now marked, except for the data in font caches,
5786 undo lists, and finalizers. The first two are compacted by
5787 removing an items which aren't reachable otherwise. */
5789 compact_font_caches ();
5791 FOR_EACH_BUFFER (nextb
)
5793 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5794 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5795 /* Now that we have stripped the elements that need not be
5796 in the undo_list any more, we can finally mark the list. */
5797 mark_object (BVAR (nextb
, undo_list
));
5800 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5801 to doomed_finalizers so we can run their associated functions
5802 after GC. It's important to scan finalizers at this stage so
5803 that we can be sure that unmarked finalizers are really
5804 unreachable except for references from their associated functions
5805 and from other finalizers. */
5807 queue_doomed_finalizers (&doomed_finalizers
, &finalizers
);
5808 mark_finalizer_list (&doomed_finalizers
);
5812 /* Clear the mark bits that we set in certain root slots. */
5813 VECTOR_UNMARK (&buffer_defaults
);
5814 VECTOR_UNMARK (&buffer_local_symbols
);
5822 consing_since_gc
= 0;
5823 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5824 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5826 gc_relative_threshold
= 0;
5827 if (FLOATP (Vgc_cons_percentage
))
5828 { /* Set gc_cons_combined_threshold. */
5829 double tot
= total_bytes_of_live_objects ();
5831 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5834 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5835 gc_relative_threshold
= tot
;
5837 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5841 if (garbage_collection_messages
&& NILP (Vmemory_full
))
5843 if (message_p
|| minibuf_level
> 0)
5846 message1_nolog ("Garbage collecting...done");
5849 unbind_to (count
, Qnil
);
5851 Lisp_Object total
[] = {
5852 list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5853 bounded_number (total_conses
),
5854 bounded_number (total_free_conses
)),
5855 list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5856 bounded_number (total_symbols
),
5857 bounded_number (total_free_symbols
)),
5858 list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5859 bounded_number (total_markers
),
5860 bounded_number (total_free_markers
)),
5861 list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5862 bounded_number (total_strings
),
5863 bounded_number (total_free_strings
)),
5864 list3 (Qstring_bytes
, make_number (1),
5865 bounded_number (total_string_bytes
)),
5867 make_number (header_size
+ sizeof (Lisp_Object
)),
5868 bounded_number (total_vectors
)),
5869 list4 (Qvector_slots
, make_number (word_size
),
5870 bounded_number (total_vector_slots
),
5871 bounded_number (total_free_vector_slots
)),
5872 list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5873 bounded_number (total_floats
),
5874 bounded_number (total_free_floats
)),
5875 list4 (Qintervals
, make_number (sizeof (struct interval
)),
5876 bounded_number (total_intervals
),
5877 bounded_number (total_free_intervals
)),
5878 list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5879 bounded_number (total_buffers
)),
5881 #ifdef DOUG_LEA_MALLOC
5882 list4 (Qheap
, make_number (1024),
5883 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5884 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10)),
5887 retval
= CALLMANY (Flist
, total
);
5889 /* GC is complete: now we can run our finalizer callbacks. */
5890 run_finalizers (&doomed_finalizers
);
5892 if (!NILP (Vpost_gc_hook
))
5894 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5895 safe_run_hooks (Qpost_gc_hook
);
5896 unbind_to (gc_count
, Qnil
);
5899 /* Accumulate statistics. */
5900 if (FLOATP (Vgc_elapsed
))
5902 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5903 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5904 + timespectod (since_start
));
5909 /* Collect profiling data. */
5910 if (profiler_memory_running
)
5913 size_t tot_after
= total_bytes_of_live_objects ();
5914 if (tot_before
> tot_after
)
5915 swept
= tot_before
- tot_after
;
5916 malloc_probe (swept
);
5922 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5923 doc
: /* Reclaim storage for Lisp objects no longer needed.
5924 Garbage collection happens automatically if you cons more than
5925 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5926 `garbage-collect' normally returns a list with info on amount of space in use,
5927 where each entry has the form (NAME SIZE USED FREE), where:
5928 - NAME is a symbol describing the kind of objects this entry represents,
5929 - SIZE is the number of bytes used by each one,
5930 - USED is the number of those objects that were found live in the heap,
5931 - FREE is the number of those objects that are not live but that Emacs
5932 keeps around for future allocations (maybe because it does not know how
5933 to return them to the OS).
5934 However, if there was overflow in pure space, `garbage-collect'
5935 returns nil, because real GC can't be done.
5936 See Info node `(elisp)Garbage Collection'. */)
5941 #ifdef HAVE___BUILTIN_UNWIND_INIT
5942 /* Force callee-saved registers and register windows onto the stack.
5943 This is the preferred method if available, obviating the need for
5944 machine dependent methods. */
5945 __builtin_unwind_init ();
5947 #else /* not HAVE___BUILTIN_UNWIND_INIT */
5948 #ifndef GC_SAVE_REGISTERS_ON_STACK
5949 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5950 union aligned_jmpbuf
{
5954 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
5956 /* This trick flushes the register windows so that all the state of
5957 the process is contained in the stack. */
5958 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5959 needed on ia64 too. See mach_dep.c, where it also says inline
5960 assembler doesn't work with relevant proprietary compilers. */
5962 #if defined (__sparc64__) && defined (__FreeBSD__)
5963 /* FreeBSD does not have a ta 3 handler. */
5970 /* Save registers that we need to see on the stack. We need to see
5971 registers used to hold register variables and registers used to
5973 #ifdef GC_SAVE_REGISTERS_ON_STACK
5974 GC_SAVE_REGISTERS_ON_STACK (end
);
5975 #else /* not GC_SAVE_REGISTERS_ON_STACK */
5977 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5978 setjmp will definitely work, test it
5979 and print a message with the result
5981 if (!setjmp_tested_p
)
5983 setjmp_tested_p
= 1;
5986 #endif /* GC_SETJMP_WORKS */
5989 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
5990 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
5991 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
5992 return garbage_collect_1 (end
);
5995 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5996 only interesting objects referenced from glyphs are strings. */
5999 mark_glyph_matrix (struct glyph_matrix
*matrix
)
6001 struct glyph_row
*row
= matrix
->rows
;
6002 struct glyph_row
*end
= row
+ matrix
->nrows
;
6004 for (; row
< end
; ++row
)
6008 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
6010 struct glyph
*glyph
= row
->glyphs
[area
];
6011 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
6013 for (; glyph
< end_glyph
; ++glyph
)
6014 if (STRINGP (glyph
->object
)
6015 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
6016 mark_object (glyph
->object
);
6021 /* Mark reference to a Lisp_Object.
6022 If the object referred to has not been seen yet, recursively mark
6023 all the references contained in it. */
6025 #define LAST_MARKED_SIZE 500
6026 Lisp_Object last_marked
[LAST_MARKED_SIZE
] EXTERNALLY_VISIBLE
;
6027 static int last_marked_index
;
6029 /* For debugging--call abort when we cdr down this many
6030 links of a list, in mark_object. In debugging,
6031 the call to abort will hit a breakpoint.
6032 Normally this is zero and the check never goes off. */
6033 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
6036 mark_vectorlike (struct Lisp_Vector
*ptr
)
6038 ptrdiff_t size
= ptr
->header
.size
;
6041 eassert (!VECTOR_MARKED_P (ptr
));
6042 VECTOR_MARK (ptr
); /* Else mark it. */
6043 if (size
& PSEUDOVECTOR_FLAG
)
6044 size
&= PSEUDOVECTOR_SIZE_MASK
;
6046 /* Note that this size is not the memory-footprint size, but only
6047 the number of Lisp_Object fields that we should trace.
6048 The distinction is used e.g. by Lisp_Process which places extra
6049 non-Lisp_Object fields at the end of the structure... */
6050 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
6051 mark_object (ptr
->contents
[i
]);
6054 /* Like mark_vectorlike but optimized for char-tables (and
6055 sub-char-tables) assuming that the contents are mostly integers or
6059 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
6061 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6062 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
6063 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
6065 eassert (!VECTOR_MARKED_P (ptr
));
6067 for (i
= idx
; i
< size
; i
++)
6069 Lisp_Object val
= ptr
->contents
[i
];
6071 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
6073 if (SUB_CHAR_TABLE_P (val
))
6075 if (! VECTOR_MARKED_P (XVECTOR (val
)))
6076 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
6083 NO_INLINE
/* To reduce stack depth in mark_object. */
6085 mark_compiled (struct Lisp_Vector
*ptr
)
6087 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6090 for (i
= 0; i
< size
; i
++)
6091 if (i
!= COMPILED_CONSTANTS
)
6092 mark_object (ptr
->contents
[i
]);
6093 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6096 /* Mark the chain of overlays starting at PTR. */
6099 mark_overlay (struct Lisp_Overlay
*ptr
)
6101 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6104 /* These two are always markers and can be marked fast. */
6105 XMARKER (ptr
->start
)->gcmarkbit
= 1;
6106 XMARKER (ptr
->end
)->gcmarkbit
= 1;
6107 mark_object (ptr
->plist
);
6111 /* Mark Lisp_Objects and special pointers in BUFFER. */
6114 mark_buffer (struct buffer
*buffer
)
6116 /* This is handled much like other pseudovectors... */
6117 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6119 /* ...but there are some buffer-specific things. */
6121 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6123 /* For now, we just don't mark the undo_list. It's done later in
6124 a special way just before the sweep phase, and after stripping
6125 some of its elements that are not needed any more. */
6127 mark_overlay (buffer
->overlays_before
);
6128 mark_overlay (buffer
->overlays_after
);
6130 /* If this is an indirect buffer, mark its base buffer. */
6131 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6132 mark_buffer (buffer
->base_buffer
);
6135 /* Mark Lisp faces in the face cache C. */
6137 NO_INLINE
/* To reduce stack depth in mark_object. */
6139 mark_face_cache (struct face_cache
*c
)
6144 for (i
= 0; i
< c
->used
; ++i
)
6146 struct face
*face
= FACE_FROM_ID_OR_NULL (c
->f
, i
);
6150 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6151 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6153 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6154 mark_object (face
->lface
[j
]);
6160 NO_INLINE
/* To reduce stack depth in mark_object. */
6162 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6164 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6165 Lisp_Object where
= blv
->where
;
6166 /* If the value is set up for a killed buffer or deleted
6167 frame, restore its global binding. If the value is
6168 forwarded to a C variable, either it's not a Lisp_Object
6169 var, or it's staticpro'd already. */
6170 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6171 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6172 swap_in_global_binding (ptr
);
6173 mark_object (blv
->where
);
6174 mark_object (blv
->valcell
);
6175 mark_object (blv
->defcell
);
6178 NO_INLINE
/* To reduce stack depth in mark_object. */
6180 mark_save_value (struct Lisp_Save_Value
*ptr
)
6182 /* If `save_type' is zero, `data[0].pointer' is the address
6183 of a memory area containing `data[1].integer' potential
6185 if (ptr
->save_type
== SAVE_TYPE_MEMORY
)
6187 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6189 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6190 mark_maybe_object (*p
);
6194 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6196 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6197 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6198 mark_object (ptr
->data
[i
].object
);
6202 /* Remove killed buffers or items whose car is a killed buffer from
6203 LIST, and mark other items. Return changed LIST, which is marked. */
6206 mark_discard_killed_buffers (Lisp_Object list
)
6208 Lisp_Object tail
, *prev
= &list
;
6210 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6213 Lisp_Object tem
= XCAR (tail
);
6216 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6217 *prev
= XCDR (tail
);
6220 CONS_MARK (XCONS (tail
));
6221 mark_object (XCAR (tail
));
6222 prev
= xcdr_addr (tail
);
6229 /* Determine type of generic Lisp_Object and mark it accordingly.
6231 This function implements a straightforward depth-first marking
6232 algorithm and so the recursion depth may be very high (a few
6233 tens of thousands is not uncommon). To minimize stack usage,
6234 a few cold paths are moved out to NO_INLINE functions above.
6235 In general, inlining them doesn't help you to gain more speed. */
6238 mark_object (Lisp_Object arg
)
6240 register Lisp_Object obj
;
6242 #ifdef GC_CHECK_MARKED_OBJECTS
6245 ptrdiff_t cdr_count
= 0;
6254 last_marked
[last_marked_index
++] = obj
;
6255 if (last_marked_index
== LAST_MARKED_SIZE
)
6256 last_marked_index
= 0;
6258 /* Perform some sanity checks on the objects marked here. Abort if
6259 we encounter an object we know is bogus. This increases GC time
6261 #ifdef GC_CHECK_MARKED_OBJECTS
6263 /* Check that the object pointed to by PO is known to be a Lisp
6264 structure allocated from the heap. */
6265 #define CHECK_ALLOCATED() \
6267 m = mem_find (po); \
6272 /* Check that the object pointed to by PO is live, using predicate
6274 #define CHECK_LIVE(LIVEP) \
6276 if (!LIVEP (m, po)) \
6280 /* Check both of the above conditions, for non-symbols. */
6281 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6283 CHECK_ALLOCATED (); \
6284 CHECK_LIVE (LIVEP); \
6287 /* Check both of the above conditions, for symbols. */
6288 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6290 if (!c_symbol_p (ptr)) \
6292 CHECK_ALLOCATED (); \
6293 CHECK_LIVE (live_symbol_p); \
6297 #else /* not GC_CHECK_MARKED_OBJECTS */
6299 #define CHECK_LIVE(LIVEP) ((void) 0)
6300 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6301 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6303 #endif /* not GC_CHECK_MARKED_OBJECTS */
6305 switch (XTYPE (obj
))
6309 register struct Lisp_String
*ptr
= XSTRING (obj
);
6310 if (STRING_MARKED_P (ptr
))
6312 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6314 MARK_INTERVAL_TREE (ptr
->intervals
);
6315 #ifdef GC_CHECK_STRING_BYTES
6316 /* Check that the string size recorded in the string is the
6317 same as the one recorded in the sdata structure. */
6319 #endif /* GC_CHECK_STRING_BYTES */
6323 case Lisp_Vectorlike
:
6325 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6326 register ptrdiff_t pvectype
;
6328 if (VECTOR_MARKED_P (ptr
))
6331 #ifdef GC_CHECK_MARKED_OBJECTS
6333 if (m
== MEM_NIL
&& !SUBRP (obj
))
6335 #endif /* GC_CHECK_MARKED_OBJECTS */
6337 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6338 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6339 >> PSEUDOVECTOR_AREA_BITS
);
6341 pvectype
= PVEC_NORMAL_VECTOR
;
6343 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6344 CHECK_LIVE (live_vector_p
);
6349 #ifdef GC_CHECK_MARKED_OBJECTS
6358 #endif /* GC_CHECK_MARKED_OBJECTS */
6359 mark_buffer ((struct buffer
*) ptr
);
6363 /* Although we could treat this just like a vector, mark_compiled
6364 returns the COMPILED_CONSTANTS element, which is marked at the
6365 next iteration of goto-loop here. This is done to avoid a few
6366 recursive calls to mark_object. */
6367 obj
= mark_compiled (ptr
);
6374 struct frame
*f
= (struct frame
*) ptr
;
6376 mark_vectorlike (ptr
);
6377 mark_face_cache (f
->face_cache
);
6378 #ifdef HAVE_WINDOW_SYSTEM
6379 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6381 struct font
*font
= FRAME_FONT (f
);
6383 if (font
&& !VECTOR_MARKED_P (font
))
6384 mark_vectorlike ((struct Lisp_Vector
*) font
);
6392 struct window
*w
= (struct window
*) ptr
;
6394 mark_vectorlike (ptr
);
6396 /* Mark glyph matrices, if any. Marking window
6397 matrices is sufficient because frame matrices
6398 use the same glyph memory. */
6399 if (w
->current_matrix
)
6401 mark_glyph_matrix (w
->current_matrix
);
6402 mark_glyph_matrix (w
->desired_matrix
);
6405 /* Filter out killed buffers from both buffer lists
6406 in attempt to help GC to reclaim killed buffers faster.
6407 We can do it elsewhere for live windows, but this is the
6408 best place to do it for dead windows. */
6410 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6412 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6416 case PVEC_HASH_TABLE
:
6418 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6420 mark_vectorlike (ptr
);
6421 mark_object (h
->test
.name
);
6422 mark_object (h
->test
.user_hash_function
);
6423 mark_object (h
->test
.user_cmp_function
);
6424 /* If hash table is not weak, mark all keys and values.
6425 For weak tables, mark only the vector. */
6427 mark_object (h
->key_and_value
);
6429 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6433 case PVEC_CHAR_TABLE
:
6434 case PVEC_SUB_CHAR_TABLE
:
6435 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6438 case PVEC_BOOL_VECTOR
:
6439 /* No Lisp_Objects to mark in a bool vector. */
6450 mark_vectorlike (ptr
);
6457 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6461 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6463 /* Attempt to catch bogus objects. */
6464 eassert (valid_lisp_object_p (ptr
->function
));
6465 mark_object (ptr
->function
);
6466 mark_object (ptr
->plist
);
6467 switch (ptr
->redirect
)
6469 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6470 case SYMBOL_VARALIAS
:
6473 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6477 case SYMBOL_LOCALIZED
:
6478 mark_localized_symbol (ptr
);
6480 case SYMBOL_FORWARDED
:
6481 /* If the value is forwarded to a buffer or keyboard field,
6482 these are marked when we see the corresponding object.
6483 And if it's forwarded to a C variable, either it's not
6484 a Lisp_Object var, or it's staticpro'd already. */
6486 default: emacs_abort ();
6488 if (!PURE_P (XSTRING (ptr
->name
)))
6489 MARK_STRING (XSTRING (ptr
->name
));
6490 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6491 /* Inner loop to mark next symbol in this bucket, if any. */
6492 po
= ptr
= ptr
->next
;
6499 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6501 if (XMISCANY (obj
)->gcmarkbit
)
6504 switch (XMISCTYPE (obj
))
6506 case Lisp_Misc_Marker
:
6507 /* DO NOT mark thru the marker's chain.
6508 The buffer's markers chain does not preserve markers from gc;
6509 instead, markers are removed from the chain when freed by gc. */
6510 XMISCANY (obj
)->gcmarkbit
= 1;
6513 case Lisp_Misc_Save_Value
:
6514 XMISCANY (obj
)->gcmarkbit
= 1;
6515 mark_save_value (XSAVE_VALUE (obj
));
6518 case Lisp_Misc_Overlay
:
6519 mark_overlay (XOVERLAY (obj
));
6522 case Lisp_Misc_Finalizer
:
6523 XMISCANY (obj
)->gcmarkbit
= true;
6524 mark_object (XFINALIZER (obj
)->function
);
6528 case Lisp_Misc_User_Ptr
:
6529 XMISCANY (obj
)->gcmarkbit
= true;
6540 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6541 if (CONS_MARKED_P (ptr
))
6543 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6545 /* If the cdr is nil, avoid recursion for the car. */
6546 if (EQ (ptr
->u
.cdr
, Qnil
))
6552 mark_object (ptr
->car
);
6555 if (cdr_count
== mark_object_loop_halt
)
6561 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6562 FLOAT_MARK (XFLOAT (obj
));
6573 #undef CHECK_ALLOCATED
6574 #undef CHECK_ALLOCATED_AND_LIVE
6576 /* Mark the Lisp pointers in the terminal objects.
6577 Called by Fgarbage_collect. */
6580 mark_terminals (void)
6583 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6585 eassert (t
->name
!= NULL
);
6586 #ifdef HAVE_WINDOW_SYSTEM
6587 /* If a terminal object is reachable from a stacpro'ed object,
6588 it might have been marked already. Make sure the image cache
6590 mark_image_cache (t
->image_cache
);
6591 #endif /* HAVE_WINDOW_SYSTEM */
6592 if (!VECTOR_MARKED_P (t
))
6593 mark_vectorlike ((struct Lisp_Vector
*)t
);
6599 /* Value is non-zero if OBJ will survive the current GC because it's
6600 either marked or does not need to be marked to survive. */
6603 survives_gc_p (Lisp_Object obj
)
6607 switch (XTYPE (obj
))
6614 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6618 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6622 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6625 case Lisp_Vectorlike
:
6626 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6630 survives_p
= CONS_MARKED_P (XCONS (obj
));
6634 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6641 return survives_p
|| PURE_P (XPNTR (obj
));
6647 NO_INLINE
/* For better stack traces */
6651 struct cons_block
*cblk
;
6652 struct cons_block
**cprev
= &cons_block
;
6653 int lim
= cons_block_index
;
6654 EMACS_INT num_free
= 0, num_used
= 0;
6658 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6662 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6664 /* Scan the mark bits an int at a time. */
6665 for (i
= 0; i
< ilim
; i
++)
6667 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6669 /* Fast path - all cons cells for this int are marked. */
6670 cblk
->gcmarkbits
[i
] = 0;
6671 num_used
+= BITS_PER_BITS_WORD
;
6675 /* Some cons cells for this int are not marked.
6676 Find which ones, and free them. */
6677 int start
, pos
, stop
;
6679 start
= i
* BITS_PER_BITS_WORD
;
6681 if (stop
> BITS_PER_BITS_WORD
)
6682 stop
= BITS_PER_BITS_WORD
;
6685 for (pos
= start
; pos
< stop
; pos
++)
6687 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6690 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6691 cons_free_list
= &cblk
->conses
[pos
];
6692 cons_free_list
->car
= Vdead
;
6697 CONS_UNMARK (&cblk
->conses
[pos
]);
6703 lim
= CONS_BLOCK_SIZE
;
6704 /* If this block contains only free conses and we have already
6705 seen more than two blocks worth of free conses then deallocate
6707 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6709 *cprev
= cblk
->next
;
6710 /* Unhook from the free list. */
6711 cons_free_list
= cblk
->conses
[0].u
.chain
;
6712 lisp_align_free (cblk
);
6716 num_free
+= this_free
;
6717 cprev
= &cblk
->next
;
6720 total_conses
= num_used
;
6721 total_free_conses
= num_free
;
6724 NO_INLINE
/* For better stack traces */
6728 register struct float_block
*fblk
;
6729 struct float_block
**fprev
= &float_block
;
6730 register int lim
= float_block_index
;
6731 EMACS_INT num_free
= 0, num_used
= 0;
6733 float_free_list
= 0;
6735 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6739 for (i
= 0; i
< lim
; i
++)
6740 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6743 fblk
->floats
[i
].u
.chain
= float_free_list
;
6744 float_free_list
= &fblk
->floats
[i
];
6749 FLOAT_UNMARK (&fblk
->floats
[i
]);
6751 lim
= FLOAT_BLOCK_SIZE
;
6752 /* If this block contains only free floats and we have already
6753 seen more than two blocks worth of free floats then deallocate
6755 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6757 *fprev
= fblk
->next
;
6758 /* Unhook from the free list. */
6759 float_free_list
= fblk
->floats
[0].u
.chain
;
6760 lisp_align_free (fblk
);
6764 num_free
+= this_free
;
6765 fprev
= &fblk
->next
;
6768 total_floats
= num_used
;
6769 total_free_floats
= num_free
;
6772 NO_INLINE
/* For better stack traces */
6774 sweep_intervals (void)
6776 register struct interval_block
*iblk
;
6777 struct interval_block
**iprev
= &interval_block
;
6778 register int lim
= interval_block_index
;
6779 EMACS_INT num_free
= 0, num_used
= 0;
6781 interval_free_list
= 0;
6783 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6788 for (i
= 0; i
< lim
; i
++)
6790 if (!iblk
->intervals
[i
].gcmarkbit
)
6792 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6793 interval_free_list
= &iblk
->intervals
[i
];
6799 iblk
->intervals
[i
].gcmarkbit
= 0;
6802 lim
= INTERVAL_BLOCK_SIZE
;
6803 /* If this block contains only free intervals and we have already
6804 seen more than two blocks worth of free intervals then
6805 deallocate this block. */
6806 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6808 *iprev
= iblk
->next
;
6809 /* Unhook from the free list. */
6810 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6815 num_free
+= this_free
;
6816 iprev
= &iblk
->next
;
6819 total_intervals
= num_used
;
6820 total_free_intervals
= num_free
;
6823 NO_INLINE
/* For better stack traces */
6825 sweep_symbols (void)
6827 struct symbol_block
*sblk
;
6828 struct symbol_block
**sprev
= &symbol_block
;
6829 int lim
= symbol_block_index
;
6830 EMACS_INT num_free
= 0, num_used
= ARRAYELTS (lispsym
);
6832 symbol_free_list
= NULL
;
6834 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
6835 lispsym
[i
].gcmarkbit
= 0;
6837 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6840 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6841 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6843 for (; sym
< end
; ++sym
)
6845 if (!sym
->s
.gcmarkbit
)
6847 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6848 xfree (SYMBOL_BLV (&sym
->s
));
6849 sym
->s
.next
= symbol_free_list
;
6850 symbol_free_list
= &sym
->s
;
6851 symbol_free_list
->function
= Vdead
;
6857 sym
->s
.gcmarkbit
= 0;
6858 /* Attempt to catch bogus objects. */
6859 eassert (valid_lisp_object_p (sym
->s
.function
));
6863 lim
= SYMBOL_BLOCK_SIZE
;
6864 /* If this block contains only free symbols and we have already
6865 seen more than two blocks worth of free symbols then deallocate
6867 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6869 *sprev
= sblk
->next
;
6870 /* Unhook from the free list. */
6871 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6876 num_free
+= this_free
;
6877 sprev
= &sblk
->next
;
6880 total_symbols
= num_used
;
6881 total_free_symbols
= num_free
;
6884 NO_INLINE
/* For better stack traces. */
6888 register struct marker_block
*mblk
;
6889 struct marker_block
**mprev
= &marker_block
;
6890 register int lim
= marker_block_index
;
6891 EMACS_INT num_free
= 0, num_used
= 0;
6893 /* Put all unmarked misc's on free list. For a marker, first
6894 unchain it from the buffer it points into. */
6896 marker_free_list
= 0;
6898 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6903 for (i
= 0; i
< lim
; i
++)
6905 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6907 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6908 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6909 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Finalizer
)
6910 unchain_finalizer (&mblk
->markers
[i
].m
.u_finalizer
);
6912 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_User_Ptr
)
6914 struct Lisp_User_Ptr
*uptr
= &mblk
->markers
[i
].m
.u_user_ptr
;
6915 if (uptr
->finalizer
)
6916 uptr
->finalizer (uptr
->p
);
6919 /* Set the type of the freed object to Lisp_Misc_Free.
6920 We could leave the type alone, since nobody checks it,
6921 but this might catch bugs faster. */
6922 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6923 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6924 marker_free_list
= &mblk
->markers
[i
].m
;
6930 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6933 lim
= MARKER_BLOCK_SIZE
;
6934 /* If this block contains only free markers and we have already
6935 seen more than two blocks worth of free markers then deallocate
6937 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6939 *mprev
= mblk
->next
;
6940 /* Unhook from the free list. */
6941 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6946 num_free
+= this_free
;
6947 mprev
= &mblk
->next
;
6951 total_markers
= num_used
;
6952 total_free_markers
= num_free
;
6955 NO_INLINE
/* For better stack traces */
6957 sweep_buffers (void)
6959 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6962 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6963 if (!VECTOR_MARKED_P (buffer
))
6965 *bprev
= buffer
->next
;
6970 VECTOR_UNMARK (buffer
);
6971 /* Do not use buffer_(set|get)_intervals here. */
6972 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6974 bprev
= &buffer
->next
;
6978 /* Sweep: find all structures not marked, and free them. */
6982 /* Remove or mark entries in weak hash tables.
6983 This must be done before any object is unmarked. */
6984 sweep_weak_hash_tables ();
6987 check_string_bytes (!noninteractive
);
6995 check_string_bytes (!noninteractive
);
6998 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
6999 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
7000 All values are in Kbytes. If there is no swap space,
7001 last two values are zero. If the system is not supported
7002 or memory information can't be obtained, return nil. */)
7005 #if defined HAVE_LINUX_SYSINFO
7011 #ifdef LINUX_SYSINFO_UNIT
7012 units
= si
.mem_unit
;
7016 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
7017 (uintmax_t) si
.freeram
* units
/ 1024,
7018 (uintmax_t) si
.totalswap
* units
/ 1024,
7019 (uintmax_t) si
.freeswap
* units
/ 1024);
7020 #elif defined WINDOWSNT
7021 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
7023 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7024 return list4i ((uintmax_t) totalram
/ 1024,
7025 (uintmax_t) freeram
/ 1024,
7026 (uintmax_t) totalswap
/ 1024,
7027 (uintmax_t) freeswap
/ 1024);
7031 unsigned long totalram
, freeram
, totalswap
, freeswap
;
7033 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7034 return list4i ((uintmax_t) totalram
/ 1024,
7035 (uintmax_t) freeram
/ 1024,
7036 (uintmax_t) totalswap
/ 1024,
7037 (uintmax_t) freeswap
/ 1024);
7040 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7041 /* FIXME: add more systems. */
7043 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7046 /* Debugging aids. */
7048 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
7049 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
7050 This may be helpful in debugging Emacs's memory usage.
7051 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
7057 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
7060 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
7066 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
7067 doc
: /* Return a list of counters that measure how much consing there has been.
7068 Each of these counters increments for a certain kind of object.
7069 The counters wrap around from the largest positive integer to zero.
7070 Garbage collection does not decrease them.
7071 The elements of the value are as follows:
7072 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
7073 All are in units of 1 = one object consed
7074 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
7076 MISCS include overlays, markers, and some internal types.
7077 Frames, windows, buffers, and subprocesses count as vectors
7078 (but the contents of a buffer's text do not count here). */)
7081 return listn (CONSTYPE_HEAP
, 8,
7082 bounded_number (cons_cells_consed
),
7083 bounded_number (floats_consed
),
7084 bounded_number (vector_cells_consed
),
7085 bounded_number (symbols_consed
),
7086 bounded_number (string_chars_consed
),
7087 bounded_number (misc_objects_consed
),
7088 bounded_number (intervals_consed
),
7089 bounded_number (strings_consed
));
7093 symbol_uses_obj (Lisp_Object symbol
, Lisp_Object obj
)
7095 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
7096 Lisp_Object val
= find_symbol_value (symbol
);
7097 return (EQ (val
, obj
)
7098 || EQ (sym
->function
, obj
)
7099 || (!NILP (sym
->function
)
7100 && COMPILEDP (sym
->function
)
7101 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
7104 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)));
7107 /* Find at most FIND_MAX symbols which have OBJ as their value or
7108 function. This is used in gdbinit's `xwhichsymbols' command. */
7111 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
7113 struct symbol_block
*sblk
;
7114 ptrdiff_t gc_count
= inhibit_garbage_collection ();
7115 Lisp_Object found
= Qnil
;
7119 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
7121 Lisp_Object sym
= builtin_lisp_symbol (i
);
7122 if (symbol_uses_obj (sym
, obj
))
7124 found
= Fcons (sym
, found
);
7125 if (--find_max
== 0)
7130 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7132 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
7135 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
7137 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7140 Lisp_Object sym
= make_lisp_symbol (&aligned_sym
->s
);
7141 if (symbol_uses_obj (sym
, obj
))
7143 found
= Fcons (sym
, found
);
7144 if (--find_max
== 0)
7152 unbind_to (gc_count
, Qnil
);
7156 #ifdef SUSPICIOUS_OBJECT_CHECKING
7159 find_suspicious_object_in_range (void *begin
, void *end
)
7161 char *begin_a
= begin
;
7165 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7167 char *suspicious_object
= suspicious_objects
[i
];
7168 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7169 return suspicious_object
;
7176 note_suspicious_free (void* ptr
)
7178 struct suspicious_free_record
* rec
;
7180 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7181 if (suspicious_free_history_index
==
7182 ARRAYELTS (suspicious_free_history
))
7184 suspicious_free_history_index
= 0;
7187 memset (rec
, 0, sizeof (*rec
));
7188 rec
->suspicious_object
= ptr
;
7189 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7193 detect_suspicious_free (void* ptr
)
7197 eassert (ptr
!= NULL
);
7199 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7200 if (suspicious_objects
[i
] == ptr
)
7202 note_suspicious_free (ptr
);
7203 suspicious_objects
[i
] = NULL
;
7207 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7209 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7210 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7211 If Emacs is compiled with suspicious object checking, capture
7212 a stack trace when OBJ is freed in order to help track down
7213 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7216 #ifdef SUSPICIOUS_OBJECT_CHECKING
7217 /* Right now, we care only about vectors. */
7218 if (VECTORLIKEP (obj
))
7220 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7221 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7222 suspicious_object_index
= 0;
7228 #ifdef ENABLE_CHECKING
7230 bool suppress_checking
;
7233 die (const char *msg
, const char *file
, int line
)
7235 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7237 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7240 #endif /* ENABLE_CHECKING */
7242 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7244 /* Stress alloca with inconveniently sized requests and check
7245 whether all allocated areas may be used for Lisp_Object. */
7247 NO_INLINE
static void
7248 verify_alloca (void)
7251 enum { ALLOCA_CHECK_MAX
= 256 };
7252 /* Start from size of the smallest Lisp object. */
7253 for (i
= sizeof (struct Lisp_Cons
); i
<= ALLOCA_CHECK_MAX
; i
++)
7255 void *ptr
= alloca (i
);
7256 make_lisp_ptr (ptr
, Lisp_Cons
);
7260 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7262 #define verify_alloca() ((void) 0)
7264 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7266 /* Initialization. */
7269 init_alloc_once (void)
7271 /* Even though Qt's contents are not set up, its address is known. */
7275 pure_size
= PURESIZE
;
7278 init_finalizer_list (&finalizers
);
7279 init_finalizer_list (&doomed_finalizers
);
7282 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7284 #ifdef DOUG_LEA_MALLOC
7285 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7286 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7287 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7292 refill_memory_reserve ();
7293 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7299 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7300 setjmp_tested_p
= longjmps_done
= 0;
7302 Vgc_elapsed
= make_float (0.0);
7306 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7311 syms_of_alloc (void)
7313 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7314 doc
: /* Number of bytes of consing between garbage collections.
7315 Garbage collection can happen automatically once this many bytes have been
7316 allocated since the last garbage collection. All data types count.
7318 Garbage collection happens automatically only when `eval' is called.
7320 By binding this temporarily to a large number, you can effectively
7321 prevent garbage collection during a part of the program.
7322 See also `gc-cons-percentage'. */);
7324 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7325 doc
: /* Portion of the heap used for allocation.
7326 Garbage collection can happen automatically once this portion of the heap
7327 has been allocated since the last garbage collection.
7328 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7329 Vgc_cons_percentage
= make_float (0.1);
7331 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7332 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7334 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7335 doc
: /* Number of cons cells that have been consed so far. */);
7337 DEFVAR_INT ("floats-consed", floats_consed
,
7338 doc
: /* Number of floats that have been consed so far. */);
7340 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7341 doc
: /* Number of vector cells that have been consed so far. */);
7343 DEFVAR_INT ("symbols-consed", symbols_consed
,
7344 doc
: /* Number of symbols that have been consed so far. */);
7345 symbols_consed
+= ARRAYELTS (lispsym
);
7347 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7348 doc
: /* Number of string characters that have been consed so far. */);
7350 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7351 doc
: /* Number of miscellaneous objects that have been consed so far.
7352 These include markers and overlays, plus certain objects not visible
7355 DEFVAR_INT ("intervals-consed", intervals_consed
,
7356 doc
: /* Number of intervals that have been consed so far. */);
7358 DEFVAR_INT ("strings-consed", strings_consed
,
7359 doc
: /* Number of strings that have been consed so far. */);
7361 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7362 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7363 This means that certain objects should be allocated in shared (pure) space.
7364 It can also be set to a hash-table, in which case this table is used to
7365 do hash-consing of the objects allocated to pure space. */);
7367 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7368 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7369 garbage_collection_messages
= 0;
7371 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7372 doc
: /* Hook run after garbage collection has finished. */);
7373 Vpost_gc_hook
= Qnil
;
7374 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7376 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7377 doc
: /* Precomputed `signal' argument for memory-full error. */);
7378 /* We build this in advance because if we wait until we need it, we might
7379 not be able to allocate the memory to hold it. */
7381 = listn (CONSTYPE_PURE
, 2, Qerror
,
7382 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7384 DEFVAR_LISP ("memory-full", Vmemory_full
,
7385 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7386 Vmemory_full
= Qnil
;
7388 DEFSYM (Qconses
, "conses");
7389 DEFSYM (Qsymbols
, "symbols");
7390 DEFSYM (Qmiscs
, "miscs");
7391 DEFSYM (Qstrings
, "strings");
7392 DEFSYM (Qvectors
, "vectors");
7393 DEFSYM (Qfloats
, "floats");
7394 DEFSYM (Qintervals
, "intervals");
7395 DEFSYM (Qbuffers
, "buffers");
7396 DEFSYM (Qstring_bytes
, "string-bytes");
7397 DEFSYM (Qvector_slots
, "vector-slots");
7398 DEFSYM (Qheap
, "heap");
7399 DEFSYM (QAutomatic_GC
, "Automatic GC");
7401 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7402 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7404 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7405 doc
: /* Accumulated time elapsed in garbage collections.
7406 The time is in seconds as a floating point value. */);
7407 DEFVAR_INT ("gcs-done", gcs_done
,
7408 doc
: /* Accumulated number of garbage collections done. */);
7413 defsubr (&Sbool_vector
);
7414 defsubr (&Smake_byte_code
);
7415 defsubr (&Smake_list
);
7416 defsubr (&Smake_vector
);
7417 defsubr (&Smake_string
);
7418 defsubr (&Smake_bool_vector
);
7419 defsubr (&Smake_symbol
);
7420 defsubr (&Smake_marker
);
7421 defsubr (&Smake_finalizer
);
7422 defsubr (&Spurecopy
);
7423 defsubr (&Sgarbage_collect
);
7424 defsubr (&Smemory_limit
);
7425 defsubr (&Smemory_info
);
7426 defsubr (&Smemory_use_counts
);
7427 defsubr (&Ssuspicious_object
);
7430 /* When compiled with GCC, GDB might say "No enum type named
7431 pvec_type" if we don't have at least one symbol with that type, and
7432 then xbacktrace could fail. Similarly for the other enums and
7433 their values. Some non-GCC compilers don't like these constructs. */
7437 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7438 enum char_table_specials char_table_specials
;
7439 enum char_bits char_bits
;
7440 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7441 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7442 enum Lisp_Bits Lisp_Bits
;
7443 enum Lisp_Compiled Lisp_Compiled
;
7444 enum maxargs maxargs
;
7445 enum MAX_ALLOCA MAX_ALLOCA
;
7446 enum More_Lisp_Bits More_Lisp_Bits
;
7447 enum pvec_type pvec_type
;
7448 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7449 #endif /* __GNUC__ */