1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 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/>. */
23 #define LISP_INLINE EXTERN_INLINE
26 #include <limits.h> /* For CHAR_BIT. */
28 #ifdef ENABLE_CHECKING
29 #include <signal.h> /* For SIGABRT. */
38 #include "intervals.h"
40 #include "character.h"
45 #include "blockinput.h"
46 #include "termhooks.h" /* For struct terminal. */
50 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
53 # undef GC_CHECK_MARKED_OBJECTS
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c and if not checking
60 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
62 #undef GC_MALLOC_CHECK
73 #include "w32heap.h" /* for sbrk */
76 #ifdef DOUG_LEA_MALLOC
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #endif /* not DOUG_LEA_MALLOC */
87 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
88 to a struct Lisp_String. */
90 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
91 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
92 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
94 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
95 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
96 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
98 /* Default value of gc_cons_threshold (see below). */
100 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
102 /* Global variables. */
103 struct emacs_globals globals
;
105 /* Number of bytes of consing done since the last gc. */
107 EMACS_INT consing_since_gc
;
109 /* Similar minimum, computed from Vgc_cons_percentage. */
111 EMACS_INT gc_relative_threshold
;
113 /* Minimum number of bytes of consing since GC before next GC,
114 when memory is full. */
116 EMACS_INT memory_full_cons_threshold
;
118 /* True during GC. */
122 /* True means abort if try to GC.
123 This is for code which is written on the assumption that
124 no GC will happen, so as to verify that assumption. */
128 /* Number of live and free conses etc. */
130 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
131 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
132 static EMACS_INT total_free_floats
, total_floats
;
134 /* Points to memory space allocated as "spare", to be freed if we run
135 out of memory. We keep one large block, four cons-blocks, and
136 two string blocks. */
138 static char *spare_memory
[7];
140 /* Amount of spare memory to keep in large reserve block, or to see
141 whether this much is available when malloc fails on a larger request. */
143 #define SPARE_MEMORY (1 << 14)
145 /* Initialize it to a nonzero value to force it into data space
146 (rather than bss space). That way unexec will remap it into text
147 space (pure), on some systems. We have not implemented the
148 remapping on more recent systems because this is less important
149 nowadays than in the days of small memories and timesharing. */
151 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
152 #define PUREBEG (char *) pure
154 /* Pointer to the pure area, and its size. */
156 static char *purebeg
;
157 static ptrdiff_t pure_size
;
159 /* Number of bytes of pure storage used before pure storage overflowed.
160 If this is non-zero, this implies that an overflow occurred. */
162 static ptrdiff_t pure_bytes_used_before_overflow
;
164 /* True if P points into pure space. */
166 #define PURE_POINTER_P(P) \
167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
169 /* Index in pure at which next pure Lisp object will be allocated.. */
171 static ptrdiff_t pure_bytes_used_lisp
;
173 /* Number of bytes allocated for non-Lisp objects in pure storage. */
175 static ptrdiff_t pure_bytes_used_non_lisp
;
177 /* If nonzero, this is a warning delivered by malloc and not yet
180 const char *pending_malloc_warning
;
182 /* Maximum amount of C stack to save when a GC happens. */
184 #ifndef MAX_SAVE_STACK
185 #define MAX_SAVE_STACK 16000
188 /* Buffer in which we save a copy of the C stack at each GC. */
190 #if MAX_SAVE_STACK > 0
191 static char *stack_copy
;
192 static ptrdiff_t stack_copy_size
;
195 static Lisp_Object Qconses
;
196 static Lisp_Object Qsymbols
;
197 static Lisp_Object Qmiscs
;
198 static Lisp_Object Qstrings
;
199 static Lisp_Object Qvectors
;
200 static Lisp_Object Qfloats
;
201 static Lisp_Object Qintervals
;
202 static Lisp_Object Qbuffers
;
203 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
204 static Lisp_Object Qgc_cons_threshold
;
205 Lisp_Object Qautomatic_gc
;
206 Lisp_Object Qchar_table_extra_slots
;
208 /* Hook run after GC has finished. */
210 static Lisp_Object Qpost_gc_hook
;
212 static void mark_terminals (void);
213 static void gc_sweep (void);
214 static Lisp_Object
make_pure_vector (ptrdiff_t);
215 static void mark_buffer (struct buffer
*);
217 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
218 static void refill_memory_reserve (void);
220 static void compact_small_strings (void);
221 static void free_large_strings (void);
222 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
224 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
225 what memory allocated via lisp_malloc and lisp_align_malloc is intended
226 for what purpose. This enumeration specifies the type of memory. */
237 /* Since all non-bool pseudovectors are small enough to be
238 allocated from vector blocks, this memory type denotes
239 large regular vectors and large bool pseudovectors. */
241 /* Special type to denote vector blocks. */
242 MEM_TYPE_VECTOR_BLOCK
,
243 /* Special type to denote reserved memory. */
247 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
249 /* A unique object in pure space used to make some Lisp objects
250 on free lists recognizable in O(1). */
252 static Lisp_Object Vdead
;
253 #define DEADP(x) EQ (x, Vdead)
255 #ifdef GC_MALLOC_CHECK
257 enum mem_type allocated_mem_type
;
259 #endif /* GC_MALLOC_CHECK */
261 /* A node in the red-black tree describing allocated memory containing
262 Lisp data. Each such block is recorded with its start and end
263 address when it is allocated, and removed from the tree when it
266 A red-black tree is a balanced binary tree with the following
269 1. Every node is either red or black.
270 2. Every leaf is black.
271 3. If a node is red, then both of its children are black.
272 4. Every simple path from a node to a descendant leaf contains
273 the same number of black nodes.
274 5. The root is always black.
276 When nodes are inserted into the tree, or deleted from the tree,
277 the tree is "fixed" so that these properties are always true.
279 A red-black tree with N internal nodes has height at most 2
280 log(N+1). Searches, insertions and deletions are done in O(log N).
281 Please see a text book about data structures for a detailed
282 description of red-black trees. Any book worth its salt should
287 /* Children of this node. These pointers are never NULL. When there
288 is no child, the value is MEM_NIL, which points to a dummy node. */
289 struct mem_node
*left
, *right
;
291 /* The parent of this node. In the root node, this is NULL. */
292 struct mem_node
*parent
;
294 /* Start and end of allocated region. */
298 enum {MEM_BLACK
, MEM_RED
} color
;
304 /* Base address of stack. Set in main. */
306 Lisp_Object
*stack_base
;
308 /* Root of the tree describing allocated Lisp memory. */
310 static struct mem_node
*mem_root
;
312 /* Lowest and highest known address in the heap. */
314 static void *min_heap_address
, *max_heap_address
;
316 /* Sentinel node of the tree. */
318 static struct mem_node mem_z
;
319 #define MEM_NIL &mem_z
321 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
322 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
323 static void mem_insert_fixup (struct mem_node
*);
324 static void mem_rotate_left (struct mem_node
*);
325 static void mem_rotate_right (struct mem_node
*);
326 static void mem_delete (struct mem_node
*);
327 static void mem_delete_fixup (struct mem_node
*);
328 static struct mem_node
*mem_find (void *);
331 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
337 /* Recording what needs to be marked for gc. */
339 struct gcpro
*gcprolist
;
341 /* Addresses of staticpro'd variables. Initialize it to a nonzero
342 value; otherwise some compilers put it into BSS. */
344 enum { NSTATICS
= 2048 };
345 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
347 /* Index of next unused slot in staticvec. */
349 static int staticidx
;
351 static void *pure_alloc (size_t, int);
354 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
355 ALIGNMENT must be a power of 2. */
357 #define ALIGN(ptr, ALIGNMENT) \
358 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
359 & ~ ((ALIGNMENT) - 1)))
362 XFLOAT_INIT (Lisp_Object f
, double n
)
364 XFLOAT (f
)->u
.data
= n
;
368 /************************************************************************
370 ************************************************************************/
372 /* Function malloc calls this if it finds we are near exhausting storage. */
375 malloc_warning (const char *str
)
377 pending_malloc_warning
= str
;
381 /* Display an already-pending malloc warning. */
384 display_malloc_warning (void)
386 call3 (intern ("display-warning"),
388 build_string (pending_malloc_warning
),
389 intern ("emergency"));
390 pending_malloc_warning
= 0;
393 /* Called if we can't allocate relocatable space for a buffer. */
396 buffer_memory_full (ptrdiff_t nbytes
)
398 /* If buffers use the relocating allocator, no need to free
399 spare_memory, because we may have plenty of malloc space left
400 that we could get, and if we don't, the malloc that fails will
401 itself cause spare_memory to be freed. If buffers don't use the
402 relocating allocator, treat this like any other failing
406 memory_full (nbytes
);
408 /* This used to call error, but if we've run out of memory, we could
409 get infinite recursion trying to build the string. */
410 xsignal (Qnil
, Vmemory_signal_data
);
414 /* A common multiple of the positive integers A and B. Ideally this
415 would be the least common multiple, but there's no way to do that
416 as a constant expression in C, so do the best that we can easily do. */
417 #define COMMON_MULTIPLE(a, b) \
418 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
420 #ifndef XMALLOC_OVERRUN_CHECK
421 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
424 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
427 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
428 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
429 block size in little-endian order. The trailer consists of
430 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
432 The header is used to detect whether this block has been allocated
433 through these functions, as some low-level libc functions may
434 bypass the malloc hooks. */
436 #define XMALLOC_OVERRUN_CHECK_SIZE 16
437 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
438 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
440 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
441 hold a size_t value and (2) the header size is a multiple of the
442 alignment that Emacs needs for C types and for USE_LSB_TAG. */
443 #define XMALLOC_BASE_ALIGNMENT \
444 alignof (union { long double d; intmax_t i; void *p; })
447 # define XMALLOC_HEADER_ALIGNMENT \
448 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
450 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
452 #define XMALLOC_OVERRUN_SIZE_SIZE \
453 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
454 + XMALLOC_HEADER_ALIGNMENT - 1) \
455 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
456 - XMALLOC_OVERRUN_CHECK_SIZE)
458 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
459 { '\x9a', '\x9b', '\xae', '\xaf',
460 '\xbf', '\xbe', '\xce', '\xcf',
461 '\xea', '\xeb', '\xec', '\xed',
462 '\xdf', '\xde', '\x9c', '\x9d' };
464 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
465 { '\xaa', '\xab', '\xac', '\xad',
466 '\xba', '\xbb', '\xbc', '\xbd',
467 '\xca', '\xcb', '\xcc', '\xcd',
468 '\xda', '\xdb', '\xdc', '\xdd' };
470 /* Insert and extract the block size in the header. */
473 xmalloc_put_size (unsigned char *ptr
, size_t size
)
476 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
478 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
484 xmalloc_get_size (unsigned char *ptr
)
488 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
489 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
498 /* Like malloc, but wraps allocated block with header and trailer. */
501 overrun_check_malloc (size_t size
)
503 register unsigned char *val
;
504 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
507 val
= malloc (size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
510 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
511 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
512 xmalloc_put_size (val
, size
);
513 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
514 XMALLOC_OVERRUN_CHECK_SIZE
);
520 /* Like realloc, but checks old block for overrun, and wraps new block
521 with header and trailer. */
524 overrun_check_realloc (void *block
, size_t size
)
526 register unsigned char *val
= (unsigned char *) block
;
527 if (SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
< size
)
531 && memcmp (xmalloc_overrun_check_header
,
532 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
533 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
535 size_t osize
= xmalloc_get_size (val
);
536 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
537 XMALLOC_OVERRUN_CHECK_SIZE
))
539 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
540 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
541 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
544 val
= realloc (val
, size
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
548 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
549 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
550 xmalloc_put_size (val
, size
);
551 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
552 XMALLOC_OVERRUN_CHECK_SIZE
);
557 /* Like free, but checks block for overrun. */
560 overrun_check_free (void *block
)
562 unsigned char *val
= (unsigned char *) block
;
565 && memcmp (xmalloc_overrun_check_header
,
566 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
567 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
569 size_t osize
= xmalloc_get_size (val
);
570 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
571 XMALLOC_OVERRUN_CHECK_SIZE
))
573 #ifdef XMALLOC_CLEAR_FREE_MEMORY
574 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
575 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
577 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
578 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
579 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
589 #define malloc overrun_check_malloc
590 #define realloc overrun_check_realloc
591 #define free overrun_check_free
594 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
595 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
596 If that variable is set, block input while in one of Emacs's memory
597 allocation functions. There should be no need for this debugging
598 option, since signal handlers do not allocate memory, but Emacs
599 formerly allocated memory in signal handlers and this compile-time
600 option remains as a way to help debug the issue should it rear its
602 #ifdef XMALLOC_BLOCK_INPUT_CHECK
603 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE
;
605 malloc_block_input (void)
607 if (block_input_in_memory_allocators
)
611 malloc_unblock_input (void)
613 if (block_input_in_memory_allocators
)
616 # define MALLOC_BLOCK_INPUT malloc_block_input ()
617 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
619 # define MALLOC_BLOCK_INPUT ((void) 0)
620 # define MALLOC_UNBLOCK_INPUT ((void) 0)
623 #define MALLOC_PROBE(size) \
625 if (profiler_memory_running) \
626 malloc_probe (size); \
630 /* Like malloc but check for no memory and block interrupt input.. */
633 xmalloc (size_t size
)
639 MALLOC_UNBLOCK_INPUT
;
647 /* Like the above, but zeroes out the memory just allocated. */
650 xzalloc (size_t size
)
656 MALLOC_UNBLOCK_INPUT
;
660 memset (val
, 0, size
);
665 /* Like realloc but check for no memory and block interrupt input.. */
668 xrealloc (void *block
, size_t size
)
673 /* We must call malloc explicitly when BLOCK is 0, since some
674 reallocs don't do this. */
678 val
= realloc (block
, size
);
679 MALLOC_UNBLOCK_INPUT
;
688 /* Like free but block interrupt input. */
697 MALLOC_UNBLOCK_INPUT
;
698 /* We don't call refill_memory_reserve here
699 because in practice the call in r_alloc_free seems to suffice. */
703 /* Other parts of Emacs pass large int values to allocator functions
704 expecting ptrdiff_t. This is portable in practice, but check it to
706 verify (INT_MAX
<= PTRDIFF_MAX
);
709 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
710 Signal an error on memory exhaustion, and block interrupt input. */
713 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
715 eassert (0 <= nitems
&& 0 < item_size
);
716 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
717 memory_full (SIZE_MAX
);
718 return xmalloc (nitems
* item_size
);
722 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
723 Signal an error on memory exhaustion, and block interrupt input. */
726 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
728 eassert (0 <= nitems
&& 0 < item_size
);
729 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
730 memory_full (SIZE_MAX
);
731 return xrealloc (pa
, nitems
* item_size
);
735 /* Grow PA, which points to an array of *NITEMS items, and return the
736 location of the reallocated array, updating *NITEMS to reflect its
737 new size. The new array will contain at least NITEMS_INCR_MIN more
738 items, but will not contain more than NITEMS_MAX items total.
739 ITEM_SIZE is the size of each item, in bytes.
741 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
742 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
745 If PA is null, then allocate a new array instead of reallocating
748 Block interrupt input as needed. If memory exhaustion occurs, set
749 *NITEMS to zero if PA is null, and signal an error (i.e., do not
752 Thus, to grow an array A without saving its old contents, do
753 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
754 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
755 and signals an error, and later this code is reexecuted and
756 attempts to free A. */
759 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
760 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
762 /* The approximate size to use for initial small allocation
763 requests. This is the largest "small" request for the GNU C
765 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
767 /* If the array is tiny, grow it to about (but no greater than)
768 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
769 ptrdiff_t n
= *nitems
;
770 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
771 ptrdiff_t half_again
= n
>> 1;
772 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
774 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
775 NITEMS_MAX, and what the C language can represent safely. */
776 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
777 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
778 ? nitems_max
: C_language_max
);
779 ptrdiff_t nitems_incr_max
= n_max
- n
;
780 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
782 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
785 if (nitems_incr_max
< incr
)
786 memory_full (SIZE_MAX
);
788 pa
= xrealloc (pa
, n
* item_size
);
794 /* Like strdup, but uses xmalloc. */
797 xstrdup (const char *s
)
801 size
= strlen (s
) + 1;
802 return memcpy (xmalloc (size
), s
, size
);
805 /* Like above, but duplicates Lisp string to C string. */
808 xlispstrdup (Lisp_Object string
)
810 ptrdiff_t size
= SBYTES (string
) + 1;
811 return memcpy (xmalloc (size
), SSDATA (string
), size
);
814 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
815 argument is a const pointer. */
818 xputenv (char const *string
)
820 if (putenv ((char *) string
) != 0)
824 /* Return a newly allocated memory block of SIZE bytes, remembering
825 to free it when unwinding. */
827 record_xmalloc (size_t size
)
829 void *p
= xmalloc (size
);
830 record_unwind_protect_ptr (xfree
, p
);
835 /* Like malloc but used for allocating Lisp data. NBYTES is the
836 number of bytes to allocate, TYPE describes the intended use of the
837 allocated memory block (for strings, for conses, ...). */
840 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
844 lisp_malloc (size_t nbytes
, enum mem_type type
)
850 #ifdef GC_MALLOC_CHECK
851 allocated_mem_type
= type
;
854 val
= malloc (nbytes
);
857 /* If the memory just allocated cannot be addressed thru a Lisp
858 object's pointer, and it needs to be,
859 that's equivalent to running out of memory. */
860 if (val
&& type
!= MEM_TYPE_NON_LISP
)
863 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
864 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
866 lisp_malloc_loser
= val
;
873 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
874 if (val
&& type
!= MEM_TYPE_NON_LISP
)
875 mem_insert (val
, (char *) val
+ nbytes
, type
);
878 MALLOC_UNBLOCK_INPUT
;
880 memory_full (nbytes
);
881 MALLOC_PROBE (nbytes
);
885 /* Free BLOCK. This must be called to free memory allocated with a
886 call to lisp_malloc. */
889 lisp_free (void *block
)
893 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
894 mem_delete (mem_find (block
));
896 MALLOC_UNBLOCK_INPUT
;
899 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
901 /* The entry point is lisp_align_malloc which returns blocks of at most
902 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
904 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
905 #define USE_POSIX_MEMALIGN 1
908 /* BLOCK_ALIGN has to be a power of 2. */
909 #define BLOCK_ALIGN (1 << 10)
911 /* Padding to leave at the end of a malloc'd block. This is to give
912 malloc a chance to minimize the amount of memory wasted to alignment.
913 It should be tuned to the particular malloc library used.
914 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
915 posix_memalign on the other hand would ideally prefer a value of 4
916 because otherwise, there's 1020 bytes wasted between each ablocks.
917 In Emacs, testing shows that those 1020 can most of the time be
918 efficiently used by malloc to place other objects, so a value of 0 can
919 still preferable unless you have a lot of aligned blocks and virtually
921 #define BLOCK_PADDING 0
922 #define BLOCK_BYTES \
923 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
925 /* Internal data structures and constants. */
927 #define ABLOCKS_SIZE 16
929 /* An aligned block of memory. */
934 char payload
[BLOCK_BYTES
];
935 struct ablock
*next_free
;
937 /* `abase' is the aligned base of the ablocks. */
938 /* It is overloaded to hold the virtual `busy' field that counts
939 the number of used ablock in the parent ablocks.
940 The first ablock has the `busy' field, the others have the `abase'
941 field. To tell the difference, we assume that pointers will have
942 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
943 is used to tell whether the real base of the parent ablocks is `abase'
944 (if not, the word before the first ablock holds a pointer to the
946 struct ablocks
*abase
;
947 /* The padding of all but the last ablock is unused. The padding of
948 the last ablock in an ablocks is not allocated. */
950 char padding
[BLOCK_PADDING
];
954 /* A bunch of consecutive aligned blocks. */
957 struct ablock blocks
[ABLOCKS_SIZE
];
960 /* Size of the block requested from malloc or posix_memalign. */
961 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
963 #define ABLOCK_ABASE(block) \
964 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
965 ? (struct ablocks *)(block) \
968 /* Virtual `busy' field. */
969 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
971 /* Pointer to the (not necessarily aligned) malloc block. */
972 #ifdef USE_POSIX_MEMALIGN
973 #define ABLOCKS_BASE(abase) (abase)
975 #define ABLOCKS_BASE(abase) \
976 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
979 /* The list of free ablock. */
980 static struct ablock
*free_ablock
;
982 /* Allocate an aligned block of nbytes.
983 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
984 smaller or equal to BLOCK_BYTES. */
986 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
989 struct ablocks
*abase
;
991 eassert (nbytes
<= BLOCK_BYTES
);
995 #ifdef GC_MALLOC_CHECK
996 allocated_mem_type
= type
;
1002 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1004 #ifdef DOUG_LEA_MALLOC
1005 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1006 because mapped region contents are not preserved in
1008 mallopt (M_MMAP_MAX
, 0);
1011 #ifdef USE_POSIX_MEMALIGN
1013 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1019 base
= malloc (ABLOCKS_BYTES
);
1020 abase
= ALIGN (base
, BLOCK_ALIGN
);
1025 MALLOC_UNBLOCK_INPUT
;
1026 memory_full (ABLOCKS_BYTES
);
1029 aligned
= (base
== abase
);
1031 ((void**)abase
)[-1] = base
;
1033 #ifdef DOUG_LEA_MALLOC
1034 /* Back to a reasonable maximum of mmap'ed areas. */
1035 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1039 /* If the memory just allocated cannot be addressed thru a Lisp
1040 object's pointer, and it needs to be, that's equivalent to
1041 running out of memory. */
1042 if (type
!= MEM_TYPE_NON_LISP
)
1045 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1046 XSETCONS (tem
, end
);
1047 if ((char *) XCONS (tem
) != end
)
1049 lisp_malloc_loser
= base
;
1051 MALLOC_UNBLOCK_INPUT
;
1052 memory_full (SIZE_MAX
);
1057 /* Initialize the blocks and put them on the free list.
1058 If `base' was not properly aligned, we can't use the last block. */
1059 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1061 abase
->blocks
[i
].abase
= abase
;
1062 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1063 free_ablock
= &abase
->blocks
[i
];
1065 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1067 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1068 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1069 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1070 eassert (ABLOCKS_BASE (abase
) == base
);
1071 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1074 abase
= ABLOCK_ABASE (free_ablock
);
1075 ABLOCKS_BUSY (abase
) =
1076 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1078 free_ablock
= free_ablock
->x
.next_free
;
1080 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1081 if (type
!= MEM_TYPE_NON_LISP
)
1082 mem_insert (val
, (char *) val
+ nbytes
, type
);
1085 MALLOC_UNBLOCK_INPUT
;
1087 MALLOC_PROBE (nbytes
);
1089 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1094 lisp_align_free (void *block
)
1096 struct ablock
*ablock
= block
;
1097 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1100 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1101 mem_delete (mem_find (block
));
1103 /* Put on free list. */
1104 ablock
->x
.next_free
= free_ablock
;
1105 free_ablock
= ablock
;
1106 /* Update busy count. */
1107 ABLOCKS_BUSY (abase
)
1108 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1110 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1111 { /* All the blocks are free. */
1112 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1113 struct ablock
**tem
= &free_ablock
;
1114 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1118 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1121 *tem
= (*tem
)->x
.next_free
;
1124 tem
= &(*tem
)->x
.next_free
;
1126 eassert ((aligned
& 1) == aligned
);
1127 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1128 #ifdef USE_POSIX_MEMALIGN
1129 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1131 free (ABLOCKS_BASE (abase
));
1133 MALLOC_UNBLOCK_INPUT
;
1137 /***********************************************************************
1139 ***********************************************************************/
1141 /* Number of intervals allocated in an interval_block structure.
1142 The 1020 is 1024 minus malloc overhead. */
1144 #define INTERVAL_BLOCK_SIZE \
1145 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1147 /* Intervals are allocated in chunks in the form of an interval_block
1150 struct interval_block
1152 /* Place `intervals' first, to preserve alignment. */
1153 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1154 struct interval_block
*next
;
1157 /* Current interval block. Its `next' pointer points to older
1160 static struct interval_block
*interval_block
;
1162 /* Index in interval_block above of the next unused interval
1165 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1167 /* Number of free and live intervals. */
1169 static EMACS_INT total_free_intervals
, total_intervals
;
1171 /* List of free intervals. */
1173 static INTERVAL interval_free_list
;
1175 /* Return a new interval. */
1178 make_interval (void)
1184 if (interval_free_list
)
1186 val
= interval_free_list
;
1187 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1191 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1193 struct interval_block
*newi
1194 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1196 newi
->next
= interval_block
;
1197 interval_block
= newi
;
1198 interval_block_index
= 0;
1199 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1201 val
= &interval_block
->intervals
[interval_block_index
++];
1204 MALLOC_UNBLOCK_INPUT
;
1206 consing_since_gc
+= sizeof (struct interval
);
1208 total_free_intervals
--;
1209 RESET_INTERVAL (val
);
1215 /* Mark Lisp objects in interval I. */
1218 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1220 /* Intervals should never be shared. So, if extra internal checking is
1221 enabled, GC aborts if it seems to have visited an interval twice. */
1222 eassert (!i
->gcmarkbit
);
1224 mark_object (i
->plist
);
1227 /* Mark the interval tree rooted in I. */
1229 #define MARK_INTERVAL_TREE(i) \
1231 if (i && !i->gcmarkbit) \
1232 traverse_intervals_noorder (i, mark_interval, Qnil); \
1235 /***********************************************************************
1237 ***********************************************************************/
1239 /* Lisp_Strings are allocated in string_block structures. When a new
1240 string_block is allocated, all the Lisp_Strings it contains are
1241 added to a free-list string_free_list. When a new Lisp_String is
1242 needed, it is taken from that list. During the sweep phase of GC,
1243 string_blocks that are entirely free are freed, except two which
1246 String data is allocated from sblock structures. Strings larger
1247 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1248 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1250 Sblocks consist internally of sdata structures, one for each
1251 Lisp_String. The sdata structure points to the Lisp_String it
1252 belongs to. The Lisp_String points back to the `u.data' member of
1253 its sdata structure.
1255 When a Lisp_String is freed during GC, it is put back on
1256 string_free_list, and its `data' member and its sdata's `string'
1257 pointer is set to null. The size of the string is recorded in the
1258 `n.nbytes' member of the sdata. So, sdata structures that are no
1259 longer used, can be easily recognized, and it's easy to compact the
1260 sblocks of small strings which we do in compact_small_strings. */
1262 /* Size in bytes of an sblock structure used for small strings. This
1263 is 8192 minus malloc overhead. */
1265 #define SBLOCK_SIZE 8188
1267 /* Strings larger than this are considered large strings. String data
1268 for large strings is allocated from individual sblocks. */
1270 #define LARGE_STRING_BYTES 1024
1272 /* Struct or union describing string memory sub-allocated from an sblock.
1273 This is where the contents of Lisp strings are stored. */
1275 #ifdef GC_CHECK_STRING_BYTES
1279 /* Back-pointer to the string this sdata belongs to. If null, this
1280 structure is free, and the NBYTES member of the union below
1281 contains the string's byte size (the same value that STRING_BYTES
1282 would return if STRING were non-null). If non-null, STRING_BYTES
1283 (STRING) is the size of the data, and DATA contains the string's
1285 struct Lisp_String
*string
;
1288 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1291 #define SDATA_NBYTES(S) (S)->nbytes
1292 #define SDATA_DATA(S) (S)->data
1293 #define SDATA_SELECTOR(member) member
1299 struct Lisp_String
*string
;
1301 /* When STRING is non-null. */
1304 struct Lisp_String
*string
;
1305 unsigned char data
[FLEXIBLE_ARRAY_MEMBER
];
1308 /* When STRING is null. */
1311 struct Lisp_String
*string
;
1316 #define SDATA_NBYTES(S) (S)->n.nbytes
1317 #define SDATA_DATA(S) (S)->u.data
1318 #define SDATA_SELECTOR(member) u.member
1320 #endif /* not GC_CHECK_STRING_BYTES */
1322 #define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1325 /* Structure describing a block of memory which is sub-allocated to
1326 obtain string data memory for strings. Blocks for small strings
1327 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1328 as large as needed. */
1333 struct sblock
*next
;
1335 /* Pointer to the next free sdata block. This points past the end
1336 of the sblock if there isn't any space left in this block. */
1339 /* Start of data. */
1343 /* Number of Lisp strings in a string_block structure. The 1020 is
1344 1024 minus malloc overhead. */
1346 #define STRING_BLOCK_SIZE \
1347 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1349 /* Structure describing a block from which Lisp_String structures
1354 /* Place `strings' first, to preserve alignment. */
1355 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1356 struct string_block
*next
;
1359 /* Head and tail of the list of sblock structures holding Lisp string
1360 data. We always allocate from current_sblock. The NEXT pointers
1361 in the sblock structures go from oldest_sblock to current_sblock. */
1363 static struct sblock
*oldest_sblock
, *current_sblock
;
1365 /* List of sblocks for large strings. */
1367 static struct sblock
*large_sblocks
;
1369 /* List of string_block structures. */
1371 static struct string_block
*string_blocks
;
1373 /* Free-list of Lisp_Strings. */
1375 static struct Lisp_String
*string_free_list
;
1377 /* Number of live and free Lisp_Strings. */
1379 static EMACS_INT total_strings
, total_free_strings
;
1381 /* Number of bytes used by live strings. */
1383 static EMACS_INT total_string_bytes
;
1385 /* Given a pointer to a Lisp_String S which is on the free-list
1386 string_free_list, return a pointer to its successor in the
1389 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1391 /* Return a pointer to the sdata structure belonging to Lisp string S.
1392 S must be live, i.e. S->data must not be null. S->data is actually
1393 a pointer to the `u.data' member of its sdata structure; the
1394 structure starts at a constant offset in front of that. */
1396 #define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1399 #ifdef GC_CHECK_STRING_OVERRUN
1401 /* We check for overrun in string data blocks by appending a small
1402 "cookie" after each allocated string data block, and check for the
1403 presence of this cookie during GC. */
1405 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1406 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1407 { '\xde', '\xad', '\xbe', '\xef' };
1410 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1413 /* Value is the size of an sdata structure large enough to hold NBYTES
1414 bytes of string data. The value returned includes a terminating
1415 NUL byte, the size of the sdata structure, and padding. */
1417 #ifdef GC_CHECK_STRING_BYTES
1419 #define SDATA_SIZE(NBYTES) \
1420 ((SDATA_DATA_OFFSET \
1422 + sizeof (ptrdiff_t) - 1) \
1423 & ~(sizeof (ptrdiff_t) - 1))
1425 #else /* not GC_CHECK_STRING_BYTES */
1427 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1428 less than the size of that member. The 'max' is not needed when
1429 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1430 alignment code reserves enough space. */
1432 #define SDATA_SIZE(NBYTES) \
1433 ((SDATA_DATA_OFFSET \
1434 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1436 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1438 + sizeof (ptrdiff_t) - 1) \
1439 & ~(sizeof (ptrdiff_t) - 1))
1441 #endif /* not GC_CHECK_STRING_BYTES */
1443 /* Extra bytes to allocate for each string. */
1445 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1447 /* Exact bound on the number of bytes in a string, not counting the
1448 terminating null. A string cannot contain more bytes than
1449 STRING_BYTES_BOUND, nor can it be so long that the size_t
1450 arithmetic in allocate_string_data would overflow while it is
1451 calculating a value to be passed to malloc. */
1452 static ptrdiff_t const STRING_BYTES_MAX
=
1453 min (STRING_BYTES_BOUND
,
1454 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1456 - offsetof (struct sblock
, first_data
)
1457 - SDATA_DATA_OFFSET
)
1458 & ~(sizeof (EMACS_INT
) - 1)));
1460 /* Initialize string allocation. Called from init_alloc_once. */
1465 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1466 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1470 #ifdef GC_CHECK_STRING_BYTES
1472 static int check_string_bytes_count
;
1474 /* Like STRING_BYTES, but with debugging check. Can be
1475 called during GC, so pay attention to the mark bit. */
1478 string_bytes (struct Lisp_String
*s
)
1481 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1483 if (!PURE_POINTER_P (s
)
1485 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1490 /* Check validity of Lisp strings' string_bytes member in B. */
1493 check_sblock (struct sblock
*b
)
1495 sdata
*from
, *end
, *from_end
;
1499 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1501 /* Compute the next FROM here because copying below may
1502 overwrite data we need to compute it. */
1505 /* Check that the string size recorded in the string is the
1506 same as the one recorded in the sdata structure. */
1507 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1508 : SDATA_NBYTES (from
));
1509 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1514 /* Check validity of Lisp strings' string_bytes member. ALL_P
1515 means check all strings, otherwise check only most
1516 recently allocated strings. Used for hunting a bug. */
1519 check_string_bytes (bool all_p
)
1525 for (b
= large_sblocks
; b
; b
= b
->next
)
1527 struct Lisp_String
*s
= b
->first_data
.string
;
1532 for (b
= oldest_sblock
; b
; b
= b
->next
)
1535 else if (current_sblock
)
1536 check_sblock (current_sblock
);
1539 #else /* not GC_CHECK_STRING_BYTES */
1541 #define check_string_bytes(all) ((void) 0)
1543 #endif /* GC_CHECK_STRING_BYTES */
1545 #ifdef GC_CHECK_STRING_FREE_LIST
1547 /* Walk through the string free list looking for bogus next pointers.
1548 This may catch buffer overrun from a previous string. */
1551 check_string_free_list (void)
1553 struct Lisp_String
*s
;
1555 /* Pop a Lisp_String off the free-list. */
1556 s
= string_free_list
;
1559 if ((uintptr_t) s
< 1024)
1561 s
= NEXT_FREE_LISP_STRING (s
);
1565 #define check_string_free_list()
1568 /* Return a new Lisp_String. */
1570 static struct Lisp_String
*
1571 allocate_string (void)
1573 struct Lisp_String
*s
;
1577 /* If the free-list is empty, allocate a new string_block, and
1578 add all the Lisp_Strings in it to the free-list. */
1579 if (string_free_list
== NULL
)
1581 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1584 b
->next
= string_blocks
;
1587 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1590 /* Every string on a free list should have NULL data pointer. */
1592 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1593 string_free_list
= s
;
1596 total_free_strings
+= STRING_BLOCK_SIZE
;
1599 check_string_free_list ();
1601 /* Pop a Lisp_String off the free-list. */
1602 s
= string_free_list
;
1603 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1605 MALLOC_UNBLOCK_INPUT
;
1607 --total_free_strings
;
1610 consing_since_gc
+= sizeof *s
;
1612 #ifdef GC_CHECK_STRING_BYTES
1613 if (!noninteractive
)
1615 if (++check_string_bytes_count
== 200)
1617 check_string_bytes_count
= 0;
1618 check_string_bytes (1);
1621 check_string_bytes (0);
1623 #endif /* GC_CHECK_STRING_BYTES */
1629 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1630 plus a NUL byte at the end. Allocate an sdata structure for S, and
1631 set S->data to its `u.data' member. Store a NUL byte at the end of
1632 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1633 S->data if it was initially non-null. */
1636 allocate_string_data (struct Lisp_String
*s
,
1637 EMACS_INT nchars
, EMACS_INT nbytes
)
1639 sdata
*data
, *old_data
;
1641 ptrdiff_t needed
, old_nbytes
;
1643 if (STRING_BYTES_MAX
< nbytes
)
1646 /* Determine the number of bytes needed to store NBYTES bytes
1648 needed
= SDATA_SIZE (nbytes
);
1651 old_data
= SDATA_OF_STRING (s
);
1652 old_nbytes
= STRING_BYTES (s
);
1659 if (nbytes
> LARGE_STRING_BYTES
)
1661 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1663 #ifdef DOUG_LEA_MALLOC
1664 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1665 because mapped region contents are not preserved in
1668 In case you think of allowing it in a dumped Emacs at the
1669 cost of not being able to re-dump, there's another reason:
1670 mmap'ed data typically have an address towards the top of the
1671 address space, which won't fit into an EMACS_INT (at least on
1672 32-bit systems with the current tagging scheme). --fx */
1673 mallopt (M_MMAP_MAX
, 0);
1676 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1678 #ifdef DOUG_LEA_MALLOC
1679 /* Back to a reasonable maximum of mmap'ed areas. */
1680 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1683 b
->next_free
= &b
->first_data
;
1684 b
->first_data
.string
= NULL
;
1685 b
->next
= large_sblocks
;
1688 else if (current_sblock
== NULL
1689 || (((char *) current_sblock
+ SBLOCK_SIZE
1690 - (char *) current_sblock
->next_free
)
1691 < (needed
+ GC_STRING_EXTRA
)))
1693 /* Not enough room in the current sblock. */
1694 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1695 b
->next_free
= &b
->first_data
;
1696 b
->first_data
.string
= NULL
;
1700 current_sblock
->next
= b
;
1708 data
= b
->next_free
;
1709 b
->next_free
= (sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1711 MALLOC_UNBLOCK_INPUT
;
1714 s
->data
= SDATA_DATA (data
);
1715 #ifdef GC_CHECK_STRING_BYTES
1716 SDATA_NBYTES (data
) = nbytes
;
1719 s
->size_byte
= nbytes
;
1720 s
->data
[nbytes
] = '\0';
1721 #ifdef GC_CHECK_STRING_OVERRUN
1722 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
1723 GC_STRING_OVERRUN_COOKIE_SIZE
);
1726 /* Note that Faset may call to this function when S has already data
1727 assigned. In this case, mark data as free by setting it's string
1728 back-pointer to null, and record the size of the data in it. */
1731 SDATA_NBYTES (old_data
) = old_nbytes
;
1732 old_data
->string
= NULL
;
1735 consing_since_gc
+= needed
;
1739 /* Sweep and compact strings. */
1742 sweep_strings (void)
1744 struct string_block
*b
, *next
;
1745 struct string_block
*live_blocks
= NULL
;
1747 string_free_list
= NULL
;
1748 total_strings
= total_free_strings
= 0;
1749 total_string_bytes
= 0;
1751 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1752 for (b
= string_blocks
; b
; b
= next
)
1755 struct Lisp_String
*free_list_before
= string_free_list
;
1759 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1761 struct Lisp_String
*s
= b
->strings
+ i
;
1765 /* String was not on free-list before. */
1766 if (STRING_MARKED_P (s
))
1768 /* String is live; unmark it and its intervals. */
1771 /* Do not use string_(set|get)_intervals here. */
1772 s
->intervals
= balance_intervals (s
->intervals
);
1775 total_string_bytes
+= STRING_BYTES (s
);
1779 /* String is dead. Put it on the free-list. */
1780 sdata
*data
= SDATA_OF_STRING (s
);
1782 /* Save the size of S in its sdata so that we know
1783 how large that is. Reset the sdata's string
1784 back-pointer so that we know it's free. */
1785 #ifdef GC_CHECK_STRING_BYTES
1786 if (string_bytes (s
) != SDATA_NBYTES (data
))
1789 data
->n
.nbytes
= STRING_BYTES (s
);
1791 data
->string
= NULL
;
1793 /* Reset the strings's `data' member so that we
1797 /* Put the string on the free-list. */
1798 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1799 string_free_list
= s
;
1805 /* S was on the free-list before. Put it there again. */
1806 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1807 string_free_list
= s
;
1812 /* Free blocks that contain free Lisp_Strings only, except
1813 the first two of them. */
1814 if (nfree
== STRING_BLOCK_SIZE
1815 && total_free_strings
> STRING_BLOCK_SIZE
)
1818 string_free_list
= free_list_before
;
1822 total_free_strings
+= nfree
;
1823 b
->next
= live_blocks
;
1828 check_string_free_list ();
1830 string_blocks
= live_blocks
;
1831 free_large_strings ();
1832 compact_small_strings ();
1834 check_string_free_list ();
1838 /* Free dead large strings. */
1841 free_large_strings (void)
1843 struct sblock
*b
, *next
;
1844 struct sblock
*live_blocks
= NULL
;
1846 for (b
= large_sblocks
; b
; b
= next
)
1850 if (b
->first_data
.string
== NULL
)
1854 b
->next
= live_blocks
;
1859 large_sblocks
= live_blocks
;
1863 /* Compact data of small strings. Free sblocks that don't contain
1864 data of live strings after compaction. */
1867 compact_small_strings (void)
1869 struct sblock
*b
, *tb
, *next
;
1870 sdata
*from
, *to
, *end
, *tb_end
;
1871 sdata
*to_end
, *from_end
;
1873 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1874 to, and TB_END is the end of TB. */
1876 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1877 to
= &tb
->first_data
;
1879 /* Step through the blocks from the oldest to the youngest. We
1880 expect that old blocks will stabilize over time, so that less
1881 copying will happen this way. */
1882 for (b
= oldest_sblock
; b
; b
= b
->next
)
1885 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1887 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1889 /* Compute the next FROM here because copying below may
1890 overwrite data we need to compute it. */
1892 struct Lisp_String
*s
= from
->string
;
1894 #ifdef GC_CHECK_STRING_BYTES
1895 /* Check that the string size recorded in the string is the
1896 same as the one recorded in the sdata structure. */
1897 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
1899 #endif /* GC_CHECK_STRING_BYTES */
1901 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
1902 eassert (nbytes
<= LARGE_STRING_BYTES
);
1904 nbytes
= SDATA_SIZE (nbytes
);
1905 from_end
= (sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1907 #ifdef GC_CHECK_STRING_OVERRUN
1908 if (memcmp (string_overrun_cookie
,
1909 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
1910 GC_STRING_OVERRUN_COOKIE_SIZE
))
1914 /* Non-NULL S means it's alive. Copy its data. */
1917 /* If TB is full, proceed with the next sblock. */
1918 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1919 if (to_end
> tb_end
)
1923 tb_end
= (sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1924 to
= &tb
->first_data
;
1925 to_end
= (sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
1928 /* Copy, and update the string's `data' pointer. */
1931 eassert (tb
!= b
|| to
< from
);
1932 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
1933 to
->string
->data
= SDATA_DATA (to
);
1936 /* Advance past the sdata we copied to. */
1942 /* The rest of the sblocks following TB don't contain live data, so
1943 we can free them. */
1944 for (b
= tb
->next
; b
; b
= next
)
1952 current_sblock
= tb
;
1956 string_overflow (void)
1958 error ("Maximum string size exceeded");
1961 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1962 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1963 LENGTH must be an integer.
1964 INIT must be an integer that represents a character. */)
1965 (Lisp_Object length
, Lisp_Object init
)
1967 register Lisp_Object val
;
1968 register unsigned char *p
, *end
;
1972 CHECK_NATNUM (length
);
1973 CHECK_CHARACTER (init
);
1975 c
= XFASTINT (init
);
1976 if (ASCII_CHAR_P (c
))
1978 nbytes
= XINT (length
);
1979 val
= make_uninit_string (nbytes
);
1981 end
= p
+ SCHARS (val
);
1987 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1988 int len
= CHAR_STRING (c
, str
);
1989 EMACS_INT string_len
= XINT (length
);
1991 if (string_len
> STRING_BYTES_MAX
/ len
)
1993 nbytes
= len
* string_len
;
1994 val
= make_uninit_multibyte_string (string_len
, nbytes
);
1999 memcpy (p
, str
, len
);
2009 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2010 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2011 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2012 (Lisp_Object length
, Lisp_Object init
)
2014 register Lisp_Object val
;
2015 struct Lisp_Bool_Vector
*p
;
2016 ptrdiff_t length_in_chars
;
2017 EMACS_INT length_in_elts
;
2019 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2022 CHECK_NATNUM (length
);
2024 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2026 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2028 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2030 /* No Lisp_Object to trace in there. */
2031 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0, 0);
2033 p
= XBOOL_VECTOR (val
);
2034 p
->size
= XFASTINT (length
);
2036 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2037 / BOOL_VECTOR_BITS_PER_CHAR
);
2038 if (length_in_chars
)
2040 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2042 /* Clear any extraneous bits in the last byte. */
2043 p
->data
[length_in_chars
- 1]
2044 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2051 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2052 of characters from the contents. This string may be unibyte or
2053 multibyte, depending on the contents. */
2056 make_string (const char *contents
, ptrdiff_t nbytes
)
2058 register Lisp_Object val
;
2059 ptrdiff_t nchars
, multibyte_nbytes
;
2061 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2062 &nchars
, &multibyte_nbytes
);
2063 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2064 /* CONTENTS contains no multibyte sequences or contains an invalid
2065 multibyte sequence. We must make unibyte string. */
2066 val
= make_unibyte_string (contents
, nbytes
);
2068 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2073 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2076 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2078 register Lisp_Object val
;
2079 val
= make_uninit_string (length
);
2080 memcpy (SDATA (val
), contents
, length
);
2085 /* Make a multibyte string from NCHARS characters occupying NBYTES
2086 bytes at CONTENTS. */
2089 make_multibyte_string (const char *contents
,
2090 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2092 register Lisp_Object val
;
2093 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2094 memcpy (SDATA (val
), contents
, nbytes
);
2099 /* Make a string from NCHARS characters occupying NBYTES bytes at
2100 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2103 make_string_from_bytes (const char *contents
,
2104 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2106 register Lisp_Object val
;
2107 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2108 memcpy (SDATA (val
), contents
, nbytes
);
2109 if (SBYTES (val
) == SCHARS (val
))
2110 STRING_SET_UNIBYTE (val
);
2115 /* Make a string from NCHARS characters occupying NBYTES bytes at
2116 CONTENTS. The argument MULTIBYTE controls whether to label the
2117 string as multibyte. If NCHARS is negative, it counts the number of
2118 characters by itself. */
2121 make_specified_string (const char *contents
,
2122 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2129 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2134 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2135 memcpy (SDATA (val
), contents
, nbytes
);
2137 STRING_SET_UNIBYTE (val
);
2142 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2143 occupying LENGTH bytes. */
2146 make_uninit_string (EMACS_INT length
)
2151 return empty_unibyte_string
;
2152 val
= make_uninit_multibyte_string (length
, length
);
2153 STRING_SET_UNIBYTE (val
);
2158 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2159 which occupy NBYTES bytes. */
2162 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2165 struct Lisp_String
*s
;
2170 return empty_multibyte_string
;
2172 s
= allocate_string ();
2173 s
->intervals
= NULL
;
2174 allocate_string_data (s
, nchars
, nbytes
);
2175 XSETSTRING (string
, s
);
2176 string_chars_consed
+= nbytes
;
2180 /* Print arguments to BUF according to a FORMAT, then return
2181 a Lisp_String initialized with the data from BUF. */
2184 make_formatted_string (char *buf
, const char *format
, ...)
2189 va_start (ap
, format
);
2190 length
= vsprintf (buf
, format
, ap
);
2192 return make_string (buf
, length
);
2196 /***********************************************************************
2198 ***********************************************************************/
2200 /* We store float cells inside of float_blocks, allocating a new
2201 float_block with malloc whenever necessary. Float cells reclaimed
2202 by GC are put on a free list to be reallocated before allocating
2203 any new float cells from the latest float_block. */
2205 #define FLOAT_BLOCK_SIZE \
2206 (((BLOCK_BYTES - sizeof (struct float_block *) \
2207 /* The compiler might add padding at the end. */ \
2208 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2209 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2211 #define GETMARKBIT(block,n) \
2212 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2213 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2216 #define SETMARKBIT(block,n) \
2217 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2218 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2220 #define UNSETMARKBIT(block,n) \
2221 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2222 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2224 #define FLOAT_BLOCK(fptr) \
2225 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2227 #define FLOAT_INDEX(fptr) \
2228 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2232 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2233 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2234 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2235 struct float_block
*next
;
2238 #define FLOAT_MARKED_P(fptr) \
2239 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2241 #define FLOAT_MARK(fptr) \
2242 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2244 #define FLOAT_UNMARK(fptr) \
2245 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2247 /* Current float_block. */
2249 static struct float_block
*float_block
;
2251 /* Index of first unused Lisp_Float in the current float_block. */
2253 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2255 /* Free-list of Lisp_Floats. */
2257 static struct Lisp_Float
*float_free_list
;
2259 /* Return a new float object with value FLOAT_VALUE. */
2262 make_float (double float_value
)
2264 register Lisp_Object val
;
2268 if (float_free_list
)
2270 /* We use the data field for chaining the free list
2271 so that we won't use the same field that has the mark bit. */
2272 XSETFLOAT (val
, float_free_list
);
2273 float_free_list
= float_free_list
->u
.chain
;
2277 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2279 struct float_block
*new
2280 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2281 new->next
= float_block
;
2282 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2284 float_block_index
= 0;
2285 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2287 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2288 float_block_index
++;
2291 MALLOC_UNBLOCK_INPUT
;
2293 XFLOAT_INIT (val
, float_value
);
2294 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2295 consing_since_gc
+= sizeof (struct Lisp_Float
);
2297 total_free_floats
--;
2303 /***********************************************************************
2305 ***********************************************************************/
2307 /* We store cons cells inside of cons_blocks, allocating a new
2308 cons_block with malloc whenever necessary. Cons cells reclaimed by
2309 GC are put on a free list to be reallocated before allocating
2310 any new cons cells from the latest cons_block. */
2312 #define CONS_BLOCK_SIZE \
2313 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2314 /* The compiler might add padding at the end. */ \
2315 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2316 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2318 #define CONS_BLOCK(fptr) \
2319 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2321 #define CONS_INDEX(fptr) \
2322 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2326 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2327 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2328 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2329 struct cons_block
*next
;
2332 #define CONS_MARKED_P(fptr) \
2333 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2335 #define CONS_MARK(fptr) \
2336 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2338 #define CONS_UNMARK(fptr) \
2339 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2341 /* Current cons_block. */
2343 static struct cons_block
*cons_block
;
2345 /* Index of first unused Lisp_Cons in the current block. */
2347 static int cons_block_index
= CONS_BLOCK_SIZE
;
2349 /* Free-list of Lisp_Cons structures. */
2351 static struct Lisp_Cons
*cons_free_list
;
2353 /* Explicitly free a cons cell by putting it on the free-list. */
2356 free_cons (struct Lisp_Cons
*ptr
)
2358 ptr
->u
.chain
= cons_free_list
;
2362 cons_free_list
= ptr
;
2363 consing_since_gc
-= sizeof *ptr
;
2364 total_free_conses
++;
2367 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2368 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2369 (Lisp_Object car
, Lisp_Object cdr
)
2371 register Lisp_Object val
;
2377 /* We use the cdr for chaining the free list
2378 so that we won't use the same field that has the mark bit. */
2379 XSETCONS (val
, cons_free_list
);
2380 cons_free_list
= cons_free_list
->u
.chain
;
2384 if (cons_block_index
== CONS_BLOCK_SIZE
)
2386 struct cons_block
*new
2387 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2388 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2389 new->next
= cons_block
;
2391 cons_block_index
= 0;
2392 total_free_conses
+= CONS_BLOCK_SIZE
;
2394 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2398 MALLOC_UNBLOCK_INPUT
;
2402 eassert (!CONS_MARKED_P (XCONS (val
)));
2403 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2404 total_free_conses
--;
2405 cons_cells_consed
++;
2409 #ifdef GC_CHECK_CONS_LIST
2410 /* Get an error now if there's any junk in the cons free list. */
2412 check_cons_list (void)
2414 struct Lisp_Cons
*tail
= cons_free_list
;
2417 tail
= tail
->u
.chain
;
2421 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2424 list1 (Lisp_Object arg1
)
2426 return Fcons (arg1
, Qnil
);
2430 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2432 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2437 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2439 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2444 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2446 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2451 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2453 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2454 Fcons (arg5
, Qnil
)))));
2457 /* Make a list of COUNT Lisp_Objects, where ARG is the
2458 first one. Allocate conses from pure space if TYPE
2459 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2462 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2466 Lisp_Object val
, *objp
;
2468 /* Change to SAFE_ALLOCA if you hit this eassert. */
2469 eassert (count
<= MAX_ALLOCA
/ word_size
);
2471 objp
= alloca (count
* word_size
);
2474 for (i
= 1; i
< count
; i
++)
2475 objp
[i
] = va_arg (ap
, Lisp_Object
);
2478 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2480 if (type
== CONSTYPE_PURE
)
2481 val
= pure_cons (objp
[i
], val
);
2482 else if (type
== CONSTYPE_HEAP
)
2483 val
= Fcons (objp
[i
], val
);
2490 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2491 doc
: /* Return a newly created list with specified arguments as elements.
2492 Any number of arguments, even zero arguments, are allowed.
2493 usage: (list &rest OBJECTS) */)
2494 (ptrdiff_t nargs
, Lisp_Object
*args
)
2496 register Lisp_Object val
;
2502 val
= Fcons (args
[nargs
], val
);
2508 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2509 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2510 (register Lisp_Object length
, Lisp_Object init
)
2512 register Lisp_Object val
;
2513 register EMACS_INT size
;
2515 CHECK_NATNUM (length
);
2516 size
= XFASTINT (length
);
2521 val
= Fcons (init
, val
);
2526 val
= Fcons (init
, val
);
2531 val
= Fcons (init
, val
);
2536 val
= Fcons (init
, val
);
2541 val
= Fcons (init
, val
);
2556 /***********************************************************************
2558 ***********************************************************************/
2560 /* This value is balanced well enough to avoid too much internal overhead
2561 for the most common cases; it's not required to be a power of two, but
2562 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2564 #define VECTOR_BLOCK_SIZE 4096
2566 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2569 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2572 /* ROUNDUP_SIZE must be a power of 2. */
2573 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2575 /* Verify assumptions described above. */
2576 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2577 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2579 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2581 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2583 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2585 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2587 /* Size of the minimal vector allocated from block. */
2589 #define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
2591 /* Size of the largest vector allocated from block. */
2593 #define VBLOCK_BYTES_MAX \
2594 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2596 /* We maintain one free list for each possible block-allocated
2597 vector size, and this is the number of free lists we have. */
2599 #define VECTOR_MAX_FREE_LIST_INDEX \
2600 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2602 /* Common shortcut to advance vector pointer over a block data. */
2604 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2606 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2608 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2610 /* Get and set the next field in block-allocated vectorlike objects on
2611 the free list. Doing it this way respects C's aliasing rules.
2612 We could instead make 'contents' a union, but that would mean
2613 changes everywhere that the code uses 'contents'. */
2614 static struct Lisp_Vector
*
2615 next_in_free_list (struct Lisp_Vector
*v
)
2617 intptr_t i
= XLI (v
->contents
[0]);
2618 return (struct Lisp_Vector
*) i
;
2621 set_next_in_free_list (struct Lisp_Vector
*v
, struct Lisp_Vector
*next
)
2623 v
->contents
[0] = XIL ((intptr_t) next
);
2626 /* Common shortcut to setup vector on a free list. */
2628 #define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2630 (tmp) = ((nbytes - header_size) / word_size); \
2631 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2632 eassert ((nbytes) % roundup_size == 0); \
2633 (tmp) = VINDEX (nbytes); \
2634 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2635 set_next_in_free_list (v, vector_free_lists[tmp]); \
2636 vector_free_lists[tmp] = (v); \
2637 total_free_vector_slots += (nbytes) / word_size; \
2640 /* This internal type is used to maintain the list of large vectors
2641 which are allocated at their own, e.g. outside of vector blocks. */
2646 struct large_vector
*vector
;
2648 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2649 unsigned char c
[vroundup (sizeof (struct large_vector
*))];
2652 struct Lisp_Vector v
;
2655 /* This internal type is used to maintain an underlying storage
2656 for small vectors. */
2660 char data
[VECTOR_BLOCK_BYTES
];
2661 struct vector_block
*next
;
2664 /* Chain of vector blocks. */
2666 static struct vector_block
*vector_blocks
;
2668 /* Vector free lists, where NTH item points to a chain of free
2669 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2671 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2673 /* Singly-linked list of large vectors. */
2675 static struct large_vector
*large_vectors
;
2677 /* The only vector with 0 slots, allocated from pure space. */
2679 Lisp_Object zero_vector
;
2681 /* Number of live vectors. */
2683 static EMACS_INT total_vectors
;
2685 /* Total size of live and free vectors, in Lisp_Object units. */
2687 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2689 /* Get a new vector block. */
2691 static struct vector_block
*
2692 allocate_vector_block (void)
2694 struct vector_block
*block
= xmalloc (sizeof *block
);
2696 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2697 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2698 MEM_TYPE_VECTOR_BLOCK
);
2701 block
->next
= vector_blocks
;
2702 vector_blocks
= block
;
2706 /* Called once to initialize vector allocation. */
2711 zero_vector
= make_pure_vector (0);
2714 /* Allocate vector from a vector block. */
2716 static struct Lisp_Vector
*
2717 allocate_vector_from_block (size_t nbytes
)
2719 struct Lisp_Vector
*vector
;
2720 struct vector_block
*block
;
2721 size_t index
, restbytes
;
2723 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
2724 eassert (nbytes
% roundup_size
== 0);
2726 /* First, try to allocate from a free list
2727 containing vectors of the requested size. */
2728 index
= VINDEX (nbytes
);
2729 if (vector_free_lists
[index
])
2731 vector
= vector_free_lists
[index
];
2732 vector_free_lists
[index
] = next_in_free_list (vector
);
2733 total_free_vector_slots
-= nbytes
/ word_size
;
2737 /* Next, check free lists containing larger vectors. Since
2738 we will split the result, we should have remaining space
2739 large enough to use for one-slot vector at least. */
2740 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
2741 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
2742 if (vector_free_lists
[index
])
2744 /* This vector is larger than requested. */
2745 vector
= vector_free_lists
[index
];
2746 vector_free_lists
[index
] = next_in_free_list (vector
);
2747 total_free_vector_slots
-= nbytes
/ word_size
;
2749 /* Excess bytes are used for the smaller vector,
2750 which should be set on an appropriate free list. */
2751 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
2752 eassert (restbytes
% roundup_size
== 0);
2753 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2757 /* Finally, need a new vector block. */
2758 block
= allocate_vector_block ();
2760 /* New vector will be at the beginning of this block. */
2761 vector
= (struct Lisp_Vector
*) block
->data
;
2763 /* If the rest of space from this block is large enough
2764 for one-slot vector at least, set up it on a free list. */
2765 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
2766 if (restbytes
>= VBLOCK_BYTES_MIN
)
2768 eassert (restbytes
% roundup_size
== 0);
2769 SETUP_ON_FREE_LIST (ADVANCE (vector
, nbytes
), restbytes
, index
);
2774 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2776 #define VECTOR_IN_BLOCK(vector, block) \
2777 ((char *) (vector) <= (block)->data \
2778 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2780 /* Return the memory footprint of V in bytes. */
2783 vector_nbytes (struct Lisp_Vector
*v
)
2785 ptrdiff_t size
= v
->header
.size
& ~ARRAY_MARK_FLAG
;
2787 if (size
& PSEUDOVECTOR_FLAG
)
2789 if (PSEUDOVECTOR_TYPEP (&v
->header
, PVEC_BOOL_VECTOR
))
2790 size
= (bool_header_size
2791 + (((struct Lisp_Bool_Vector
*) v
)->size
2792 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2793 / BOOL_VECTOR_BITS_PER_CHAR
);
2796 + ((size
& PSEUDOVECTOR_SIZE_MASK
)
2797 + ((size
& PSEUDOVECTOR_REST_MASK
)
2798 >> PSEUDOVECTOR_SIZE_BITS
)) * word_size
);
2801 size
= header_size
+ size
* word_size
;
2802 return vroundup (size
);
2805 /* Reclaim space used by unmarked vectors. */
2808 sweep_vectors (void)
2810 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
2811 struct large_vector
*lv
, **lvprev
= &large_vectors
;
2812 struct Lisp_Vector
*vector
, *next
;
2814 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
2815 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
2817 /* Looking through vector blocks. */
2819 for (block
= vector_blocks
; block
; block
= *bprev
)
2821 bool free_this_block
= 0;
2824 for (vector
= (struct Lisp_Vector
*) block
->data
;
2825 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
2827 if (VECTOR_MARKED_P (vector
))
2829 VECTOR_UNMARK (vector
);
2831 nbytes
= vector_nbytes (vector
);
2832 total_vector_slots
+= nbytes
/ word_size
;
2833 next
= ADVANCE (vector
, nbytes
);
2837 ptrdiff_t total_bytes
;
2839 nbytes
= vector_nbytes (vector
);
2840 total_bytes
= nbytes
;
2841 next
= ADVANCE (vector
, nbytes
);
2843 /* While NEXT is not marked, try to coalesce with VECTOR,
2844 thus making VECTOR of the largest possible size. */
2846 while (VECTOR_IN_BLOCK (next
, block
))
2848 if (VECTOR_MARKED_P (next
))
2850 nbytes
= vector_nbytes (next
);
2851 total_bytes
+= nbytes
;
2852 next
= ADVANCE (next
, nbytes
);
2855 eassert (total_bytes
% roundup_size
== 0);
2857 if (vector
== (struct Lisp_Vector
*) block
->data
2858 && !VECTOR_IN_BLOCK (next
, block
))
2859 /* This block should be freed because all of it's
2860 space was coalesced into the only free vector. */
2861 free_this_block
= 1;
2865 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
2870 if (free_this_block
)
2872 *bprev
= block
->next
;
2873 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2874 mem_delete (mem_find (block
->data
));
2879 bprev
= &block
->next
;
2882 /* Sweep large vectors. */
2884 for (lv
= large_vectors
; lv
; lv
= *lvprev
)
2887 if (VECTOR_MARKED_P (vector
))
2889 VECTOR_UNMARK (vector
);
2891 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
2893 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
2895 /* All non-bool pseudovectors are small enough to be allocated
2896 from vector blocks. This code should be redesigned if some
2897 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2898 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
2901 += (bool_header_size
2902 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2903 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
2907 += header_size
/ word_size
+ vector
->header
.size
;
2908 lvprev
= &lv
->next
.vector
;
2912 *lvprev
= lv
->next
.vector
;
2918 /* Value is a pointer to a newly allocated Lisp_Vector structure
2919 with room for LEN Lisp_Objects. */
2921 static struct Lisp_Vector
*
2922 allocate_vectorlike (ptrdiff_t len
)
2924 struct Lisp_Vector
*p
;
2929 p
= XVECTOR (zero_vector
);
2932 size_t nbytes
= header_size
+ len
* word_size
;
2934 #ifdef DOUG_LEA_MALLOC
2935 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2936 because mapped region contents are not preserved in
2938 mallopt (M_MMAP_MAX
, 0);
2941 if (nbytes
<= VBLOCK_BYTES_MAX
)
2942 p
= allocate_vector_from_block (vroundup (nbytes
));
2945 struct large_vector
*lv
2946 = lisp_malloc ((offsetof (struct large_vector
, v
.contents
)
2948 MEM_TYPE_VECTORLIKE
);
2949 lv
->next
.vector
= large_vectors
;
2954 #ifdef DOUG_LEA_MALLOC
2955 /* Back to a reasonable maximum of mmap'ed areas. */
2956 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2959 consing_since_gc
+= nbytes
;
2960 vector_cells_consed
+= len
;
2963 MALLOC_UNBLOCK_INPUT
;
2969 /* Allocate a vector with LEN slots. */
2971 struct Lisp_Vector
*
2972 allocate_vector (EMACS_INT len
)
2974 struct Lisp_Vector
*v
;
2975 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2977 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2978 memory_full (SIZE_MAX
);
2979 v
= allocate_vectorlike (len
);
2980 v
->header
.size
= len
;
2985 /* Allocate other vector-like structures. */
2987 struct Lisp_Vector
*
2988 allocate_pseudovector (int memlen
, int lisplen
, enum pvec_type tag
)
2990 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2993 /* Catch bogus values. */
2994 eassert (tag
<= PVEC_FONT
);
2995 eassert (memlen
- lisplen
<= (1 << PSEUDOVECTOR_REST_BITS
) - 1);
2996 eassert (lisplen
<= (1 << PSEUDOVECTOR_SIZE_BITS
) - 1);
2998 /* Only the first lisplen slots will be traced normally by the GC. */
2999 for (i
= 0; i
< lisplen
; ++i
)
3000 v
->contents
[i
] = Qnil
;
3002 XSETPVECTYPESIZE (v
, tag
, lisplen
, memlen
- lisplen
);
3007 allocate_buffer (void)
3009 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3011 BUFFER_PVEC_INIT (b
);
3012 /* Put B on the chain of all buffers including killed ones. */
3013 b
->next
= all_buffers
;
3015 /* Note that the rest fields of B are not initialized. */
3019 struct Lisp_Hash_Table
*
3020 allocate_hash_table (void)
3022 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3026 allocate_window (void)
3030 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3031 /* Users assumes that non-Lisp data is zeroed. */
3032 memset (&w
->current_matrix
, 0,
3033 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3038 allocate_terminal (void)
3042 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3043 /* Users assumes that non-Lisp data is zeroed. */
3044 memset (&t
->next_terminal
, 0,
3045 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3050 allocate_frame (void)
3054 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3055 /* Users assumes that non-Lisp data is zeroed. */
3056 memset (&f
->face_cache
, 0,
3057 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3061 struct Lisp_Process
*
3062 allocate_process (void)
3064 struct Lisp_Process
*p
;
3066 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3067 /* Users assumes that non-Lisp data is zeroed. */
3069 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3073 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3074 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3075 See also the function `vector'. */)
3076 (register Lisp_Object length
, Lisp_Object init
)
3079 register ptrdiff_t sizei
;
3080 register ptrdiff_t i
;
3081 register struct Lisp_Vector
*p
;
3083 CHECK_NATNUM (length
);
3085 p
= allocate_vector (XFASTINT (length
));
3086 sizei
= XFASTINT (length
);
3087 for (i
= 0; i
< sizei
; i
++)
3088 p
->contents
[i
] = init
;
3090 XSETVECTOR (vector
, p
);
3095 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3096 doc
: /* Return a newly created vector with specified arguments as elements.
3097 Any number of arguments, even zero arguments, are allowed.
3098 usage: (vector &rest OBJECTS) */)
3099 (ptrdiff_t nargs
, Lisp_Object
*args
)
3102 register Lisp_Object val
= make_uninit_vector (nargs
);
3103 register struct Lisp_Vector
*p
= XVECTOR (val
);
3105 for (i
= 0; i
< nargs
; i
++)
3106 p
->contents
[i
] = args
[i
];
3111 make_byte_code (struct Lisp_Vector
*v
)
3113 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3114 && STRING_MULTIBYTE (v
->contents
[1]))
3115 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3116 earlier because they produced a raw 8-bit string for byte-code
3117 and now such a byte-code string is loaded as multibyte while
3118 raw 8-bit characters converted to multibyte form. Thus, now we
3119 must convert them back to the original unibyte form. */
3120 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3121 XSETPVECTYPE (v
, PVEC_COMPILED
);
3124 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3125 doc
: /* Create a byte-code object with specified arguments as elements.
3126 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3127 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3128 and (optional) INTERACTIVE-SPEC.
3129 The first four arguments are required; at most six have any
3131 The ARGLIST can be either like the one of `lambda', in which case the arguments
3132 will be dynamically bound before executing the byte code, or it can be an
3133 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3134 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3135 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3136 argument to catch the left-over arguments. If such an integer is used, the
3137 arguments will not be dynamically bound but will be instead pushed on the
3138 stack before executing the byte-code.
3139 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3140 (ptrdiff_t nargs
, Lisp_Object
*args
)
3143 register Lisp_Object val
= make_uninit_vector (nargs
);
3144 register struct Lisp_Vector
*p
= XVECTOR (val
);
3146 /* We used to purecopy everything here, if purify-flag was set. This worked
3147 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3148 dangerous, since make-byte-code is used during execution to build
3149 closures, so any closure built during the preload phase would end up
3150 copied into pure space, including its free variables, which is sometimes
3151 just wasteful and other times plainly wrong (e.g. those free vars may want
3154 for (i
= 0; i
< nargs
; i
++)
3155 p
->contents
[i
] = args
[i
];
3157 XSETCOMPILED (val
, p
);
3163 /***********************************************************************
3165 ***********************************************************************/
3167 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3168 of the required alignment if LSB tags are used. */
3170 union aligned_Lisp_Symbol
3172 struct Lisp_Symbol s
;
3174 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3179 /* Each symbol_block is just under 1020 bytes long, since malloc
3180 really allocates in units of powers of two and uses 4 bytes for its
3183 #define SYMBOL_BLOCK_SIZE \
3184 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3188 /* Place `symbols' first, to preserve alignment. */
3189 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3190 struct symbol_block
*next
;
3193 /* Current symbol block and index of first unused Lisp_Symbol
3196 static struct symbol_block
*symbol_block
;
3197 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3199 /* List of free symbols. */
3201 static struct Lisp_Symbol
*symbol_free_list
;
3204 set_symbol_name (Lisp_Object sym
, Lisp_Object name
)
3206 XSYMBOL (sym
)->name
= name
;
3209 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3210 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3211 Its value is void, and its function definition and property list are nil. */)
3214 register Lisp_Object val
;
3215 register struct Lisp_Symbol
*p
;
3217 CHECK_STRING (name
);
3221 if (symbol_free_list
)
3223 XSETSYMBOL (val
, symbol_free_list
);
3224 symbol_free_list
= symbol_free_list
->next
;
3228 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3230 struct symbol_block
*new
3231 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3232 new->next
= symbol_block
;
3234 symbol_block_index
= 0;
3235 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3237 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3238 symbol_block_index
++;
3241 MALLOC_UNBLOCK_INPUT
;
3244 set_symbol_name (val
, name
);
3245 set_symbol_plist (val
, Qnil
);
3246 p
->redirect
= SYMBOL_PLAINVAL
;
3247 SET_SYMBOL_VAL (p
, Qunbound
);
3248 set_symbol_function (val
, Qnil
);
3249 set_symbol_next (val
, NULL
);
3251 p
->interned
= SYMBOL_UNINTERNED
;
3253 p
->declared_special
= 0;
3254 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3256 total_free_symbols
--;
3262 /***********************************************************************
3263 Marker (Misc) Allocation
3264 ***********************************************************************/
3266 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3267 the required alignment when LSB tags are used. */
3269 union aligned_Lisp_Misc
3273 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3278 /* Allocation of markers and other objects that share that structure.
3279 Works like allocation of conses. */
3281 #define MARKER_BLOCK_SIZE \
3282 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3286 /* Place `markers' first, to preserve alignment. */
3287 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3288 struct marker_block
*next
;
3291 static struct marker_block
*marker_block
;
3292 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3294 static union Lisp_Misc
*marker_free_list
;
3296 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3299 allocate_misc (enum Lisp_Misc_Type type
)
3305 if (marker_free_list
)
3307 XSETMISC (val
, marker_free_list
);
3308 marker_free_list
= marker_free_list
->u_free
.chain
;
3312 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3314 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3315 new->next
= marker_block
;
3317 marker_block_index
= 0;
3318 total_free_markers
+= MARKER_BLOCK_SIZE
;
3320 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3321 marker_block_index
++;
3324 MALLOC_UNBLOCK_INPUT
;
3326 --total_free_markers
;
3327 consing_since_gc
+= sizeof (union Lisp_Misc
);
3328 misc_objects_consed
++;
3329 XMISCANY (val
)->type
= type
;
3330 XMISCANY (val
)->gcmarkbit
= 0;
3334 /* Free a Lisp_Misc object. */
3337 free_misc (Lisp_Object misc
)
3339 XMISCANY (misc
)->type
= Lisp_Misc_Free
;
3340 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3341 marker_free_list
= XMISC (misc
);
3342 consing_since_gc
-= sizeof (union Lisp_Misc
);
3343 total_free_markers
++;
3346 /* Verify properties of Lisp_Save_Value's representation
3347 that are assumed here and elsewhere. */
3349 verify (SAVE_UNUSED
== 0);
3350 verify (((SAVE_INTEGER
| SAVE_POINTER
| SAVE_FUNCPOINTER
| SAVE_OBJECT
)
3354 /* Return Lisp_Save_Value objects for the various combinations
3355 that callers need. */
3358 make_save_int_int_int (ptrdiff_t a
, ptrdiff_t b
, ptrdiff_t c
)
3360 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3361 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3362 p
->save_type
= SAVE_TYPE_INT_INT_INT
;
3363 p
->data
[0].integer
= a
;
3364 p
->data
[1].integer
= b
;
3365 p
->data
[2].integer
= c
;
3370 make_save_obj_obj_obj_obj (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
,
3373 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3374 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3375 p
->save_type
= SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
;
3376 p
->data
[0].object
= a
;
3377 p
->data
[1].object
= b
;
3378 p
->data
[2].object
= c
;
3379 p
->data
[3].object
= d
;
3383 #if defined HAVE_NS || defined HAVE_NTGUI
3385 make_save_ptr (void *a
)
3387 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3388 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3389 p
->save_type
= SAVE_POINTER
;
3390 p
->data
[0].pointer
= a
;
3396 make_save_ptr_int (void *a
, ptrdiff_t b
)
3398 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3399 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3400 p
->save_type
= SAVE_TYPE_PTR_INT
;
3401 p
->data
[0].pointer
= a
;
3402 p
->data
[1].integer
= b
;
3406 #if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3408 make_save_ptr_ptr (void *a
, void *b
)
3410 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3411 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3412 p
->save_type
= SAVE_TYPE_PTR_PTR
;
3413 p
->data
[0].pointer
= a
;
3414 p
->data
[1].pointer
= b
;
3420 make_save_funcptr_ptr_obj (void (*a
) (void), void *b
, Lisp_Object c
)
3422 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3423 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3424 p
->save_type
= SAVE_TYPE_FUNCPTR_PTR_OBJ
;
3425 p
->data
[0].funcpointer
= a
;
3426 p
->data
[1].pointer
= b
;
3427 p
->data
[2].object
= c
;
3431 /* Return a Lisp_Save_Value object that represents an array A
3432 of N Lisp objects. */
3435 make_save_memory (Lisp_Object
*a
, ptrdiff_t n
)
3437 Lisp_Object val
= allocate_misc (Lisp_Misc_Save_Value
);
3438 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
3439 p
->save_type
= SAVE_TYPE_MEMORY
;
3440 p
->data
[0].pointer
= a
;
3441 p
->data
[1].integer
= n
;
3445 /* Free a Lisp_Save_Value object. Do not use this function
3446 if SAVE contains pointer other than returned by xmalloc. */
3449 free_save_value (Lisp_Object save
)
3451 xfree (XSAVE_POINTER (save
, 0));
3455 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3458 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3460 register Lisp_Object overlay
;
3462 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3463 OVERLAY_START (overlay
) = start
;
3464 OVERLAY_END (overlay
) = end
;
3465 set_overlay_plist (overlay
, plist
);
3466 XOVERLAY (overlay
)->next
= NULL
;
3470 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3471 doc
: /* Return a newly allocated marker which does not point at any place. */)
3474 register Lisp_Object val
;
3475 register struct Lisp_Marker
*p
;
3477 val
= allocate_misc (Lisp_Misc_Marker
);
3483 p
->insertion_type
= 0;
3487 /* Return a newly allocated marker which points into BUF
3488 at character position CHARPOS and byte position BYTEPOS. */
3491 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3494 struct Lisp_Marker
*m
;
3496 /* No dead buffers here. */
3497 eassert (BUFFER_LIVE_P (buf
));
3499 /* Every character is at least one byte. */
3500 eassert (charpos
<= bytepos
);
3502 obj
= allocate_misc (Lisp_Misc_Marker
);
3505 m
->charpos
= charpos
;
3506 m
->bytepos
= bytepos
;
3507 m
->insertion_type
= 0;
3508 m
->next
= BUF_MARKERS (buf
);
3509 BUF_MARKERS (buf
) = m
;
3513 /* Put MARKER back on the free list after using it temporarily. */
3516 free_marker (Lisp_Object marker
)
3518 unchain_marker (XMARKER (marker
));
3523 /* Return a newly created vector or string with specified arguments as
3524 elements. If all the arguments are characters that can fit
3525 in a string of events, make a string; otherwise, make a vector.
3527 Any number of arguments, even zero arguments, are allowed. */
3530 make_event_array (register int nargs
, Lisp_Object
*args
)
3534 for (i
= 0; i
< nargs
; i
++)
3535 /* The things that fit in a string
3536 are characters that are in 0...127,
3537 after discarding the meta bit and all the bits above it. */
3538 if (!INTEGERP (args
[i
])
3539 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3540 return Fvector (nargs
, args
);
3542 /* Since the loop exited, we know that all the things in it are
3543 characters, so we can make a string. */
3547 result
= Fmake_string (make_number (nargs
), make_number (0));
3548 for (i
= 0; i
< nargs
; i
++)
3550 SSET (result
, i
, XINT (args
[i
]));
3551 /* Move the meta bit to the right place for a string char. */
3552 if (XINT (args
[i
]) & CHAR_META
)
3553 SSET (result
, i
, SREF (result
, i
) | 0x80);
3562 /************************************************************************
3563 Memory Full Handling
3564 ************************************************************************/
3567 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3568 there may have been size_t overflow so that malloc was never
3569 called, or perhaps malloc was invoked successfully but the
3570 resulting pointer had problems fitting into a tagged EMACS_INT. In
3571 either case this counts as memory being full even though malloc did
3575 memory_full (size_t nbytes
)
3577 /* Do not go into hysterics merely because a large request failed. */
3578 bool enough_free_memory
= 0;
3579 if (SPARE_MEMORY
< nbytes
)
3584 p
= malloc (SPARE_MEMORY
);
3588 enough_free_memory
= 1;
3590 MALLOC_UNBLOCK_INPUT
;
3593 if (! enough_free_memory
)
3599 memory_full_cons_threshold
= sizeof (struct cons_block
);
3601 /* The first time we get here, free the spare memory. */
3602 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3603 if (spare_memory
[i
])
3606 free (spare_memory
[i
]);
3607 else if (i
>= 1 && i
<= 4)
3608 lisp_align_free (spare_memory
[i
]);
3610 lisp_free (spare_memory
[i
]);
3611 spare_memory
[i
] = 0;
3615 /* This used to call error, but if we've run out of memory, we could
3616 get infinite recursion trying to build the string. */
3617 xsignal (Qnil
, Vmemory_signal_data
);
3620 /* If we released our reserve (due to running out of memory),
3621 and we have a fair amount free once again,
3622 try to set aside another reserve in case we run out once more.
3624 This is called when a relocatable block is freed in ralloc.c,
3625 and also directly from this file, in case we're not using ralloc.c. */
3628 refill_memory_reserve (void)
3630 #ifndef SYSTEM_MALLOC
3631 if (spare_memory
[0] == 0)
3632 spare_memory
[0] = malloc (SPARE_MEMORY
);
3633 if (spare_memory
[1] == 0)
3634 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3636 if (spare_memory
[2] == 0)
3637 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3639 if (spare_memory
[3] == 0)
3640 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3642 if (spare_memory
[4] == 0)
3643 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3645 if (spare_memory
[5] == 0)
3646 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3648 if (spare_memory
[6] == 0)
3649 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3651 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3652 Vmemory_full
= Qnil
;
3656 /************************************************************************
3658 ************************************************************************/
3660 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3662 /* Conservative C stack marking requires a method to identify possibly
3663 live Lisp objects given a pointer value. We do this by keeping
3664 track of blocks of Lisp data that are allocated in a red-black tree
3665 (see also the comment of mem_node which is the type of nodes in
3666 that tree). Function lisp_malloc adds information for an allocated
3667 block to the red-black tree with calls to mem_insert, and function
3668 lisp_free removes it with mem_delete. Functions live_string_p etc
3669 call mem_find to lookup information about a given pointer in the
3670 tree, and use that to determine if the pointer points to a Lisp
3673 /* Initialize this part of alloc.c. */
3678 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3679 mem_z
.parent
= NULL
;
3680 mem_z
.color
= MEM_BLACK
;
3681 mem_z
.start
= mem_z
.end
= NULL
;
3686 /* Value is a pointer to the mem_node containing START. Value is
3687 MEM_NIL if there is no node in the tree containing START. */
3689 static struct mem_node
*
3690 mem_find (void *start
)
3694 if (start
< min_heap_address
|| start
> max_heap_address
)
3697 /* Make the search always successful to speed up the loop below. */
3698 mem_z
.start
= start
;
3699 mem_z
.end
= (char *) start
+ 1;
3702 while (start
< p
->start
|| start
>= p
->end
)
3703 p
= start
< p
->start
? p
->left
: p
->right
;
3708 /* Insert a new node into the tree for a block of memory with start
3709 address START, end address END, and type TYPE. Value is a
3710 pointer to the node that was inserted. */
3712 static struct mem_node
*
3713 mem_insert (void *start
, void *end
, enum mem_type type
)
3715 struct mem_node
*c
, *parent
, *x
;
3717 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3718 min_heap_address
= start
;
3719 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3720 max_heap_address
= end
;
3722 /* See where in the tree a node for START belongs. In this
3723 particular application, it shouldn't happen that a node is already
3724 present. For debugging purposes, let's check that. */
3728 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3730 while (c
!= MEM_NIL
)
3732 if (start
>= c
->start
&& start
< c
->end
)
3735 c
= start
< c
->start
? c
->left
: c
->right
;
3738 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3740 while (c
!= MEM_NIL
)
3743 c
= start
< c
->start
? c
->left
: c
->right
;
3746 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3748 /* Create a new node. */
3749 #ifdef GC_MALLOC_CHECK
3750 x
= malloc (sizeof *x
);
3754 x
= xmalloc (sizeof *x
);
3760 x
->left
= x
->right
= MEM_NIL
;
3763 /* Insert it as child of PARENT or install it as root. */
3766 if (start
< parent
->start
)
3774 /* Re-establish red-black tree properties. */
3775 mem_insert_fixup (x
);
3781 /* Re-establish the red-black properties of the tree, and thereby
3782 balance the tree, after node X has been inserted; X is always red. */
3785 mem_insert_fixup (struct mem_node
*x
)
3787 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3789 /* X is red and its parent is red. This is a violation of
3790 red-black tree property #3. */
3792 if (x
->parent
== x
->parent
->parent
->left
)
3794 /* We're on the left side of our grandparent, and Y is our
3796 struct mem_node
*y
= x
->parent
->parent
->right
;
3798 if (y
->color
== MEM_RED
)
3800 /* Uncle and parent are red but should be black because
3801 X is red. Change the colors accordingly and proceed
3802 with the grandparent. */
3803 x
->parent
->color
= MEM_BLACK
;
3804 y
->color
= MEM_BLACK
;
3805 x
->parent
->parent
->color
= MEM_RED
;
3806 x
= x
->parent
->parent
;
3810 /* Parent and uncle have different colors; parent is
3811 red, uncle is black. */
3812 if (x
== x
->parent
->right
)
3815 mem_rotate_left (x
);
3818 x
->parent
->color
= MEM_BLACK
;
3819 x
->parent
->parent
->color
= MEM_RED
;
3820 mem_rotate_right (x
->parent
->parent
);
3825 /* This is the symmetrical case of above. */
3826 struct mem_node
*y
= x
->parent
->parent
->left
;
3828 if (y
->color
== MEM_RED
)
3830 x
->parent
->color
= MEM_BLACK
;
3831 y
->color
= MEM_BLACK
;
3832 x
->parent
->parent
->color
= MEM_RED
;
3833 x
= x
->parent
->parent
;
3837 if (x
== x
->parent
->left
)
3840 mem_rotate_right (x
);
3843 x
->parent
->color
= MEM_BLACK
;
3844 x
->parent
->parent
->color
= MEM_RED
;
3845 mem_rotate_left (x
->parent
->parent
);
3850 /* The root may have been changed to red due to the algorithm. Set
3851 it to black so that property #5 is satisfied. */
3852 mem_root
->color
= MEM_BLACK
;
3863 mem_rotate_left (struct mem_node
*x
)
3867 /* Turn y's left sub-tree into x's right sub-tree. */
3870 if (y
->left
!= MEM_NIL
)
3871 y
->left
->parent
= x
;
3873 /* Y's parent was x's parent. */
3875 y
->parent
= x
->parent
;
3877 /* Get the parent to point to y instead of x. */
3880 if (x
== x
->parent
->left
)
3881 x
->parent
->left
= y
;
3883 x
->parent
->right
= y
;
3888 /* Put x on y's left. */
3902 mem_rotate_right (struct mem_node
*x
)
3904 struct mem_node
*y
= x
->left
;
3907 if (y
->right
!= MEM_NIL
)
3908 y
->right
->parent
= x
;
3911 y
->parent
= x
->parent
;
3914 if (x
== x
->parent
->right
)
3915 x
->parent
->right
= y
;
3917 x
->parent
->left
= y
;
3928 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3931 mem_delete (struct mem_node
*z
)
3933 struct mem_node
*x
, *y
;
3935 if (!z
|| z
== MEM_NIL
)
3938 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3943 while (y
->left
!= MEM_NIL
)
3947 if (y
->left
!= MEM_NIL
)
3952 x
->parent
= y
->parent
;
3955 if (y
== y
->parent
->left
)
3956 y
->parent
->left
= x
;
3958 y
->parent
->right
= x
;
3965 z
->start
= y
->start
;
3970 if (y
->color
== MEM_BLACK
)
3971 mem_delete_fixup (x
);
3973 #ifdef GC_MALLOC_CHECK
3981 /* Re-establish the red-black properties of the tree, after a
3985 mem_delete_fixup (struct mem_node
*x
)
3987 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3989 if (x
== x
->parent
->left
)
3991 struct mem_node
*w
= x
->parent
->right
;
3993 if (w
->color
== MEM_RED
)
3995 w
->color
= MEM_BLACK
;
3996 x
->parent
->color
= MEM_RED
;
3997 mem_rotate_left (x
->parent
);
3998 w
= x
->parent
->right
;
4001 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4008 if (w
->right
->color
== MEM_BLACK
)
4010 w
->left
->color
= MEM_BLACK
;
4012 mem_rotate_right (w
);
4013 w
= x
->parent
->right
;
4015 w
->color
= x
->parent
->color
;
4016 x
->parent
->color
= MEM_BLACK
;
4017 w
->right
->color
= MEM_BLACK
;
4018 mem_rotate_left (x
->parent
);
4024 struct mem_node
*w
= x
->parent
->left
;
4026 if (w
->color
== MEM_RED
)
4028 w
->color
= MEM_BLACK
;
4029 x
->parent
->color
= MEM_RED
;
4030 mem_rotate_right (x
->parent
);
4031 w
= x
->parent
->left
;
4034 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4041 if (w
->left
->color
== MEM_BLACK
)
4043 w
->right
->color
= MEM_BLACK
;
4045 mem_rotate_left (w
);
4046 w
= x
->parent
->left
;
4049 w
->color
= x
->parent
->color
;
4050 x
->parent
->color
= MEM_BLACK
;
4051 w
->left
->color
= MEM_BLACK
;
4052 mem_rotate_right (x
->parent
);
4058 x
->color
= MEM_BLACK
;
4062 /* Value is non-zero if P is a pointer to a live Lisp string on
4063 the heap. M is a pointer to the mem_block for P. */
4066 live_string_p (struct mem_node
*m
, void *p
)
4068 if (m
->type
== MEM_TYPE_STRING
)
4070 struct string_block
*b
= m
->start
;
4071 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4073 /* P must point to the start of a Lisp_String structure, and it
4074 must not be on the free-list. */
4076 && offset
% sizeof b
->strings
[0] == 0
4077 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4078 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4085 /* Value is non-zero if P is a pointer to a live Lisp cons on
4086 the heap. M is a pointer to the mem_block for P. */
4089 live_cons_p (struct mem_node
*m
, void *p
)
4091 if (m
->type
== MEM_TYPE_CONS
)
4093 struct cons_block
*b
= m
->start
;
4094 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4096 /* P must point to the start of a Lisp_Cons, not be
4097 one of the unused cells in the current cons block,
4098 and not be on the free-list. */
4100 && offset
% sizeof b
->conses
[0] == 0
4101 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4103 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4104 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4111 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4112 the heap. M is a pointer to the mem_block for P. */
4115 live_symbol_p (struct mem_node
*m
, void *p
)
4117 if (m
->type
== MEM_TYPE_SYMBOL
)
4119 struct symbol_block
*b
= m
->start
;
4120 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4122 /* P must point to the start of a Lisp_Symbol, not be
4123 one of the unused cells in the current symbol block,
4124 and not be on the free-list. */
4126 && offset
% sizeof b
->symbols
[0] == 0
4127 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4128 && (b
!= symbol_block
4129 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4130 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4137 /* Value is non-zero if P is a pointer to a live Lisp float on
4138 the heap. M is a pointer to the mem_block for P. */
4141 live_float_p (struct mem_node
*m
, void *p
)
4143 if (m
->type
== MEM_TYPE_FLOAT
)
4145 struct float_block
*b
= m
->start
;
4146 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4148 /* P must point to the start of a Lisp_Float and not be
4149 one of the unused cells in the current float block. */
4151 && offset
% sizeof b
->floats
[0] == 0
4152 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4153 && (b
!= float_block
4154 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4161 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4162 the heap. M is a pointer to the mem_block for P. */
4165 live_misc_p (struct mem_node
*m
, void *p
)
4167 if (m
->type
== MEM_TYPE_MISC
)
4169 struct marker_block
*b
= m
->start
;
4170 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4172 /* P must point to the start of a Lisp_Misc, not be
4173 one of the unused cells in the current misc block,
4174 and not be on the free-list. */
4176 && offset
% sizeof b
->markers
[0] == 0
4177 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4178 && (b
!= marker_block
4179 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4180 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4187 /* Value is non-zero if P is a pointer to a live vector-like object.
4188 M is a pointer to the mem_block for P. */
4191 live_vector_p (struct mem_node
*m
, void *p
)
4193 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4195 /* This memory node corresponds to a vector block. */
4196 struct vector_block
*block
= m
->start
;
4197 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4199 /* P is in the block's allocation range. Scan the block
4200 up to P and see whether P points to the start of some
4201 vector which is not on a free list. FIXME: check whether
4202 some allocation patterns (probably a lot of short vectors)
4203 may cause a substantial overhead of this loop. */
4204 while (VECTOR_IN_BLOCK (vector
, block
)
4205 && vector
<= (struct Lisp_Vector
*) p
)
4207 if (!PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
) && vector
== p
)
4210 vector
= ADVANCE (vector
, vector_nbytes (vector
));
4213 else if (m
->type
== MEM_TYPE_VECTORLIKE
4214 && (char *) p
== ((char *) m
->start
4215 + offsetof (struct large_vector
, v
)))
4216 /* This memory node corresponds to a large vector. */
4222 /* Value is non-zero if P is a pointer to a live buffer. M is a
4223 pointer to the mem_block for P. */
4226 live_buffer_p (struct mem_node
*m
, void *p
)
4228 /* P must point to the start of the block, and the buffer
4229 must not have been killed. */
4230 return (m
->type
== MEM_TYPE_BUFFER
4232 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4235 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4239 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4241 /* Array of objects that are kept alive because the C stack contains
4242 a pattern that looks like a reference to them . */
4244 #define MAX_ZOMBIES 10
4245 static Lisp_Object zombies
[MAX_ZOMBIES
];
4247 /* Number of zombie objects. */
4249 static EMACS_INT nzombies
;
4251 /* Number of garbage collections. */
4253 static EMACS_INT ngcs
;
4255 /* Average percentage of zombies per collection. */
4257 static double avg_zombies
;
4259 /* Max. number of live and zombie objects. */
4261 static EMACS_INT max_live
, max_zombies
;
4263 /* Average number of live objects per GC. */
4265 static double avg_live
;
4267 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4268 doc
: /* Show information about live and zombie objects. */)
4271 Lisp_Object args
[8], zombie_list
= Qnil
;
4273 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4274 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4275 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4276 args
[1] = make_number (ngcs
);
4277 args
[2] = make_float (avg_live
);
4278 args
[3] = make_float (avg_zombies
);
4279 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4280 args
[5] = make_number (max_live
);
4281 args
[6] = make_number (max_zombies
);
4282 args
[7] = zombie_list
;
4283 return Fmessage (8, args
);
4286 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4289 /* Mark OBJ if we can prove it's a Lisp_Object. */
4292 mark_maybe_object (Lisp_Object obj
)
4300 po
= (void *) XPNTR (obj
);
4307 switch (XTYPE (obj
))
4310 mark_p
= (live_string_p (m
, po
)
4311 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4315 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4319 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4323 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4326 case Lisp_Vectorlike
:
4327 /* Note: can't check BUFFERP before we know it's a
4328 buffer because checking that dereferences the pointer
4329 PO which might point anywhere. */
4330 if (live_vector_p (m
, po
))
4331 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4332 else if (live_buffer_p (m
, po
))
4333 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4337 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4346 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4347 if (nzombies
< MAX_ZOMBIES
)
4348 zombies
[nzombies
] = obj
;
4357 /* If P points to Lisp data, mark that as live if it isn't already
4361 mark_maybe_pointer (void *p
)
4365 /* Quickly rule out some values which can't point to Lisp data.
4366 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4367 Otherwise, assume that Lisp data is aligned on even addresses. */
4368 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4374 Lisp_Object obj
= Qnil
;
4378 case MEM_TYPE_NON_LISP
:
4379 case MEM_TYPE_SPARE
:
4380 /* Nothing to do; not a pointer to Lisp memory. */
4383 case MEM_TYPE_BUFFER
:
4384 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4385 XSETVECTOR (obj
, p
);
4389 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4393 case MEM_TYPE_STRING
:
4394 if (live_string_p (m
, p
)
4395 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4396 XSETSTRING (obj
, p
);
4400 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4404 case MEM_TYPE_SYMBOL
:
4405 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4406 XSETSYMBOL (obj
, p
);
4409 case MEM_TYPE_FLOAT
:
4410 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4414 case MEM_TYPE_VECTORLIKE
:
4415 case MEM_TYPE_VECTOR_BLOCK
:
4416 if (live_vector_p (m
, p
))
4419 XSETVECTOR (tem
, p
);
4420 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4435 /* Alignment of pointer values. Use alignof, as it sometimes returns
4436 a smaller alignment than GCC's __alignof__ and mark_memory might
4437 miss objects if __alignof__ were used. */
4438 #define GC_POINTER_ALIGNMENT alignof (void *)
4440 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4441 not suffice, which is the typical case. A host where a Lisp_Object is
4442 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4443 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4444 suffice to widen it to to a Lisp_Object and check it that way. */
4445 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4446 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4447 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4448 nor mark_maybe_object can follow the pointers. This should not occur on
4449 any practical porting target. */
4450 # error "MSB type bits straddle pointer-word boundaries"
4452 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4453 pointer words that hold pointers ORed with type bits. */
4454 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4456 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4457 words that hold unmodified pointers. */
4458 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4461 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4462 or END+OFFSET..START. */
4465 mark_memory (void *start
, void *end
)
4466 #if defined (__clang__) && defined (__has_feature)
4467 #if __has_feature(address_sanitizer)
4468 /* Do not allow -faddress-sanitizer to check this function, since it
4469 crosses the function stack boundary, and thus would yield many
4471 __attribute__((no_address_safety_analysis
))
4478 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4482 /* Make START the pointer to the start of the memory region,
4483 if it isn't already. */
4491 /* Mark Lisp data pointed to. This is necessary because, in some
4492 situations, the C compiler optimizes Lisp objects away, so that
4493 only a pointer to them remains. Example:
4495 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4498 Lisp_Object obj = build_string ("test");
4499 struct Lisp_String *s = XSTRING (obj);
4500 Fgarbage_collect ();
4501 fprintf (stderr, "test `%s'\n", s->data);
4505 Here, `obj' isn't really used, and the compiler optimizes it
4506 away. The only reference to the life string is through the
4509 for (pp
= start
; (void *) pp
< end
; pp
++)
4510 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4512 void *p
= *(void **) ((char *) pp
+ i
);
4513 mark_maybe_pointer (p
);
4514 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4515 mark_maybe_object (XIL ((intptr_t) p
));
4519 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4521 static bool setjmp_tested_p
;
4522 static int longjmps_done
;
4524 #define SETJMP_WILL_LIKELY_WORK "\
4526 Emacs garbage collector has been changed to use conservative stack\n\
4527 marking. Emacs has determined that the method it uses to do the\n\
4528 marking will likely work on your system, but this isn't sure.\n\
4530 If you are a system-programmer, or can get the help of a local wizard\n\
4531 who is, please take a look at the function mark_stack in alloc.c, and\n\
4532 verify that the methods used are appropriate for your system.\n\
4534 Please mail the result to <emacs-devel@gnu.org>.\n\
4537 #define SETJMP_WILL_NOT_WORK "\
4539 Emacs garbage collector has been changed to use conservative stack\n\
4540 marking. Emacs has determined that the default method it uses to do the\n\
4541 marking will not work on your system. We will need a system-dependent\n\
4542 solution for your system.\n\
4544 Please take a look at the function mark_stack in alloc.c, and\n\
4545 try to find a way to make it work on your system.\n\
4547 Note that you may get false negatives, depending on the compiler.\n\
4548 In particular, you need to use -O with GCC for this test.\n\
4550 Please mail the result to <emacs-devel@gnu.org>.\n\
4554 /* Perform a quick check if it looks like setjmp saves registers in a
4555 jmp_buf. Print a message to stderr saying so. When this test
4556 succeeds, this is _not_ a proof that setjmp is sufficient for
4557 conservative stack marking. Only the sources or a disassembly
4567 /* Arrange for X to be put in a register. */
4573 if (longjmps_done
== 1)
4575 /* Came here after the longjmp at the end of the function.
4577 If x == 1, the longjmp has restored the register to its
4578 value before the setjmp, and we can hope that setjmp
4579 saves all such registers in the jmp_buf, although that
4582 For other values of X, either something really strange is
4583 taking place, or the setjmp just didn't save the register. */
4586 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4589 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4596 if (longjmps_done
== 1)
4597 sys_longjmp (jbuf
, 1);
4600 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4603 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4605 /* Abort if anything GCPRO'd doesn't survive the GC. */
4613 for (p
= gcprolist
; p
; p
= p
->next
)
4614 for (i
= 0; i
< p
->nvars
; ++i
)
4615 if (!survives_gc_p (p
->var
[i
]))
4616 /* FIXME: It's not necessarily a bug. It might just be that the
4617 GCPRO is unnecessary or should release the object sooner. */
4621 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4628 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4629 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4631 fprintf (stderr
, " %d = ", i
);
4632 debug_print (zombies
[i
]);
4636 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4639 /* Mark live Lisp objects on the C stack.
4641 There are several system-dependent problems to consider when
4642 porting this to new architectures:
4646 We have to mark Lisp objects in CPU registers that can hold local
4647 variables or are used to pass parameters.
4649 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4650 something that either saves relevant registers on the stack, or
4651 calls mark_maybe_object passing it each register's contents.
4653 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4654 implementation assumes that calling setjmp saves registers we need
4655 to see in a jmp_buf which itself lies on the stack. This doesn't
4656 have to be true! It must be verified for each system, possibly
4657 by taking a look at the source code of setjmp.
4659 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4660 can use it as a machine independent method to store all registers
4661 to the stack. In this case the macros described in the previous
4662 two paragraphs are not used.
4666 Architectures differ in the way their processor stack is organized.
4667 For example, the stack might look like this
4670 | Lisp_Object | size = 4
4672 | something else | size = 2
4674 | Lisp_Object | size = 4
4678 In such a case, not every Lisp_Object will be aligned equally. To
4679 find all Lisp_Object on the stack it won't be sufficient to walk
4680 the stack in steps of 4 bytes. Instead, two passes will be
4681 necessary, one starting at the start of the stack, and a second
4682 pass starting at the start of the stack + 2. Likewise, if the
4683 minimal alignment of Lisp_Objects on the stack is 1, four passes
4684 would be necessary, each one starting with one byte more offset
4685 from the stack start. */
4692 #ifdef HAVE___BUILTIN_UNWIND_INIT
4693 /* Force callee-saved registers and register windows onto the stack.
4694 This is the preferred method if available, obviating the need for
4695 machine dependent methods. */
4696 __builtin_unwind_init ();
4698 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4699 #ifndef GC_SAVE_REGISTERS_ON_STACK
4700 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4701 union aligned_jmpbuf
{
4705 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4707 /* This trick flushes the register windows so that all the state of
4708 the process is contained in the stack. */
4709 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4710 needed on ia64 too. See mach_dep.c, where it also says inline
4711 assembler doesn't work with relevant proprietary compilers. */
4713 #if defined (__sparc64__) && defined (__FreeBSD__)
4714 /* FreeBSD does not have a ta 3 handler. */
4721 /* Save registers that we need to see on the stack. We need to see
4722 registers used to hold register variables and registers used to
4724 #ifdef GC_SAVE_REGISTERS_ON_STACK
4725 GC_SAVE_REGISTERS_ON_STACK (end
);
4726 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4728 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4729 setjmp will definitely work, test it
4730 and print a message with the result
4732 if (!setjmp_tested_p
)
4734 setjmp_tested_p
= 1;
4737 #endif /* GC_SETJMP_WORKS */
4740 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4741 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4742 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4744 /* This assumes that the stack is a contiguous region in memory. If
4745 that's not the case, something has to be done here to iterate
4746 over the stack segments. */
4747 mark_memory (stack_base
, end
);
4749 /* Allow for marking a secondary stack, like the register stack on the
4751 #ifdef GC_MARK_SECONDARY_STACK
4752 GC_MARK_SECONDARY_STACK ();
4755 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4760 #endif /* GC_MARK_STACK != 0 */
4763 /* Determine whether it is safe to access memory at address P. */
4765 valid_pointer_p (void *p
)
4768 return w32_valid_pointer_p (p
, 16);
4772 /* Obviously, we cannot just access it (we would SEGV trying), so we
4773 trick the o/s to tell us whether p is a valid pointer.
4774 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4775 not validate p in that case. */
4777 if (emacs_pipe (fd
) == 0)
4779 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4780 emacs_close (fd
[1]);
4781 emacs_close (fd
[0]);
4789 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4790 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4791 cannot validate OBJ. This function can be quite slow, so its primary
4792 use is the manual debugging. The only exception is print_object, where
4793 we use it to check whether the memory referenced by the pointer of
4794 Lisp_Save_Value object contains valid objects. */
4797 valid_lisp_object_p (Lisp_Object obj
)
4807 p
= (void *) XPNTR (obj
);
4808 if (PURE_POINTER_P (p
))
4811 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
4815 return valid_pointer_p (p
);
4822 int valid
= valid_pointer_p (p
);
4834 case MEM_TYPE_NON_LISP
:
4835 case MEM_TYPE_SPARE
:
4838 case MEM_TYPE_BUFFER
:
4839 return live_buffer_p (m
, p
) ? 1 : 2;
4842 return live_cons_p (m
, p
);
4844 case MEM_TYPE_STRING
:
4845 return live_string_p (m
, p
);
4848 return live_misc_p (m
, p
);
4850 case MEM_TYPE_SYMBOL
:
4851 return live_symbol_p (m
, p
);
4853 case MEM_TYPE_FLOAT
:
4854 return live_float_p (m
, p
);
4856 case MEM_TYPE_VECTORLIKE
:
4857 case MEM_TYPE_VECTOR_BLOCK
:
4858 return live_vector_p (m
, p
);
4871 /***********************************************************************
4872 Pure Storage Management
4873 ***********************************************************************/
4875 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4876 pointer to it. TYPE is the Lisp type for which the memory is
4877 allocated. TYPE < 0 means it's not used for a Lisp object. */
4880 pure_alloc (size_t size
, int type
)
4884 size_t alignment
= GCALIGNMENT
;
4886 size_t alignment
= alignof (EMACS_INT
);
4888 /* Give Lisp_Floats an extra alignment. */
4889 if (type
== Lisp_Float
)
4890 alignment
= alignof (struct Lisp_Float
);
4896 /* Allocate space for a Lisp object from the beginning of the free
4897 space with taking account of alignment. */
4898 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4899 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4903 /* Allocate space for a non-Lisp object from the end of the free
4905 pure_bytes_used_non_lisp
+= size
;
4906 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4908 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4910 if (pure_bytes_used
<= pure_size
)
4913 /* Don't allocate a large amount here,
4914 because it might get mmap'd and then its address
4915 might not be usable. */
4916 purebeg
= xmalloc (10000);
4918 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4919 pure_bytes_used
= 0;
4920 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4925 /* Print a warning if PURESIZE is too small. */
4928 check_pure_size (void)
4930 if (pure_bytes_used_before_overflow
)
4931 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4933 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4937 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4938 the non-Lisp data pool of the pure storage, and return its start
4939 address. Return NULL if not found. */
4942 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4945 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4946 const unsigned char *p
;
4949 if (pure_bytes_used_non_lisp
<= nbytes
)
4952 /* Set up the Boyer-Moore table. */
4954 for (i
= 0; i
< 256; i
++)
4957 p
= (const unsigned char *) data
;
4959 bm_skip
[*p
++] = skip
;
4961 last_char_skip
= bm_skip
['\0'];
4963 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4964 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4966 /* See the comments in the function `boyer_moore' (search.c) for the
4967 use of `infinity'. */
4968 infinity
= pure_bytes_used_non_lisp
+ 1;
4969 bm_skip
['\0'] = infinity
;
4971 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4975 /* Check the last character (== '\0'). */
4978 start
+= bm_skip
[*(p
+ start
)];
4980 while (start
<= start_max
);
4982 if (start
< infinity
)
4983 /* Couldn't find the last character. */
4986 /* No less than `infinity' means we could find the last
4987 character at `p[start - infinity]'. */
4990 /* Check the remaining characters. */
4991 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4993 return non_lisp_beg
+ start
;
4995 start
+= last_char_skip
;
4997 while (start
<= start_max
);
5003 /* Return a string allocated in pure space. DATA is a buffer holding
5004 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5005 means make the result string multibyte.
5007 Must get an error if pure storage is full, since if it cannot hold
5008 a large string it may be able to hold conses that point to that
5009 string; then the string is not protected from gc. */
5012 make_pure_string (const char *data
,
5013 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5016 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5017 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5018 if (s
->data
== NULL
)
5020 s
->data
= pure_alloc (nbytes
+ 1, -1);
5021 memcpy (s
->data
, data
, nbytes
);
5022 s
->data
[nbytes
] = '\0';
5025 s
->size_byte
= multibyte
? nbytes
: -1;
5026 s
->intervals
= NULL
;
5027 XSETSTRING (string
, s
);
5031 /* Return a string allocated in pure space. Do not
5032 allocate the string data, just point to DATA. */
5035 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5038 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5041 s
->data
= (unsigned char *) data
;
5042 s
->intervals
= NULL
;
5043 XSETSTRING (string
, s
);
5047 /* Return a cons allocated from pure space. Give it pure copies
5048 of CAR as car and CDR as cdr. */
5051 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5054 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5056 XSETCAR (new, Fpurecopy (car
));
5057 XSETCDR (new, Fpurecopy (cdr
));
5062 /* Value is a float object with value NUM allocated from pure space. */
5065 make_pure_float (double num
)
5068 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5070 XFLOAT_INIT (new, num
);
5075 /* Return a vector with room for LEN Lisp_Objects allocated from
5079 make_pure_vector (ptrdiff_t len
)
5082 size_t size
= header_size
+ len
* word_size
;
5083 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5084 XSETVECTOR (new, p
);
5085 XVECTOR (new)->header
.size
= len
;
5090 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5091 doc
: /* Make a copy of object OBJ in pure storage.
5092 Recursively copies contents of vectors and cons cells.
5093 Does not copy symbols. Copies strings without text properties. */)
5094 (register Lisp_Object obj
)
5096 if (NILP (Vpurify_flag
))
5099 if (PURE_POINTER_P (XPNTR (obj
)))
5102 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5104 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5110 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5111 else if (FLOATP (obj
))
5112 obj
= make_pure_float (XFLOAT_DATA (obj
));
5113 else if (STRINGP (obj
))
5114 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5116 STRING_MULTIBYTE (obj
));
5117 else if (COMPILEDP (obj
) || VECTORP (obj
))
5119 register struct Lisp_Vector
*vec
;
5120 register ptrdiff_t i
;
5124 if (size
& PSEUDOVECTOR_FLAG
)
5125 size
&= PSEUDOVECTOR_SIZE_MASK
;
5126 vec
= XVECTOR (make_pure_vector (size
));
5127 for (i
= 0; i
< size
; i
++)
5128 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5129 if (COMPILEDP (obj
))
5131 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5132 XSETCOMPILED (obj
, vec
);
5135 XSETVECTOR (obj
, vec
);
5137 else if (MARKERP (obj
))
5138 error ("Attempt to copy a marker to pure storage");
5140 /* Not purified, don't hash-cons. */
5143 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5144 Fputhash (obj
, obj
, Vpurify_flag
);
5151 /***********************************************************************
5153 ***********************************************************************/
5155 /* Put an entry in staticvec, pointing at the variable with address
5159 staticpro (Lisp_Object
*varaddress
)
5161 if (staticidx
>= NSTATICS
)
5162 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5163 staticvec
[staticidx
++] = varaddress
;
5167 /***********************************************************************
5169 ***********************************************************************/
5171 /* Temporarily prevent garbage collection. */
5174 inhibit_garbage_collection (void)
5176 ptrdiff_t count
= SPECPDL_INDEX ();
5178 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5182 /* Used to avoid possible overflows when
5183 converting from C to Lisp integers. */
5186 bounded_number (EMACS_INT number
)
5188 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5191 /* Calculate total bytes of live objects. */
5194 total_bytes_of_live_objects (void)
5197 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5198 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5199 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5200 tot
+= total_string_bytes
;
5201 tot
+= total_vector_slots
* word_size
;
5202 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5203 tot
+= total_intervals
* sizeof (struct interval
);
5204 tot
+= total_strings
* sizeof (struct Lisp_String
);
5208 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5209 doc
: /* Reclaim storage for Lisp objects no longer needed.
5210 Garbage collection happens automatically if you cons more than
5211 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5212 `garbage-collect' normally returns a list with info on amount of space in use,
5213 where each entry has the form (NAME SIZE USED FREE), where:
5214 - NAME is a symbol describing the kind of objects this entry represents,
5215 - SIZE is the number of bytes used by each one,
5216 - USED is the number of those objects that were found live in the heap,
5217 - FREE is the number of those objects that are not live but that Emacs
5218 keeps around for future allocations (maybe because it does not know how
5219 to return them to the OS).
5220 However, if there was overflow in pure space, `garbage-collect'
5221 returns nil, because real GC can't be done.
5222 See Info node `(elisp)Garbage Collection'. */)
5225 struct buffer
*nextb
;
5226 char stack_top_variable
;
5229 ptrdiff_t count
= SPECPDL_INDEX ();
5231 Lisp_Object retval
= Qnil
;
5232 size_t tot_before
= 0;
5237 /* Can't GC if pure storage overflowed because we can't determine
5238 if something is a pure object or not. */
5239 if (pure_bytes_used_before_overflow
)
5242 /* Record this function, so it appears on the profiler's backtraces. */
5243 record_in_backtrace (Qautomatic_gc
, &Qnil
, 0);
5247 /* Don't keep undo information around forever.
5248 Do this early on, so it is no problem if the user quits. */
5249 FOR_EACH_BUFFER (nextb
)
5250 compact_buffer (nextb
);
5252 if (profiler_memory_running
)
5253 tot_before
= total_bytes_of_live_objects ();
5255 start
= current_emacs_time ();
5257 /* In case user calls debug_print during GC,
5258 don't let that cause a recursive GC. */
5259 consing_since_gc
= 0;
5261 /* Save what's currently displayed in the echo area. */
5262 message_p
= push_message ();
5263 record_unwind_protect_void (pop_message_unwind
);
5265 /* Save a copy of the contents of the stack, for debugging. */
5266 #if MAX_SAVE_STACK > 0
5267 if (NILP (Vpurify_flag
))
5270 ptrdiff_t stack_size
;
5271 if (&stack_top_variable
< stack_bottom
)
5273 stack
= &stack_top_variable
;
5274 stack_size
= stack_bottom
- &stack_top_variable
;
5278 stack
= stack_bottom
;
5279 stack_size
= &stack_top_variable
- stack_bottom
;
5281 if (stack_size
<= MAX_SAVE_STACK
)
5283 if (stack_copy_size
< stack_size
)
5285 stack_copy
= xrealloc (stack_copy
, stack_size
);
5286 stack_copy_size
= stack_size
;
5288 memcpy (stack_copy
, stack
, stack_size
);
5291 #endif /* MAX_SAVE_STACK > 0 */
5293 if (garbage_collection_messages
)
5294 message1_nolog ("Garbage collecting...");
5298 shrink_regexp_cache ();
5302 /* Mark all the special slots that serve as the roots of accessibility. */
5304 mark_buffer (&buffer_defaults
);
5305 mark_buffer (&buffer_local_symbols
);
5307 for (i
= 0; i
< staticidx
; i
++)
5308 mark_object (*staticvec
[i
]);
5318 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5319 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5323 register struct gcpro
*tail
;
5324 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5325 for (i
= 0; i
< tail
->nvars
; i
++)
5326 mark_object (tail
->var
[i
]);
5330 struct catchtag
*catch;
5331 struct handler
*handler
;
5333 for (catch = catchlist
; catch; catch = catch->next
)
5335 mark_object (catch->tag
);
5336 mark_object (catch->val
);
5338 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5340 mark_object (handler
->handler
);
5341 mark_object (handler
->var
);
5346 #ifdef HAVE_WINDOW_SYSTEM
5347 mark_fringe_data ();
5350 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5354 /* Everything is now marked, except for the things that require special
5355 finalization, i.e. the undo_list.
5356 Look thru every buffer's undo list
5357 for elements that update markers that were not marked,
5359 FOR_EACH_BUFFER (nextb
)
5361 /* If a buffer's undo list is Qt, that means that undo is
5362 turned off in that buffer. Calling truncate_undo_list on
5363 Qt tends to return NULL, which effectively turns undo back on.
5364 So don't call truncate_undo_list if undo_list is Qt. */
5365 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5367 Lisp_Object tail
, prev
;
5368 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5370 while (CONSP (tail
))
5372 if (CONSP (XCAR (tail
))
5373 && MARKERP (XCAR (XCAR (tail
)))
5374 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5377 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5381 XSETCDR (prev
, tail
);
5391 /* Now that we have stripped the elements that need not be in the
5392 undo_list any more, we can finally mark the list. */
5393 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5398 /* Clear the mark bits that we set in certain root slots. */
5400 unmark_byte_stack ();
5401 VECTOR_UNMARK (&buffer_defaults
);
5402 VECTOR_UNMARK (&buffer_local_symbols
);
5404 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5414 consing_since_gc
= 0;
5415 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5416 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5418 gc_relative_threshold
= 0;
5419 if (FLOATP (Vgc_cons_percentage
))
5420 { /* Set gc_cons_combined_threshold. */
5421 double tot
= total_bytes_of_live_objects ();
5423 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5426 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5427 gc_relative_threshold
= tot
;
5429 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5433 if (garbage_collection_messages
)
5435 if (message_p
|| minibuf_level
> 0)
5438 message1_nolog ("Garbage collecting...done");
5441 unbind_to (count
, Qnil
);
5443 Lisp_Object total
[11];
5444 int total_size
= 10;
5446 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5447 bounded_number (total_conses
),
5448 bounded_number (total_free_conses
));
5450 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5451 bounded_number (total_symbols
),
5452 bounded_number (total_free_symbols
));
5454 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5455 bounded_number (total_markers
),
5456 bounded_number (total_free_markers
));
5458 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5459 bounded_number (total_strings
),
5460 bounded_number (total_free_strings
));
5462 total
[4] = list3 (Qstring_bytes
, make_number (1),
5463 bounded_number (total_string_bytes
));
5465 total
[5] = list3 (Qvectors
,
5466 make_number (header_size
+ sizeof (Lisp_Object
)),
5467 bounded_number (total_vectors
));
5469 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5470 bounded_number (total_vector_slots
),
5471 bounded_number (total_free_vector_slots
));
5473 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5474 bounded_number (total_floats
),
5475 bounded_number (total_free_floats
));
5477 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5478 bounded_number (total_intervals
),
5479 bounded_number (total_free_intervals
));
5481 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5482 bounded_number (total_buffers
));
5484 #ifdef DOUG_LEA_MALLOC
5486 total
[10] = list4 (Qheap
, make_number (1024),
5487 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5488 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5490 retval
= Flist (total_size
, total
);
5493 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5495 /* Compute average percentage of zombies. */
5497 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5498 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5500 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5501 max_live
= max (nlive
, max_live
);
5502 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5503 max_zombies
= max (nzombies
, max_zombies
);
5508 if (!NILP (Vpost_gc_hook
))
5510 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5511 safe_run_hooks (Qpost_gc_hook
);
5512 unbind_to (gc_count
, Qnil
);
5515 /* Accumulate statistics. */
5516 if (FLOATP (Vgc_elapsed
))
5518 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5519 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5520 + EMACS_TIME_TO_DOUBLE (since_start
));
5525 /* Collect profiling data. */
5526 if (profiler_memory_running
)
5529 size_t tot_after
= total_bytes_of_live_objects ();
5530 if (tot_before
> tot_after
)
5531 swept
= tot_before
- tot_after
;
5532 malloc_probe (swept
);
5539 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5540 only interesting objects referenced from glyphs are strings. */
5543 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5545 struct glyph_row
*row
= matrix
->rows
;
5546 struct glyph_row
*end
= row
+ matrix
->nrows
;
5548 for (; row
< end
; ++row
)
5552 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5554 struct glyph
*glyph
= row
->glyphs
[area
];
5555 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5557 for (; glyph
< end_glyph
; ++glyph
)
5558 if (STRINGP (glyph
->object
)
5559 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5560 mark_object (glyph
->object
);
5566 /* Mark Lisp faces in the face cache C. */
5569 mark_face_cache (struct face_cache
*c
)
5574 for (i
= 0; i
< c
->used
; ++i
)
5576 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5580 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5581 mark_object (face
->lface
[j
]);
5589 /* Mark reference to a Lisp_Object.
5590 If the object referred to has not been seen yet, recursively mark
5591 all the references contained in it. */
5593 #define LAST_MARKED_SIZE 500
5594 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5595 static int last_marked_index
;
5597 /* For debugging--call abort when we cdr down this many
5598 links of a list, in mark_object. In debugging,
5599 the call to abort will hit a breakpoint.
5600 Normally this is zero and the check never goes off. */
5601 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5604 mark_vectorlike (struct Lisp_Vector
*ptr
)
5606 ptrdiff_t size
= ptr
->header
.size
;
5609 eassert (!VECTOR_MARKED_P (ptr
));
5610 VECTOR_MARK (ptr
); /* Else mark it. */
5611 if (size
& PSEUDOVECTOR_FLAG
)
5612 size
&= PSEUDOVECTOR_SIZE_MASK
;
5614 /* Note that this size is not the memory-footprint size, but only
5615 the number of Lisp_Object fields that we should trace.
5616 The distinction is used e.g. by Lisp_Process which places extra
5617 non-Lisp_Object fields at the end of the structure... */
5618 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5619 mark_object (ptr
->contents
[i
]);
5622 /* Like mark_vectorlike but optimized for char-tables (and
5623 sub-char-tables) assuming that the contents are mostly integers or
5627 mark_char_table (struct Lisp_Vector
*ptr
)
5629 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5632 eassert (!VECTOR_MARKED_P (ptr
));
5634 for (i
= 0; i
< size
; i
++)
5636 Lisp_Object val
= ptr
->contents
[i
];
5638 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5640 if (SUB_CHAR_TABLE_P (val
))
5642 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5643 mark_char_table (XVECTOR (val
));
5650 /* Mark the chain of overlays starting at PTR. */
5653 mark_overlay (struct Lisp_Overlay
*ptr
)
5655 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5658 mark_object (ptr
->start
);
5659 mark_object (ptr
->end
);
5660 mark_object (ptr
->plist
);
5664 /* Mark Lisp_Objects and special pointers in BUFFER. */
5667 mark_buffer (struct buffer
*buffer
)
5669 /* This is handled much like other pseudovectors... */
5670 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5672 /* ...but there are some buffer-specific things. */
5674 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5676 /* For now, we just don't mark the undo_list. It's done later in
5677 a special way just before the sweep phase, and after stripping
5678 some of its elements that are not needed any more. */
5680 mark_overlay (buffer
->overlays_before
);
5681 mark_overlay (buffer
->overlays_after
);
5683 /* If this is an indirect buffer, mark its base buffer. */
5684 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5685 mark_buffer (buffer
->base_buffer
);
5688 /* Remove killed buffers or items whose car is a killed buffer from
5689 LIST, and mark other items. Return changed LIST, which is marked. */
5692 mark_discard_killed_buffers (Lisp_Object list
)
5694 Lisp_Object tail
, *prev
= &list
;
5696 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5699 Lisp_Object tem
= XCAR (tail
);
5702 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5703 *prev
= XCDR (tail
);
5706 CONS_MARK (XCONS (tail
));
5707 mark_object (XCAR (tail
));
5708 prev
= xcdr_addr (tail
);
5715 /* Determine type of generic Lisp_Object and mark it accordingly. */
5718 mark_object (Lisp_Object arg
)
5720 register Lisp_Object obj
= arg
;
5721 #ifdef GC_CHECK_MARKED_OBJECTS
5725 ptrdiff_t cdr_count
= 0;
5729 if (PURE_POINTER_P (XPNTR (obj
)))
5732 last_marked
[last_marked_index
++] = obj
;
5733 if (last_marked_index
== LAST_MARKED_SIZE
)
5734 last_marked_index
= 0;
5736 /* Perform some sanity checks on the objects marked here. Abort if
5737 we encounter an object we know is bogus. This increases GC time
5738 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5739 #ifdef GC_CHECK_MARKED_OBJECTS
5741 po
= (void *) XPNTR (obj
);
5743 /* Check that the object pointed to by PO is known to be a Lisp
5744 structure allocated from the heap. */
5745 #define CHECK_ALLOCATED() \
5747 m = mem_find (po); \
5752 /* Check that the object pointed to by PO is live, using predicate
5754 #define CHECK_LIVE(LIVEP) \
5756 if (!LIVEP (m, po)) \
5760 /* Check both of the above conditions. */
5761 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5763 CHECK_ALLOCATED (); \
5764 CHECK_LIVE (LIVEP); \
5767 #else /* not GC_CHECK_MARKED_OBJECTS */
5769 #define CHECK_LIVE(LIVEP) (void) 0
5770 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5772 #endif /* not GC_CHECK_MARKED_OBJECTS */
5774 switch (XTYPE (obj
))
5778 register struct Lisp_String
*ptr
= XSTRING (obj
);
5779 if (STRING_MARKED_P (ptr
))
5781 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5783 MARK_INTERVAL_TREE (ptr
->intervals
);
5784 #ifdef GC_CHECK_STRING_BYTES
5785 /* Check that the string size recorded in the string is the
5786 same as the one recorded in the sdata structure. */
5788 #endif /* GC_CHECK_STRING_BYTES */
5792 case Lisp_Vectorlike
:
5794 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5795 register ptrdiff_t pvectype
;
5797 if (VECTOR_MARKED_P (ptr
))
5800 #ifdef GC_CHECK_MARKED_OBJECTS
5802 if (m
== MEM_NIL
&& !SUBRP (obj
))
5804 #endif /* GC_CHECK_MARKED_OBJECTS */
5806 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5807 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5808 >> PSEUDOVECTOR_AREA_BITS
);
5810 pvectype
= PVEC_NORMAL_VECTOR
;
5812 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5813 CHECK_LIVE (live_vector_p
);
5818 #ifdef GC_CHECK_MARKED_OBJECTS
5827 #endif /* GC_CHECK_MARKED_OBJECTS */
5828 mark_buffer ((struct buffer
*) ptr
);
5832 { /* We could treat this just like a vector, but it is better
5833 to save the COMPILED_CONSTANTS element for last and avoid
5835 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5839 for (i
= 0; i
< size
; i
++)
5840 if (i
!= COMPILED_CONSTANTS
)
5841 mark_object (ptr
->contents
[i
]);
5842 if (size
> COMPILED_CONSTANTS
)
5844 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5851 mark_vectorlike (ptr
);
5852 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
5857 struct window
*w
= (struct window
*) ptr
;
5859 mark_vectorlike (ptr
);
5861 /* Mark glyph matrices, if any. Marking window
5862 matrices is sufficient because frame matrices
5863 use the same glyph memory. */
5864 if (w
->current_matrix
)
5866 mark_glyph_matrix (w
->current_matrix
);
5867 mark_glyph_matrix (w
->desired_matrix
);
5870 /* Filter out killed buffers from both buffer lists
5871 in attempt to help GC to reclaim killed buffers faster.
5872 We can do it elsewhere for live windows, but this is the
5873 best place to do it for dead windows. */
5875 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
5877 (w
, mark_discard_killed_buffers (w
->next_buffers
));
5881 case PVEC_HASH_TABLE
:
5883 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
5885 mark_vectorlike (ptr
);
5886 mark_object (h
->test
.name
);
5887 mark_object (h
->test
.user_hash_function
);
5888 mark_object (h
->test
.user_cmp_function
);
5889 /* If hash table is not weak, mark all keys and values.
5890 For weak tables, mark only the vector. */
5892 mark_object (h
->key_and_value
);
5894 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5898 case PVEC_CHAR_TABLE
:
5899 mark_char_table (ptr
);
5902 case PVEC_BOOL_VECTOR
:
5903 /* No Lisp_Objects to mark in a bool vector. */
5914 mark_vectorlike (ptr
);
5921 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5922 struct Lisp_Symbol
*ptrx
;
5926 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5928 mark_object (ptr
->function
);
5929 mark_object (ptr
->plist
);
5930 switch (ptr
->redirect
)
5932 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5933 case SYMBOL_VARALIAS
:
5936 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5940 case SYMBOL_LOCALIZED
:
5942 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5943 Lisp_Object where
= blv
->where
;
5944 /* If the value is set up for a killed buffer or deleted
5945 frame, restore it's global binding. If the value is
5946 forwarded to a C variable, either it's not a Lisp_Object
5947 var, or it's staticpro'd already. */
5948 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
5949 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
5950 swap_in_global_binding (ptr
);
5951 mark_object (blv
->where
);
5952 mark_object (blv
->valcell
);
5953 mark_object (blv
->defcell
);
5956 case SYMBOL_FORWARDED
:
5957 /* If the value is forwarded to a buffer or keyboard field,
5958 these are marked when we see the corresponding object.
5959 And if it's forwarded to a C variable, either it's not
5960 a Lisp_Object var, or it's staticpro'd already. */
5962 default: emacs_abort ();
5964 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
5965 MARK_STRING (XSTRING (ptr
->name
));
5966 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
5971 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
5972 XSETSYMBOL (obj
, ptrx
);
5979 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5981 if (XMISCANY (obj
)->gcmarkbit
)
5984 switch (XMISCTYPE (obj
))
5986 case Lisp_Misc_Marker
:
5987 /* DO NOT mark thru the marker's chain.
5988 The buffer's markers chain does not preserve markers from gc;
5989 instead, markers are removed from the chain when freed by gc. */
5990 XMISCANY (obj
)->gcmarkbit
= 1;
5993 case Lisp_Misc_Save_Value
:
5994 XMISCANY (obj
)->gcmarkbit
= 1;
5996 struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5997 /* If `save_type' is zero, `data[0].pointer' is the address
5998 of a memory area containing `data[1].integer' potential
6000 if (GC_MARK_STACK
&& ptr
->save_type
== SAVE_TYPE_MEMORY
)
6002 Lisp_Object
*p
= ptr
->data
[0].pointer
;
6004 for (nelt
= ptr
->data
[1].integer
; nelt
> 0; nelt
--, p
++)
6005 mark_maybe_object (*p
);
6009 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6011 for (i
= 0; i
< SAVE_VALUE_SLOTS
; i
++)
6012 if (save_type (ptr
, i
) == SAVE_OBJECT
)
6013 mark_object (ptr
->data
[i
].object
);
6018 case Lisp_Misc_Overlay
:
6019 mark_overlay (XOVERLAY (obj
));
6029 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6030 if (CONS_MARKED_P (ptr
))
6032 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6034 /* If the cdr is nil, avoid recursion for the car. */
6035 if (EQ (ptr
->u
.cdr
, Qnil
))
6041 mark_object (ptr
->car
);
6044 if (cdr_count
== mark_object_loop_halt
)
6050 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6051 FLOAT_MARK (XFLOAT (obj
));
6062 #undef CHECK_ALLOCATED
6063 #undef CHECK_ALLOCATED_AND_LIVE
6065 /* Mark the Lisp pointers in the terminal objects.
6066 Called by Fgarbage_collect. */
6069 mark_terminals (void)
6072 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6074 eassert (t
->name
!= NULL
);
6075 #ifdef HAVE_WINDOW_SYSTEM
6076 /* If a terminal object is reachable from a stacpro'ed object,
6077 it might have been marked already. Make sure the image cache
6079 mark_image_cache (t
->image_cache
);
6080 #endif /* HAVE_WINDOW_SYSTEM */
6081 if (!VECTOR_MARKED_P (t
))
6082 mark_vectorlike ((struct Lisp_Vector
*)t
);
6088 /* Value is non-zero if OBJ will survive the current GC because it's
6089 either marked or does not need to be marked to survive. */
6092 survives_gc_p (Lisp_Object obj
)
6096 switch (XTYPE (obj
))
6103 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6107 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6111 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6114 case Lisp_Vectorlike
:
6115 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6119 survives_p
= CONS_MARKED_P (XCONS (obj
));
6123 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6130 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6135 /* Sweep: find all structures not marked, and free them. */
6140 /* Remove or mark entries in weak hash tables.
6141 This must be done before any object is unmarked. */
6142 sweep_weak_hash_tables ();
6145 check_string_bytes (!noninteractive
);
6147 /* Put all unmarked conses on free list */
6149 register struct cons_block
*cblk
;
6150 struct cons_block
**cprev
= &cons_block
;
6151 register int lim
= cons_block_index
;
6152 EMACS_INT num_free
= 0, num_used
= 0;
6156 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6160 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6162 /* Scan the mark bits an int at a time. */
6163 for (i
= 0; i
< ilim
; i
++)
6165 if (cblk
->gcmarkbits
[i
] == -1)
6167 /* Fast path - all cons cells for this int are marked. */
6168 cblk
->gcmarkbits
[i
] = 0;
6169 num_used
+= BITS_PER_INT
;
6173 /* Some cons cells for this int are not marked.
6174 Find which ones, and free them. */
6175 int start
, pos
, stop
;
6177 start
= i
* BITS_PER_INT
;
6179 if (stop
> BITS_PER_INT
)
6180 stop
= BITS_PER_INT
;
6183 for (pos
= start
; pos
< stop
; pos
++)
6185 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6188 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6189 cons_free_list
= &cblk
->conses
[pos
];
6191 cons_free_list
->car
= Vdead
;
6197 CONS_UNMARK (&cblk
->conses
[pos
]);
6203 lim
= CONS_BLOCK_SIZE
;
6204 /* If this block contains only free conses and we have already
6205 seen more than two blocks worth of free conses then deallocate
6207 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6209 *cprev
= cblk
->next
;
6210 /* Unhook from the free list. */
6211 cons_free_list
= cblk
->conses
[0].u
.chain
;
6212 lisp_align_free (cblk
);
6216 num_free
+= this_free
;
6217 cprev
= &cblk
->next
;
6220 total_conses
= num_used
;
6221 total_free_conses
= num_free
;
6224 /* Put all unmarked floats on free list */
6226 register struct float_block
*fblk
;
6227 struct float_block
**fprev
= &float_block
;
6228 register int lim
= float_block_index
;
6229 EMACS_INT num_free
= 0, num_used
= 0;
6231 float_free_list
= 0;
6233 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6237 for (i
= 0; i
< lim
; i
++)
6238 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6241 fblk
->floats
[i
].u
.chain
= float_free_list
;
6242 float_free_list
= &fblk
->floats
[i
];
6247 FLOAT_UNMARK (&fblk
->floats
[i
]);
6249 lim
= FLOAT_BLOCK_SIZE
;
6250 /* If this block contains only free floats and we have already
6251 seen more than two blocks worth of free floats then deallocate
6253 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6255 *fprev
= fblk
->next
;
6256 /* Unhook from the free list. */
6257 float_free_list
= fblk
->floats
[0].u
.chain
;
6258 lisp_align_free (fblk
);
6262 num_free
+= this_free
;
6263 fprev
= &fblk
->next
;
6266 total_floats
= num_used
;
6267 total_free_floats
= num_free
;
6270 /* Put all unmarked intervals on free list */
6272 register struct interval_block
*iblk
;
6273 struct interval_block
**iprev
= &interval_block
;
6274 register int lim
= interval_block_index
;
6275 EMACS_INT num_free
= 0, num_used
= 0;
6277 interval_free_list
= 0;
6279 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6284 for (i
= 0; i
< lim
; i
++)
6286 if (!iblk
->intervals
[i
].gcmarkbit
)
6288 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6289 interval_free_list
= &iblk
->intervals
[i
];
6295 iblk
->intervals
[i
].gcmarkbit
= 0;
6298 lim
= INTERVAL_BLOCK_SIZE
;
6299 /* If this block contains only free intervals and we have already
6300 seen more than two blocks worth of free intervals then
6301 deallocate this block. */
6302 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6304 *iprev
= iblk
->next
;
6305 /* Unhook from the free list. */
6306 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6311 num_free
+= this_free
;
6312 iprev
= &iblk
->next
;
6315 total_intervals
= num_used
;
6316 total_free_intervals
= num_free
;
6319 /* Put all unmarked symbols on free list */
6321 register struct symbol_block
*sblk
;
6322 struct symbol_block
**sprev
= &symbol_block
;
6323 register int lim
= symbol_block_index
;
6324 EMACS_INT num_free
= 0, num_used
= 0;
6326 symbol_free_list
= NULL
;
6328 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6331 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6332 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6334 for (; sym
< end
; ++sym
)
6336 /* Check if the symbol was created during loadup. In such a case
6337 it might be pointed to by pure bytecode which we don't trace,
6338 so we conservatively assume that it is live. */
6339 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6341 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6343 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6344 xfree (SYMBOL_BLV (&sym
->s
));
6345 sym
->s
.next
= symbol_free_list
;
6346 symbol_free_list
= &sym
->s
;
6348 symbol_free_list
->function
= Vdead
;
6356 UNMARK_STRING (XSTRING (sym
->s
.name
));
6357 sym
->s
.gcmarkbit
= 0;
6361 lim
= SYMBOL_BLOCK_SIZE
;
6362 /* If this block contains only free symbols and we have already
6363 seen more than two blocks worth of free symbols then deallocate
6365 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6367 *sprev
= sblk
->next
;
6368 /* Unhook from the free list. */
6369 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6374 num_free
+= this_free
;
6375 sprev
= &sblk
->next
;
6378 total_symbols
= num_used
;
6379 total_free_symbols
= num_free
;
6382 /* Put all unmarked misc's on free list.
6383 For a marker, first unchain it from the buffer it points into. */
6385 register struct marker_block
*mblk
;
6386 struct marker_block
**mprev
= &marker_block
;
6387 register int lim
= marker_block_index
;
6388 EMACS_INT num_free
= 0, num_used
= 0;
6390 marker_free_list
= 0;
6392 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6397 for (i
= 0; i
< lim
; i
++)
6399 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6401 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6402 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6403 /* Set the type of the freed object to Lisp_Misc_Free.
6404 We could leave the type alone, since nobody checks it,
6405 but this might catch bugs faster. */
6406 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6407 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6408 marker_free_list
= &mblk
->markers
[i
].m
;
6414 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6417 lim
= MARKER_BLOCK_SIZE
;
6418 /* If this block contains only free markers and we have already
6419 seen more than two blocks worth of free markers then deallocate
6421 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6423 *mprev
= mblk
->next
;
6424 /* Unhook from the free list. */
6425 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6430 num_free
+= this_free
;
6431 mprev
= &mblk
->next
;
6435 total_markers
= num_used
;
6436 total_free_markers
= num_free
;
6439 /* Free all unmarked buffers */
6441 register struct buffer
*buffer
, **bprev
= &all_buffers
;
6444 for (buffer
= all_buffers
; buffer
; buffer
= *bprev
)
6445 if (!VECTOR_MARKED_P (buffer
))
6447 *bprev
= buffer
->next
;
6452 VECTOR_UNMARK (buffer
);
6453 /* Do not use buffer_(set|get)_intervals here. */
6454 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6456 bprev
= &buffer
->next
;
6461 check_string_bytes (!noninteractive
);
6467 /* Debugging aids. */
6469 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6470 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6471 This may be helpful in debugging Emacs's memory usage.
6472 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6477 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6482 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6483 doc
: /* Return a list of counters that measure how much consing there has been.
6484 Each of these counters increments for a certain kind of object.
6485 The counters wrap around from the largest positive integer to zero.
6486 Garbage collection does not decrease them.
6487 The elements of the value are as follows:
6488 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6489 All are in units of 1 = one object consed
6490 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6492 MISCS include overlays, markers, and some internal types.
6493 Frames, windows, buffers, and subprocesses count as vectors
6494 (but the contents of a buffer's text do not count here). */)
6497 return listn (CONSTYPE_HEAP
, 8,
6498 bounded_number (cons_cells_consed
),
6499 bounded_number (floats_consed
),
6500 bounded_number (vector_cells_consed
),
6501 bounded_number (symbols_consed
),
6502 bounded_number (string_chars_consed
),
6503 bounded_number (misc_objects_consed
),
6504 bounded_number (intervals_consed
),
6505 bounded_number (strings_consed
));
6508 /* Find at most FIND_MAX symbols which have OBJ as their value or
6509 function. This is used in gdbinit's `xwhichsymbols' command. */
6512 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6514 struct symbol_block
*sblk
;
6515 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6516 Lisp_Object found
= Qnil
;
6520 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6522 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6525 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6527 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6531 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6534 XSETSYMBOL (tem
, sym
);
6535 val
= find_symbol_value (tem
);
6537 || EQ (sym
->function
, obj
)
6538 || (!NILP (sym
->function
)
6539 && COMPILEDP (sym
->function
)
6540 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6543 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6545 found
= Fcons (tem
, found
);
6546 if (--find_max
== 0)
6554 unbind_to (gc_count
, Qnil
);
6558 #ifdef ENABLE_CHECKING
6560 bool suppress_checking
;
6563 die (const char *msg
, const char *file
, int line
)
6565 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6567 terminate_due_to_signal (SIGABRT
, INT_MAX
);
6571 /* Initialization. */
6574 init_alloc_once (void)
6576 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6578 pure_size
= PURESIZE
;
6580 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6582 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6585 #ifdef DOUG_LEA_MALLOC
6586 mallopt (M_TRIM_THRESHOLD
, 128 * 1024); /* Trim threshold. */
6587 mallopt (M_MMAP_THRESHOLD
, 64 * 1024); /* Mmap threshold. */
6588 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* Max. number of mmap'ed areas. */
6593 refill_memory_reserve ();
6594 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6601 byte_stack_list
= 0;
6603 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6604 setjmp_tested_p
= longjmps_done
= 0;
6607 Vgc_elapsed
= make_float (0.0);
6612 syms_of_alloc (void)
6614 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6615 doc
: /* Number of bytes of consing between garbage collections.
6616 Garbage collection can happen automatically once this many bytes have been
6617 allocated since the last garbage collection. All data types count.
6619 Garbage collection happens automatically only when `eval' is called.
6621 By binding this temporarily to a large number, you can effectively
6622 prevent garbage collection during a part of the program.
6623 See also `gc-cons-percentage'. */);
6625 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6626 doc
: /* Portion of the heap used for allocation.
6627 Garbage collection can happen automatically once this portion of the heap
6628 has been allocated since the last garbage collection.
6629 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6630 Vgc_cons_percentage
= make_float (0.1);
6632 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6633 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6635 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6636 doc
: /* Number of cons cells that have been consed so far. */);
6638 DEFVAR_INT ("floats-consed", floats_consed
,
6639 doc
: /* Number of floats that have been consed so far. */);
6641 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6642 doc
: /* Number of vector cells that have been consed so far. */);
6644 DEFVAR_INT ("symbols-consed", symbols_consed
,
6645 doc
: /* Number of symbols that have been consed so far. */);
6647 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6648 doc
: /* Number of string characters that have been consed so far. */);
6650 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6651 doc
: /* Number of miscellaneous objects that have been consed so far.
6652 These include markers and overlays, plus certain objects not visible
6655 DEFVAR_INT ("intervals-consed", intervals_consed
,
6656 doc
: /* Number of intervals that have been consed so far. */);
6658 DEFVAR_INT ("strings-consed", strings_consed
,
6659 doc
: /* Number of strings that have been consed so far. */);
6661 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6662 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6663 This means that certain objects should be allocated in shared (pure) space.
6664 It can also be set to a hash-table, in which case this table is used to
6665 do hash-consing of the objects allocated to pure space. */);
6667 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6668 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6669 garbage_collection_messages
= 0;
6671 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6672 doc
: /* Hook run after garbage collection has finished. */);
6673 Vpost_gc_hook
= Qnil
;
6674 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6676 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6677 doc
: /* Precomputed `signal' argument for memory-full error. */);
6678 /* We build this in advance because if we wait until we need it, we might
6679 not be able to allocate the memory to hold it. */
6681 = listn (CONSTYPE_PURE
, 2, Qerror
,
6682 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6684 DEFVAR_LISP ("memory-full", Vmemory_full
,
6685 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6686 Vmemory_full
= Qnil
;
6688 DEFSYM (Qconses
, "conses");
6689 DEFSYM (Qsymbols
, "symbols");
6690 DEFSYM (Qmiscs
, "miscs");
6691 DEFSYM (Qstrings
, "strings");
6692 DEFSYM (Qvectors
, "vectors");
6693 DEFSYM (Qfloats
, "floats");
6694 DEFSYM (Qintervals
, "intervals");
6695 DEFSYM (Qbuffers
, "buffers");
6696 DEFSYM (Qstring_bytes
, "string-bytes");
6697 DEFSYM (Qvector_slots
, "vector-slots");
6698 DEFSYM (Qheap
, "heap");
6699 DEFSYM (Qautomatic_gc
, "Automatic GC");
6701 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6702 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6704 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6705 doc
: /* Accumulated time elapsed in garbage collections.
6706 The time is in seconds as a floating point value. */);
6707 DEFVAR_INT ("gcs-done", gcs_done
,
6708 doc
: /* Accumulated number of garbage collections done. */);
6713 defsubr (&Smake_byte_code
);
6714 defsubr (&Smake_list
);
6715 defsubr (&Smake_vector
);
6716 defsubr (&Smake_string
);
6717 defsubr (&Smake_bool_vector
);
6718 defsubr (&Smake_symbol
);
6719 defsubr (&Smake_marker
);
6720 defsubr (&Spurecopy
);
6721 defsubr (&Sgarbage_collect
);
6722 defsubr (&Smemory_limit
);
6723 defsubr (&Smemory_use_counts
);
6725 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6726 defsubr (&Sgc_status
);
6730 /* When compiled with GCC, GDB might say "No enum type named
6731 pvec_type" if we don't have at least one symbol with that type, and
6732 then xbacktrace could fail. Similarly for the other enums and
6733 their values. Some non-GCC compilers don't like these constructs. */
6737 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6738 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6739 enum char_bits char_bits
;
6740 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6741 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6742 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6743 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6744 enum Lisp_Bits Lisp_Bits
;
6745 enum Lisp_Compiled Lisp_Compiled
;
6746 enum maxargs maxargs
;
6747 enum MAX_ALLOCA MAX_ALLOCA
;
6748 enum More_Lisp_Bits More_Lisp_Bits
;
6749 enum pvec_type pvec_type
;
6750 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};
6751 #endif /* __GNUC__ */