1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
24 #include <limits.h> /* For CHAR_BIT. */
26 #ifdef ENABLE_CHECKING
27 #include <signal.h> /* For SIGABRT. */
35 #include "dispextern.h"
36 #include "intervals.h"
39 #include "character.h"
44 #include "blockinput.h"
45 #include "termhooks.h" /* For struct terminal. */
46 #ifdef HAVE_WINDOW_SYSTEM
48 #endif /* HAVE_WINDOW_SYSTEM */
51 #include <execinfo.h> /* For backtrace. */
53 #ifdef HAVE_LINUX_SYSINFO
54 #include <sys/sysinfo.h>
58 #include "dosfns.h" /* For dos_memory_info. */
61 #if (defined ENABLE_CHECKING \
62 && defined HAVE_VALGRIND_VALGRIND_H \
63 && !defined USE_VALGRIND)
64 # define USE_VALGRIND 1
68 #include <valgrind/valgrind.h>
69 #include <valgrind/memcheck.h>
70 static bool valgrind_p
;
73 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */
75 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
76 memory. Can do this only if using gmalloc.c and if not checking
79 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
80 || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
81 #undef GC_MALLOC_CHECK
92 #include "w32heap.h" /* for sbrk */
95 #if defined DOUG_LEA_MALLOC || defined GNU_LINUX
96 /* The address where the heap starts. */
107 #ifdef DOUG_LEA_MALLOC
111 /* Specify maximum number of areas to mmap. It would be nice to use a
112 value that explicitly means "no limit". */
114 #define MMAP_MAX_AREAS 100000000
116 /* A pointer to the memory allocated that copies that static data
117 inside glibc's malloc. */
118 static void *malloc_state_ptr
;
120 /* Get and free this pointer; useful around unexec. */
122 alloc_unexec_pre (void)
124 malloc_state_ptr
= malloc_get_state ();
127 alloc_unexec_post (void)
129 free (malloc_state_ptr
);
132 /* Restore the dumped malloc state. Because malloc can be invoked
133 even before main (e.g. by the dynamic linker), the dumped malloc
134 state must be restored as early as possible using this special hook. */
136 malloc_initialize_hook (void)
138 static bool malloc_using_checking
;
143 malloc_using_checking
= getenv ("MALLOC_CHECK_") != NULL
;
147 if (!malloc_using_checking
)
149 /* Work around a bug in glibc's malloc. MALLOC_CHECK_ must be
150 ignored if the heap to be restored was constructed without
151 malloc checking. Can't use unsetenv, since that calls malloc. */
155 if (strncmp (*p
, "MALLOC_CHECK_=", 14) == 0)
165 malloc_set_state (malloc_state_ptr
);
166 # ifndef XMALLOC_OVERRUN_CHECK
167 alloc_unexec_post ();
172 # ifndef __MALLOC_HOOK_VOLATILE
173 # define __MALLOC_HOOK_VOLATILE
175 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook
176 = malloc_initialize_hook
;
180 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
181 to a struct Lisp_String. */
183 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
184 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
185 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
187 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
188 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
189 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
191 /* Default value of gc_cons_threshold (see below). */
193 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
195 /* Global variables. */
196 struct emacs_globals globals
;
198 /* Number of bytes of consing done since the last gc. */
200 EMACS_INT consing_since_gc
;
202 /* Similar minimum, computed from Vgc_cons_percentage. */
204 EMACS_INT gc_relative_threshold
;
206 /* Minimum number of bytes of consing since GC before next GC,
207 when memory is full. */
209 EMACS_INT memory_full_cons_threshold
;
211 /* True during GC. */
215 /* True means abort if try to GC.
216 This is for code which is written on the assumption that
217 no GC will happen, so as to verify that assumption. */
221 /* Number of live and free conses etc. */
223 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
224 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
225 static EMACS_INT total_free_floats
, total_floats
;
227 /* Points to memory space allocated as "spare", to be freed if we run
228 out of memory. We keep one large block, four cons-blocks, and
229 two string blocks. */
231 static char *spare_memory
[7];
233 /* Amount of spare memory to keep in large reserve block, or to see
234 whether this much is available when malloc fails on a larger request. */
236 #define SPARE_MEMORY (1 << 14)
238 /* Initialize it to a nonzero value to force it into data space
239 (rather than bss space). That way unexec will remap it into text
240 space (pure), on some systems. We have not implemented the
241 remapping on more recent systems because this is less important
242 nowadays than in the days of small memories and timesharing. */
244 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
245 #define PUREBEG (char *) pure
247 /* Pointer to the pure area, and its size. */
249 static char *purebeg
;
250 static ptrdiff_t pure_size
;
252 /* Number of bytes of pure storage used before pure storage overflowed.
253 If this is non-zero, this implies that an overflow occurred. */
255 static ptrdiff_t pure_bytes_used_before_overflow
;
257 /* Index in pure at which next pure Lisp object will be allocated.. */
259 static ptrdiff_t pure_bytes_used_lisp
;
261 /* Number of bytes allocated for non-Lisp objects in pure storage. */
263 static ptrdiff_t pure_bytes_used_non_lisp
;
265 /* If nonzero, this is a warning delivered by malloc and not yet
268 const char *pending_malloc_warning
;
270 #if 0 /* Normally, pointer sanity only on request... */
271 #ifdef ENABLE_CHECKING
272 #define SUSPICIOUS_OBJECT_CHECKING 1
276 /* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
277 bug is unresolved. */
278 #define SUSPICIOUS_OBJECT_CHECKING 1
280 #ifdef SUSPICIOUS_OBJECT_CHECKING
281 struct suspicious_free_record
283 void *suspicious_object
;
284 void *backtrace
[128];
286 static void *suspicious_objects
[32];
287 static int suspicious_object_index
;
288 struct suspicious_free_record suspicious_free_history
[64] EXTERNALLY_VISIBLE
;
289 static int suspicious_free_history_index
;
290 /* Find the first currently-monitored suspicious pointer in range
291 [begin,end) or NULL if no such pointer exists. */
292 static void *find_suspicious_object_in_range (void *begin
, void *end
);
293 static void detect_suspicious_free (void *ptr
);
295 # define find_suspicious_object_in_range(begin, end) NULL
296 # define detect_suspicious_free(ptr) (void)
299 /* Maximum amount of C stack to save when a GC happens. */
301 #ifndef MAX_SAVE_STACK
302 #define MAX_SAVE_STACK 16000
305 /* Buffer in which we save a copy of the C stack at each GC. */
307 #if MAX_SAVE_STACK > 0
308 static char *stack_copy
;
309 static ptrdiff_t stack_copy_size
;
311 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
312 avoiding any address sanitization. */
314 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
315 no_sanitize_memcpy (void *dest
, void const *src
, size_t size
)
317 if (! ADDRESS_SANITIZER
)
318 return memcpy (dest
, src
, size
);
324 for (i
= 0; i
< size
; i
++)
330 #endif /* MAX_SAVE_STACK > 0 */
332 static void mark_terminals (void);
333 static void gc_sweep (void);
334 static Lisp_Object
make_pure_vector (ptrdiff_t);
335 static void mark_buffer (struct buffer
*);
337 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
338 static void refill_memory_reserve (void);
340 static void compact_small_strings (void);
341 static void free_large_strings (void);
342 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
344 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
345 what memory allocated via lisp_malloc and lisp_align_malloc is intended
346 for what purpose. This enumeration specifies the type of memory. */
357 /* Since all non-bool pseudovectors are small enough to be
358 allocated from vector blocks, this memory type denotes
359 large regular vectors and large bool pseudovectors. */
361 /* Special type to denote vector blocks. */
362 MEM_TYPE_VECTOR_BLOCK
,
363 /* Special type to denote reserved memory. */
367 /* A unique object in pure space used to make some Lisp objects
368 on free lists recognizable in O(1). */
370 static Lisp_Object Vdead
;
371 #define DEADP(x) EQ (x, Vdead)
373 #ifdef GC_MALLOC_CHECK
375 enum mem_type allocated_mem_type
;
377 #endif /* GC_MALLOC_CHECK */
379 /* A node in the red-black tree describing allocated memory containing
380 Lisp data. Each such block is recorded with its start and end
381 address when it is allocated, and removed from the tree when it
384 A red-black tree is a balanced binary tree with the following
387 1. Every node is either red or black.
388 2. Every leaf is black.
389 3. If a node is red, then both of its children are black.
390 4. Every simple path from a node to a descendant leaf contains
391 the same number of black nodes.
392 5. The root is always black.
394 When nodes are inserted into the tree, or deleted from the tree,
395 the tree is "fixed" so that these properties are always true.
397 A red-black tree with N internal nodes has height at most 2
398 log(N+1). Searches, insertions and deletions are done in O(log N).
399 Please see a text book about data structures for a detailed
400 description of red-black trees. Any book worth its salt should
405 /* Children of this node. These pointers are never NULL. When there
406 is no child, the value is MEM_NIL, which points to a dummy node. */
407 struct mem_node
*left
, *right
;
409 /* The parent of this node. In the root node, this is NULL. */
410 struct mem_node
*parent
;
412 /* Start and end of allocated region. */
416 enum {MEM_BLACK
, MEM_RED
} color
;
422 /* Base address of stack. Set in main. */
424 Lisp_Object
*stack_base
;
426 /* Root of the tree describing allocated Lisp memory. */
428 static struct mem_node
*mem_root
;
430 /* Lowest and highest known address in the heap. */
432 static void *min_heap_address
, *max_heap_address
;
434 /* Sentinel node of the tree. */
436 static struct mem_node mem_z
;
437 #define MEM_NIL &mem_z
439 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
440 static void mem_insert_fixup (struct mem_node
*);
441 static void mem_rotate_left (struct mem_node
*);
442 static void mem_rotate_right (struct mem_node
*);
443 static void mem_delete (struct mem_node
*);
444 static void mem_delete_fixup (struct mem_node
*);
445 static struct mem_node
*mem_find (void *);
451 /* Addresses of staticpro'd variables. Initialize it to a nonzero
452 value; otherwise some compilers put it into BSS. */
454 enum { NSTATICS
= 2048 };
455 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
457 /* Index of next unused slot in staticvec. */
459 static int staticidx
;
461 static void *pure_alloc (size_t, int);
463 /* Return X rounded to the next multiple of Y. Arguments should not
464 have side effects, as they are evaluated more than once. Assume X
465 + Y - 1 does not overflow. Tune for Y being a power of 2. */
467 #define ROUNDUP(x, y) ((y) & ((y) - 1) \
468 ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
469 : ((x) + (y) - 1) & ~ ((y) - 1))
471 /* Return PTR rounded up to the next multiple of ALIGNMENT. */
474 ALIGN (void *ptr
, int alignment
)
476 return (void *) ROUNDUP ((uintptr_t) ptr
, alignment
);
479 /* Extract the pointer hidden within A, if A is not a symbol.
480 If A is a symbol, extract the hidden pointer's offset from lispsym,
481 converted to void *. */
483 #define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
484 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
486 /* Extract the pointer hidden within A. */
488 #define macro_XPNTR(a) \
489 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
490 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
492 /* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
493 functions, as functions are cleaner and can be used in debuggers.
494 Also, define them as macros if being compiled with GCC without
495 optimization, for performance in that case. The macro_* names are
496 private to this section of code. */
498 static ATTRIBUTE_UNUSED
void *
499 XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a
)
501 return macro_XPNTR_OR_SYMBOL_OFFSET (a
);
503 static ATTRIBUTE_UNUSED
void *
504 XPNTR (Lisp_Object a
)
506 return macro_XPNTR (a
);
509 #if DEFINE_KEY_OPS_AS_MACROS
510 # define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
511 # define XPNTR(a) macro_XPNTR (a)
515 XFLOAT_INIT (Lisp_Object f
, double n
)
517 XFLOAT (f
)->u
.data
= n
;
520 #ifdef DOUG_LEA_MALLOC
522 pointers_fit_in_lispobj_p (void)
524 return (UINTPTR_MAX
<= VAL_MAX
) || USE_LSB_TAG
;
528 mmap_lisp_allowed_p (void)
530 /* If we can't store all memory addresses in our lisp objects, it's
531 risky to let the heap use mmap and give us addresses from all
532 over our address space. We also can't use mmap for lisp objects
533 if we might dump: unexec doesn't preserve the contents of mmapped
535 return pointers_fit_in_lispobj_p () && !might_dump
;
539 /* Head of a circularly-linked list of extant finalizers. */
540 static struct Lisp_Finalizer finalizers
;
542 /* Head of a circularly-linked list of finalizers that must be invoked
543 because we deemed them unreachable. This list must be global, and
544 not a local inside garbage_collect_1, in case we GC again while
545 running finalizers. */
546 static struct Lisp_Finalizer doomed_finalizers
;
549 /************************************************************************
551 ************************************************************************/
553 /* Function malloc calls this if it finds we are near exhausting storage. */
556 malloc_warning (const char *str
)
558 pending_malloc_warning
= str
;
562 /* Display an already-pending malloc warning. */
565 display_malloc_warning (void)
567 call3 (intern ("display-warning"),
569 build_string (pending_malloc_warning
),
570 intern ("emergency"));
571 pending_malloc_warning
= 0;
574 /* Called if we can't allocate relocatable space for a buffer. */
577 buffer_memory_full (ptrdiff_t nbytes
)
579 /* If buffers use the relocating allocator, no need to free
580 spare_memory, because we may have plenty of malloc space left
581 that we could get, and if we don't, the malloc that fails will
582 itself cause spare_memory to be freed. If buffers don't use the
583 relocating allocator, treat this like any other failing
587 memory_full (nbytes
);
589 /* This used to call error, but if we've run out of memory, we could
590 get infinite recursion trying to build the string. */
591 xsignal (Qnil
, Vmemory_signal_data
);
595 /* A common multiple of the positive integers A and B. Ideally this
596 would be the least common multiple, but there's no way to do that
597 as a constant expression in C, so do the best that we can easily do. */
598 #define COMMON_MULTIPLE(a, b) \
599 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
601 #ifndef XMALLOC_OVERRUN_CHECK
602 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
605 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
608 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
609 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
610 block size in little-endian order. The trailer consists of
611 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
613 The header is used to detect whether this block has been allocated
614 through these functions, as some low-level libc functions may
615 bypass the malloc hooks. */
617 #define XMALLOC_OVERRUN_CHECK_SIZE 16
618 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
619 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
621 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
622 hold a size_t value and (2) the header size is a multiple of the
623 alignment that Emacs needs for C types and for USE_LSB_TAG. */
624 #define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
626 #define XMALLOC_HEADER_ALIGNMENT \
627 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
628 #define XMALLOC_OVERRUN_SIZE_SIZE \
629 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
630 + XMALLOC_HEADER_ALIGNMENT - 1) \
631 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
632 - XMALLOC_OVERRUN_CHECK_SIZE)
634 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
635 { '\x9a', '\x9b', '\xae', '\xaf',
636 '\xbf', '\xbe', '\xce', '\xcf',
637 '\xea', '\xeb', '\xec', '\xed',
638 '\xdf', '\xde', '\x9c', '\x9d' };
640 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
641 { '\xaa', '\xab', '\xac', '\xad',
642 '\xba', '\xbb', '\xbc', '\xbd',
643 '\xca', '\xcb', '\xcc', '\xcd',
644 '\xda', '\xdb', '\xdc', '\xdd' };
646 /* Insert and extract the block size in the header. */
649 xmalloc_put_size (unsigned char *ptr
, size_t size
)
652 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
654 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
660 xmalloc_get_size (unsigned char *ptr
)
664 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
665 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
674 /* Like malloc, but wraps allocated block with header and trailer. */
677 overrun_check_malloc (size_t size
)
679 register unsigned char *val
;
680 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
683 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
686 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
687 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
688 xmalloc_put_size (val
, size
);
689 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
690 XMALLOC_OVERRUN_CHECK_SIZE
);
696 /* Like realloc, but checks old block for overrun, and wraps new block
697 with header and trailer. */
700 overrun_check_realloc (void *block
, size_t size
)
702 register unsigned char *val
= (unsigned char *) block
;
703 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
707 && memcmp (xmalloc_overrun_check_header
,
708 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
709 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
711 size_t osize
= xmalloc_get_size (val
);
712 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
713 XMALLOC_OVERRUN_CHECK_SIZE
))
715 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
716 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
717 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
720 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
724 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
725 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
726 xmalloc_put_size (val
, size
);
727 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
728 XMALLOC_OVERRUN_CHECK_SIZE
);
733 /* Like free, but checks block for overrun. */
736 overrun_check_free (void *block
)
738 unsigned char *val
= (unsigned char *) block
;
741 && memcmp (xmalloc_overrun_check_header
,
742 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
743 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
745 size_t osize
= xmalloc_get_size (val
);
746 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
747 XMALLOC_OVERRUN_CHECK_SIZE
))
749 #ifdef XMALLOC_CLEAR_FREE_MEMORY
750 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
751 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
753 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
754 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
755 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
765 #define malloc overrun_check_malloc
766 #define realloc overrun_check_realloc
767 #define free overrun_check_free
770 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
771 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
772 If that variable is set, block input while in one of Emacs's memory
773 allocation functions. There should be no need for this debugging
774 option, since signal handlers do not allocate memory, but Emacs
775 formerly allocated memory in signal handlers and this compile-time
776 option remains as a way to help debug the issue should it rear its
778 #ifdef XMALLOC_BLOCK_INPUT_CHECK
779 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
781 malloc_block_input (void)
783 if (block_input_in_memory_allocators
)
787 malloc_unblock_input (void)
789 if (block_input_in_memory_allocators
)
792 # define MALLOC_BLOCK_INPUT malloc_block_input ()
793 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
795 # define MALLOC_BLOCK_INPUT ((void) 0)
796 # define MALLOC_UNBLOCK_INPUT ((void) 0)
799 #define MALLOC_PROBE(size) \
801 if (profiler_memory_running) \
802 malloc_probe (size); \
805 static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
806 static void *lrealloc (void *, size_t);
808 /* Like malloc but check for no memory and block interrupt input. */
811 xmalloc (size_t size
)
816 val
= lmalloc (size
);
817 MALLOC_UNBLOCK_INPUT
;
825 /* Like the above, but zeroes out the memory just allocated. */
828 xzalloc (size_t size
)
833 val
= lmalloc (size
);
834 MALLOC_UNBLOCK_INPUT
;
838 memset (val
, 0, size
);
843 /* Like realloc but check for no memory and block interrupt input.. */
846 xrealloc (void *block
, size_t size
)
851 /* We must call malloc explicitly when BLOCK is 0, since some
852 reallocs don't do this. */
854 val
= lmalloc (size
);
856 val
= lrealloc (block
, size
);
857 MALLOC_UNBLOCK_INPUT
;
866 /* Like free but block interrupt input. */
875 MALLOC_UNBLOCK_INPUT
;
876 /* We don't call refill_memory_reserve here
877 because in practice the call in r_alloc_free seems to suffice. */
881 /* Other parts of Emacs pass large int values to allocator functions
882 expecting ptrdiff_t. This is portable in practice, but check it to
884 verify (INT_MAX
<= PTRDIFF_MAX
);
887 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
888 Signal an error on memory exhaustion, and block interrupt input. */
891 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
893 eassert (0 <= nitems
&& 0 < item_size
);
895 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
896 memory_full (SIZE_MAX
);
897 return xmalloc (nbytes
);
901 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
902 Signal an error on memory exhaustion, and block interrupt input. */
905 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
907 eassert (0 <= nitems
&& 0 < item_size
);
909 if (INT_MULTIPLY_WRAPV (nitems
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
910 memory_full (SIZE_MAX
);
911 return xrealloc (pa
, nbytes
);
915 /* Grow PA, which points to an array of *NITEMS items, and return the
916 location of the reallocated array, updating *NITEMS to reflect its
917 new size. The new array will contain at least NITEMS_INCR_MIN more
918 items, but will not contain more than NITEMS_MAX items total.
919 ITEM_SIZE is the size of each item, in bytes.
921 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
922 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
925 If PA is null, then allocate a new array instead of reallocating
928 Block interrupt input as needed. If memory exhaustion occurs, set
929 *NITEMS to zero if PA is null, and signal an error (i.e., do not
932 Thus, to grow an array A without saving its old contents, do
933 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
934 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
935 and signals an error, and later this code is reexecuted and
936 attempts to free A. */
939 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
940 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
942 ptrdiff_t n0
= *nitems
;
943 eassume (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n0
&& -1 <= nitems_max
);
945 /* The approximate size to use for initial small allocation
946 requests. This is the largest "small" request for the GNU C
948 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
950 /* If the array is tiny, grow it to about (but no greater than)
951 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
952 Adjust the growth according to three constraints: NITEMS_INCR_MIN,
953 NITEMS_MAX, and what the C language can represent safely. */
956 if (INT_ADD_WRAPV (n0
, n0
>> 1, &n
))
958 if (0 <= nitems_max
&& nitems_max
< n
)
961 ptrdiff_t adjusted_nbytes
962 = ((INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
) || SIZE_MAX
< nbytes
)
963 ? min (PTRDIFF_MAX
, SIZE_MAX
)
964 : nbytes
< DEFAULT_MXFAST
? DEFAULT_MXFAST
: 0);
967 n
= adjusted_nbytes
/ item_size
;
968 nbytes
= adjusted_nbytes
- adjusted_nbytes
% item_size
;
973 if (n
- n0
< nitems_incr_min
974 && (INT_ADD_WRAPV (n0
, nitems_incr_min
, &n
)
975 || (0 <= nitems_max
&& nitems_max
< n
)
976 || INT_MULTIPLY_WRAPV (n
, item_size
, &nbytes
)))
977 memory_full (SIZE_MAX
);
978 pa
= xrealloc (pa
, nbytes
);
984 /* Like strdup, but uses xmalloc. */
987 xstrdup (const char *s
)
991 size
= strlen (s
) + 1;
992 return memcpy (xmalloc (size
), s
, size
);
995 /* Like above, but duplicates Lisp string to C string. */
998 xlispstrdup (Lisp_Object string
)
1000 ptrdiff_t size
= SBYTES (string
) + 1;
1001 return memcpy (xmalloc (size
), SSDATA (string
), size
);
1004 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
1005 pointed to. If STRING is null, assign it without copying anything.
1006 Allocate before freeing, to avoid a dangling pointer if allocation
1010 dupstring (char **ptr
, char const *string
)
1013 *ptr
= string
? xstrdup (string
) : 0;
1018 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
1019 argument is a const pointer. */
1022 xputenv (char const *string
)
1024 if (putenv ((char *) string
) != 0)
1028 /* Return a newly allocated memory block of SIZE bytes, remembering
1029 to free it when unwinding. */
1031 record_xmalloc (size_t size
)
1033 void *p
= xmalloc (size
);
1034 record_unwind_protect_ptr (xfree
, p
);
1039 /* Like malloc but used for allocating Lisp data. NBYTES is the
1040 number of bytes to allocate, TYPE describes the intended use of the
1041 allocated memory block (for strings, for conses, ...). */
1044 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
1048 lisp_malloc (size_t nbytes
, enum mem_type type
)
1054 #ifdef GC_MALLOC_CHECK
1055 allocated_mem_type
= type
;
1058 val
= lmalloc (nbytes
);
1061 /* If the memory just allocated cannot be addressed thru a Lisp
1062 object's pointer, and it needs to be,
1063 that's equivalent to running out of memory. */
1064 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1067 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
1068 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
1070 lisp_malloc_loser
= val
;
1077 #ifndef GC_MALLOC_CHECK
1078 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1079 mem_insert (val
, (char *) val
+ nbytes
, type
);
1082 MALLOC_UNBLOCK_INPUT
;
1084 memory_full (nbytes
);
1085 MALLOC_PROBE (nbytes
);
1089 /* Free BLOCK. This must be called to free memory allocated with a
1090 call to lisp_malloc. */
1093 lisp_free (void *block
)
1097 #ifndef GC_MALLOC_CHECK
1098 mem_delete (mem_find (block
));
1100 MALLOC_UNBLOCK_INPUT
;
1103 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
1105 /* The entry point is lisp_align_malloc which returns blocks of at most
1106 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
1108 /* Use aligned_alloc if it or a simple substitute is available.
1109 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
1110 clang 3.3 anyway. Aligned allocation is incompatible with
1111 unexmacosx.c, so don't use it on Darwin. */
1113 #if ! ADDRESS_SANITIZER && !defined DARWIN_OS
1114 # if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
1115 # define USE_ALIGNED_ALLOC 1
1116 # ifndef HAVE_ALIGNED_ALLOC
1117 /* Defined in gmalloc.c. */
1118 void *aligned_alloc (size_t, size_t);
1120 # elif defined HYBRID_MALLOC
1121 # if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
1122 # define USE_ALIGNED_ALLOC 1
1123 # define aligned_alloc hybrid_aligned_alloc
1124 /* Defined in gmalloc.c. */
1125 void *aligned_alloc (size_t, size_t);
1127 # elif defined HAVE_ALIGNED_ALLOC
1128 # define USE_ALIGNED_ALLOC 1
1129 # elif defined HAVE_POSIX_MEMALIGN
1130 # define USE_ALIGNED_ALLOC 1
1132 aligned_alloc (size_t alignment
, size_t size
)
1135 return posix_memalign (&p
, alignment
, size
) == 0 ? p
: 0;
1140 /* BLOCK_ALIGN has to be a power of 2. */
1141 #define BLOCK_ALIGN (1 << 10)
1143 /* Padding to leave at the end of a malloc'd block. This is to give
1144 malloc a chance to minimize the amount of memory wasted to alignment.
1145 It should be tuned to the particular malloc library used.
1146 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
1147 aligned_alloc on the other hand would ideally prefer a value of 4
1148 because otherwise, there's 1020 bytes wasted between each ablocks.
1149 In Emacs, testing shows that those 1020 can most of the time be
1150 efficiently used by malloc to place other objects, so a value of 0 can
1151 still preferable unless you have a lot of aligned blocks and virtually
1153 #define BLOCK_PADDING 0
1154 #define BLOCK_BYTES \
1155 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1157 /* Internal data structures and constants. */
1159 #define ABLOCKS_SIZE 16
1161 /* An aligned block of memory. */
1166 char payload
[BLOCK_BYTES
];
1167 struct ablock
*next_free
;
1169 /* `abase' is the aligned base of the ablocks. */
1170 /* It is overloaded to hold the virtual `busy' field that counts
1171 the number of used ablock in the parent ablocks.
1172 The first ablock has the `busy' field, the others have the `abase'
1173 field. To tell the difference, we assume that pointers will have
1174 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1175 is used to tell whether the real base of the parent ablocks is `abase'
1176 (if not, the word before the first ablock holds a pointer to the
1178 struct ablocks
*abase
;
1179 /* The padding of all but the last ablock is unused. The padding of
1180 the last ablock in an ablocks is not allocated. */
1182 char padding
[BLOCK_PADDING
];
1186 /* A bunch of consecutive aligned blocks. */
1189 struct ablock blocks
[ABLOCKS_SIZE
];
1192 /* Size of the block requested from malloc or aligned_alloc. */
1193 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1195 #define ABLOCK_ABASE(block) \
1196 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1197 ? (struct ablocks *)(block) \
1200 /* Virtual `busy' field. */
1201 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1203 /* Pointer to the (not necessarily aligned) malloc block. */
1204 #ifdef USE_ALIGNED_ALLOC
1205 #define ABLOCKS_BASE(abase) (abase)
1207 #define ABLOCKS_BASE(abase) \
1208 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
1211 /* The list of free ablock. */
1212 static struct ablock
*free_ablock
;
1214 /* Allocate an aligned block of nbytes.
1215 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1216 smaller or equal to BLOCK_BYTES. */
1218 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1221 struct ablocks
*abase
;
1223 eassert (nbytes
<= BLOCK_BYTES
);
1227 #ifdef GC_MALLOC_CHECK
1228 allocated_mem_type
= type
;
1234 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1236 #ifdef DOUG_LEA_MALLOC
1237 if (!mmap_lisp_allowed_p ())
1238 mallopt (M_MMAP_MAX
, 0);
1241 #ifdef USE_ALIGNED_ALLOC
1242 abase
= base
= aligned_alloc (BLOCK_ALIGN
, ABLOCKS_BYTES
);
1244 base
= malloc (ABLOCKS_BYTES
);
1245 abase
= ALIGN (base
, BLOCK_ALIGN
);
1250 MALLOC_UNBLOCK_INPUT
;
1251 memory_full (ABLOCKS_BYTES
);
1254 aligned
= (base
== abase
);
1256 ((void **) abase
)[-1] = base
;
1258 #ifdef DOUG_LEA_MALLOC
1259 if (!mmap_lisp_allowed_p ())
1260 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1264 /* If the memory just allocated cannot be addressed thru a Lisp
1265 object's pointer, and it needs to be, that's equivalent to
1266 running out of memory. */
1267 if (type
!= MEM_TYPE_NON_LISP
)
1270 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1271 XSETCONS (tem
, end
);
1272 if ((char *) XCONS (tem
) != end
)
1274 lisp_malloc_loser
= base
;
1276 MALLOC_UNBLOCK_INPUT
;
1277 memory_full (SIZE_MAX
);
1282 /* Initialize the blocks and put them on the free list.
1283 If `base' was not properly aligned, we can't use the last block. */
1284 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1286 abase
->blocks
[i
].abase
= abase
;
1287 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1288 free_ablock
= &abase
->blocks
[i
];
1290 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1292 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1293 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1294 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1295 eassert (ABLOCKS_BASE (abase
) == base
);
1296 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1299 abase
= ABLOCK_ABASE (free_ablock
);
1300 ABLOCKS_BUSY (abase
)
1301 = (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1303 free_ablock
= free_ablock
->x
.next_free
;
1305 #ifndef GC_MALLOC_CHECK
1306 if (type
!= MEM_TYPE_NON_LISP
)
1307 mem_insert (val
, (char *) val
+ nbytes
, type
);
1310 MALLOC_UNBLOCK_INPUT
;
1312 MALLOC_PROBE (nbytes
);
1314 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1319 lisp_align_free (void *block
)
1321 struct ablock
*ablock
= block
;
1322 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1325 #ifndef GC_MALLOC_CHECK
1326 mem_delete (mem_find (block
));
1328 /* Put on free list. */
1329 ablock
->x
.next_free
= free_ablock
;
1330 free_ablock
= ablock
;
1331 /* Update busy count. */
1332 ABLOCKS_BUSY (abase
)
1333 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1335 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1336 { /* All the blocks are free. */
1337 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1338 struct ablock
**tem
= &free_ablock
;
1339 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1343 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1346 *tem
= (*tem
)->x
.next_free
;
1349 tem
= &(*tem
)->x
.next_free
;
1351 eassert ((aligned
& 1) == aligned
);
1352 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1353 #ifdef USE_POSIX_MEMALIGN
1354 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1356 free (ABLOCKS_BASE (abase
));
1358 MALLOC_UNBLOCK_INPUT
;
1361 #if !defined __GNUC__ && !defined __alignof__
1362 # define __alignof__(type) alignof (type)
1365 /* True if malloc returns a multiple of GCALIGNMENT. In practice this
1366 holds if __alignof__ (max_align_t) is a multiple. Use __alignof__
1367 if available, as otherwise this check would fail with GCC x86.
1368 This is a macro, not an enum constant, for portability to HP-UX
1369 10.20 cc and AIX 3.2.5 xlc. */
1370 #define MALLOC_IS_GC_ALIGNED (__alignof__ (max_align_t) % GCALIGNMENT == 0)
1372 /* True if P is suitably aligned for SIZE, where Lisp alignment may be
1373 needed if SIZE is Lisp-aligned. */
1376 laligned (void *p
, size_t size
)
1378 return (MALLOC_IS_GC_ALIGNED
|| (intptr_t) p
% GCALIGNMENT
== 0
1379 || size
% GCALIGNMENT
!= 0);
1382 /* Like malloc and realloc except that if SIZE is Lisp-aligned, make
1383 sure the result is too, if necessary by reallocating (typically
1384 with larger and larger sizes) until the allocator returns a
1385 Lisp-aligned pointer. Code that needs to allocate C heap memory
1386 for a Lisp object should use one of these functions to obtain a
1387 pointer P; that way, if T is an enum Lisp_Type value and L ==
1388 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
1390 On typical modern platforms these functions' loops do not iterate.
1391 On now-rare (and perhaps nonexistent) platforms, the loops in
1392 theory could repeat forever. If an infinite loop is possible on a
1393 platform, a build would surely loop and the builder can then send
1394 us a bug report. Adding a counter to try to detect any such loop
1395 would complicate the code (and possibly introduce bugs, in code
1396 that's never really exercised) for little benefit. */
1399 lmalloc (size_t size
)
1401 #if USE_ALIGNED_ALLOC
1402 if (! MALLOC_IS_GC_ALIGNED
)
1403 return aligned_alloc (GCALIGNMENT
, size
);
1410 if (laligned (p
, size
))
1414 if (! INT_ADD_WRAPV (size
, GCALIGNMENT
, &bigger
))
1418 eassert ((intptr_t) p
% GCALIGNMENT
== 0);
1423 lrealloc (void *p
, size_t size
)
1427 p
= realloc (p
, size
);
1428 if (laligned (p
, size
))
1431 if (! INT_ADD_WRAPV (size
, GCALIGNMENT
, &bigger
))
1435 eassert ((intptr_t) p
% GCALIGNMENT
== 0);
1440 /***********************************************************************
1442 ***********************************************************************/
1444 /* Number of intervals allocated in an interval_block structure.
1445 The 1020 is 1024 minus malloc overhead. */
1447 #define INTERVAL_BLOCK_SIZE \
1448 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1450 /* Intervals are allocated in chunks in the form of an interval_block
1453 struct interval_block
1455 /* Place `intervals' first, to preserve alignment. */
1456 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1457 struct interval_block
*next
;
1460 /* Current interval block. Its `next' pointer points to older
1463 static struct interval_block
*interval_block
;
1465 /* Index in interval_block above of the next unused interval
1468 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1470 /* Number of free and live intervals. */
1472 static EMACS_INT total_free_intervals
, total_intervals
;
1474 /* List of free intervals. */
1476 static INTERVAL interval_free_list
;
1478 /* Return a new interval. */
1481 make_interval (void)
1487 if (interval_free_list
)
1489 val
= interval_free_list
;
1490 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1494 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1496 struct interval_block
*newi
1497 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1499 newi
->next
= interval_block
;
1500 interval_block
= newi
;
1501 interval_block_index
= 0;
1502 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1504 val
= &interval_block
->intervals
[interval_block_index
++];
1507 MALLOC_UNBLOCK_INPUT
;
1509 consing_since_gc
+= sizeof (struct interval
);
1511 total_free_intervals
--;
1512 RESET_INTERVAL (val
);
1518 /* Mark Lisp objects in interval I. */
1521 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1523 /* Intervals should never be shared. So, if extra internal checking is
1524 enabled, GC aborts if it seems to have visited an interval twice. */
1525 eassert (!i
->gcmarkbit
);
1527 mark_object (i
->plist
);
1530 /* Mark the interval tree rooted in I. */
1532 #define MARK_INTERVAL_TREE(i) \
1534 if (i && !i->gcmarkbit) \
1535 traverse_intervals_noorder (i, mark_interval, Qnil); \
1538 /***********************************************************************
1540 ***********************************************************************/
1542 /* Lisp_Strings are allocated in string_block structures. When a new
1543 string_block is allocated, all the Lisp_Strings it contains are
1544 added to a free-list string_free_list. When a new Lisp_String is
1545 needed, it is taken from that list. During the sweep phase of GC,
1546 string_blocks that are entirely free are freed, except two which
1549 String data is allocated from sblock structures. Strings larger
1550 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1551 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1553 Sblocks consist internally of sdata structures, one for each
1554 Lisp_String. The sdata structure points to the Lisp_String it
1555 belongs to. The Lisp_String points back to the `u.data' member of
1556 its sdata structure.
1558 When a Lisp_String is freed during GC, it is put back on
1559 string_free_list, and its `data' member and its sdata's `string'
1560 pointer is set to null. The size of the string is recorded in the
1561 `n.nbytes' member of the sdata. So, sdata structures that are no
1562 longer used, can be easily recognized, and it's easy to compact the
1563 sblocks of small strings which we do in compact_small_strings. */
1565 /* Size in bytes of an sblock structure used for small strings. This
1566 is 8192 minus malloc overhead. */
1568 #define SBLOCK_SIZE 8188
1570 /* Strings larger than this are considered large strings. String data
1571 for large strings is allocated from individual sblocks. */
1573 #define LARGE_STRING_BYTES 1024
1575 /* The SDATA typedef is a struct or union describing string memory
1576 sub-allocated from an sblock. This is where the contents of Lisp
1577 strings are stored. */
1581 /* Back-pointer to the string this sdata belongs to. If null, this
1582 structure is free, and NBYTES (in this structure or in the union below)
1583 contains the string's byte size (the same value that STRING_BYTES
1584 would return if STRING were non-null). If non-null, STRING_BYTES
1585 (STRING) is the size of the data, and DATA contains the string's
1587 struct Lisp_String
*string
;
1589 #ifdef GC_CHECK_STRING_BYTES
1593 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1596 #ifdef GC_CHECK_STRING_BYTES
1598 typedef struct sdata sdata
;
1599 #define SDATA_NBYTES(S) (S)->nbytes
1600 #define SDATA_DATA(S) (S)->data
1606 struct Lisp_String
*string
;
1608 /* When STRING is nonnull, this union is actually of type 'struct sdata',
1609 which has a flexible array member. However, if implemented by
1610 giving this union a member of type 'struct sdata', the union
1611 could not be the last (flexible) member of 'struct sblock',
1612 because C99 prohibits a flexible array member from having a type
1613 that is itself a flexible array. So, comment this member out here,
1614 but remember that the option's there when using this union. */
1619 /* When STRING is null. */
1622 struct Lisp_String
*string
;
1627 #define SDATA_NBYTES(S) (S)->n.nbytes
1628 #define SDATA_DATA(S) ((struct sdata *) (S))->data
1630 #endif /* not GC_CHECK_STRING_BYTES */
1632 enum { SDATA_DATA_OFFSET
= offsetof (struct sdata
, data
) };
1634 /* Structure describing a block of memory which is sub-allocated to
1635 obtain string data memory for strings. Blocks for small strings
1636 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1637 as large as needed. */
1642 struct sblock
*next
;
1644 /* Pointer to the next free sdata block. This points past the end
1645 of the sblock if there isn't any space left in this block. */
1649 sdata data
[FLEXIBLE_ARRAY_MEMBER
];
1652 /* Number of Lisp strings in a string_block structure. The 1020 is
1653 1024 minus malloc overhead. */
1655 #define STRING_BLOCK_SIZE \
1656 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1658 /* Structure describing a block from which Lisp_String structures
1663 /* Place `strings' first, to preserve alignment. */
1664 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1665 struct string_block
*next
;
1668 /* Head and tail of the list of sblock structures holding Lisp string
1669 data. We always allocate from current_sblock. The NEXT pointers
1670 in the sblock structures go from oldest_sblock to current_sblock. */
1672 static struct sblock
*oldest_sblock
, *current_sblock
;
1674 /* List of sblocks for large strings. */
1676 static struct sblock
*large_sblocks
;
1678 /* List of string_block structures. */
1680 static struct string_block
*string_blocks
;
1682 /* Free-list of Lisp_Strings. */
1684 static struct Lisp_String
*string_free_list
;
1686 /* Number of live and free Lisp_Strings. */
1688 static EMACS_INT total_strings
, total_free_strings
;
1690 /* Number of bytes used by live strings. */
1692 static EMACS_INT total_string_bytes
;
1694 /* Given a pointer to a Lisp_String S which is on the free-list
1695 string_free_list, return a pointer to its successor in the
1698 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1700 /* Return a pointer to the sdata structure belonging to Lisp string S.
1701 S must be live, i.e. S->data must not be null. S->data is actually
1702 a pointer to the `u.data' member of its sdata structure; the
1703 structure starts at a constant offset in front of that. */
1705 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1708 #ifdef GC_CHECK_STRING_OVERRUN
1710 /* We check for overrun in string data blocks by appending a small
1711 "cookie" after each allocated string data block, and check for the
1712 presence of this cookie during GC. */
1714 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1715 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1716 { '\xde', '\xad', '\xbe', '\xef' };
1719 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1722 /* Value is the size of an sdata structure large enough to hold NBYTES
1723 bytes of string data. The value returned includes a terminating
1724 NUL byte, the size of the sdata structure, and padding. */
1726 #ifdef GC_CHECK_STRING_BYTES
1728 #define SDATA_SIZE(NBYTES) \
1729 ((SDATA_DATA_OFFSET \
1731 + sizeof (ptrdiff_t) - 1) \
1732 & ~(sizeof (ptrdiff_t) - 1))
1734 #else /* not GC_CHECK_STRING_BYTES */
1736 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1737 less than the size of that member. The 'max' is not needed when
1738 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1739 alignment code reserves enough space. */
1741 #define SDATA_SIZE(NBYTES) \
1742 ((SDATA_DATA_OFFSET \
1743 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1745 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1747 + sizeof (ptrdiff_t) - 1) \
1748 & ~(sizeof (ptrdiff_t) - 1))
1750 #endif /* not GC_CHECK_STRING_BYTES */
1752 /* Extra bytes to allocate for each string. */
1754 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1756 /* Exact bound on the number of bytes in a string, not counting the
1757 terminating null. A string cannot contain more bytes than
1758 STRING_BYTES_BOUND, nor can it be so long that the size_t
1759 arithmetic in allocate_string_data would overflow while it is
1760 calculating a value to be passed to malloc. */
1761 static ptrdiff_t const STRING_BYTES_MAX
=
1762 min (STRING_BYTES_BOUND
,
1763 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1765 - offsetof (struct sblock
, data
)
1766 - SDATA_DATA_OFFSET
)
1767 & ~(sizeof (EMACS_INT
) - 1)));
1769 /* Initialize string allocation. Called from init_alloc_once. */
1774 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1775 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1779 #ifdef GC_CHECK_STRING_BYTES
1781 static int check_string_bytes_count
;
1783 /* Like STRING_BYTES, but with debugging check. Can be
1784 called during GC, so pay attention to the mark bit. */
1787 string_bytes (struct Lisp_String
*s
)
1790 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1792 if (!PURE_P (s
) && s
->data
&& nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1797 /* Check validity of Lisp strings' string_bytes member in B. */
1800 check_sblock (struct sblock
*b
)
1802 sdata
*from
, *end
, *from_end
;
1806 for (from
= b
->data
; from
< end
; from
= from_end
)
1808 /* Compute the next FROM here because copying below may
1809 overwrite data we need to compute it. */
1812 /* Check that the string size recorded in the string is the
1813 same as the one recorded in the sdata structure. */
1814 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1815 : SDATA_NBYTES (from
));
1816 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1821 /* Check validity of Lisp strings' string_bytes member. ALL_P
1822 means check all strings, otherwise check only most
1823 recently allocated strings. Used for hunting a bug. */
1826 check_string_bytes (bool all_p
)
1832 for (b
= large_sblocks
; b
; b
= b
->next
)
1834 struct Lisp_String
*s
= b
->data
[0].string
;
1839 for (b
= oldest_sblock
; b
; b
= b
->next
)
1842 else if (current_sblock
)
1843 check_sblock (current_sblock
);
1846 #else /* not GC_CHECK_STRING_BYTES */
1848 #define check_string_bytes(all) ((void) 0)
1850 #endif /* GC_CHECK_STRING_BYTES */
1852 #ifdef GC_CHECK_STRING_FREE_LIST
1854 /* Walk through the string free list looking for bogus next pointers.
1855 This may catch buffer overrun from a previous string. */
1858 check_string_free_list (void)
1860 struct Lisp_String
*s
;
1862 /* Pop a Lisp_String off the free-list. */
1863 s
= string_free_list
;
1866 if ((uintptr_t) s
< 1024)
1868 s
= NEXT_FREE_LISP_STRING (s
);
1872 #define check_string_free_list()
1875 /* Return a new Lisp_String. */
1877 static struct Lisp_String
*
1878 allocate_string (void)
1880 struct Lisp_String
*s
;
1884 /* If the free-list is empty, allocate a new string_block, and
1885 add all the Lisp_Strings in it to the free-list. */
1886 if (string_free_list
== NULL
)
1888 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1891 b
->next
= string_blocks
;
1894 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1897 /* Every string on a free list should have NULL data pointer. */
1899 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1900 string_free_list
= s
;
1903 total_free_strings
+= STRING_BLOCK_SIZE
;
1906 check_string_free_list ();
1908 /* Pop a Lisp_String off the free-list. */
1909 s
= string_free_list
;
1910 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1912 MALLOC_UNBLOCK_INPUT
;
1914 --total_free_strings
;
1917 consing_since_gc
+= sizeof *s
;
1919 #ifdef GC_CHECK_STRING_BYTES
1920 if (!noninteractive
)
1922 if (++check_string_bytes_count
== 200)
1924 check_string_bytes_count
= 0;
1925 check_string_bytes (1);
1928 check_string_bytes (0);
1930 #endif /* GC_CHECK_STRING_BYTES */
1936 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1937 plus a NUL byte at the end. Allocate an sdata structure for S, and
1938 set S->data to its `u.data' member. Store a NUL byte at the end of
1939 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1940 S->data if it was initially non-null. */
1943 allocate_string_data (struct Lisp_String
*s
,
1944 EMACS_INT nchars
, EMACS_INT nbytes
)
1946 sdata
*data
, *old_data
;
1948 ptrdiff_t needed
, old_nbytes
;
1950 if (STRING_BYTES_MAX
< nbytes
)
1953 /* Determine the number of bytes needed to store NBYTES bytes
1955 needed
= SDATA_SIZE (nbytes
);
1958 old_data
= SDATA_OF_STRING (s
);
1959 old_nbytes
= STRING_BYTES (s
);
1966 if (nbytes
> LARGE_STRING_BYTES
)
1968 size_t size
= offsetof (struct sblock
, data
) + needed
;
1970 #ifdef DOUG_LEA_MALLOC
1971 if (!mmap_lisp_allowed_p ())
1972 mallopt (M_MMAP_MAX
, 0);
1975 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1977 #ifdef DOUG_LEA_MALLOC
1978 if (!mmap_lisp_allowed_p ())
1979 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1982 b
->next_free
= b
->data
;
1983 b
->data
[0].string
= NULL
;
1984 b
->next
= large_sblocks
;
1987 else if (current_sblock
== NULL
1988 || (((char *) current_sblock
+ SBLOCK_SIZE
1989 - (char *) current_sblock
->next_free
)
1990 < (needed
+ GC_STRING_EXTRA
)))
1992 /* Not enough room in the current sblock. */
1993 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1994 b
->next_free
= b
->data
;
1995 b
->data
[0].string
= NULL
;
1999 current_sblock
->next
= b
;
2007 data
= b
->next_free
;
2008 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2010 MALLOC_UNBLOCK_INPUT
;
2013 s
->data
= SDATA_DATA (data
);
2014 #ifdef GC_CHECK_STRING_BYTES
2015 SDATA_NBYTES (data
) = nbytes
;
2018 s
->size_byte
= nbytes
;
2019 s
->data
[nbytes
] = '\0';
2020 #ifdef GC_CHECK_STRING_OVERRUN
2021 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2022 GC_STRING_OVERRUN_COOKIE_SIZE
);
2025 /* Note that Faset may call to this function when S has already data
2026 assigned. In this case, mark data as free by setting it's string
2027 back-pointer to null, and record the size of the data in it. */
2030 SDATA_NBYTES (old_data
) = old_nbytes
;
2031 old_data
->string
= NULL
;
2034 consing_since_gc
+= needed
;
2038 /* Sweep and compact strings. */
2040 NO_INLINE
/* For better stack traces */
2042 sweep_strings (void)
2044 struct string_block
*b
, *next
;
2045 struct string_block
*live_blocks
= NULL
;
2047 string_free_list
= NULL
;
2048 total_strings
= total_free_strings
= 0;
2049 total_string_bytes
= 0;
2051 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2052 for (b
= string_blocks
; b
; b
= next
)
2055 struct Lisp_String
*free_list_before
= string_free_list
;
2059 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2061 struct Lisp_String
*s
= b
->strings
+ i
;
2065 /* String was not on free-list before. */
2066 if (STRING_MARKED_P (s
))
2068 /* String is live; unmark it and its intervals. */
2071 /* Do not use string_(set|get)_intervals here. */
2072 s
->intervals
= balance_intervals (s
->intervals
);
2075 total_string_bytes
+= STRING_BYTES (s
);
2079 /* String is dead. Put it on the free-list. */
2080 sdata
*data
= SDATA_OF_STRING (s
);
2082 /* Save the size of S in its sdata so that we know
2083 how large that is. Reset the sdata's string
2084 back-pointer so that we know it's free. */
2085 #ifdef GC_CHECK_STRING_BYTES
2086 if (string_bytes (s
) != SDATA_NBYTES (data
))
2089 data
->n
.nbytes
= STRING_BYTES (s
);
2091 data
->string
= NULL
;
2093 /* Reset the strings's `data' member so that we
2097 /* Put the string on the free-list. */
2098 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2099 string_free_list
= s
;
2105 /* S was on the free-list before. Put it there again. */
2106 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2107 string_free_list
= s
;
2112 /* Free blocks that contain free Lisp_Strings only, except
2113 the first two of them. */
2114 if (nfree
== STRING_BLOCK_SIZE
2115 && total_free_strings
> STRING_BLOCK_SIZE
)
2118 string_free_list
= free_list_before
;
2122 total_free_strings
+= nfree
;
2123 b
->next
= live_blocks
;
2128 check_string_free_list ();
2130 string_blocks
= live_blocks
;
2131 free_large_strings ();
2132 compact_small_strings ();
2134 check_string_free_list ();
2138 /* Free dead large strings. */
2141 free_large_strings (void)
2143 struct sblock
*b
, *next
;
2144 struct sblock
*live_blocks
= NULL
;
2146 for (b
= large_sblocks
; b
; b
= next
)
2150 if (b
->data
[0].string
== NULL
)
2154 b
->next
= live_blocks
;
2159 large_sblocks
= live_blocks
;
2163 /* Compact data of small strings. Free sblocks that don't contain
2164 data of live strings after compaction. */
2167 compact_small_strings (void)
2169 struct sblock
*b
, *tb
, *next
;
2170 sdata
*from
, *to
, *end
, *tb_end
;
2171 sdata
*to_end
, *from_end
;
2173 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2174 to, and TB_END is the end of TB. */
2176 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2179 /* Step through the blocks from the oldest to the youngest. We
2180 expect that old blocks will stabilize over time, so that less
2181 copying will happen this way. */
2182 for (b
= oldest_sblock
; b
; b
= b
->next
)
2185 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2187 for (from
= b
->data
; from
< end
; from
= from_end
)
2189 /* Compute the next FROM here because copying below may
2190 overwrite data we need to compute it. */
2192 struct Lisp_String
*s
= from
->string
;
2194 #ifdef GC_CHECK_STRING_BYTES
2195 /* Check that the string size recorded in the string is the
2196 same as the one recorded in the sdata structure. */
2197 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2199 #endif /* GC_CHECK_STRING_BYTES */
2201 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2202 eassert (nbytes
<= LARGE_STRING_BYTES
);
2204 nbytes
= SDATA_SIZE (nbytes
);
2205 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2207 #ifdef GC_CHECK_STRING_OVERRUN
2208 if (memcmp (string_overrun_cookie
,
2209 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2210 GC_STRING_OVERRUN_COOKIE_SIZE
))
2214 /* Non-NULL S means it's alive. Copy its data. */
2217 /* If TB is full, proceed with the next sblock. */
2218 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2219 if (to_end
> tb_end
)
2223 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2225 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2228 /* Copy, and update the string's `data' pointer. */
2231 eassert (tb
!= b
|| to
< from
);
2232 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2233 to
->string
->data
= SDATA_DATA (to
);
2236 /* Advance past the sdata we copied to. */
2242 /* The rest of the sblocks following TB don't contain live data, so
2243 we can free them. */
2244 for (b
= tb
->next
; b
; b
= next
)
2252 current_sblock
= tb
;
2256 string_overflow (void)
2258 error ("Maximum string size exceeded");
2261 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2262 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2263 LENGTH must be an integer.
2264 INIT must be an integer that represents a character. */)
2265 (Lisp_Object length
, Lisp_Object init
)
2267 register Lisp_Object val
;
2271 CHECK_NATNUM (length
);
2272 CHECK_CHARACTER (init
);
2274 c
= XFASTINT (init
);
2275 if (ASCII_CHAR_P (c
))
2277 nbytes
= XINT (length
);
2278 val
= make_uninit_string (nbytes
);
2281 memset (SDATA (val
), c
, nbytes
);
2282 SDATA (val
)[nbytes
] = 0;
2287 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2288 ptrdiff_t len
= CHAR_STRING (c
, str
);
2289 EMACS_INT string_len
= XINT (length
);
2290 unsigned char *p
, *beg
, *end
;
2292 if (INT_MULTIPLY_WRAPV (len
, string_len
, &nbytes
))
2294 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2295 for (beg
= SDATA (val
), p
= beg
, end
= beg
+ nbytes
; p
< end
; p
+= len
)
2297 /* First time we just copy `str' to the data of `val'. */
2299 memcpy (p
, str
, len
);
2302 /* Next time we copy largest possible chunk from
2303 initialized to uninitialized part of `val'. */
2304 len
= min (p
- beg
, end
- p
);
2305 memcpy (p
, beg
, len
);
2315 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
2319 bool_vector_fill (Lisp_Object a
, Lisp_Object init
)
2321 EMACS_INT nbits
= bool_vector_size (a
);
2324 unsigned char *data
= bool_vector_uchar_data (a
);
2325 int pattern
= NILP (init
) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR
) - 1;
2326 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
2327 int last_mask
= ~ (~0u << ((nbits
- 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1));
2328 memset (data
, pattern
, nbytes
- 1);
2329 data
[nbytes
- 1] = pattern
& last_mask
;
2334 /* Return a newly allocated, uninitialized bool vector of size NBITS. */
2337 make_uninit_bool_vector (EMACS_INT nbits
)
2340 EMACS_INT words
= bool_vector_words (nbits
);
2341 EMACS_INT word_bytes
= words
* sizeof (bits_word
);
2342 EMACS_INT needed_elements
= ((bool_header_size
- header_size
+ word_bytes
2345 struct Lisp_Bool_Vector
*p
2346 = (struct Lisp_Bool_Vector
*) allocate_vector (needed_elements
);
2347 XSETVECTOR (val
, p
);
2348 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2351 /* Clear padding at the end. */
2353 p
->data
[words
- 1] = 0;
2358 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2359 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2360 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2361 (Lisp_Object length
, Lisp_Object init
)
2365 CHECK_NATNUM (length
);
2366 val
= make_uninit_bool_vector (XFASTINT (length
));
2367 return bool_vector_fill (val
, init
);
2370 DEFUN ("bool-vector", Fbool_vector
, Sbool_vector
, 0, MANY
, 0,
2371 doc
: /* Return a new bool-vector with specified arguments as elements.
2372 Any number of arguments, even zero arguments, are allowed.
2373 usage: (bool-vector &rest OBJECTS) */)
2374 (ptrdiff_t nargs
, Lisp_Object
*args
)
2379 vector
= make_uninit_bool_vector (nargs
);
2380 for (i
= 0; i
< nargs
; i
++)
2381 bool_vector_set (vector
, i
, !NILP (args
[i
]));
2386 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2387 of characters from the contents. This string may be unibyte or
2388 multibyte, depending on the contents. */
2391 make_string (const char *contents
, ptrdiff_t nbytes
)
2393 register Lisp_Object val
;
2394 ptrdiff_t nchars
, multibyte_nbytes
;
2396 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2397 &nchars
, &multibyte_nbytes
);
2398 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2399 /* CONTENTS contains no multibyte sequences or contains an invalid
2400 multibyte sequence. We must make unibyte string. */
2401 val
= make_unibyte_string (contents
, nbytes
);
2403 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2407 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
2410 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2412 register Lisp_Object val
;
2413 val
= make_uninit_string (length
);
2414 memcpy (SDATA (val
), contents
, length
);
2419 /* Make a multibyte string from NCHARS characters occupying NBYTES
2420 bytes at CONTENTS. */
2423 make_multibyte_string (const char *contents
,
2424 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2426 register Lisp_Object val
;
2427 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2428 memcpy (SDATA (val
), contents
, nbytes
);
2433 /* Make a string from NCHARS characters occupying NBYTES bytes at
2434 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2437 make_string_from_bytes (const char *contents
,
2438 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2440 register Lisp_Object val
;
2441 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2442 memcpy (SDATA (val
), contents
, nbytes
);
2443 if (SBYTES (val
) == SCHARS (val
))
2444 STRING_SET_UNIBYTE (val
);
2449 /* Make a string from NCHARS characters occupying NBYTES bytes at
2450 CONTENTS. The argument MULTIBYTE controls whether to label the
2451 string as multibyte. If NCHARS is negative, it counts the number of
2452 characters by itself. */
2455 make_specified_string (const char *contents
,
2456 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2463 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2468 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2469 memcpy (SDATA (val
), contents
, nbytes
);
2471 STRING_SET_UNIBYTE (val
);
2476 /* Return a unibyte Lisp_String set up to hold LENGTH characters
2477 occupying LENGTH bytes. */
2480 make_uninit_string (EMACS_INT length
)
2485 return empty_unibyte_string
;
2486 val
= make_uninit_multibyte_string (length
, length
);
2487 STRING_SET_UNIBYTE (val
);
2492 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2493 which occupy NBYTES bytes. */
2496 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2499 struct Lisp_String
*s
;
2504 return empty_multibyte_string
;
2506 s
= allocate_string ();
2507 s
->intervals
= NULL
;
2508 allocate_string_data (s
, nchars
, nbytes
);
2509 XSETSTRING (string
, s
);
2510 string_chars_consed
+= nbytes
;
2514 /* Print arguments to BUF according to a FORMAT, then return
2515 a Lisp_String initialized with the data from BUF. */
2518 make_formatted_string (char *buf
, const char *format
, ...)
2523 va_start (ap
, format
);
2524 length
= vsprintf (buf
, format
, ap
);
2526 return make_string (buf
, length
);
2530 /***********************************************************************
2532 ***********************************************************************/
2534 /* We store float cells inside of float_blocks, allocating a new
2535 float_block with malloc whenever necessary. Float cells reclaimed
2536 by GC are put on a free list to be reallocated before allocating
2537 any new float cells from the latest float_block. */
2539 #define FLOAT_BLOCK_SIZE \
2540 (((BLOCK_BYTES - sizeof (struct float_block *) \
2541 /* The compiler might add padding at the end. */ \
2542 - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
2543 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2545 #define GETMARKBIT(block,n) \
2546 (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2547 >> ((n) % BITS_PER_BITS_WORD)) \
2550 #define SETMARKBIT(block,n) \
2551 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2552 |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
2554 #define UNSETMARKBIT(block,n) \
2555 ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
2556 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2558 #define FLOAT_BLOCK(fptr) \
2559 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2561 #define FLOAT_INDEX(fptr) \
2562 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2566 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2567 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2568 bits_word gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2569 struct float_block
*next
;
2572 #define FLOAT_MARKED_P(fptr) \
2573 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2575 #define FLOAT_MARK(fptr) \
2576 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2578 #define FLOAT_UNMARK(fptr) \
2579 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2581 /* Current float_block. */
2583 static struct float_block
*float_block
;
2585 /* Index of first unused Lisp_Float in the current float_block. */
2587 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2589 /* Free-list of Lisp_Floats. */
2591 static struct Lisp_Float
*float_free_list
;
2593 /* Return a new float object with value FLOAT_VALUE. */
2596 make_float (double float_value
)
2598 register Lisp_Object val
;
2602 if (float_free_list
)
2604 /* We use the data field for chaining the free list
2605 so that we won't use the same field that has the mark bit. */
2606 XSETFLOAT (val
, float_free_list
);
2607 float_free_list
= float_free_list
->u
.chain
;
2611 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2613 struct float_block
*new
2614 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2615 new->next
= float_block
;
2616 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2618 float_block_index
= 0;
2619 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2621 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2622 float_block_index
++;
2625 MALLOC_UNBLOCK_INPUT
;
2627 XFLOAT_INIT (val
, float_value
);
2628 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2629 consing_since_gc
+= sizeof (struct Lisp_Float
);
2631 total_free_floats
--;
2637 /***********************************************************************
2639 ***********************************************************************/
2641 /* We store cons cells inside of cons_blocks, allocating a new
2642 cons_block with malloc whenever necessary. Cons cells reclaimed by
2643 GC are put on a free list to be reallocated before allocating
2644 any new cons cells from the latest cons_block. */
2646 #define CONS_BLOCK_SIZE \
2647 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2648 /* The compiler might add padding at the end. */ \
2649 - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
2650 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2652 #define CONS_BLOCK(fptr) \
2653 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2655 #define CONS_INDEX(fptr) \
2656 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2660 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2661 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2662 bits_word gcmarkbits
[1 + CONS_BLOCK_SIZE
/ BITS_PER_BITS_WORD
];
2663 struct cons_block
*next
;
2666 #define CONS_MARKED_P(fptr) \
2667 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2669 #define CONS_MARK(fptr) \
2670 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2672 #define CONS_UNMARK(fptr) \
2673 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2675 /* Current cons_block. */
2677 static struct cons_block
*cons_block
;
2679 /* Index of first unused Lisp_Cons in the current block. */
2681 static int cons_block_index
= CONS_BLOCK_SIZE
;
2683 /* Free-list of Lisp_Cons structures. */
2685 static struct Lisp_Cons
*cons_free_list
;
2687 /* Explicitly free a cons cell by putting it on the free-list. */
2690 free_cons (struct Lisp_Cons
*ptr
)
2692 ptr
->u
.chain
= cons_free_list
;
2694 cons_free_list
= ptr
;
2695 consing_since_gc
-= sizeof *ptr
;
2696 total_free_conses
++;
2699 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2700 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2701 (Lisp_Object car
, Lisp_Object cdr
)
2703 register Lisp_Object val
;
2709 /* We use the cdr for chaining the free list
2710 so that we won't use the same field that has the mark bit. */
2711 XSETCONS (val
, cons_free_list
);
2712 cons_free_list
= cons_free_list
->u
.chain
;
2716 if (cons_block_index
== CONS_BLOCK_SIZE
)
2718 struct cons_block
*new
2719 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2720 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2721 new->next
= cons_block
;
2723 cons_block_index
= 0;
2724 total_free_conses
+= CONS_BLOCK_SIZE
;
2726 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2730 MALLOC_UNBLOCK_INPUT
;
2734 eassert (!CONS_MARKED_P (XCONS (val
)));
2735 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2736 total_free_conses
--;
2737 cons_cells_consed
++;
2741 #ifdef GC_CHECK_CONS_LIST
2742 /* Get an error now if there's any junk in the cons free list. */
2744 check_cons_list (void)
2746 struct Lisp_Cons
*tail
= cons_free_list
;
2749 tail
= tail
->u
.chain
;
2753 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2756 list1 (Lisp_Object arg1
)
2758 return Fcons (arg1
, Qnil
);
2762 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2764 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2769 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2771 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2776 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2778 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2783 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2785 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2786 Fcons (arg5
, Qnil
)))));
2789 /* Make a list of COUNT Lisp_Objects, where ARG is the
2790 first one. Allocate conses from pure space if TYPE
2791 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2794 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2796 Lisp_Object (*cons
) (Lisp_Object
, Lisp_Object
);
2799 case CONSTYPE_PURE
: cons
= pure_cons
; break;
2800 case CONSTYPE_HEAP
: cons
= Fcons
; break;
2801 default: emacs_abort ();
2804 eassume (0 < count
);
2805 Lisp_Object val
= cons (arg
, Qnil
);
2806 Lisp_Object tail
= val
;
2810 for (ptrdiff_t i
= 1; i
< count
; i
++)
2812 Lisp_Object elem
= cons (va_arg (ap
, Lisp_Object
), Qnil
);
2813 XSETCDR (tail
, elem
);
2821 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2822 doc
: /* Return a newly created list with specified arguments as elements.
2823 Any number of arguments, even zero arguments, are allowed.
2824 usage: (list &rest OBJECTS) */)
2825 (ptrdiff_t nargs
, Lisp_Object
*args
)
2827 register Lisp_Object val
;
2833 val
= Fcons (args
[nargs
], val
);
2839 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2840 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2841 (register Lisp_Object length
, Lisp_Object init
)
2843 register Lisp_Object val
;
2844 register EMACS_INT size
;
2846 CHECK_NATNUM (length
);
2847 size
= XFASTINT (length
);
2852 val
= Fcons (init
, val
);
2857 val
= Fcons (init
, val
);
2862 val
= Fcons (init
, val
);
2867 val
= Fcons (init
, val
);
2872 val
= Fcons (init
, val
);
2887 /***********************************************************************
2889 ***********************************************************************/
2891 /* Sometimes a vector's contents are merely a pointer internally used
2892 in vector allocation code. On the rare platforms where a null
2893 pointer cannot be tagged, represent it with a Lisp 0.
2894 Usually you don't want to touch this. */
2896 static struct Lisp_Vector
*
2897 next_vector (struct Lisp_Vector
*v
)
2899 return XUNTAG (v
->contents
[0], Lisp_Int0
);
2903 set_next_vector (struct Lisp_Vector
*v
, struct Lisp_Vector
*p
)
2905 v
->contents
[0] = make_lisp_ptr (p
, Lisp_Int0
);
2908 /* This value is balanced well enough to avoid too much internal overhead
2909 for the most common cases; it's not required to be a power of two, but
2910 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2912 #define VECTOR_BLOCK_SIZE 4096
2916 /* Alignment of struct Lisp_Vector objects. */
2917 vector_alignment
= COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR
,
2920 /* Vector size requests are a multiple of this. */
2921 roundup_size
= COMMON_MULTIPLE (vector_alignment
, word_size
)
2924 /* Verify assumptions described above. */
2925 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2926 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2928 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
2929 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
2930 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
2931 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
2933 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2935 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
2937 /* Size of the minimal vector allocated from block. */
2939 #define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
2941 /* Size of the largest vector allocated from block. */
2943 #define VBLOCK_BYTES_MAX \
2944 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2946 /* We maintain one free list for each possible block-allocated
2947 vector size, and this is the number of free lists we have. */
2949 #define VECTOR_MAX_FREE_LIST_INDEX \
2950 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2952 /* Common shortcut to advance vector pointer over a block data. */
2954 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2956 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2958 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2960 /* Common shortcut to setup vector on a free list. */
2962 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2964 (tmp) = ((nbytes - header_size) / word_size); \
2965 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2966 eassert ((nbytes) % roundup_size == 0); \
2967 (tmp) = VINDEX (nbytes); \
2968 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2969 set_next_vector (v, vector_free_lists[tmp]); \
2970 vector_free_lists[tmp] = (v); \
2971 total_free_vector_slots += (nbytes) / word_size; \
2974 /* This internal type is used to maintain the list of large vectors
2975 which are allocated at their own, e.g. outside of vector blocks.
2977 struct large_vector itself cannot contain a struct Lisp_Vector, as
2978 the latter contains a flexible array member and C99 does not allow
2979 such structs to be nested. Instead, each struct large_vector
2980 object LV is followed by a struct Lisp_Vector, which is at offset
2981 large_vector_offset from LV, and whose address is therefore
2982 large_vector_vec (&LV). */
2986 struct large_vector
*next
;
2991 large_vector_offset
= ROUNDUP (sizeof (struct large_vector
), vector_alignment
)
2994 static struct Lisp_Vector
*
2995 large_vector_vec (struct large_vector
*p
)
2997 return (struct Lisp_Vector
*) ((char *) p
+ large_vector_offset
);
3000 /* This internal type is used to maintain an underlying storage
3001 for small vectors. */
3005 char data
[VECTOR_BLOCK_BYTES
];
3006 struct vector_block
*next
;
3009 /* Chain of vector blocks. */
3011 static struct vector_block
*vector_blocks
;
3013 /* Vector free lists, where NTH item points to a chain of free
3014 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
3016 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
3018 /* Singly-linked list of large vectors. */
3020 static struct large_vector
*large_vectors
;
3022 /* The only vector with 0 slots, allocated from pure space. */
3024 Lisp_Object zero_vector
;
3026 /* Number of live vectors. */
3028 static EMACS_INT total_vectors
;
3030 /* Total size of live and free vectors, in Lisp_Object units. */
3032 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
3034 /* Get a new vector block. */
3036 static struct vector_block
*
3037 allocate_vector_block (void)
3039 struct vector_block
*block
= xmalloc (sizeof *block
);
3041 #ifndef GC_MALLOC_CHECK
3042 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
3043 MEM_TYPE_VECTOR_BLOCK
);
3046 block
->next
= vector_blocks
;
3047 vector_blocks
= block
;
3051 /* Called once to initialize vector allocation. */
3056 zero_vector
= make_pure_vector (0);
3059 /* Allocate vector from a vector block. */
3061 static struct Lisp_Vector
*
3062 allocate_vector_from_block (size_t nbytes
)
3064 struct Lisp_Vector
*vector
;
3065 struct vector_block
*block
;
3066 size_t index
, restbytes
;
3068 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
3069 eassert (nbytes
% roundup_size
== 0);
3071 /* First, try to allocate from a free list
3072 containing vectors of the requested size. */
3073 index
= VINDEX (nbytes
);
3074 if (vector_free_lists
[index
])
3076 vector
= vector_free_lists
[index
];
3077 vector_free_lists
[index
] = next_vector (vector
);
3078 total_free_vector_slots
-= nbytes
/ word_size
;
3082 /* Next, check free lists containing larger vectors. Since
3083 we will split the result, we should have remaining space
3084 large enough to use for one-slot vector at least. */
3085 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3086 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3087 if (vector_free_lists
[index
])
3089 /* This vector is larger than requested. */
3090 vector
= vector_free_lists
[index
];
3091 vector_free_lists
[index
] = next_vector (vector
);
3092 total_free_vector_slots
-= nbytes
/ word_size
;
3094 /* Excess bytes are used for the smaller vector,
3095 which should be set on an appropriate free list. */
3096 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3097 eassert (restbytes
% roundup_size
== 0);
3098 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3102 /* Finally, need a new vector block. */
3103 block
= allocate_vector_block ();
3105 /* New vector will be at the beginning of this block. */
3106 vector
= (struct Lisp_Vector
*) block
->data
;
3108 /* If the rest of space from this block is large enough
3109 for one-slot vector at least, set up it on a free list. */
3110 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3111 if (restbytes
>= VBLOCK_BYTES_MIN
)
3113 eassert (restbytes
% roundup_size
== 0);
3114 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
3119 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3121 #define VECTOR_IN_BLOCK(vector, block) \
3122 ((char *) (vector) <= (block)->data \
3123 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3125 /* Return the memory footprint of V in bytes. */
3128 vector_nbytes (struct Lisp_Vector
*v
)
3130 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
3133 if (size
& PSEUDOVECTOR_FLAG
)
3135 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
3137 struct Lisp_Bool_Vector
*bv
= (struct Lisp_Bool_Vector
*) v
;
3138 ptrdiff_t word_bytes
= (bool_vector_words (bv
->size
)
3139 * sizeof (bits_word
));
3140 ptrdiff_t boolvec_bytes
= bool_header_size
+ word_bytes
;
3141 verify (header_size
<= bool_header_size
);
3142 nwords
= (boolvec_bytes
- header_size
+ word_size
- 1) / word_size
;
3145 nwords
= ((size
& PSEUDOVECTOR_SIZE_MASK
)
3146 + ((size
& PSEUDOVECTOR_REST_MASK
)
3147 >> PSEUDOVECTOR_SIZE_BITS
));
3151 return vroundup (header_size
+ word_size
* nwords
);
3154 /* Release extra resources still in use by VECTOR, which may be any
3155 vector-like object. For now, this is used just to free data in
3159 cleanup_vector (struct Lisp_Vector
*vector
)
3161 detect_suspicious_free (vector
);
3162 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FONT
)
3163 && ((vector
->header
.size
& PSEUDOVECTOR_SIZE_MASK
)
3164 == FONT_OBJECT_MAX
))
3166 struct font_driver
*drv
= ((struct font
*) vector
)->driver
;
3168 /* The font driver might sometimes be NULL, e.g. if Emacs was
3169 interrupted before it had time to set it up. */
3172 /* Attempt to catch subtle bugs like Bug#16140. */
3173 eassert (valid_font_driver (drv
));
3174 drv
->close ((struct font
*) vector
);
3179 /* Reclaim space used by unmarked vectors. */
3181 NO_INLINE
/* For better stack traces */
3183 sweep_vectors (void)
3185 struct vector_block
*block
, **bprev
= &vector_blocks
;
3186 struct large_vector
*lv
, **lvprev
= &large_vectors
;
3187 struct Lisp_Vector
*vector
, *next
;
3189 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3190 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3192 /* Looking through vector blocks. */
3194 for (block
= vector_blocks
; block
; block
= *bprev
)
3196 bool free_this_block
= 0;
3199 for (vector
= (struct Lisp_Vector
*) block
->data
;
3200 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3202 if (VECTOR_MARKED_P (vector
))
3204 VECTOR_UNMARK (vector
);
3206 nbytes
= vector_nbytes (vector
);
3207 total_vector_slots
+= nbytes
/ word_size
;
3208 next
= ADVANCE (vector
, nbytes
);
3212 ptrdiff_t total_bytes
;
3214 cleanup_vector (vector
);
3215 nbytes
= vector_nbytes (vector
);
3216 total_bytes
= nbytes
;
3217 next
= ADVANCE (vector
, nbytes
);
3219 /* While NEXT is not marked, try to coalesce with VECTOR,
3220 thus making VECTOR of the largest possible size. */
3222 while (VECTOR_IN_BLOCK (next
, block
))
3224 if (VECTOR_MARKED_P (next
))
3226 cleanup_vector (next
);
3227 nbytes
= vector_nbytes (next
);
3228 total_bytes
+= nbytes
;
3229 next
= ADVANCE (next
, nbytes
);
3232 eassert (total_bytes
% roundup_size
== 0);
3234 if (vector
== (struct Lisp_Vector
*) block
->data
3235 && !VECTOR_IN_BLOCK (next
, block
))
3236 /* This block should be freed because all of its
3237 space was coalesced into the only free vector. */
3238 free_this_block
= 1;
3242 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3247 if (free_this_block
)
3249 *bprev
= block
->next
;
3250 #ifndef GC_MALLOC_CHECK
3251 mem_delete (mem_find (block
->data
));
3256 bprev
= &block
->next
;
3259 /* Sweep large vectors. */
3261 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
3263 vector
= large_vector_vec (lv
);
3264 if (VECTOR_MARKED_P (vector
))
3266 VECTOR_UNMARK (vector
);
3268 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3270 /* All non-bool pseudovectors are small enough to be allocated
3271 from vector blocks. This code should be redesigned if some
3272 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3273 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3274 total_vector_slots
+= vector_nbytes (vector
) / word_size
;
3278 += header_size
/ word_size
+ vector
->header
.size
;
3289 /* Value is a pointer to a newly allocated Lisp_Vector structure
3290 with room for LEN Lisp_Objects. */
3292 static struct Lisp_Vector
*
3293 allocate_vectorlike (ptrdiff_t len
)
3295 struct Lisp_Vector
*p
;
3300 p
= XVECTOR (zero_vector
);
3303 size_t nbytes
= header_size
+ len
* word_size
;
3305 #ifdef DOUG_LEA_MALLOC
3306 if (!mmap_lisp_allowed_p ())
3307 mallopt (M_MMAP_MAX
, 0);
3310 if (nbytes
<= VBLOCK_BYTES_MAX
)
3311 p
= allocate_vector_from_block (vroundup (nbytes
));
3314 struct large_vector
*lv
3315 = lisp_malloc ((large_vector_offset
+ header_size
3317 MEM_TYPE_VECTORLIKE
);
3318 lv
->next
= large_vectors
;
3320 p
= large_vector_vec (lv
);
3323 #ifdef DOUG_LEA_MALLOC
3324 if (!mmap_lisp_allowed_p ())
3325 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3328 if (find_suspicious_object_in_range (p
, (char *) p
+ nbytes
))
3331 consing_since_gc
+= nbytes
;
3332 vector_cells_consed
+= len
;
3335 MALLOC_UNBLOCK_INPUT
;
3341 /* Allocate a vector with LEN slots. */
3343 struct Lisp_Vector
*
3344 allocate_vector (EMACS_INT len
)
3346 struct Lisp_Vector
*v
;
3347 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3349 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3350 memory_full (SIZE_MAX
);
3351 v
= allocate_vectorlike (len
);
3353 v
->header
.size
= len
;
3358 /* Allocate other vector-like structures. */
3360 struct Lisp_Vector
*
3361 allocate_pseudovector (int memlen
, int lisplen
,
3362 int zerolen
, enum pvec_type tag
)
3364 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3366 /* Catch bogus values. */
3367 eassert (0 <= tag
&& tag
<= PVEC_FONT
);
3368 eassert (0 <= lisplen
&& lisplen
<= zerolen
&& zerolen
<= memlen
);
3369 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
3370 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
3372 /* Only the first LISPLEN slots will be traced normally by the GC. */
3373 memclear (v
->contents
, zerolen
* word_size
);
3374 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3379 allocate_buffer (void)
3381 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3383 BUFFER_PVEC_INIT (b
);
3384 /* Put B on the chain of all buffers including killed ones. */
3385 b
->next
= all_buffers
;
3387 /* Note that the rest fields of B are not initialized. */
3391 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3392 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3393 See also the function `vector'. */)
3394 (register Lisp_Object length
, Lisp_Object init
)
3397 register ptrdiff_t sizei
;
3398 register ptrdiff_t i
;
3399 register struct Lisp_Vector
*p
;
3401 CHECK_NATNUM (length
);
3403 p
= allocate_vector (XFASTINT (length
));
3404 sizei
= XFASTINT (length
);
3405 for (i
= 0; i
< sizei
; i
++)
3406 p
->contents
[i
] = init
;
3408 XSETVECTOR (vector
, p
);
3412 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3413 doc
: /* Return a newly created vector with specified arguments as elements.
3414 Any number of arguments, even zero arguments, are allowed.
3415 usage: (vector &rest OBJECTS) */)
3416 (ptrdiff_t nargs
, Lisp_Object
*args
)
3419 register Lisp_Object val
= make_uninit_vector (nargs
);
3420 register struct Lisp_Vector
*p
= XVECTOR (val
);
3422 for (i
= 0; i
< nargs
; i
++)
3423 p
->contents
[i
] = args
[i
];
3428 make_byte_code (struct Lisp_Vector
*v
)
3430 /* Don't allow the global zero_vector to become a byte code object. */
3431 eassert (0 < v
->header
.size
);
3433 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3434 && STRING_MULTIBYTE (v
->contents
[1]))
3435 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3436 earlier because they produced a raw 8-bit string for byte-code
3437 and now such a byte-code string is loaded as multibyte while
3438 raw 8-bit characters converted to multibyte form. Thus, now we
3439 must convert them back to the original unibyte form. */
3440 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3441 XSETPVECTYPE (v
, PVEC_COMPILED
);
3444 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3445 doc
: /* Create a byte-code object with specified arguments as elements.
3446 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3447 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3448 and (optional) INTERACTIVE-SPEC.
3449 The first four arguments are required; at most six have any
3451 The ARGLIST can be either like the one of `lambda', in which case the arguments
3452 will be dynamically bound before executing the byte code, or it can be an
3453 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3454 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3455 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3456 argument to catch the left-over arguments. If such an integer is used, the
3457 arguments will not be dynamically bound but will be instead pushed on the
3458 stack before executing the byte-code.
3459 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3460 (ptrdiff_t nargs
, Lisp_Object
*args
)
3463 register Lisp_Object val
= make_uninit_vector (nargs
);
3464 register struct Lisp_Vector
*p
= XVECTOR (val
);
3466 /* We used to purecopy everything here, if purify-flag was set. This worked
3467 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3468 dangerous, since make-byte-code is used during execution to build
3469 closures, so any closure built during the preload phase would end up
3470 copied into pure space, including its free variables, which is sometimes
3471 just wasteful and other times plainly wrong (e.g. those free vars may want
3474 for (i
= 0; i
< nargs
; i
++)
3475 p
->contents
[i
] = args
[i
];
3477 XSETCOMPILED (val
, p
);
3483 /***********************************************************************
3485 ***********************************************************************/
3487 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3488 of the required alignment. */
3490 union aligned_Lisp_Symbol
3492 struct Lisp_Symbol s
;
3493 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3497 /* Each symbol_block is just under 1020 bytes long, since malloc
3498 really allocates in units of powers of two and uses 4 bytes for its
3501 #define SYMBOL_BLOCK_SIZE \
3502 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3506 /* Place `symbols' first, to preserve alignment. */
3507 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3508 struct symbol_block
*next
;
3511 /* Current symbol block and index of first unused Lisp_Symbol
3514 static struct symbol_block
*symbol_block
;
3515 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3516 /* Pointer to the first symbol_block that contains pinned symbols.
3517 Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
3518 10K of which are pinned (and all but 250 of them are interned in obarray),
3519 whereas a "typical session" has in the order of 30K symbols.
3520 `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
3521 than 30K to find the 10K symbols we need to mark. */
3522 static struct symbol_block
*symbol_block_pinned
;
3524 /* List of free symbols. */
3526 static struct Lisp_Symbol
*symbol_free_list
;
3529 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3531 XSYMBOL (sym
)->name
= name
;
3535 init_symbol (Lisp_Object val
, Lisp_Object name
)
3537 struct Lisp_Symbol
*p
= XSYMBOL (val
);
3538 set_symbol_name (val
, name
);
3539 set_symbol_plist (val
, Qnil
);
3540 p
->redirect
= SYMBOL_PLAINVAL
;
3541 SET_SYMBOL_VAL (p
, Qunbound
);
3542 set_symbol_function (val
, Qnil
);
3543 set_symbol_next (val
, NULL
);
3544 p
->gcmarkbit
= false;
3545 p
->interned
= SYMBOL_UNINTERNED
;
3547 p
->declared_special
= false;
3551 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3552 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3553 Its value is void, and its function definition and property list are nil. */)
3558 CHECK_STRING (name
);
3562 if (symbol_free_list
)
3564 XSETSYMBOL (val
, symbol_free_list
);
3565 symbol_free_list
= symbol_free_list
->next
;
3569 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3571 struct symbol_block
*new
3572 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3573 new->next
= symbol_block
;
3575 symbol_block_index
= 0;
3576 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3578 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3579 symbol_block_index
++;
3582 MALLOC_UNBLOCK_INPUT
;
3584 init_symbol (val
, name
);
3585 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3587 total_free_symbols
--;
3593 /***********************************************************************
3594 Marker (Misc) Allocation
3595 ***********************************************************************/
3597 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3598 the required alignment. */
3600 union aligned_Lisp_Misc
3603 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3607 /* Allocation of markers and other objects that share that structure.
3608 Works like allocation of conses. */
3610 #define MARKER_BLOCK_SIZE \
3611 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3615 /* Place `markers' first, to preserve alignment. */
3616 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3617 struct marker_block
*next
;
3620 static struct marker_block
*marker_block
;
3621 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3623 static union Lisp_Misc
*marker_free_list
;
3625 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3628 allocate_misc (enum Lisp_Misc_Type type
)
3634 if (marker_free_list
)
3636 XSETMISC (val
, marker_free_list
);
3637 marker_free_list
= marker_free_list
->u_free
.chain
;
3641 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3643 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3644 new->next
= marker_block
;
3646 marker_block_index
= 0;
3647 total_free_markers
+= MARKER_BLOCK_SIZE
;
3649 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3650 marker_block_index
++;
3653 MALLOC_UNBLOCK_INPUT
;
3655 --total_free_markers
;
3656 consing_since_gc
+= sizeof (union Lisp_Misc
);
3657 misc_objects_consed
++;
3658 XMISCANY (val
)->type
= type
;
3659 XMISCANY (val
)->gcmarkbit
= 0;
3663 /* Free a Lisp_Misc object. */
3666 free_misc (Lisp_Object misc
)
3668 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3669 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3670 marker_free_list
= XMISC (misc
);
3671 consing_since_gc
-= sizeof (union Lisp_Misc
);
3672 total_free_markers
++;
3675 /* Verify properties of Lisp_Save_Value's representation
3676 that are assumed here and elsewhere. */
3678 verify (SAVE_UNUSED
== 0);
3679 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3683 /* Return Lisp_Save_Value objects for the various combinations
3684 that callers need. */
3687 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3689 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3690 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3691 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3692 p
->data
[0].integer
= a
;
3693 p
->data
[1].integer
= b
;
3694 p
->data
[2].integer
= c
;
3699 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3702 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3703 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3704 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3705 p
->data
[0].object
= a
;
3706 p
->data
[1].object
= b
;
3707 p
->data
[2].object
= c
;
3708 p
->data
[3].object
= d
;
3713 make_save_ptr (void *a
)
3715 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3716 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3717 p
->save_type
= SAVE_POINTER
;
3718 p
->data
[0].pointer
= a
;
3723 make_save_ptr_int (void *a
, ptrdiff_t b
)
3725 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3726 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3727 p
->save_type
= SAVE_TYPE_PTR_INT
;
3728 p
->data
[0].pointer
= a
;
3729 p
->data
[1].integer
= b
;
3733 #if ! (defined USE_X_TOOLKIT || defined USE_GTK)
3735 make_save_ptr_ptr (void *a
, void *b
)
3737 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3738 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3739 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3740 p
->data
[0].pointer
= a
;
3741 p
->data
[1].pointer
= b
;
3747 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3749 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3750 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3751 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3752 p
->data
[0].funcpointer
= a
;
3753 p
->data
[1].pointer
= b
;
3754 p
->data
[2].object
= c
;
3758 /* Return a Lisp_Save_Value object that represents an array A
3759 of N Lisp objects. */
3762 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3764 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3765 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3766 p
->save_type
= SAVE_TYPE_MEMORY
;
3767 p
->data
[0].pointer
= a
;
3768 p
->data
[1].integer
= n
;
3772 /* Free a Lisp_Save_Value object. Do not use this function
3773 if SAVE contains pointer other than returned by xmalloc. */
3776 free_save_value (Lisp_Object save
)
3778 xfree (XSAVE_POINTER (save
, 0));
3782 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3785 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3787 register Lisp_Object overlay
;
3789 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3790 OVERLAY_START (overlay
) = start
;
3791 OVERLAY_END (overlay
) = end
;
3792 set_overlay_plist (overlay
, plist
);
3793 XOVERLAY (overlay
)->next
= NULL
;
3797 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3798 doc
: /* Return a newly allocated marker which does not point at any place. */)
3801 register Lisp_Object val
;
3802 register struct Lisp_Marker
*p
;
3804 val
= allocate_misc (Lisp_Misc_Marker
);
3810 p
->insertion_type
= 0;
3811 p
->need_adjustment
= 0;
3815 /* Return a newly allocated marker which points into BUF
3816 at character position CHARPOS and byte position BYTEPOS. */
3819 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3822 struct Lisp_Marker
*m
;
3824 /* No dead buffers here. */
3825 eassert (BUFFER_LIVE_P (buf
));
3827 /* Every character is at least one byte. */
3828 eassert (charpos
<= bytepos
);
3830 obj
= allocate_misc (Lisp_Misc_Marker
);
3833 m
->charpos
= charpos
;
3834 m
->bytepos
= bytepos
;
3835 m
->insertion_type
= 0;
3836 m
->need_adjustment
= 0;
3837 m
->next
= BUF_MARKERS (buf
);
3838 BUF_MARKERS (buf
) = m
;
3842 /* Put MARKER back on the free list after using it temporarily. */
3845 free_marker (Lisp_Object marker
)
3847 unchain_marker (XMARKER (marker
));
3852 /* Return a newly created vector or string with specified arguments as
3853 elements. If all the arguments are characters that can fit
3854 in a string of events, make a string; otherwise, make a vector.
3856 Any number of arguments, even zero arguments, are allowed. */
3859 make_event_array (ptrdiff_t nargs
, Lisp_Object
*args
)
3863 for (i
= 0; i
< nargs
; i
++)
3864 /* The things that fit in a string
3865 are characters that are in 0...127,
3866 after discarding the meta bit and all the bits above it. */
3867 if (!INTEGERP (args
[i
])
3868 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3869 return Fvector (nargs
, args
);
3871 /* Since the loop exited, we know that all the things in it are
3872 characters, so we can make a string. */
3876 result
= Fmake_string (make_number (nargs
), make_number (0));
3877 for (i
= 0; i
< nargs
; i
++)
3879 SSET (result
, i
, XINT (args
[i
]));
3880 /* Move the meta bit to the right place for a string char. */
3881 if (XINT (args
[i
]) & CHAR_META
)
3882 SSET (result
, i
, SREF (result
, i
) | 0x80);
3890 /* Create a new module user ptr object. */
3892 make_user_ptr (void (*finalizer
) (void *), void *p
)
3895 struct Lisp_User_Ptr
*uptr
;
3897 obj
= allocate_misc (Lisp_Misc_User_Ptr
);
3898 uptr
= XUSER_PTR (obj
);
3899 uptr
->finalizer
= finalizer
;
3907 init_finalizer_list (struct Lisp_Finalizer
*head
)
3909 head
->prev
= head
->next
= head
;
3912 /* Insert FINALIZER before ELEMENT. */
3915 finalizer_insert (struct Lisp_Finalizer
*element
,
3916 struct Lisp_Finalizer
*finalizer
)
3918 eassert (finalizer
->prev
== NULL
);
3919 eassert (finalizer
->next
== NULL
);
3920 finalizer
->next
= element
;
3921 finalizer
->prev
= element
->prev
;
3922 finalizer
->prev
->next
= finalizer
;
3923 element
->prev
= finalizer
;
3927 unchain_finalizer (struct Lisp_Finalizer
*finalizer
)
3929 if (finalizer
->prev
!= NULL
)
3931 eassert (finalizer
->next
!= NULL
);
3932 finalizer
->prev
->next
= finalizer
->next
;
3933 finalizer
->next
->prev
= finalizer
->prev
;
3934 finalizer
->prev
= finalizer
->next
= NULL
;
3939 mark_finalizer_list (struct Lisp_Finalizer
*head
)
3941 for (struct Lisp_Finalizer
*finalizer
= head
->next
;
3943 finalizer
= finalizer
->next
)
3945 finalizer
->base
.gcmarkbit
= true;
3946 mark_object (finalizer
->function
);
3950 /* Move doomed finalizers to list DEST from list SRC. A doomed
3951 finalizer is one that is not GC-reachable and whose
3952 finalizer->function is non-nil. */
3955 queue_doomed_finalizers (struct Lisp_Finalizer
*dest
,
3956 struct Lisp_Finalizer
*src
)
3958 struct Lisp_Finalizer
*finalizer
= src
->next
;
3959 while (finalizer
!= src
)
3961 struct Lisp_Finalizer
*next
= finalizer
->next
;
3962 if (!finalizer
->base
.gcmarkbit
&& !NILP (finalizer
->function
))
3964 unchain_finalizer (finalizer
);
3965 finalizer_insert (dest
, finalizer
);
3973 run_finalizer_handler (Lisp_Object args
)
3975 add_to_log ("finalizer failed: %S", args
);
3980 run_finalizer_function (Lisp_Object function
)
3982 ptrdiff_t count
= SPECPDL_INDEX ();
3984 specbind (Qinhibit_quit
, Qt
);
3985 internal_condition_case_1 (call0
, function
, Qt
, run_finalizer_handler
);
3986 unbind_to (count
, Qnil
);
3990 run_finalizers (struct Lisp_Finalizer
*finalizers
)
3992 struct Lisp_Finalizer
*finalizer
;
3993 Lisp_Object function
;
3995 while (finalizers
->next
!= finalizers
)
3997 finalizer
= finalizers
->next
;
3998 eassert (finalizer
->base
.type
== Lisp_Misc_Finalizer
);
3999 unchain_finalizer (finalizer
);
4000 function
= finalizer
->function
;
4001 if (!NILP (function
))
4003 finalizer
->function
= Qnil
;
4004 run_finalizer_function (function
);
4009 DEFUN ("make-finalizer", Fmake_finalizer
, Smake_finalizer
, 1, 1, 0,
4010 doc
: /* Make a finalizer that will run FUNCTION.
4011 FUNCTION will be called after garbage collection when the returned
4012 finalizer object becomes unreachable. If the finalizer object is
4013 reachable only through references from finalizer objects, it does not
4014 count as reachable for the purpose of deciding whether to run
4015 FUNCTION. FUNCTION will be run once per finalizer object. */)
4016 (Lisp_Object function
)
4018 Lisp_Object val
= allocate_misc (Lisp_Misc_Finalizer
);
4019 struct Lisp_Finalizer
*finalizer
= XFINALIZER (val
);
4020 finalizer
->function
= function
;
4021 finalizer
->prev
= finalizer
->next
= NULL
;
4022 finalizer_insert (&finalizers
, finalizer
);
4027 /************************************************************************
4028 Memory Full Handling
4029 ************************************************************************/
4032 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
4033 there may have been size_t overflow so that malloc was never
4034 called, or perhaps malloc was invoked successfully but the
4035 resulting pointer had problems fitting into a tagged EMACS_INT. In
4036 either case this counts as memory being full even though malloc did
4040 memory_full (size_t nbytes
)
4042 /* Do not go into hysterics merely because a large request failed. */
4043 bool enough_free_memory
= 0;
4044 if (SPARE_MEMORY
< nbytes
)
4049 p
= malloc (SPARE_MEMORY
);
4053 enough_free_memory
= 1;
4055 MALLOC_UNBLOCK_INPUT
;
4058 if (! enough_free_memory
)
4064 memory_full_cons_threshold
= sizeof (struct cons_block
);
4066 /* The first time we get here, free the spare memory. */
4067 for (i
= 0; i
< ARRAYELTS (spare_memory
); i
++)
4068 if (spare_memory
[i
])
4071 free (spare_memory
[i
]);
4072 else if (i
>= 1 && i
<= 4)
4073 lisp_align_free (spare_memory
[i
]);
4075 lisp_free (spare_memory
[i
]);
4076 spare_memory
[i
] = 0;
4080 /* This used to call error, but if we've run out of memory, we could
4081 get infinite recursion trying to build the string. */
4082 xsignal (Qnil
, Vmemory_signal_data
);
4085 /* If we released our reserve (due to running out of memory),
4086 and we have a fair amount free once again,
4087 try to set aside another reserve in case we run out once more.
4089 This is called when a relocatable block is freed in ralloc.c,
4090 and also directly from this file, in case we're not using ralloc.c. */
4093 refill_memory_reserve (void)
4095 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
4096 if (spare_memory
[0] == 0)
4097 spare_memory
[0] = malloc (SPARE_MEMORY
);
4098 if (spare_memory
[1] == 0)
4099 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
4101 if (spare_memory
[2] == 0)
4102 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
4104 if (spare_memory
[3] == 0)
4105 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
4107 if (spare_memory
[4] == 0)
4108 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
4110 if (spare_memory
[5] == 0)
4111 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
4113 if (spare_memory
[6] == 0)
4114 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
4116 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
4117 Vmemory_full
= Qnil
;
4121 /************************************************************************
4123 ************************************************************************/
4125 /* Conservative C stack marking requires a method to identify possibly
4126 live Lisp objects given a pointer value. We do this by keeping
4127 track of blocks of Lisp data that are allocated in a red-black tree
4128 (see also the comment of mem_node which is the type of nodes in
4129 that tree). Function lisp_malloc adds information for an allocated
4130 block to the red-black tree with calls to mem_insert, and function
4131 lisp_free removes it with mem_delete. Functions live_string_p etc
4132 call mem_find to lookup information about a given pointer in the
4133 tree, and use that to determine if the pointer points to a Lisp
4136 /* Initialize this part of alloc.c. */
4141 mem_z
.left
= mem_z
.right
= MEM_NIL
;
4142 mem_z
.parent
= NULL
;
4143 mem_z
.color
= MEM_BLACK
;
4144 mem_z
.start
= mem_z
.end
= NULL
;
4149 /* Value is a pointer to the mem_node containing START. Value is
4150 MEM_NIL if there is no node in the tree containing START. */
4152 static struct mem_node
*
4153 mem_find (void *start
)
4157 if (start
< min_heap_address
|| start
> max_heap_address
)
4160 /* Make the search always successful to speed up the loop below. */
4161 mem_z
.start
= start
;
4162 mem_z
.end
= (char *) start
+ 1;
4165 while (start
< p
->start
|| start
>= p
->end
)
4166 p
= start
< p
->start
? p
->left
: p
->right
;
4171 /* Insert a new node into the tree for a block of memory with start
4172 address START, end address END, and type TYPE. Value is a
4173 pointer to the node that was inserted. */
4175 static struct mem_node
*
4176 mem_insert (void *start
, void *end
, enum mem_type type
)
4178 struct mem_node
*c
, *parent
, *x
;
4180 if (min_heap_address
== NULL
|| start
< min_heap_address
)
4181 min_heap_address
= start
;
4182 if (max_heap_address
== NULL
|| end
> max_heap_address
)
4183 max_heap_address
= end
;
4185 /* See where in the tree a node for START belongs. In this
4186 particular application, it shouldn't happen that a node is already
4187 present. For debugging purposes, let's check that. */
4191 while (c
!= MEM_NIL
)
4194 c
= start
< c
->start
? c
->left
: c
->right
;
4197 /* Create a new node. */
4198 #ifdef GC_MALLOC_CHECK
4199 x
= malloc (sizeof *x
);
4203 x
= xmalloc (sizeof *x
);
4209 x
->left
= x
->right
= MEM_NIL
;
4212 /* Insert it as child of PARENT or install it as root. */
4215 if (start
< parent
->start
)
4223 /* Re-establish red-black tree properties. */
4224 mem_insert_fixup (x
);
4230 /* Re-establish the red-black properties of the tree, and thereby
4231 balance the tree, after node X has been inserted; X is always red. */
4234 mem_insert_fixup (struct mem_node
*x
)
4236 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
4238 /* X is red and its parent is red. This is a violation of
4239 red-black tree property #3. */
4241 if (x
->parent
== x
->parent
->parent
->left
)
4243 /* We're on the left side of our grandparent, and Y is our
4245 struct mem_node
*y
= x
->parent
->parent
->right
;
4247 if (y
->color
== MEM_RED
)
4249 /* Uncle and parent are red but should be black because
4250 X is red. Change the colors accordingly and proceed
4251 with the grandparent. */
4252 x
->parent
->color
= MEM_BLACK
;
4253 y
->color
= MEM_BLACK
;
4254 x
->parent
->parent
->color
= MEM_RED
;
4255 x
= x
->parent
->parent
;
4259 /* Parent and uncle have different colors; parent is
4260 red, uncle is black. */
4261 if (x
== x
->parent
->right
)
4264 mem_rotate_left (x
);
4267 x
->parent
->color
= MEM_BLACK
;
4268 x
->parent
->parent
->color
= MEM_RED
;
4269 mem_rotate_right (x
->parent
->parent
);
4274 /* This is the symmetrical case of above. */
4275 struct mem_node
*y
= x
->parent
->parent
->left
;
4277 if (y
->color
== MEM_RED
)
4279 x
->parent
->color
= MEM_BLACK
;
4280 y
->color
= MEM_BLACK
;
4281 x
->parent
->parent
->color
= MEM_RED
;
4282 x
= x
->parent
->parent
;
4286 if (x
== x
->parent
->left
)
4289 mem_rotate_right (x
);
4292 x
->parent
->color
= MEM_BLACK
;
4293 x
->parent
->parent
->color
= MEM_RED
;
4294 mem_rotate_left (x
->parent
->parent
);
4299 /* The root may have been changed to red due to the algorithm. Set
4300 it to black so that property #5 is satisfied. */
4301 mem_root
->color
= MEM_BLACK
;
4312 mem_rotate_left (struct mem_node
*x
)
4316 /* Turn y's left sub-tree into x's right sub-tree. */
4319 if (y
->left
!= MEM_NIL
)
4320 y
->left
->parent
= x
;
4322 /* Y's parent was x's parent. */
4324 y
->parent
= x
->parent
;
4326 /* Get the parent to point to y instead of x. */
4329 if (x
== x
->parent
->left
)
4330 x
->parent
->left
= y
;
4332 x
->parent
->right
= y
;
4337 /* Put x on y's left. */
4351 mem_rotate_right (struct mem_node
*x
)
4353 struct mem_node
*y
= x
->left
;
4356 if (y
->right
!= MEM_NIL
)
4357 y
->right
->parent
= x
;
4360 y
->parent
= x
->parent
;
4363 if (x
== x
->parent
->right
)
4364 x
->parent
->right
= y
;
4366 x
->parent
->left
= y
;
4377 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4380 mem_delete (struct mem_node
*z
)
4382 struct mem_node
*x
, *y
;
4384 if (!z
|| z
== MEM_NIL
)
4387 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4392 while (y
->left
!= MEM_NIL
)
4396 if (y
->left
!= MEM_NIL
)
4401 x
->parent
= y
->parent
;
4404 if (y
== y
->parent
->left
)
4405 y
->parent
->left
= x
;
4407 y
->parent
->right
= x
;
4414 z
->start
= y
->start
;
4419 if (y
->color
== MEM_BLACK
)
4420 mem_delete_fixup (x
);
4422 #ifdef GC_MALLOC_CHECK
4430 /* Re-establish the red-black properties of the tree, after a
4434 mem_delete_fixup (struct mem_node
*x
)
4436 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4438 if (x
== x
->parent
->left
)
4440 struct mem_node
*w
= x
->parent
->right
;
4442 if (w
->color
== MEM_RED
)
4444 w
->color
= MEM_BLACK
;
4445 x
->parent
->color
= MEM_RED
;
4446 mem_rotate_left (x
->parent
);
4447 w
= x
->parent
->right
;
4450 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4457 if (w
->right
->color
== MEM_BLACK
)
4459 w
->left
->color
= MEM_BLACK
;
4461 mem_rotate_right (w
);
4462 w
= x
->parent
->right
;
4464 w
->color
= x
->parent
->color
;
4465 x
->parent
->color
= MEM_BLACK
;
4466 w
->right
->color
= MEM_BLACK
;
4467 mem_rotate_left (x
->parent
);
4473 struct mem_node
*w
= x
->parent
->left
;
4475 if (w
->color
== MEM_RED
)
4477 w
->color
= MEM_BLACK
;
4478 x
->parent
->color
= MEM_RED
;
4479 mem_rotate_right (x
->parent
);
4480 w
= x
->parent
->left
;
4483 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4490 if (w
->left
->color
== MEM_BLACK
)
4492 w
->right
->color
= MEM_BLACK
;
4494 mem_rotate_left (w
);
4495 w
= x
->parent
->left
;
4498 w
->color
= x
->parent
->color
;
4499 x
->parent
->color
= MEM_BLACK
;
4500 w
->left
->color
= MEM_BLACK
;
4501 mem_rotate_right (x
->parent
);
4507 x
->color
= MEM_BLACK
;
4511 /* Value is non-zero if P is a pointer to a live Lisp string on
4512 the heap. M is a pointer to the mem_block for P. */
4515 live_string_p (struct mem_node
*m
, void *p
)
4517 if (m
->type
== MEM_TYPE_STRING
)
4519 struct string_block
*b
= m
->start
;
4520 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4522 /* P must point to the start of a Lisp_String structure, and it
4523 must not be on the free-list. */
4525 && offset
% sizeof b
->strings
[0] == 0
4526 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4527 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4534 /* Value is non-zero if P is a pointer to a live Lisp cons on
4535 the heap. M is a pointer to the mem_block for P. */
4538 live_cons_p (struct mem_node
*m
, void *p
)
4540 if (m
->type
== MEM_TYPE_CONS
)
4542 struct cons_block
*b
= m
->start
;
4543 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4545 /* P must point to the start of a Lisp_Cons, not be
4546 one of the unused cells in the current cons block,
4547 and not be on the free-list. */
4549 && offset
% sizeof b
->conses
[0] == 0
4550 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4552 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4553 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4560 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4561 the heap. M is a pointer to the mem_block for P. */
4564 live_symbol_p (struct mem_node
*m
, void *p
)
4566 if (m
->type
== MEM_TYPE_SYMBOL
)
4568 struct symbol_block
*b
= m
->start
;
4569 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4571 /* P must point to the start of a Lisp_Symbol, not be
4572 one of the unused cells in the current symbol block,
4573 and not be on the free-list. */
4575 && offset
% sizeof b
->symbols
[0] == 0
4576 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4577 && (b
!= symbol_block
4578 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4579 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4586 /* Value is non-zero if P is a pointer to a live Lisp float on
4587 the heap. M is a pointer to the mem_block for P. */
4590 live_float_p (struct mem_node
*m
, void *p
)
4592 if (m
->type
== MEM_TYPE_FLOAT
)
4594 struct float_block
*b
= m
->start
;
4595 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4597 /* P must point to the start of a Lisp_Float and not be
4598 one of the unused cells in the current float block. */
4600 && offset
% sizeof b
->floats
[0] == 0
4601 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4602 && (b
!= float_block
4603 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4610 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4611 the heap. M is a pointer to the mem_block for P. */
4614 live_misc_p (struct mem_node
*m
, void *p
)
4616 if (m
->type
== MEM_TYPE_MISC
)
4618 struct marker_block
*b
= m
->start
;
4619 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4621 /* P must point to the start of a Lisp_Misc, not be
4622 one of the unused cells in the current misc block,
4623 and not be on the free-list. */
4625 && offset
% sizeof b
->markers
[0] == 0
4626 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4627 && (b
!= marker_block
4628 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4629 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4636 /* Value is non-zero if P is a pointer to a live vector-like object.
4637 M is a pointer to the mem_block for P. */
4640 live_vector_p (struct mem_node
*m
, void *p
)
4642 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4644 /* This memory node corresponds to a vector block. */
4645 struct vector_block
*block
= m
->start
;
4646 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4648 /* P is in the block's allocation range. Scan the block
4649 up to P and see whether P points to the start of some
4650 vector which is not on a free list. FIXME: check whether
4651 some allocation patterns (probably a lot of short vectors)
4652 may cause a substantial overhead of this loop. */
4653 while (VECTOR_IN_BLOCK (vector
, block
)
4654 && vector
<= (struct Lisp_Vector
*) p
)
4656 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4659 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4662 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== large_vector_vec (m
->start
))
4663 /* This memory node corresponds to a large vector. */
4669 /* Value is non-zero if P is a pointer to a live buffer. M is a
4670 pointer to the mem_block for P. */
4673 live_buffer_p (struct mem_node
*m
, void *p
)
4675 /* P must point to the start of the block, and the buffer
4676 must not have been killed. */
4677 return (m
->type
== MEM_TYPE_BUFFER
4679 && !NILP (((struct buffer
*) p
)->name_
));
4682 /* Mark OBJ if we can prove it's a Lisp_Object. */
4685 mark_maybe_object (Lisp_Object obj
)
4689 VALGRIND_MAKE_MEM_DEFINED (&obj
, sizeof (obj
));
4695 void *po
= XPNTR (obj
);
4696 struct mem_node
*m
= mem_find (po
);
4700 bool mark_p
= false;
4702 switch (XTYPE (obj
))
4705 mark_p
= (live_string_p (m
, po
)
4706 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4710 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4714 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4718 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4721 case Lisp_Vectorlike
:
4722 /* Note: can't check BUFFERP before we know it's a
4723 buffer because checking that dereferences the pointer
4724 PO which might point anywhere. */
4725 if (live_vector_p (m
, po
))
4726 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4727 else if (live_buffer_p (m
, po
))
4728 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4732 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4744 /* Return true if P can point to Lisp data, and false otherwise.
4745 Symbols are implemented via offsets not pointers, but the offsets
4746 are also multiples of GCALIGNMENT. */
4749 maybe_lisp_pointer (void *p
)
4751 return (uintptr_t) p
% GCALIGNMENT
== 0;
4754 #ifndef HAVE_MODULES
4755 enum { HAVE_MODULES
= false };
4758 /* If P points to Lisp data, mark that as live if it isn't already
4762 mark_maybe_pointer (void *p
)
4768 VALGRIND_MAKE_MEM_DEFINED (&p
, sizeof (p
));
4771 if (sizeof (Lisp_Object
) == sizeof (void *) || !HAVE_MODULES
)
4773 if (!maybe_lisp_pointer (p
))
4778 /* For the wide-int case, also mark emacs_value tagged pointers,
4779 which can be generated by emacs-module.c's value_to_lisp. */
4780 p
= (void *) ((uintptr_t) p
& ~(GCALIGNMENT
- 1));
4786 Lisp_Object obj
= Qnil
;
4790 case MEM_TYPE_NON_LISP
:
4791 case MEM_TYPE_SPARE
:
4792 /* Nothing to do; not a pointer to Lisp memory. */
4795 case MEM_TYPE_BUFFER
:
4796 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4797 XSETVECTOR (obj
, p
);
4801 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4805 case MEM_TYPE_STRING
:
4806 if (live_string_p (m
, p
)
4807 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4808 XSETSTRING (obj
, p
);
4812 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4816 case MEM_TYPE_SYMBOL
:
4817 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4818 XSETSYMBOL (obj
, p
);
4821 case MEM_TYPE_FLOAT
:
4822 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4826 case MEM_TYPE_VECTORLIKE
:
4827 case MEM_TYPE_VECTOR_BLOCK
:
4828 if (live_vector_p (m
, p
))
4831 XSETVECTOR (tem
, p
);
4832 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4847 /* Alignment of pointer values. Use alignof, as it sometimes returns
4848 a smaller alignment than GCC's __alignof__ and mark_memory might
4849 miss objects if __alignof__ were used. */
4850 #define GC_POINTER_ALIGNMENT alignof (void *)
4852 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4853 or END+OFFSET..START. */
4855 static void ATTRIBUTE_NO_SANITIZE_ADDRESS
4856 mark_memory (void *start
, void *end
)
4860 /* Make START the pointer to the start of the memory region,
4861 if it isn't already. */
4869 eassert (((uintptr_t) start
) % GC_POINTER_ALIGNMENT
== 0);
4871 /* Mark Lisp data pointed to. This is necessary because, in some
4872 situations, the C compiler optimizes Lisp objects away, so that
4873 only a pointer to them remains. Example:
4875 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4878 Lisp_Object obj = build_string ("test");
4879 struct Lisp_String *s = XSTRING (obj);
4880 Fgarbage_collect ();
4881 fprintf (stderr, "test '%s'\n", s->data);
4885 Here, `obj' isn't really used, and the compiler optimizes it
4886 away. The only reference to the life string is through the
4889 for (pp
= start
; (void *) pp
< end
; pp
+= GC_POINTER_ALIGNMENT
)
4891 mark_maybe_pointer (*(void **) pp
);
4892 mark_maybe_object (*(Lisp_Object
*) pp
);
4896 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4898 static bool setjmp_tested_p
;
4899 static int longjmps_done
;
4901 #define SETJMP_WILL_LIKELY_WORK "\
4903 Emacs garbage collector has been changed to use conservative stack\n\
4904 marking. Emacs has determined that the method it uses to do the\n\
4905 marking will likely work on your system, but this isn't sure.\n\
4907 If you are a system-programmer, or can get the help of a local wizard\n\
4908 who is, please take a look at the function mark_stack in alloc.c, and\n\
4909 verify that the methods used are appropriate for your system.\n\
4911 Please mail the result to <emacs-devel@gnu.org>.\n\
4914 #define SETJMP_WILL_NOT_WORK "\
4916 Emacs garbage collector has been changed to use conservative stack\n\
4917 marking. Emacs has determined that the default method it uses to do the\n\
4918 marking will not work on your system. We will need a system-dependent\n\
4919 solution for your system.\n\
4921 Please take a look at the function mark_stack in alloc.c, and\n\
4922 try to find a way to make it work on your system.\n\
4924 Note that you may get false negatives, depending on the compiler.\n\
4925 In particular, you need to use -O with GCC for this test.\n\
4927 Please mail the result to <emacs-devel@gnu.org>.\n\
4931 /* Perform a quick check if it looks like setjmp saves registers in a
4932 jmp_buf. Print a message to stderr saying so. When this test
4933 succeeds, this is _not_ a proof that setjmp is sufficient for
4934 conservative stack marking. Only the sources or a disassembly
4944 /* Arrange for X to be put in a register. */
4950 if (longjmps_done
== 1)
4952 /* Came here after the longjmp at the end of the function.
4954 If x == 1, the longjmp has restored the register to its
4955 value before the setjmp, and we can hope that setjmp
4956 saves all such registers in the jmp_buf, although that
4959 For other values of X, either something really strange is
4960 taking place, or the setjmp just didn't save the register. */
4963 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4966 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4973 if (longjmps_done
== 1)
4974 sys_longjmp (jbuf
, 1);
4977 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4980 /* Mark live Lisp objects on the C stack.
4982 There are several system-dependent problems to consider when
4983 porting this to new architectures:
4987 We have to mark Lisp objects in CPU registers that can hold local
4988 variables or are used to pass parameters.
4990 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4991 something that either saves relevant registers on the stack, or
4992 calls mark_maybe_object passing it each register's contents.
4994 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4995 implementation assumes that calling setjmp saves registers we need
4996 to see in a jmp_buf which itself lies on the stack. This doesn't
4997 have to be true! It must be verified for each system, possibly
4998 by taking a look at the source code of setjmp.
5000 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
5001 can use it as a machine independent method to store all registers
5002 to the stack. In this case the macros described in the previous
5003 two paragraphs are not used.
5007 Architectures differ in the way their processor stack is organized.
5008 For example, the stack might look like this
5011 | Lisp_Object | size = 4
5013 | something else | size = 2
5015 | Lisp_Object | size = 4
5019 In such a case, not every Lisp_Object will be aligned equally. To
5020 find all Lisp_Object on the stack it won't be sufficient to walk
5021 the stack in steps of 4 bytes. Instead, two passes will be
5022 necessary, one starting at the start of the stack, and a second
5023 pass starting at the start of the stack + 2. Likewise, if the
5024 minimal alignment of Lisp_Objects on the stack is 1, four passes
5025 would be necessary, each one starting with one byte more offset
5026 from the stack start. */
5029 mark_stack (void *end
)
5032 /* This assumes that the stack is a contiguous region in memory. If
5033 that's not the case, something has to be done here to iterate
5034 over the stack segments. */
5035 mark_memory (stack_base
, end
);
5037 /* Allow for marking a secondary stack, like the register stack on the
5039 #ifdef GC_MARK_SECONDARY_STACK
5040 GC_MARK_SECONDARY_STACK ();
5045 c_symbol_p (struct Lisp_Symbol
*sym
)
5047 char *lispsym_ptr
= (char *) lispsym
;
5048 char *sym_ptr
= (char *) sym
;
5049 ptrdiff_t lispsym_offset
= sym_ptr
- lispsym_ptr
;
5050 return 0 <= lispsym_offset
&& lispsym_offset
< sizeof lispsym
;
5053 /* Determine whether it is safe to access memory at address P. */
5055 valid_pointer_p (void *p
)
5058 return w32_valid_pointer_p (p
, 16);
5061 if (ADDRESS_SANITIZER
)
5066 /* Obviously, we cannot just access it (we would SEGV trying), so we
5067 trick the o/s to tell us whether p is a valid pointer.
5068 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
5069 not validate p in that case. */
5071 if (emacs_pipe (fd
) == 0)
5073 bool valid
= emacs_write (fd
[1], p
, 16) == 16;
5074 emacs_close (fd
[1]);
5075 emacs_close (fd
[0]);
5083 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5084 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5085 cannot validate OBJ. This function can be quite slow, so its primary
5086 use is the manual debugging. The only exception is print_object, where
5087 we use it to check whether the memory referenced by the pointer of
5088 Lisp_Save_Value object contains valid objects. */
5091 valid_lisp_object_p (Lisp_Object obj
)
5096 void *p
= XPNTR (obj
);
5100 if (SYMBOLP (obj
) && c_symbol_p (p
))
5101 return ((char *) p
- (char *) lispsym
) % sizeof lispsym
[0] == 0;
5103 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5106 struct mem_node
*m
= mem_find (p
);
5110 int valid
= valid_pointer_p (p
);
5122 case MEM_TYPE_NON_LISP
:
5123 case MEM_TYPE_SPARE
:
5126 case MEM_TYPE_BUFFER
:
5127 return live_buffer_p (m
, p
) ? 1 : 2;
5130 return live_cons_p (m
, p
);
5132 case MEM_TYPE_STRING
:
5133 return live_string_p (m
, p
);
5136 return live_misc_p (m
, p
);
5138 case MEM_TYPE_SYMBOL
:
5139 return live_symbol_p (m
, p
);
5141 case MEM_TYPE_FLOAT
:
5142 return live_float_p (m
, p
);
5144 case MEM_TYPE_VECTORLIKE
:
5145 case MEM_TYPE_VECTOR_BLOCK
:
5146 return live_vector_p (m
, p
);
5155 /***********************************************************************
5156 Pure Storage Management
5157 ***********************************************************************/
5159 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5160 pointer to it. TYPE is the Lisp type for which the memory is
5161 allocated. TYPE < 0 means it's not used for a Lisp object. */
5164 pure_alloc (size_t size
, int type
)
5171 /* Allocate space for a Lisp object from the beginning of the free
5172 space with taking account of alignment. */
5173 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, GCALIGNMENT
);
5174 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5178 /* Allocate space for a non-Lisp object from the end of the free
5180 pure_bytes_used_non_lisp
+= size
;
5181 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5183 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5185 if (pure_bytes_used
<= pure_size
)
5188 /* Don't allocate a large amount here,
5189 because it might get mmap'd and then its address
5190 might not be usable. */
5191 purebeg
= xmalloc (10000);
5193 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5194 pure_bytes_used
= 0;
5195 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5200 /* Print a warning if PURESIZE is too small. */
5203 check_pure_size (void)
5205 if (pure_bytes_used_before_overflow
)
5206 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5208 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5212 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5213 the non-Lisp data pool of the pure storage, and return its start
5214 address. Return NULL if not found. */
5217 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5220 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5221 const unsigned char *p
;
5224 if (pure_bytes_used_non_lisp
<= nbytes
)
5227 /* Set up the Boyer-Moore table. */
5229 for (i
= 0; i
< 256; i
++)
5232 p
= (const unsigned char *) data
;
5234 bm_skip
[*p
++] = skip
;
5236 last_char_skip
= bm_skip
['\0'];
5238 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5239 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5241 /* See the comments in the function `boyer_moore' (search.c) for the
5242 use of `infinity'. */
5243 infinity
= pure_bytes_used_non_lisp
+ 1;
5244 bm_skip
['\0'] = infinity
;
5246 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5250 /* Check the last character (== '\0'). */
5253 start
+= bm_skip
[*(p
+ start
)];
5255 while (start
<= start_max
);
5257 if (start
< infinity
)
5258 /* Couldn't find the last character. */
5261 /* No less than `infinity' means we could find the last
5262 character at `p[start - infinity]'. */
5265 /* Check the remaining characters. */
5266 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5268 return non_lisp_beg
+ start
;
5270 start
+= last_char_skip
;
5272 while (start
<= start_max
);
5278 /* Return a string allocated in pure space. DATA is a buffer holding
5279 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5280 means make the result string multibyte.
5282 Must get an error if pure storage is full, since if it cannot hold
5283 a large string it may be able to hold conses that point to that
5284 string; then the string is not protected from gc. */
5287 make_pure_string (const char *data
,
5288 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5291 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5292 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5293 if (s
->data
== NULL
)
5295 s
->data
= pure_alloc (nbytes
+ 1, -1);
5296 memcpy (s
->data
, data
, nbytes
);
5297 s
->data
[nbytes
] = '\0';
5300 s
->size_byte
= multibyte
? nbytes
: -1;
5301 s
->intervals
= NULL
;
5302 XSETSTRING (string
, s
);
5306 /* Return a string allocated in pure space. Do not
5307 allocate the string data, just point to DATA. */
5310 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5313 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5316 s
->data
= (unsigned char *) data
;
5317 s
->intervals
= NULL
;
5318 XSETSTRING (string
, s
);
5322 static Lisp_Object
purecopy (Lisp_Object obj
);
5324 /* Return a cons allocated from pure space. Give it pure copies
5325 of CAR as car and CDR as cdr. */
5328 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5331 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5333 XSETCAR (new, purecopy (car
));
5334 XSETCDR (new, purecopy (cdr
));
5339 /* Value is a float object with value NUM allocated from pure space. */
5342 make_pure_float (double num
)
5345 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5347 XFLOAT_INIT (new, num
);
5352 /* Return a vector with room for LEN Lisp_Objects allocated from
5356 make_pure_vector (ptrdiff_t len
)
5359 size_t size
= header_size
+ len
* word_size
;
5360 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5361 XSETVECTOR (new, p
);
5362 XVECTOR (new)->header
.size
= len
;
5366 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5367 doc
: /* Make a copy of object OBJ in pure storage.
5368 Recursively copies contents of vectors and cons cells.
5369 Does not copy symbols. Copies strings without text properties. */)
5370 (register Lisp_Object obj
)
5372 if (NILP (Vpurify_flag
))
5374 else if (MARKERP (obj
) || OVERLAYP (obj
)
5375 || HASH_TABLE_P (obj
) || SYMBOLP (obj
))
5376 /* Can't purify those. */
5379 return purecopy (obj
);
5383 purecopy (Lisp_Object obj
)
5386 || (! SYMBOLP (obj
) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj
)))
5388 return obj
; /* Already pure. */
5390 if (STRINGP (obj
) && XSTRING (obj
)->intervals
)
5391 message_with_string ("Dropping text-properties while making string `%s' pure",
5394 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5396 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5402 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5403 else if (FLOATP (obj
))
5404 obj
= make_pure_float (XFLOAT_DATA (obj
));
5405 else if (STRINGP (obj
))
5406 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5408 STRING_MULTIBYTE (obj
));
5409 else if (COMPILEDP (obj
) || VECTORP (obj
) || HASH_TABLE_P (obj
))
5411 struct Lisp_Vector
*objp
= XVECTOR (obj
);
5412 ptrdiff_t nbytes
= vector_nbytes (objp
);
5413 struct Lisp_Vector
*vec
= pure_alloc (nbytes
, Lisp_Vectorlike
);
5414 register ptrdiff_t i
;
5415 ptrdiff_t size
= ASIZE (obj
);
5416 if (size
& PSEUDOVECTOR_FLAG
)
5417 size
&= PSEUDOVECTOR_SIZE_MASK
;
5418 memcpy (vec
, objp
, nbytes
);
5419 for (i
= 0; i
< size
; i
++)
5420 vec
->contents
[i
] = purecopy (vec
->contents
[i
]);
5421 XSETVECTOR (obj
, vec
);
5423 else if (SYMBOLP (obj
))
5425 if (!XSYMBOL (obj
)->pinned
&& !c_symbol_p (XSYMBOL (obj
)))
5426 { /* We can't purify them, but they appear in many pure objects.
5427 Mark them as `pinned' so we know to mark them at every GC cycle. */
5428 XSYMBOL (obj
)->pinned
= true;
5429 symbol_block_pinned
= symbol_block
;
5431 /* Don't hash-cons it. */
5436 Lisp_Object fmt
= build_pure_c_string ("Don't know how to purify: %S");
5437 Fsignal (Qerror
, list1 (CALLN (Fformat
, fmt
, obj
)));
5440 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5441 Fputhash (obj
, obj
, Vpurify_flag
);
5448 /***********************************************************************
5450 ***********************************************************************/
5452 /* Put an entry in staticvec, pointing at the variable with address
5456 staticpro (Lisp_Object
*varaddress
)
5458 if (staticidx
>= NSTATICS
)
5459 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5460 staticvec
[staticidx
++] = varaddress
;
5464 /***********************************************************************
5466 ***********************************************************************/
5468 /* Temporarily prevent garbage collection. */
5471 inhibit_garbage_collection (void)
5473 ptrdiff_t count
= SPECPDL_INDEX ();
5475 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5479 /* Used to avoid possible overflows when
5480 converting from C to Lisp integers. */
5483 bounded_number (EMACS_INT number
)
5485 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5488 /* Calculate total bytes of live objects. */
5491 total_bytes_of_live_objects (void)
5494 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5495 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5496 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5497 tot
+= total_string_bytes
;
5498 tot
+= total_vector_slots
* word_size
;
5499 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5500 tot
+= total_intervals
* sizeof (struct interval
);
5501 tot
+= total_strings
* sizeof (struct Lisp_String
);
5505 #ifdef HAVE_WINDOW_SYSTEM
5507 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
5508 (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
5511 compact_font_cache_entry (Lisp_Object entry
)
5513 Lisp_Object tail
, *prev
= &entry
;
5515 for (tail
= entry
; CONSP (tail
); tail
= XCDR (tail
))
5518 Lisp_Object obj
= XCAR (tail
);
5520 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5521 if (CONSP (obj
) && GC_FONT_SPEC_P (XCAR (obj
))
5522 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj
)))
5523 /* Don't use VECTORP here, as that calls ASIZE, which could
5524 hit assertion violation during GC. */
5525 && (VECTORLIKEP (XCDR (obj
))
5526 && ! (gc_asize (XCDR (obj
)) & PSEUDOVECTOR_FLAG
)))
5528 ptrdiff_t i
, size
= gc_asize (XCDR (obj
));
5529 Lisp_Object obj_cdr
= XCDR (obj
);
5531 /* If font-spec is not marked, most likely all font-entities
5532 are not marked too. But we must be sure that nothing is
5533 marked within OBJ before we really drop it. */
5534 for (i
= 0; i
< size
; i
++)
5536 Lisp_Object objlist
;
5538 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr
, i
))))
5541 objlist
= AREF (AREF (obj_cdr
, i
), FONT_OBJLIST_INDEX
);
5542 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
5544 Lisp_Object val
= XCAR (objlist
);
5545 struct font
*font
= GC_XFONT_OBJECT (val
);
5547 if (!NILP (AREF (val
, FONT_TYPE_INDEX
))
5548 && VECTOR_MARKED_P(font
))
5551 if (CONSP (objlist
))
5553 /* Found a marked font, bail out. */
5560 /* No marked fonts were found, so this entire font
5561 entity can be dropped. */
5566 *prev
= XCDR (tail
);
5568 prev
= xcdr_addr (tail
);
5573 /* Compact font caches on all terminals and mark
5574 everything which is still here after compaction. */
5577 compact_font_caches (void)
5581 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5583 Lisp_Object cache
= TERMINAL_FONT_CACHE (t
);
5588 for (entry
= XCDR (cache
); CONSP (entry
); entry
= XCDR (entry
))
5589 XSETCAR (entry
, compact_font_cache_entry (XCAR (entry
)));
5591 mark_object (cache
);
5595 #else /* not HAVE_WINDOW_SYSTEM */
5597 #define compact_font_caches() (void)(0)
5599 #endif /* HAVE_WINDOW_SYSTEM */
5601 /* Remove (MARKER . DATA) entries with unmarked MARKER
5602 from buffer undo LIST and return changed list. */
5605 compact_undo_list (Lisp_Object list
)
5607 Lisp_Object tail
, *prev
= &list
;
5609 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
5611 if (CONSP (XCAR (tail
))
5612 && MARKERP (XCAR (XCAR (tail
)))
5613 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5614 *prev
= XCDR (tail
);
5616 prev
= xcdr_addr (tail
);
5622 mark_pinned_symbols (void)
5624 struct symbol_block
*sblk
;
5625 int lim
= (symbol_block_pinned
== symbol_block
5626 ? symbol_block_index
: SYMBOL_BLOCK_SIZE
);
5628 for (sblk
= symbol_block_pinned
; sblk
; sblk
= sblk
->next
)
5630 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
, *end
= sym
+ lim
;
5631 for (; sym
< end
; ++sym
)
5633 mark_object (make_lisp_symbol (&sym
->s
));
5635 lim
= SYMBOL_BLOCK_SIZE
;
5639 /* Subroutine of Fgarbage_collect that does most of the work. It is a
5640 separate function so that we could limit mark_stack in searching
5641 the stack frames below this function, thus avoiding the rare cases
5642 where mark_stack finds values that look like live Lisp objects on
5643 portions of stack that couldn't possibly contain such live objects.
5644 For more details of this, see the discussion at
5645 http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
5647 garbage_collect_1 (void *end
)
5649 struct buffer
*nextb
;
5650 char stack_top_variable
;
5653 ptrdiff_t count
= SPECPDL_INDEX ();
5654 struct timespec start
;
5655 Lisp_Object retval
= Qnil
;
5656 size_t tot_before
= 0;
5661 /* Can't GC if pure storage overflowed because we can't determine
5662 if something is a pure object or not. */
5663 if (pure_bytes_used_before_overflow
)
5666 /* Record this function, so it appears on the profiler's backtraces. */
5667 record_in_backtrace (Qautomatic_gc
, 0, 0);
5671 /* Don't keep undo information around forever.
5672 Do this early on, so it is no problem if the user quits. */
5673 FOR_EACH_BUFFER (nextb
)
5674 compact_buffer (nextb
);
5676 if (profiler_memory_running
)
5677 tot_before
= total_bytes_of_live_objects ();
5679 start
= current_timespec ();
5681 /* In case user calls debug_print during GC,
5682 don't let that cause a recursive GC. */
5683 consing_since_gc
= 0;
5685 /* Save what's currently displayed in the echo area. Don't do that
5686 if we are GC'ing because we've run out of memory, since
5687 push_message will cons, and we might have no memory for that. */
5688 if (NILP (Vmemory_full
))
5690 message_p
= push_message ();
5691 record_unwind_protect_void (pop_message_unwind
);
5696 /* Save a copy of the contents of the stack, for debugging. */
5697 #if MAX_SAVE_STACK > 0
5698 if (NILP (Vpurify_flag
))
5701 ptrdiff_t stack_size
;
5702 if (&stack_top_variable
< stack_bottom
)
5704 stack
= &stack_top_variable
;
5705 stack_size
= stack_bottom
- &stack_top_variable
;
5709 stack
= stack_bottom
;
5710 stack_size
= &stack_top_variable
- stack_bottom
;
5712 if (stack_size
<= MAX_SAVE_STACK
)
5714 if (stack_copy_size
< stack_size
)
5716 stack_copy
= xrealloc (stack_copy
, stack_size
);
5717 stack_copy_size
= stack_size
;
5719 no_sanitize_memcpy (stack_copy
, stack
, stack_size
);
5722 #endif /* MAX_SAVE_STACK > 0 */
5724 if (garbage_collection_messages
)
5725 message1_nolog ("Garbage collecting...");
5729 shrink_regexp_cache ();
5733 /* Mark all the special slots that serve as the roots of accessibility. */
5735 mark_buffer (&buffer_defaults
);
5736 mark_buffer (&buffer_local_symbols
);
5738 for (i
= 0; i
< ARRAYELTS (lispsym
); i
++)
5739 mark_object (builtin_lisp_symbol (i
));
5741 for (i
= 0; i
< staticidx
; i
++)
5742 mark_object (*staticvec
[i
]);
5744 mark_pinned_symbols ();
5756 struct handler
*handler
;
5757 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5759 mark_object (handler
->tag_or_ch
);
5760 mark_object (handler
->val
);
5763 #ifdef HAVE_WINDOW_SYSTEM
5764 mark_fringe_data ();
5767 /* Everything is now marked, except for the data in font caches,
5768 undo lists, and finalizers. The first two are compacted by
5769 removing an items which aren't reachable otherwise. */
5771 compact_font_caches ();
5773 FOR_EACH_BUFFER (nextb
)
5775 if (!EQ (BVAR (nextb
, undo_list
), Qt
))
5776 bset_undo_list (nextb
, compact_undo_list (BVAR (nextb
, undo_list
)));
5777 /* Now that we have stripped the elements that need not be
5778 in the undo_list any more, we can finally mark the list. */
5779 mark_object (BVAR (nextb
, undo_list
));
5782 /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
5783 to doomed_finalizers so we can run their associated functions
5784 after GC. It's important to scan finalizers at this stage so
5785 that we can be sure that unmarked finalizers are really
5786 unreachable except for references from their associated functions
5787 and from other finalizers. */
5789 queue_doomed_finalizers (&doomed_finalizers
, &finalizers
);
5790 mark_finalizer_list (&doomed_finalizers
);
5794 relocate_byte_stack ();
5796 /* Clear the mark bits that we set in certain root slots. */
5797 VECTOR_UNMARK (&buffer_defaults
);
5798 VECTOR_UNMARK (&buffer_local_symbols
);
5806 consing_since_gc
= 0;
5807 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5808 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5810 gc_relative_threshold
= 0;
5811 if (FLOATP (Vgc_cons_percentage
))
5812 { /* Set gc_cons_combined_threshold. */
5813 double tot
= total_bytes_of_live_objects ();
5815 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5818 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5819 gc_relative_threshold
= tot
;
5821 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5825 if (garbage_collection_messages
&& NILP (Vmemory_full
))
5827 if (message_p
|| minibuf_level
> 0)
5830 message1_nolog ("Garbage collecting...done");
5833 unbind_to (count
, Qnil
);
5835 Lisp_Object total
[] = {
5836 list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5837 bounded_number (total_conses
),
5838 bounded_number (total_free_conses
)),
5839 list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5840 bounded_number (total_symbols
),
5841 bounded_number (total_free_symbols
)),
5842 list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5843 bounded_number (total_markers
),
5844 bounded_number (total_free_markers
)),
5845 list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5846 bounded_number (total_strings
),
5847 bounded_number (total_free_strings
)),
5848 list3 (Qstring_bytes
, make_number (1),
5849 bounded_number (total_string_bytes
)),
5851 make_number (header_size
+ sizeof (Lisp_Object
)),
5852 bounded_number (total_vectors
)),
5853 list4 (Qvector_slots
, make_number (word_size
),
5854 bounded_number (total_vector_slots
),
5855 bounded_number (total_free_vector_slots
)),
5856 list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5857 bounded_number (total_floats
),
5858 bounded_number (total_free_floats
)),
5859 list4 (Qintervals
, make_number (sizeof (struct interval
)),
5860 bounded_number (total_intervals
),
5861 bounded_number (total_free_intervals
)),
5862 list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5863 bounded_number (total_buffers
)),
5865 #ifdef DOUG_LEA_MALLOC
5866 list4 (Qheap
, make_number (1024),
5867 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5868 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10)),
5871 retval
= CALLMANY (Flist
, total
);
5873 /* GC is complete: now we can run our finalizer callbacks. */
5874 run_finalizers (&doomed_finalizers
);
5876 if (!NILP (Vpost_gc_hook
))
5878 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5879 safe_run_hooks (Qpost_gc_hook
);
5880 unbind_to (gc_count
, Qnil
);
5883 /* Accumulate statistics. */
5884 if (FLOATP (Vgc_elapsed
))
5886 struct timespec since_start
= timespec_sub (current_timespec (), start
);
5887 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5888 + timespectod (since_start
));
5893 /* Collect profiling data. */
5894 if (profiler_memory_running
)
5897 size_t tot_after
= total_bytes_of_live_objects ();
5898 if (tot_before
> tot_after
)
5899 swept
= tot_before
- tot_after
;
5900 malloc_probe (swept
);
5906 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5907 doc
: /* Reclaim storage for Lisp objects no longer needed.
5908 Garbage collection happens automatically if you cons more than
5909 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5910 `garbage-collect' normally returns a list with info on amount of space in use,
5911 where each entry has the form (NAME SIZE USED FREE), where:
5912 - NAME is a symbol describing the kind of objects this entry represents,
5913 - SIZE is the number of bytes used by each one,
5914 - USED is the number of those objects that were found live in the heap,
5915 - FREE is the number of those objects that are not live but that Emacs
5916 keeps around for future allocations (maybe because it does not know how
5917 to return them to the OS).
5918 However, if there was overflow in pure space, `garbage-collect'
5919 returns nil, because real GC can't be done.
5920 See Info node `(elisp)Garbage Collection'. */)
5925 #ifdef HAVE___BUILTIN_UNWIND_INIT
5926 /* Force callee-saved registers and register windows onto the stack.
5927 This is the preferred method if available, obviating the need for
5928 machine dependent methods. */
5929 __builtin_unwind_init ();
5931 #else /* not HAVE___BUILTIN_UNWIND_INIT */
5932 #ifndef GC_SAVE_REGISTERS_ON_STACK
5933 /* jmp_buf may not be aligned enough on darwin-ppc64 */
5934 union aligned_jmpbuf
{
5938 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
5940 /* This trick flushes the register windows so that all the state of
5941 the process is contained in the stack. */
5942 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
5943 needed on ia64 too. See mach_dep.c, where it also says inline
5944 assembler doesn't work with relevant proprietary compilers. */
5946 #if defined (__sparc64__) && defined (__FreeBSD__)
5947 /* FreeBSD does not have a ta 3 handler. */
5954 /* Save registers that we need to see on the stack. We need to see
5955 registers used to hold register variables and registers used to
5957 #ifdef GC_SAVE_REGISTERS_ON_STACK
5958 GC_SAVE_REGISTERS_ON_STACK (end
);
5959 #else /* not GC_SAVE_REGISTERS_ON_STACK */
5961 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
5962 setjmp will definitely work, test it
5963 and print a message with the result
5965 if (!setjmp_tested_p
)
5967 setjmp_tested_p
= 1;
5970 #endif /* GC_SETJMP_WORKS */
5973 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
5974 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
5975 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
5976 return garbage_collect_1 (end
);
5979 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5980 only interesting objects referenced from glyphs are strings. */
5983 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5985 struct glyph_row
*row
= matrix
->rows
;
5986 struct glyph_row
*end
= row
+ matrix
->nrows
;
5988 for (; row
< end
; ++row
)
5992 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5994 struct glyph
*glyph
= row
->glyphs
[area
];
5995 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5997 for (; glyph
< end_glyph
; ++glyph
)
5998 if (STRINGP (glyph
->object
)
5999 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
6000 mark_object (glyph
->object
);
6005 /* Mark reference to a Lisp_Object.
6006 If the object referred to has not been seen yet, recursively mark
6007 all the references contained in it. */
6009 #define LAST_MARKED_SIZE 500
6010 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
6011 static int last_marked_index
;
6013 /* For debugging--call abort when we cdr down this many
6014 links of a list, in mark_object. In debugging,
6015 the call to abort will hit a breakpoint.
6016 Normally this is zero and the check never goes off. */
6017 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
6020 mark_vectorlike (struct Lisp_Vector
*ptr
)
6022 ptrdiff_t size
= ptr
->header
.size
;
6025 eassert (!VECTOR_MARKED_P (ptr
));
6026 VECTOR_MARK (ptr
); /* Else mark it. */
6027 if (size
& PSEUDOVECTOR_FLAG
)
6028 size
&= PSEUDOVECTOR_SIZE_MASK
;
6030 /* Note that this size is not the memory-footprint size, but only
6031 the number of Lisp_Object fields that we should trace.
6032 The distinction is used e.g. by Lisp_Process which places extra
6033 non-Lisp_Object fields at the end of the structure... */
6034 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
6035 mark_object (ptr
->contents
[i
]);
6038 /* Like mark_vectorlike but optimized for char-tables (and
6039 sub-char-tables) assuming that the contents are mostly integers or
6043 mark_char_table (struct Lisp_Vector
*ptr
, enum pvec_type pvectype
)
6045 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6046 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
6047 int i
, idx
= (pvectype
== PVEC_SUB_CHAR_TABLE
? SUB_CHAR_TABLE_OFFSET
: 0);
6049 eassert (!VECTOR_MARKED_P (ptr
));
6051 for (i
= idx
; i
< size
; i
++)
6053 Lisp_Object val
= ptr
->contents
[i
];
6055 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
6057 if (SUB_CHAR_TABLE_P (val
))
6059 if (! VECTOR_MARKED_P (XVECTOR (val
)))
6060 mark_char_table (XVECTOR (val
), PVEC_SUB_CHAR_TABLE
);
6067 NO_INLINE
/* To reduce stack depth in mark_object. */
6069 mark_compiled (struct Lisp_Vector
*ptr
)
6071 int i
, size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6074 for (i
= 0; i
< size
; i
++)
6075 if (i
!= COMPILED_CONSTANTS
)
6076 mark_object (ptr
->contents
[i
]);
6077 return size
> COMPILED_CONSTANTS
? ptr
->contents
[COMPILED_CONSTANTS
] : Qnil
;
6080 /* Mark the chain of overlays starting at PTR. */
6083 mark_overlay (struct Lisp_Overlay
*ptr
)
6085 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
6088 /* These two are always markers and can be marked fast. */
6089 XMARKER (ptr
->start
)->gcmarkbit
= 1;
6090 XMARKER (ptr
->end
)->gcmarkbit
= 1;
6091 mark_object (ptr
->plist
);
6095 /* Mark Lisp_Objects and special pointers in BUFFER. */
6098 mark_buffer (struct buffer
*buffer
)
6100 /* This is handled much like other pseudovectors... */
6101 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
6103 /* ...but there are some buffer-specific things. */
6105 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
6107 /* For now, we just don't mark the undo_list. It's done later in
6108 a special way just before the sweep phase, and after stripping
6109 some of its elements that are not needed any more. */
6111 mark_overlay (buffer
->overlays_before
);
6112 mark_overlay (buffer
->overlays_after
);
6114 /* If this is an indirect buffer, mark its base buffer. */
6115 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
6116 mark_buffer (buffer
->base_buffer
);
6119 /* Mark Lisp faces in the face cache C. */
6121 NO_INLINE
/* To reduce stack depth in mark_object. */
6123 mark_face_cache (struct face_cache
*c
)
6128 for (i
= 0; i
< c
->used
; ++i
)
6130 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
6134 if (face
->font
&& !VECTOR_MARKED_P (face
->font
))
6135 mark_vectorlike ((struct Lisp_Vector
*) face
->font
);
6137 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
6138 mark_object (face
->lface
[j
]);
6144 NO_INLINE
/* To reduce stack depth in mark_object. */
6146 mark_localized_symbol (struct Lisp_Symbol
*ptr
)
6148 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6149 Lisp_Object where
= blv
->where
;
6150 /* If the value is set up for a killed buffer or deleted
6151 frame, restore its global binding. If the value is
6152 forwarded to a C variable, either it's not a Lisp_Object
6153 var, or it's staticpro'd already. */
6154 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6155 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6156 swap_in_global_binding (ptr
);
6157 mark_object (blv
->where
);
6158 mark_object (blv
->valcell
);
6159 mark_object (blv
->defcell
);
6162 NO_INLINE
/* To reduce stack depth in mark_object. */
6164 mark_save_value (struct Lisp_Save_Value
*ptr
)
6166 /* If `save_type' is zero, `data[0].pointer' is the address
6167 of a memory area containing `data[1].integer' potential
6169 if (ptr
->save_type
== SAVE_TYPE_MEMORY
)
6171 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6173 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6174 mark_maybe_object (*p
);
6178 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6180 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6181 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6182 mark_object (ptr
->data
[i
].object
);
6186 /* Remove killed buffers or items whose car is a killed buffer from
6187 LIST, and mark other items. Return changed LIST, which is marked. */
6190 mark_discard_killed_buffers (Lisp_Object list
)
6192 Lisp_Object tail
, *prev
= &list
;
6194 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
6197 Lisp_Object tem
= XCAR (tail
);
6200 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
6201 *prev
= XCDR (tail
);
6204 CONS_MARK (XCONS (tail
));
6205 mark_object (XCAR (tail
));
6206 prev
= xcdr_addr (tail
);
6213 /* Determine type of generic Lisp_Object and mark it accordingly.
6215 This function implements a straightforward depth-first marking
6216 algorithm and so the recursion depth may be very high (a few
6217 tens of thousands is not uncommon). To minimize stack usage,
6218 a few cold paths are moved out to NO_INLINE functions above.
6219 In general, inlining them doesn't help you to gain more speed. */
6222 mark_object (Lisp_Object arg
)
6224 register Lisp_Object obj
;
6226 #ifdef GC_CHECK_MARKED_OBJECTS
6229 ptrdiff_t cdr_count
= 0;
6238 last_marked
[last_marked_index
++] = obj
;
6239 if (last_marked_index
== LAST_MARKED_SIZE
)
6240 last_marked_index
= 0;
6242 /* Perform some sanity checks on the objects marked here. Abort if
6243 we encounter an object we know is bogus. This increases GC time
6245 #ifdef GC_CHECK_MARKED_OBJECTS
6247 /* Check that the object pointed to by PO is known to be a Lisp
6248 structure allocated from the heap. */
6249 #define CHECK_ALLOCATED() \
6251 m = mem_find (po); \
6256 /* Check that the object pointed to by PO is live, using predicate
6258 #define CHECK_LIVE(LIVEP) \
6260 if (!LIVEP (m, po)) \
6264 /* Check both of the above conditions, for non-symbols. */
6265 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
6267 CHECK_ALLOCATED (); \
6268 CHECK_LIVE (LIVEP); \
6271 /* Check both of the above conditions, for symbols. */
6272 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6274 if (!c_symbol_p (ptr)) \
6276 CHECK_ALLOCATED (); \
6277 CHECK_LIVE (live_symbol_p); \
6281 #else /* not GC_CHECK_MARKED_OBJECTS */
6283 #define CHECK_LIVE(LIVEP) ((void) 0)
6284 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
6285 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6287 #endif /* not GC_CHECK_MARKED_OBJECTS */
6289 switch (XTYPE (obj
))
6293 register struct Lisp_String
*ptr
= XSTRING (obj
);
6294 if (STRING_MARKED_P (ptr
))
6296 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
6298 MARK_INTERVAL_TREE (ptr
->intervals
);
6299 #ifdef GC_CHECK_STRING_BYTES
6300 /* Check that the string size recorded in the string is the
6301 same as the one recorded in the sdata structure. */
6303 #endif /* GC_CHECK_STRING_BYTES */
6307 case Lisp_Vectorlike
:
6309 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
6310 register ptrdiff_t pvectype
;
6312 if (VECTOR_MARKED_P (ptr
))
6315 #ifdef GC_CHECK_MARKED_OBJECTS
6317 if (m
== MEM_NIL
&& !SUBRP (obj
))
6319 #endif /* GC_CHECK_MARKED_OBJECTS */
6321 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
6322 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
6323 >> PSEUDOVECTOR_AREA_BITS
);
6325 pvectype
= PVEC_NORMAL_VECTOR
;
6327 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
6328 CHECK_LIVE (live_vector_p
);
6333 #ifdef GC_CHECK_MARKED_OBJECTS
6342 #endif /* GC_CHECK_MARKED_OBJECTS */
6343 mark_buffer ((struct buffer
*) ptr
);
6347 /* Although we could treat this just like a vector, mark_compiled
6348 returns the COMPILED_CONSTANTS element, which is marked at the
6349 next iteration of goto-loop here. This is done to avoid a few
6350 recursive calls to mark_object. */
6351 obj
= mark_compiled (ptr
);
6358 struct frame
*f
= (struct frame
*) ptr
;
6360 mark_vectorlike (ptr
);
6361 mark_face_cache (f
->face_cache
);
6362 #ifdef HAVE_WINDOW_SYSTEM
6363 if (FRAME_WINDOW_P (f
) && FRAME_X_OUTPUT (f
))
6365 struct font
*font
= FRAME_FONT (f
);
6367 if (font
&& !VECTOR_MARKED_P (font
))
6368 mark_vectorlike ((struct Lisp_Vector
*) font
);
6376 struct window
*w
= (struct window
*) ptr
;
6378 mark_vectorlike (ptr
);
6380 /* Mark glyph matrices, if any. Marking window
6381 matrices is sufficient because frame matrices
6382 use the same glyph memory. */
6383 if (w
->current_matrix
)
6385 mark_glyph_matrix (w
->current_matrix
);
6386 mark_glyph_matrix (w
->desired_matrix
);
6389 /* Filter out killed buffers from both buffer lists
6390 in attempt to help GC to reclaim killed buffers faster.
6391 We can do it elsewhere for live windows, but this is the
6392 best place to do it for dead windows. */
6394 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6396 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6400 case PVEC_HASH_TABLE
:
6402 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6404 mark_vectorlike (ptr
);
6405 mark_object (h
->test
.name
);
6406 mark_object (h
->test
.user_hash_function
);
6407 mark_object (h
->test
.user_cmp_function
);
6408 /* If hash table is not weak, mark all keys and values.
6409 For weak tables, mark only the vector. */
6411 mark_object (h
->key_and_value
);
6413 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6417 case PVEC_CHAR_TABLE
:
6418 case PVEC_SUB_CHAR_TABLE
:
6419 mark_char_table (ptr
, (enum pvec_type
) pvectype
);
6422 case PVEC_BOOL_VECTOR
:
6423 /* No Lisp_Objects to mark in a bool vector. */
6434 mark_vectorlike (ptr
);
6441 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6445 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6447 /* Attempt to catch bogus objects. */
6448 eassert (valid_lisp_object_p (ptr
->function
));
6449 mark_object (ptr
->function
);
6450 mark_object (ptr
->plist
);
6451 switch (ptr
->redirect
)
6453 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6454 case SYMBOL_VARALIAS
:
6457 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6461 case SYMBOL_LOCALIZED
:
6462 mark_localized_symbol (ptr
);
6464 case SYMBOL_FORWARDED
:
6465 /* If the value is forwarded to a buffer or keyboard field,
6466 these are marked when we see the corresponding object.
6467 And if it's forwarded to a C variable, either it's not
6468 a Lisp_Object var, or it's staticpro'd already. */
6470 default: emacs_abort ();
6472 if (!PURE_P (XSTRING (ptr
->name
)))
6473 MARK_STRING (XSTRING (ptr
->name
));
6474 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6475 /* Inner loop to mark next symbol in this bucket, if any. */
6476 po
= ptr
= ptr
->next
;
6483 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6485 if (XMISCANY (obj
)->gcmarkbit
)
6488 switch (XMISCTYPE (obj
))
6490 case Lisp_Misc_Marker
:
6491 /* DO NOT mark thru the marker's chain.
6492 The buffer's markers chain does not preserve markers from gc;
6493 instead, markers are removed from the chain when freed by gc. */
6494 XMISCANY (obj
)->gcmarkbit
= 1;
6497 case Lisp_Misc_Save_Value
:
6498 XMISCANY (obj
)->gcmarkbit
= 1;
6499 mark_save_value (XSAVE_VALUE (obj
));
6502 case Lisp_Misc_Overlay
:
6503 mark_overlay (XOVERLAY (obj
));
6506 case Lisp_Misc_Finalizer
:
6507 XMISCANY (obj
)->gcmarkbit
= true;
6508 mark_object (XFINALIZER (obj
)->function
);
6512 case Lisp_Misc_User_Ptr
:
6513 XMISCANY (obj
)->gcmarkbit
= true;
6524 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6525 if (CONS_MARKED_P (ptr
))
6527 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6529 /* If the cdr is nil, avoid recursion for the car. */
6530 if (EQ (ptr
->u
.cdr
, Qnil
))
6536 mark_object (ptr
->car
);
6539 if (cdr_count
== mark_object_loop_halt
)
6545 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6546 FLOAT_MARK (XFLOAT (obj
));
6557 #undef CHECK_ALLOCATED
6558 #undef CHECK_ALLOCATED_AND_LIVE
6560 /* Mark the Lisp pointers in the terminal objects.
6561 Called by Fgarbage_collect. */
6564 mark_terminals (void)
6567 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6569 eassert (t
->name
!= NULL
);
6570 #ifdef HAVE_WINDOW_SYSTEM
6571 /* If a terminal object is reachable from a stacpro'ed object,
6572 it might have been marked already. Make sure the image cache
6574 mark_image_cache (t
->image_cache
);
6575 #endif /* HAVE_WINDOW_SYSTEM */
6576 if (!VECTOR_MARKED_P (t
))
6577 mark_vectorlike ((struct Lisp_Vector
*)t
);
6583 /* Value is non-zero if OBJ will survive the current GC because it's
6584 either marked or does not need to be marked to survive. */
6587 survives_gc_p (Lisp_Object obj
)
6591 switch (XTYPE (obj
))
6598 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6602 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6606 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6609 case Lisp_Vectorlike
:
6610 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6614 survives_p
= CONS_MARKED_P (XCONS (obj
));
6618 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6625 return survives_p
|| PURE_P (XPNTR (obj
));
6631 NO_INLINE
/* For better stack traces */
6635 struct cons_block
*cblk
;
6636 struct cons_block
**cprev
= &cons_block
;
6637 int lim
= cons_block_index
;
6638 EMACS_INT num_free
= 0, num_used
= 0;
6642 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6646 int ilim
= (lim
+ BITS_PER_BITS_WORD
- 1) / BITS_PER_BITS_WORD
;
6648 /* Scan the mark bits an int at a time. */
6649 for (i
= 0; i
< ilim
; i
++)
6651 if (cblk
->gcmarkbits
[i
] == BITS_WORD_MAX
)
6653 /* Fast path - all cons cells for this int are marked. */
6654 cblk
->gcmarkbits
[i
] = 0;
6655 num_used
+= BITS_PER_BITS_WORD
;
6659 /* Some cons cells for this int are not marked.
6660 Find which ones, and free them. */
6661 int start
, pos
, stop
;
6663 start
= i
* BITS_PER_BITS_WORD
;
6665 if (stop
> BITS_PER_BITS_WORD
)
6666 stop
= BITS_PER_BITS_WORD
;
6669 for (pos
= start
; pos
< stop
; pos
++)
6671 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6674 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6675 cons_free_list
= &cblk
->conses
[pos
];
6676 cons_free_list
->car
= Vdead
;
6681 CONS_UNMARK (&cblk
->conses
[pos
]);
6687 lim
= CONS_BLOCK_SIZE
;
6688 /* If this block contains only free conses and we have already
6689 seen more than two blocks worth of free conses then deallocate
6691 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6693 *cprev
= cblk
->next
;
6694 /* Unhook from the free list. */
6695 cons_free_list
= cblk
->conses
[0].u
.chain
;
6696 lisp_align_free (cblk
);
6700 num_free
+= this_free
;
6701 cprev
= &cblk
->next
;
6704 total_conses
= num_used
;
6705 total_free_conses
= num_free
;
6708 NO_INLINE
/* For better stack traces */
6712 register struct float_block
*fblk
;
6713 struct float_block
**fprev
= &float_block
;
6714 register int lim
= float_block_index
;
6715 EMACS_INT num_free
= 0, num_used
= 0;
6717 float_free_list
= 0;
6719 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6723 for (i
= 0; i
< lim
; i
++)
6724 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6727 fblk
->floats
[i
].u
.chain
= float_free_list
;
6728 float_free_list
= &fblk
->floats
[i
];
6733 FLOAT_UNMARK (&fblk
->floats
[i
]);
6735 lim
= FLOAT_BLOCK_SIZE
;
6736 /* If this block contains only free floats and we have already
6737 seen more than two blocks worth of free floats then deallocate
6739 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6741 *fprev
= fblk
->next
;
6742 /* Unhook from the free list. */
6743 float_free_list
= fblk
->floats
[0].u
.chain
;
6744 lisp_align_free (fblk
);
6748 num_free
+= this_free
;
6749 fprev
= &fblk
->next
;
6752 total_floats
= num_used
;
6753 total_free_floats
= num_free
;
6756 NO_INLINE
/* For better stack traces */
6758 sweep_intervals (void)
6760 register struct interval_block
*iblk
;
6761 struct interval_block
**iprev
= &interval_block
;
6762 register int lim
= interval_block_index
;
6763 EMACS_INT num_free
= 0, num_used
= 0;
6765 interval_free_list
= 0;
6767 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6772 for (i
= 0; i
< lim
; i
++)
6774 if (!iblk
->intervals
[i
].gcmarkbit
)
6776 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6777 interval_free_list
= &iblk
->intervals
[i
];
6783 iblk
->intervals
[i
].gcmarkbit
= 0;
6786 lim
= INTERVAL_BLOCK_SIZE
;
6787 /* If this block contains only free intervals and we have already
6788 seen more than two blocks worth of free intervals then
6789 deallocate this block. */
6790 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6792 *iprev
= iblk
->next
;
6793 /* Unhook from the free list. */
6794 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6799 num_free
+= this_free
;
6800 iprev
= &iblk
->next
;
6803 total_intervals
= num_used
;
6804 total_free_intervals
= num_free
;
6807 NO_INLINE
/* For better stack traces */
6809 sweep_symbols (void)
6811 struct symbol_block
*sblk
;
6812 struct symbol_block
**sprev
= &symbol_block
;
6813 int lim
= symbol_block_index
;
6814 EMACS_INT num_free
= 0, num_used
= ARRAYELTS (lispsym
);
6816 symbol_free_list
= NULL
;
6818 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
6819 lispsym
[i
].gcmarkbit
= 0;
6821 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6824 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6825 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6827 for (; sym
< end
; ++sym
)
6829 if (!sym
->s
.gcmarkbit
)
6831 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6832 xfree (SYMBOL_BLV (&sym
->s
));
6833 sym
->s
.next
= symbol_free_list
;
6834 symbol_free_list
= &sym
->s
;
6835 symbol_free_list
->function
= Vdead
;
6841 sym
->s
.gcmarkbit
= 0;
6842 /* Attempt to catch bogus objects. */
6843 eassert (valid_lisp_object_p (sym
->s
.function
));
6847 lim
= SYMBOL_BLOCK_SIZE
;
6848 /* If this block contains only free symbols and we have already
6849 seen more than two blocks worth of free symbols then deallocate
6851 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6853 *sprev
= sblk
->next
;
6854 /* Unhook from the free list. */
6855 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6860 num_free
+= this_free
;
6861 sprev
= &sblk
->next
;
6864 total_symbols
= num_used
;
6865 total_free_symbols
= num_free
;
6868 NO_INLINE
/* For better stack traces. */
6872 register struct marker_block
*mblk
;
6873 struct marker_block
**mprev
= &marker_block
;
6874 register int lim
= marker_block_index
;
6875 EMACS_INT num_free
= 0, num_used
= 0;
6877 /* Put all unmarked misc's on free list. For a marker, first
6878 unchain it from the buffer it points into. */
6880 marker_free_list
= 0;
6882 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6887 for (i
= 0; i
< lim
; i
++)
6889 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6891 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6892 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6893 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Finalizer
)
6894 unchain_finalizer (&mblk
->markers
[i
].m
.u_finalizer
);
6896 else if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_User_Ptr
)
6898 struct Lisp_User_Ptr
*uptr
= &mblk
->markers
[i
].m
.u_user_ptr
;
6899 uptr
->finalizer (uptr
->p
);
6902 /* Set the type of the freed object to Lisp_Misc_Free.
6903 We could leave the type alone, since nobody checks it,
6904 but this might catch bugs faster. */
6905 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6906 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6907 marker_free_list
= &mblk
->markers
[i
].m
;
6913 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6916 lim
= MARKER_BLOCK_SIZE
;
6917 /* If this block contains only free markers and we have already
6918 seen more than two blocks worth of free markers then deallocate
6920 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6922 *mprev
= mblk
->next
;
6923 /* Unhook from the free list. */
6924 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6929 num_free
+= this_free
;
6930 mprev
= &mblk
->next
;
6934 total_markers
= num_used
;
6935 total_free_markers
= num_free
;
6938 NO_INLINE
/* For better stack traces */
6940 sweep_buffers (void)
6942 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6945 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6946 if (!VECTOR_MARKED_P (buffer
))
6948 *bprev
= buffer
->next
;
6953 VECTOR_UNMARK (buffer
);
6954 /* Do not use buffer_(set|get)_intervals here. */
6955 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6957 bprev
= &buffer
->next
;
6961 /* Sweep: find all structures not marked, and free them. */
6965 /* Remove or mark entries in weak hash tables.
6966 This must be done before any object is unmarked. */
6967 sweep_weak_hash_tables ();
6970 check_string_bytes (!noninteractive
);
6978 check_string_bytes (!noninteractive
);
6981 DEFUN ("memory-info", Fmemory_info
, Smemory_info
, 0, 0, 0,
6982 doc
: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
6983 All values are in Kbytes. If there is no swap space,
6984 last two values are zero. If the system is not supported
6985 or memory information can't be obtained, return nil. */)
6988 #if defined HAVE_LINUX_SYSINFO
6994 #ifdef LINUX_SYSINFO_UNIT
6995 units
= si
.mem_unit
;
6999 return list4i ((uintmax_t) si
.totalram
* units
/ 1024,
7000 (uintmax_t) si
.freeram
* units
/ 1024,
7001 (uintmax_t) si
.totalswap
* units
/ 1024,
7002 (uintmax_t) si
.freeswap
* units
/ 1024);
7003 #elif defined WINDOWSNT
7004 unsigned long long totalram
, freeram
, totalswap
, freeswap
;
7006 if (w32_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7007 return list4i ((uintmax_t) totalram
/ 1024,
7008 (uintmax_t) freeram
/ 1024,
7009 (uintmax_t) totalswap
/ 1024,
7010 (uintmax_t) freeswap
/ 1024);
7014 unsigned long totalram
, freeram
, totalswap
, freeswap
;
7016 if (dos_memory_info (&totalram
, &freeram
, &totalswap
, &freeswap
) == 0)
7017 return list4i ((uintmax_t) totalram
/ 1024,
7018 (uintmax_t) freeram
/ 1024,
7019 (uintmax_t) totalswap
/ 1024,
7020 (uintmax_t) freeswap
/ 1024);
7023 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7024 /* FIXME: add more systems. */
7026 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
7029 /* Debugging aids. */
7031 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
7032 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
7033 This may be helpful in debugging Emacs's memory usage.
7034 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
7040 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
7043 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
7049 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
7050 doc
: /* Return a list of counters that measure how much consing there has been.
7051 Each of these counters increments for a certain kind of object.
7052 The counters wrap around from the largest positive integer to zero.
7053 Garbage collection does not decrease them.
7054 The elements of the value are as follows:
7055 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
7056 All are in units of 1 = one object consed
7057 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
7059 MISCS include overlays, markers, and some internal types.
7060 Frames, windows, buffers, and subprocesses count as vectors
7061 (but the contents of a buffer's text do not count here). */)
7064 return listn (CONSTYPE_HEAP
, 8,
7065 bounded_number (cons_cells_consed
),
7066 bounded_number (floats_consed
),
7067 bounded_number (vector_cells_consed
),
7068 bounded_number (symbols_consed
),
7069 bounded_number (string_chars_consed
),
7070 bounded_number (misc_objects_consed
),
7071 bounded_number (intervals_consed
),
7072 bounded_number (strings_consed
));
7076 symbol_uses_obj (Lisp_Object symbol
, Lisp_Object obj
)
7078 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
7079 Lisp_Object val
= find_symbol_value (symbol
);
7080 return (EQ (val
, obj
)
7081 || EQ (sym
->function
, obj
)
7082 || (!NILP (sym
->function
)
7083 && COMPILEDP (sym
->function
)
7084 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
7087 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)));
7090 /* Find at most FIND_MAX symbols which have OBJ as their value or
7091 function. This is used in gdbinit's `xwhichsymbols' command. */
7094 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
7096 struct symbol_block
*sblk
;
7097 ptrdiff_t gc_count
= inhibit_garbage_collection ();
7098 Lisp_Object found
= Qnil
;
7102 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
7104 Lisp_Object sym
= builtin_lisp_symbol (i
);
7105 if (symbol_uses_obj (sym
, obj
))
7107 found
= Fcons (sym
, found
);
7108 if (--find_max
== 0)
7113 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
7115 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
7118 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
7120 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
7123 Lisp_Object sym
= make_lisp_symbol (&aligned_sym
->s
);
7124 if (symbol_uses_obj (sym
, obj
))
7126 found
= Fcons (sym
, found
);
7127 if (--find_max
== 0)
7135 unbind_to (gc_count
, Qnil
);
7139 #ifdef SUSPICIOUS_OBJECT_CHECKING
7142 find_suspicious_object_in_range (void *begin
, void *end
)
7144 char *begin_a
= begin
;
7148 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7150 char *suspicious_object
= suspicious_objects
[i
];
7151 if (begin_a
<= suspicious_object
&& suspicious_object
< end_a
)
7152 return suspicious_object
;
7159 note_suspicious_free (void* ptr
)
7161 struct suspicious_free_record
* rec
;
7163 rec
= &suspicious_free_history
[suspicious_free_history_index
++];
7164 if (suspicious_free_history_index
==
7165 ARRAYELTS (suspicious_free_history
))
7167 suspicious_free_history_index
= 0;
7170 memset (rec
, 0, sizeof (*rec
));
7171 rec
->suspicious_object
= ptr
;
7172 backtrace (&rec
->backtrace
[0], ARRAYELTS (rec
->backtrace
));
7176 detect_suspicious_free (void* ptr
)
7180 eassert (ptr
!= NULL
);
7182 for (i
= 0; i
< ARRAYELTS (suspicious_objects
); ++i
)
7183 if (suspicious_objects
[i
] == ptr
)
7185 note_suspicious_free (ptr
);
7186 suspicious_objects
[i
] = NULL
;
7190 #endif /* SUSPICIOUS_OBJECT_CHECKING */
7192 DEFUN ("suspicious-object", Fsuspicious_object
, Ssuspicious_object
, 1, 1, 0,
7193 doc
: /* Return OBJ, maybe marking it for extra scrutiny.
7194 If Emacs is compiled with suspicious object checking, capture
7195 a stack trace when OBJ is freed in order to help track down
7196 garbage collection bugs. Otherwise, do nothing and return OBJ. */)
7199 #ifdef SUSPICIOUS_OBJECT_CHECKING
7200 /* Right now, we care only about vectors. */
7201 if (VECTORLIKEP (obj
))
7203 suspicious_objects
[suspicious_object_index
++] = XVECTOR (obj
);
7204 if (suspicious_object_index
== ARRAYELTS (suspicious_objects
))
7205 suspicious_object_index
= 0;
7211 #ifdef ENABLE_CHECKING
7213 bool suppress_checking
;
7216 die (const char *msg
, const char *file
, int line
)
7218 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
7220 terminate_due_to_signal (SIGABRT
, INT_MAX
);
7223 #endif /* ENABLE_CHECKING */
7225 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
7227 /* Debugging check whether STR is ASCII-only. */
7230 verify_ascii (const char *str
)
7232 const unsigned char *ptr
= (unsigned char *) str
, *end
= ptr
+ strlen (str
);
7235 int c
= STRING_CHAR_ADVANCE (ptr
);
7236 if (!ASCII_CHAR_P (c
))
7242 /* Stress alloca with inconveniently sized requests and check
7243 whether all allocated areas may be used for Lisp_Object. */
7245 NO_INLINE
static void
7246 verify_alloca (void)
7249 enum { ALLOCA_CHECK_MAX
= 256 };
7250 /* Start from size of the smallest Lisp object. */
7251 for (i
= sizeof (struct Lisp_Cons
); i
<= ALLOCA_CHECK_MAX
; i
++)
7253 void *ptr
= alloca (i
);
7254 make_lisp_ptr (ptr
, Lisp_Cons
);
7258 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7260 #define verify_alloca() ((void) 0)
7262 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
7264 /* Initialization. */
7267 init_alloc_once (void)
7269 /* Even though Qt's contents are not set up, its address is known. */
7273 pure_size
= PURESIZE
;
7276 init_finalizer_list (&finalizers
);
7277 init_finalizer_list (&doomed_finalizers
);
7280 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
7282 #ifdef DOUG_LEA_MALLOC
7283 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
7284 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
7285 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
7290 refill_memory_reserve ();
7291 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
7297 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
7298 setjmp_tested_p
= longjmps_done
= 0;
7300 Vgc_elapsed
= make_float (0.0);
7304 valgrind_p
= RUNNING_ON_VALGRIND
!= 0;
7309 syms_of_alloc (void)
7311 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
7312 doc
: /* Number of bytes of consing between garbage collections.
7313 Garbage collection can happen automatically once this many bytes have been
7314 allocated since the last garbage collection. All data types count.
7316 Garbage collection happens automatically only when `eval' is called.
7318 By binding this temporarily to a large number, you can effectively
7319 prevent garbage collection during a part of the program.
7320 See also `gc-cons-percentage'. */);
7322 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
7323 doc
: /* Portion of the heap used for allocation.
7324 Garbage collection can happen automatically once this portion of the heap
7325 has been allocated since the last garbage collection.
7326 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7327 Vgc_cons_percentage
= make_float (0.1);
7329 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
7330 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
7332 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
7333 doc
: /* Number of cons cells that have been consed so far. */);
7335 DEFVAR_INT ("floats-consed", floats_consed
,
7336 doc
: /* Number of floats that have been consed so far. */);
7338 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
7339 doc
: /* Number of vector cells that have been consed so far. */);
7341 DEFVAR_INT ("symbols-consed", symbols_consed
,
7342 doc
: /* Number of symbols that have been consed so far. */);
7343 symbols_consed
+= ARRAYELTS (lispsym
);
7345 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
7346 doc
: /* Number of string characters that have been consed so far. */);
7348 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
7349 doc
: /* Number of miscellaneous objects that have been consed so far.
7350 These include markers and overlays, plus certain objects not visible
7353 DEFVAR_INT ("intervals-consed", intervals_consed
,
7354 doc
: /* Number of intervals that have been consed so far. */);
7356 DEFVAR_INT ("strings-consed", strings_consed
,
7357 doc
: /* Number of strings that have been consed so far. */);
7359 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
7360 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
7361 This means that certain objects should be allocated in shared (pure) space.
7362 It can also be set to a hash-table, in which case this table is used to
7363 do hash-consing of the objects allocated to pure space. */);
7365 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
7366 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
7367 garbage_collection_messages
= 0;
7369 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
7370 doc
: /* Hook run after garbage collection has finished. */);
7371 Vpost_gc_hook
= Qnil
;
7372 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
7374 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
7375 doc
: /* Precomputed `signal' argument for memory-full error. */);
7376 /* We build this in advance because if we wait until we need it, we might
7377 not be able to allocate the memory to hold it. */
7379 = listn (CONSTYPE_PURE
, 2, Qerror
,
7380 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
7382 DEFVAR_LISP ("memory-full", Vmemory_full
,
7383 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
7384 Vmemory_full
= Qnil
;
7386 DEFSYM (Qconses
, "conses");
7387 DEFSYM (Qsymbols
, "symbols");
7388 DEFSYM (Qmiscs
, "miscs");
7389 DEFSYM (Qstrings
, "strings");
7390 DEFSYM (Qvectors
, "vectors");
7391 DEFSYM (Qfloats
, "floats");
7392 DEFSYM (Qintervals
, "intervals");
7393 DEFSYM (Qbuffers
, "buffers");
7394 DEFSYM (Qstring_bytes
, "string-bytes");
7395 DEFSYM (Qvector_slots
, "vector-slots");
7396 DEFSYM (Qheap
, "heap");
7397 DEFSYM (Qautomatic_gc
, "Automatic GC");
7399 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
7400 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
7402 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
7403 doc
: /* Accumulated time elapsed in garbage collections.
7404 The time is in seconds as a floating point value. */);
7405 DEFVAR_INT ("gcs-done", gcs_done
,
7406 doc
: /* Accumulated number of garbage collections done. */);
7411 defsubr (&Sbool_vector
);
7412 defsubr (&Smake_byte_code
);
7413 defsubr (&Smake_list
);
7414 defsubr (&Smake_vector
);
7415 defsubr (&Smake_string
);
7416 defsubr (&Smake_bool_vector
);
7417 defsubr (&Smake_symbol
);
7418 defsubr (&Smake_marker
);
7419 defsubr (&Smake_finalizer
);
7420 defsubr (&Spurecopy
);
7421 defsubr (&Sgarbage_collect
);
7422 defsubr (&Smemory_limit
);
7423 defsubr (&Smemory_info
);
7424 defsubr (&Smemory_use_counts
);
7425 defsubr (&Ssuspicious_object
);
7428 /* When compiled with GCC, GDB might say "No enum type named
7429 pvec_type" if we don't have at least one symbol with that type, and
7430 then xbacktrace could fail. Similarly for the other enums and
7431 their values. Some non-GCC compilers don't like these constructs. */
7435 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
7436 enum char_table_specials char_table_specials
;
7437 enum char_bits char_bits
;
7438 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
7439 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
7440 enum Lisp_Bits Lisp_Bits
;
7441 enum Lisp_Compiled Lisp_Compiled
;
7442 enum maxargs maxargs
;
7443 enum MAX_ALLOCA MAX_ALLOCA
;
7444 enum More_Lisp_Bits More_Lisp_Bits
;
7445 enum pvec_type pvec_type
;
7446 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
7447 #endif /* __GNUC__ */