1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4 Free Software Foundation, Inc.
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
79 #ifdef DOUG_LEA_MALLOC
83 /* Specify maximum number of areas to mmap. It would be nice to use a
84 value that explicitly means "no limit". */
86 #define MMAP_MAX_AREAS 100000000
88 #else /* not DOUG_LEA_MALLOC */
90 /* The following come from gmalloc.c. */
92 extern size_t _bytes_used
;
93 extern size_t __malloc_extra_blocks
;
94 extern void *_malloc_internal (size_t);
95 extern void _free_internal (void *);
97 #endif /* not DOUG_LEA_MALLOC */
99 #if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
102 # include "syssignal.h"
104 /* When GTK uses the file chooser dialog, different backends can be loaded
105 dynamically. One such a backend is the Gnome VFS backend that gets loaded
106 if you run Gnome. That backend creates several threads and also allocates
109 Also, gconf and gsettings may create several threads.
111 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
112 functions below are called from malloc, there is a chance that one
113 of these threads preempts the Emacs main thread and the hook variables
114 end up in an inconsistent state. So we have a mutex to prevent that (note
115 that the backend handles concurrent access to malloc within its own threads
116 but Emacs code running in the main thread is not included in that control).
118 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
119 happens in one of the backend threads we will have two threads that tries
120 to run Emacs code at once, and the code is not prepared for that.
121 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
123 static pthread_mutex_t alloc_mutex
;
125 #define BLOCK_INPUT_ALLOC \
128 if (pthread_equal (pthread_self (), main_thread)) \
130 pthread_mutex_lock (&alloc_mutex); \
133 #define UNBLOCK_INPUT_ALLOC \
136 pthread_mutex_unlock (&alloc_mutex); \
137 if (pthread_equal (pthread_self (), main_thread)) \
142 #else /* ! defined HAVE_PTHREAD */
144 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
145 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
147 #endif /* ! defined HAVE_PTHREAD */
148 #endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
150 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
151 to a struct Lisp_String. */
153 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
154 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
155 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
157 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
158 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
159 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
161 /* Default value of gc_cons_threshold (see below). */
163 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
165 /* Global variables. */
166 struct emacs_globals globals
;
168 /* Number of bytes of consing done since the last gc. */
170 EMACS_INT consing_since_gc
;
172 /* Similar minimum, computed from Vgc_cons_percentage. */
174 EMACS_INT gc_relative_threshold
;
176 /* Minimum number of bytes of consing since GC before next GC,
177 when memory is full. */
179 EMACS_INT memory_full_cons_threshold
;
181 /* True during GC. */
185 /* True means abort if try to GC.
186 This is for code which is written on the assumption that
187 no GC will happen, so as to verify that assumption. */
191 /* Number of live and free conses etc. */
193 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_buffers
;
194 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
195 static EMACS_INT total_free_floats
, total_floats
;
197 /* Points to memory space allocated as "spare", to be freed if we run
198 out of memory. We keep one large block, four cons-blocks, and
199 two string blocks. */
201 static char *spare_memory
[7];
203 /* Amount of spare memory to keep in large reserve block, or to see
204 whether this much is available when malloc fails on a larger request. */
206 #define SPARE_MEMORY (1 << 14)
208 /* Number of extra blocks malloc should get when it needs more core. */
210 static int malloc_hysteresis
;
212 /* Initialize it to a nonzero value to force it into data space
213 (rather than bss space). That way unexec will remap it into text
214 space (pure), on some systems. We have not implemented the
215 remapping on more recent systems because this is less important
216 nowadays than in the days of small memories and timesharing. */
218 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
219 #define PUREBEG (char *) pure
221 /* Pointer to the pure area, and its size. */
223 static char *purebeg
;
224 static ptrdiff_t pure_size
;
226 /* Number of bytes of pure storage used before pure storage overflowed.
227 If this is non-zero, this implies that an overflow occurred. */
229 static ptrdiff_t pure_bytes_used_before_overflow
;
231 /* True if P points into pure space. */
233 #define PURE_POINTER_P(P) \
234 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
236 /* Index in pure at which next pure Lisp object will be allocated.. */
238 static ptrdiff_t pure_bytes_used_lisp
;
240 /* Number of bytes allocated for non-Lisp objects in pure storage. */
242 static ptrdiff_t pure_bytes_used_non_lisp
;
244 /* If nonzero, this is a warning delivered by malloc and not yet
247 const char *pending_malloc_warning
;
249 /* Maximum amount of C stack to save when a GC happens. */
251 #ifndef MAX_SAVE_STACK
252 #define MAX_SAVE_STACK 16000
255 /* Buffer in which we save a copy of the C stack at each GC. */
257 #if MAX_SAVE_STACK > 0
258 static char *stack_copy
;
259 static ptrdiff_t stack_copy_size
;
262 static Lisp_Object Qconses
;
263 static Lisp_Object Qsymbols
;
264 static Lisp_Object Qmiscs
;
265 static Lisp_Object Qstrings
;
266 static Lisp_Object Qvectors
;
267 static Lisp_Object Qfloats
;
268 static Lisp_Object Qintervals
;
269 static Lisp_Object Qbuffers
;
270 static Lisp_Object Qstring_bytes
, Qvector_slots
, Qheap
;
271 static Lisp_Object Qgc_cons_threshold
;
272 Lisp_Object Qchar_table_extra_slots
;
274 /* Hook run after GC has finished. */
276 static Lisp_Object Qpost_gc_hook
;
278 static void mark_terminals (void);
279 static void gc_sweep (void);
280 static Lisp_Object
make_pure_vector (ptrdiff_t);
281 static void mark_glyph_matrix (struct glyph_matrix
*);
282 static void mark_face_cache (struct face_cache
*);
283 static void mark_buffer (struct buffer
*);
285 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
286 static void refill_memory_reserve (void);
288 static struct Lisp_String
*allocate_string (void);
289 static void compact_small_strings (void);
290 static void free_large_strings (void);
291 static void sweep_strings (void);
292 static void free_misc (Lisp_Object
);
293 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
295 /* When scanning the C stack for live Lisp objects, Emacs keeps track
296 of what memory allocated via lisp_malloc is intended for what
297 purpose. This enumeration specifies the type of memory. */
308 /* We used to keep separate mem_types for subtypes of vectors such as
309 process, hash_table, frame, terminal, and window, but we never made
310 use of the distinction, so it only caused source-code complexity
311 and runtime slowdown. Minor but pointless. */
313 /* Special type to denote vector blocks. */
314 MEM_TYPE_VECTOR_BLOCK
,
315 /* Special type to denote reserved memory. */
319 static void *lisp_malloc (size_t, enum mem_type
);
322 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
324 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
325 #include <stdio.h> /* For fprintf. */
328 /* A unique object in pure space used to make some Lisp objects
329 on free lists recognizable in O(1). */
331 static Lisp_Object Vdead
;
332 #define DEADP(x) EQ (x, Vdead)
334 #ifdef GC_MALLOC_CHECK
336 enum mem_type allocated_mem_type
;
338 #endif /* GC_MALLOC_CHECK */
340 /* A node in the red-black tree describing allocated memory containing
341 Lisp data. Each such block is recorded with its start and end
342 address when it is allocated, and removed from the tree when it
345 A red-black tree is a balanced binary tree with the following
348 1. Every node is either red or black.
349 2. Every leaf is black.
350 3. If a node is red, then both of its children are black.
351 4. Every simple path from a node to a descendant leaf contains
352 the same number of black nodes.
353 5. The root is always black.
355 When nodes are inserted into the tree, or deleted from the tree,
356 the tree is "fixed" so that these properties are always true.
358 A red-black tree with N internal nodes has height at most 2
359 log(N+1). Searches, insertions and deletions are done in O(log N).
360 Please see a text book about data structures for a detailed
361 description of red-black trees. Any book worth its salt should
366 /* Children of this node. These pointers are never NULL. When there
367 is no child, the value is MEM_NIL, which points to a dummy node. */
368 struct mem_node
*left
, *right
;
370 /* The parent of this node. In the root node, this is NULL. */
371 struct mem_node
*parent
;
373 /* Start and end of allocated region. */
377 enum {MEM_BLACK
, MEM_RED
} color
;
383 /* Base address of stack. Set in main. */
385 Lisp_Object
*stack_base
;
387 /* Root of the tree describing allocated Lisp memory. */
389 static struct mem_node
*mem_root
;
391 /* Lowest and highest known address in the heap. */
393 static void *min_heap_address
, *max_heap_address
;
395 /* Sentinel node of the tree. */
397 static struct mem_node mem_z
;
398 #define MEM_NIL &mem_z
400 static struct Lisp_Vector
*allocate_vectorlike (ptrdiff_t);
401 static void lisp_free (void *);
402 static void mark_stack (void);
403 static bool live_vector_p (struct mem_node
*, void *);
404 static bool live_buffer_p (struct mem_node
*, void *);
405 static bool live_string_p (struct mem_node
*, void *);
406 static bool live_cons_p (struct mem_node
*, void *);
407 static bool live_symbol_p (struct mem_node
*, void *);
408 static bool live_float_p (struct mem_node
*, void *);
409 static bool live_misc_p (struct mem_node
*, void *);
410 static void mark_maybe_object (Lisp_Object
);
411 static void mark_memory (void *, void *);
412 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
413 static void mem_init (void);
414 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
415 static void mem_insert_fixup (struct mem_node
*);
417 static void mem_rotate_left (struct mem_node
*);
418 static void mem_rotate_right (struct mem_node
*);
419 static void mem_delete (struct mem_node
*);
420 static void mem_delete_fixup (struct mem_node
*);
421 static inline struct mem_node
*mem_find (void *);
424 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
425 static void check_gcpros (void);
428 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
434 /* Recording what needs to be marked for gc. */
436 struct gcpro
*gcprolist
;
438 /* Addresses of staticpro'd variables. Initialize it to a nonzero
439 value; otherwise some compilers put it into BSS. */
441 #define NSTATICS 0x650
442 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
444 /* Index of next unused slot in staticvec. */
446 static int staticidx
;
448 static void *pure_alloc (size_t, int);
451 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
452 ALIGNMENT must be a power of 2. */
454 #define ALIGN(ptr, ALIGNMENT) \
455 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
456 & ~ ((ALIGNMENT) - 1)))
460 /************************************************************************
462 ************************************************************************/
464 /* Function malloc calls this if it finds we are near exhausting storage. */
467 malloc_warning (const char *str
)
469 pending_malloc_warning
= str
;
473 /* Display an already-pending malloc warning. */
476 display_malloc_warning (void)
478 call3 (intern ("display-warning"),
480 build_string (pending_malloc_warning
),
481 intern ("emergency"));
482 pending_malloc_warning
= 0;
485 /* Called if we can't allocate relocatable space for a buffer. */
488 buffer_memory_full (ptrdiff_t nbytes
)
490 /* If buffers use the relocating allocator, no need to free
491 spare_memory, because we may have plenty of malloc space left
492 that we could get, and if we don't, the malloc that fails will
493 itself cause spare_memory to be freed. If buffers don't use the
494 relocating allocator, treat this like any other failing
498 memory_full (nbytes
);
501 /* This used to call error, but if we've run out of memory, we could
502 get infinite recursion trying to build the string. */
503 xsignal (Qnil
, Vmemory_signal_data
);
506 /* A common multiple of the positive integers A and B. Ideally this
507 would be the least common multiple, but there's no way to do that
508 as a constant expression in C, so do the best that we can easily do. */
509 #define COMMON_MULTIPLE(a, b) \
510 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
512 #ifndef XMALLOC_OVERRUN_CHECK
513 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
516 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
519 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
520 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
521 block size in little-endian order. The trailer consists of
522 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
524 The header is used to detect whether this block has been allocated
525 through these functions, as some low-level libc functions may
526 bypass the malloc hooks. */
528 #define XMALLOC_OVERRUN_CHECK_SIZE 16
529 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
530 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
532 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
533 hold a size_t value and (2) the header size is a multiple of the
534 alignment that Emacs needs for C types and for USE_LSB_TAG. */
535 #define XMALLOC_BASE_ALIGNMENT \
536 alignof (union { long double d; intmax_t i; void *p; })
539 # define XMALLOC_HEADER_ALIGNMENT \
540 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
542 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
544 #define XMALLOC_OVERRUN_SIZE_SIZE \
545 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
546 + XMALLOC_HEADER_ALIGNMENT - 1) \
547 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
548 - XMALLOC_OVERRUN_CHECK_SIZE)
550 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
551 { '\x9a', '\x9b', '\xae', '\xaf',
552 '\xbf', '\xbe', '\xce', '\xcf',
553 '\xea', '\xeb', '\xec', '\xed',
554 '\xdf', '\xde', '\x9c', '\x9d' };
556 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
557 { '\xaa', '\xab', '\xac', '\xad',
558 '\xba', '\xbb', '\xbc', '\xbd',
559 '\xca', '\xcb', '\xcc', '\xcd',
560 '\xda', '\xdb', '\xdc', '\xdd' };
562 /* Insert and extract the block size in the header. */
565 xmalloc_put_size (unsigned char *ptr
, size_t size
)
568 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
570 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
576 xmalloc_get_size (unsigned char *ptr
)
580 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
581 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
590 /* The call depth in overrun_check functions. For example, this might happen:
592 overrun_check_malloc()
593 -> malloc -> (via hook)_-> emacs_blocked_malloc
594 -> overrun_check_malloc
595 call malloc (hooks are NULL, so real malloc is called).
596 malloc returns 10000.
597 add overhead, return 10016.
598 <- (back in overrun_check_malloc)
599 add overhead again, return 10032
600 xmalloc returns 10032.
605 overrun_check_free(10032)
607 free(10016) <- crash, because 10000 is the original pointer. */
609 static ptrdiff_t check_depth
;
611 /* Like malloc, but wraps allocated block with header and trailer. */
614 overrun_check_malloc (size_t size
)
616 register unsigned char *val
;
617 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
618 if (SIZE_MAX
- overhead
< size
)
621 val
= malloc (size
+ overhead
);
622 if (val
&& check_depth
== 1)
624 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
625 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
626 xmalloc_put_size (val
, size
);
627 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
628 XMALLOC_OVERRUN_CHECK_SIZE
);
635 /* Like realloc, but checks old block for overrun, and wraps new block
636 with header and trailer. */
639 overrun_check_realloc (void *block
, size_t size
)
641 register unsigned char *val
= (unsigned char *) block
;
642 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
643 if (SIZE_MAX
- overhead
< size
)
648 && memcmp (xmalloc_overrun_check_header
,
649 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
650 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
652 size_t osize
= xmalloc_get_size (val
);
653 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
654 XMALLOC_OVERRUN_CHECK_SIZE
))
656 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
657 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
658 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
661 val
= realloc (val
, size
+ overhead
);
663 if (val
&& check_depth
== 1)
665 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
666 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
667 xmalloc_put_size (val
, size
);
668 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
669 XMALLOC_OVERRUN_CHECK_SIZE
);
675 /* Like free, but checks block for overrun. */
678 overrun_check_free (void *block
)
680 unsigned char *val
= (unsigned char *) block
;
685 && memcmp (xmalloc_overrun_check_header
,
686 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
687 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
689 size_t osize
= xmalloc_get_size (val
);
690 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
691 XMALLOC_OVERRUN_CHECK_SIZE
))
693 #ifdef XMALLOC_CLEAR_FREE_MEMORY
694 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
695 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
697 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
698 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
699 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
710 #define malloc overrun_check_malloc
711 #define realloc overrun_check_realloc
712 #define free overrun_check_free
716 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
717 there's no need to block input around malloc. */
718 #define MALLOC_BLOCK_INPUT ((void)0)
719 #define MALLOC_UNBLOCK_INPUT ((void)0)
721 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
722 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
725 /* Like malloc but check for no memory and block interrupt input.. */
728 xmalloc (size_t size
)
734 MALLOC_UNBLOCK_INPUT
;
741 /* Like the above, but zeroes out the memory just allocated. */
744 xzalloc (size_t size
)
750 MALLOC_UNBLOCK_INPUT
;
754 memset (val
, 0, size
);
758 /* Like realloc but check for no memory and block interrupt input.. */
761 xrealloc (void *block
, size_t size
)
766 /* We must call malloc explicitly when BLOCK is 0, since some
767 reallocs don't do this. */
771 val
= realloc (block
, size
);
772 MALLOC_UNBLOCK_INPUT
;
780 /* Like free but block interrupt input. */
789 MALLOC_UNBLOCK_INPUT
;
790 /* We don't call refill_memory_reserve here
791 because that duplicates doing so in emacs_blocked_free
792 and the criterion should go there. */
796 /* Other parts of Emacs pass large int values to allocator functions
797 expecting ptrdiff_t. This is portable in practice, but check it to
799 verify (INT_MAX
<= PTRDIFF_MAX
);
802 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
803 Signal an error on memory exhaustion, and block interrupt input. */
806 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
808 eassert (0 <= nitems
&& 0 < item_size
);
809 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
810 memory_full (SIZE_MAX
);
811 return xmalloc (nitems
* item_size
);
815 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
816 Signal an error on memory exhaustion, and block interrupt input. */
819 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
821 eassert (0 <= nitems
&& 0 < item_size
);
822 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
823 memory_full (SIZE_MAX
);
824 return xrealloc (pa
, nitems
* item_size
);
828 /* Grow PA, which points to an array of *NITEMS items, and return the
829 location of the reallocated array, updating *NITEMS to reflect its
830 new size. The new array will contain at least NITEMS_INCR_MIN more
831 items, but will not contain more than NITEMS_MAX items total.
832 ITEM_SIZE is the size of each item, in bytes.
834 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
835 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
838 If PA is null, then allocate a new array instead of reallocating
839 the old one. Thus, to grow an array A without saving its old
840 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
843 Block interrupt input as needed. If memory exhaustion occurs, set
844 *NITEMS to zero if PA is null, and signal an error (i.e., do not
848 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
849 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
851 /* The approximate size to use for initial small allocation
852 requests. This is the largest "small" request for the GNU C
854 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
856 /* If the array is tiny, grow it to about (but no greater than)
857 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
858 ptrdiff_t n
= *nitems
;
859 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
860 ptrdiff_t half_again
= n
>> 1;
861 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
863 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
864 NITEMS_MAX, and what the C language can represent safely. */
865 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
866 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
867 ? nitems_max
: C_language_max
);
868 ptrdiff_t nitems_incr_max
= n_max
- n
;
869 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
871 eassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
874 if (nitems_incr_max
< incr
)
875 memory_full (SIZE_MAX
);
877 pa
= xrealloc (pa
, n
* item_size
);
883 /* Like strdup, but uses xmalloc. */
886 xstrdup (const char *s
)
888 size_t len
= strlen (s
) + 1;
889 char *p
= xmalloc (len
);
895 /* Unwind for SAFE_ALLOCA */
898 safe_alloca_unwind (Lisp_Object arg
)
900 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
909 /* Return a newly allocated memory block of SIZE bytes, remembering
910 to free it when unwinding. */
912 record_xmalloc (size_t size
)
914 void *p
= xmalloc (size
);
915 record_unwind_protect (safe_alloca_unwind
, make_save_value (p
, 0));
920 /* Like malloc but used for allocating Lisp data. NBYTES is the
921 number of bytes to allocate, TYPE describes the intended use of the
922 allocated memory block (for strings, for conses, ...). */
925 void *lisp_malloc_loser EXTERNALLY_VISIBLE
;
929 lisp_malloc (size_t nbytes
, enum mem_type type
)
935 #ifdef GC_MALLOC_CHECK
936 allocated_mem_type
= type
;
939 val
= malloc (nbytes
);
942 /* If the memory just allocated cannot be addressed thru a Lisp
943 object's pointer, and it needs to be,
944 that's equivalent to running out of memory. */
945 if (val
&& type
!= MEM_TYPE_NON_LISP
)
948 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
949 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
951 lisp_malloc_loser
= val
;
958 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
959 if (val
&& type
!= MEM_TYPE_NON_LISP
)
960 mem_insert (val
, (char *) val
+ nbytes
, type
);
963 MALLOC_UNBLOCK_INPUT
;
965 memory_full (nbytes
);
969 /* Free BLOCK. This must be called to free memory allocated with a
970 call to lisp_malloc. */
973 lisp_free (void *block
)
977 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
978 mem_delete (mem_find (block
));
980 MALLOC_UNBLOCK_INPUT
;
983 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
985 /* The entry point is lisp_align_malloc which returns blocks of at most
986 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
988 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
989 #define USE_POSIX_MEMALIGN 1
992 /* BLOCK_ALIGN has to be a power of 2. */
993 #define BLOCK_ALIGN (1 << 10)
995 /* Padding to leave at the end of a malloc'd block. This is to give
996 malloc a chance to minimize the amount of memory wasted to alignment.
997 It should be tuned to the particular malloc library used.
998 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
999 posix_memalign on the other hand would ideally prefer a value of 4
1000 because otherwise, there's 1020 bytes wasted between each ablocks.
1001 In Emacs, testing shows that those 1020 can most of the time be
1002 efficiently used by malloc to place other objects, so a value of 0 can
1003 still preferable unless you have a lot of aligned blocks and virtually
1005 #define BLOCK_PADDING 0
1006 #define BLOCK_BYTES \
1007 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
1009 /* Internal data structures and constants. */
1011 #define ABLOCKS_SIZE 16
1013 /* An aligned block of memory. */
1018 char payload
[BLOCK_BYTES
];
1019 struct ablock
*next_free
;
1021 /* `abase' is the aligned base of the ablocks. */
1022 /* It is overloaded to hold the virtual `busy' field that counts
1023 the number of used ablock in the parent ablocks.
1024 The first ablock has the `busy' field, the others have the `abase'
1025 field. To tell the difference, we assume that pointers will have
1026 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
1027 is used to tell whether the real base of the parent ablocks is `abase'
1028 (if not, the word before the first ablock holds a pointer to the
1030 struct ablocks
*abase
;
1031 /* The padding of all but the last ablock is unused. The padding of
1032 the last ablock in an ablocks is not allocated. */
1034 char padding
[BLOCK_PADDING
];
1038 /* A bunch of consecutive aligned blocks. */
1041 struct ablock blocks
[ABLOCKS_SIZE
];
1044 /* Size of the block requested from malloc or posix_memalign. */
1045 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1047 #define ABLOCK_ABASE(block) \
1048 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1049 ? (struct ablocks *)(block) \
1052 /* Virtual `busy' field. */
1053 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1055 /* Pointer to the (not necessarily aligned) malloc block. */
1056 #ifdef USE_POSIX_MEMALIGN
1057 #define ABLOCKS_BASE(abase) (abase)
1059 #define ABLOCKS_BASE(abase) \
1060 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
1063 /* The list of free ablock. */
1064 static struct ablock
*free_ablock
;
1066 /* Allocate an aligned block of nbytes.
1067 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1068 smaller or equal to BLOCK_BYTES. */
1070 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1073 struct ablocks
*abase
;
1075 eassert (nbytes
<= BLOCK_BYTES
);
1079 #ifdef GC_MALLOC_CHECK
1080 allocated_mem_type
= type
;
1086 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1088 #ifdef DOUG_LEA_MALLOC
1089 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1090 because mapped region contents are not preserved in
1092 mallopt (M_MMAP_MAX
, 0);
1095 #ifdef USE_POSIX_MEMALIGN
1097 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1103 base
= malloc (ABLOCKS_BYTES
);
1104 abase
= ALIGN (base
, BLOCK_ALIGN
);
1109 MALLOC_UNBLOCK_INPUT
;
1110 memory_full (ABLOCKS_BYTES
);
1113 aligned
= (base
== abase
);
1115 ((void**)abase
)[-1] = base
;
1117 #ifdef DOUG_LEA_MALLOC
1118 /* Back to a reasonable maximum of mmap'ed areas. */
1119 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1123 /* If the memory just allocated cannot be addressed thru a Lisp
1124 object's pointer, and it needs to be, that's equivalent to
1125 running out of memory. */
1126 if (type
!= MEM_TYPE_NON_LISP
)
1129 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1130 XSETCONS (tem
, end
);
1131 if ((char *) XCONS (tem
) != end
)
1133 lisp_malloc_loser
= base
;
1135 MALLOC_UNBLOCK_INPUT
;
1136 memory_full (SIZE_MAX
);
1141 /* Initialize the blocks and put them on the free list.
1142 If `base' was not properly aligned, we can't use the last block. */
1143 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1145 abase
->blocks
[i
].abase
= abase
;
1146 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1147 free_ablock
= &abase
->blocks
[i
];
1149 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1151 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1152 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1153 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1154 eassert (ABLOCKS_BASE (abase
) == base
);
1155 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1158 abase
= ABLOCK_ABASE (free_ablock
);
1159 ABLOCKS_BUSY (abase
) =
1160 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1162 free_ablock
= free_ablock
->x
.next_free
;
1164 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1165 if (type
!= MEM_TYPE_NON_LISP
)
1166 mem_insert (val
, (char *) val
+ nbytes
, type
);
1169 MALLOC_UNBLOCK_INPUT
;
1171 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1176 lisp_align_free (void *block
)
1178 struct ablock
*ablock
= block
;
1179 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1182 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1183 mem_delete (mem_find (block
));
1185 /* Put on free list. */
1186 ablock
->x
.next_free
= free_ablock
;
1187 free_ablock
= ablock
;
1188 /* Update busy count. */
1189 ABLOCKS_BUSY (abase
)
1190 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1192 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1193 { /* All the blocks are free. */
1194 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1195 struct ablock
**tem
= &free_ablock
;
1196 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1200 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1203 *tem
= (*tem
)->x
.next_free
;
1206 tem
= &(*tem
)->x
.next_free
;
1208 eassert ((aligned
& 1) == aligned
);
1209 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1210 #ifdef USE_POSIX_MEMALIGN
1211 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1213 free (ABLOCKS_BASE (abase
));
1215 MALLOC_UNBLOCK_INPUT
;
1219 #ifndef SYSTEM_MALLOC
1221 /* Arranging to disable input signals while we're in malloc.
1223 This only works with GNU malloc. To help out systems which can't
1224 use GNU malloc, all the calls to malloc, realloc, and free
1225 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1226 pair; unfortunately, we have no idea what C library functions
1227 might call malloc, so we can't really protect them unless you're
1228 using GNU malloc. Fortunately, most of the major operating systems
1229 can use GNU malloc. */
1232 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1233 there's no need to block input around malloc. */
1235 #ifndef DOUG_LEA_MALLOC
1236 extern void * (*__malloc_hook
) (size_t, const void *);
1237 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1238 extern void (*__free_hook
) (void *, const void *);
1239 /* Else declared in malloc.h, perhaps with an extra arg. */
1240 #endif /* DOUG_LEA_MALLOC */
1241 static void * (*old_malloc_hook
) (size_t, const void *);
1242 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1243 static void (*old_free_hook
) (void*, const void*);
1245 #ifdef DOUG_LEA_MALLOC
1246 # define BYTES_USED (mallinfo ().uordblks)
1248 # define BYTES_USED _bytes_used
1251 #ifdef GC_MALLOC_CHECK
1252 static bool dont_register_blocks
;
1255 static size_t bytes_used_when_reconsidered
;
1257 /* Value of _bytes_used, when spare_memory was freed. */
1259 static size_t bytes_used_when_full
;
1261 /* This function is used as the hook for free to call. */
1264 emacs_blocked_free (void *ptr
, const void *ptr2
)
1268 #ifdef GC_MALLOC_CHECK
1274 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1277 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1282 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1286 #endif /* GC_MALLOC_CHECK */
1288 __free_hook
= old_free_hook
;
1291 /* If we released our reserve (due to running out of memory),
1292 and we have a fair amount free once again,
1293 try to set aside another reserve in case we run out once more. */
1294 if (! NILP (Vmemory_full
)
1295 /* Verify there is enough space that even with the malloc
1296 hysteresis this call won't run out again.
1297 The code here is correct as long as SPARE_MEMORY
1298 is substantially larger than the block size malloc uses. */
1299 && (bytes_used_when_full
1300 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1301 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1302 refill_memory_reserve ();
1304 __free_hook
= emacs_blocked_free
;
1305 UNBLOCK_INPUT_ALLOC
;
1309 /* This function is the malloc hook that Emacs uses. */
1312 emacs_blocked_malloc (size_t size
, const void *ptr
)
1317 __malloc_hook
= old_malloc_hook
;
1318 #ifdef DOUG_LEA_MALLOC
1319 /* Segfaults on my system. --lorentey */
1320 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1322 __malloc_extra_blocks
= malloc_hysteresis
;
1325 value
= malloc (size
);
1327 #ifdef GC_MALLOC_CHECK
1329 struct mem_node
*m
= mem_find (value
);
1332 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1334 fprintf (stderr
, "Region in use is %p...%p, %td bytes, type %d\n",
1335 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1340 if (!dont_register_blocks
)
1342 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1343 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1346 #endif /* GC_MALLOC_CHECK */
1348 __malloc_hook
= emacs_blocked_malloc
;
1349 UNBLOCK_INPUT_ALLOC
;
1351 /* fprintf (stderr, "%p malloc\n", value); */
1356 /* This function is the realloc hook that Emacs uses. */
1359 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1364 __realloc_hook
= old_realloc_hook
;
1366 #ifdef GC_MALLOC_CHECK
1369 struct mem_node
*m
= mem_find (ptr
);
1370 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1373 "Realloc of %p which wasn't allocated with malloc\n",
1381 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1383 /* Prevent malloc from registering blocks. */
1384 dont_register_blocks
= 1;
1385 #endif /* GC_MALLOC_CHECK */
1387 value
= realloc (ptr
, size
);
1389 #ifdef GC_MALLOC_CHECK
1390 dont_register_blocks
= 0;
1393 struct mem_node
*m
= mem_find (value
);
1396 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1400 /* Can't handle zero size regions in the red-black tree. */
1401 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1404 /* fprintf (stderr, "%p <- realloc\n", value); */
1405 #endif /* GC_MALLOC_CHECK */
1407 __realloc_hook
= emacs_blocked_realloc
;
1408 UNBLOCK_INPUT_ALLOC
;
1415 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1416 normal malloc. Some thread implementations need this as they call
1417 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1418 calls malloc because it is the first call, and we have an endless loop. */
1421 reset_malloc_hooks (void)
1423 __free_hook
= old_free_hook
;
1424 __malloc_hook
= old_malloc_hook
;
1425 __realloc_hook
= old_realloc_hook
;
1427 #endif /* HAVE_PTHREAD */
1430 /* Called from main to set up malloc to use our hooks. */
1433 uninterrupt_malloc (void)
1436 #ifdef DOUG_LEA_MALLOC
1437 pthread_mutexattr_t attr
;
1439 /* GLIBC has a faster way to do this, but let's keep it portable.
1440 This is according to the Single UNIX Specification. */
1441 pthread_mutexattr_init (&attr
);
1442 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1443 pthread_mutex_init (&alloc_mutex
, &attr
);
1444 #else /* !DOUG_LEA_MALLOC */
1445 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1446 and the bundled gmalloc.c doesn't require it. */
1447 pthread_mutex_init (&alloc_mutex
, NULL
);
1448 #endif /* !DOUG_LEA_MALLOC */
1449 #endif /* HAVE_PTHREAD */
1451 if (__free_hook
!= emacs_blocked_free
)
1452 old_free_hook
= __free_hook
;
1453 __free_hook
= emacs_blocked_free
;
1455 if (__malloc_hook
!= emacs_blocked_malloc
)
1456 old_malloc_hook
= __malloc_hook
;
1457 __malloc_hook
= emacs_blocked_malloc
;
1459 if (__realloc_hook
!= emacs_blocked_realloc
)
1460 old_realloc_hook
= __realloc_hook
;
1461 __realloc_hook
= emacs_blocked_realloc
;
1464 #endif /* not SYNC_INPUT */
1465 #endif /* not SYSTEM_MALLOC */
1469 /***********************************************************************
1471 ***********************************************************************/
1473 /* Number of intervals allocated in an interval_block structure.
1474 The 1020 is 1024 minus malloc overhead. */
1476 #define INTERVAL_BLOCK_SIZE \
1477 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1479 /* Intervals are allocated in chunks in form of an interval_block
1482 struct interval_block
1484 /* Place `intervals' first, to preserve alignment. */
1485 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1486 struct interval_block
*next
;
1489 /* Current interval block. Its `next' pointer points to older
1492 static struct interval_block
*interval_block
;
1494 /* Index in interval_block above of the next unused interval
1497 static int interval_block_index
= INTERVAL_BLOCK_SIZE
;
1499 /* Number of free and live intervals. */
1501 static EMACS_INT total_free_intervals
, total_intervals
;
1503 /* List of free intervals. */
1505 static INTERVAL interval_free_list
;
1507 /* Return a new interval. */
1510 make_interval (void)
1514 /* eassert (!handling_signal); */
1518 if (interval_free_list
)
1520 val
= interval_free_list
;
1521 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1525 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1527 struct interval_block
*newi
1528 = lisp_malloc (sizeof *newi
, MEM_TYPE_NON_LISP
);
1530 newi
->next
= interval_block
;
1531 interval_block
= newi
;
1532 interval_block_index
= 0;
1533 total_free_intervals
+= INTERVAL_BLOCK_SIZE
;
1535 val
= &interval_block
->intervals
[interval_block_index
++];
1538 MALLOC_UNBLOCK_INPUT
;
1540 consing_since_gc
+= sizeof (struct interval
);
1542 total_free_intervals
--;
1543 RESET_INTERVAL (val
);
1549 /* Mark Lisp objects in interval I. */
1552 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1554 /* Intervals should never be shared. So, if extra internal checking is
1555 enabled, GC aborts if it seems to have visited an interval twice. */
1556 eassert (!i
->gcmarkbit
);
1558 mark_object (i
->plist
);
1561 /* Mark the interval tree rooted in I. */
1563 #define MARK_INTERVAL_TREE(i) \
1565 if (i && !i->gcmarkbit) \
1566 traverse_intervals_noorder (i, mark_interval, Qnil); \
1569 /***********************************************************************
1571 ***********************************************************************/
1573 /* Lisp_Strings are allocated in string_block structures. When a new
1574 string_block is allocated, all the Lisp_Strings it contains are
1575 added to a free-list string_free_list. When a new Lisp_String is
1576 needed, it is taken from that list. During the sweep phase of GC,
1577 string_blocks that are entirely free are freed, except two which
1580 String data is allocated from sblock structures. Strings larger
1581 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1582 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1584 Sblocks consist internally of sdata structures, one for each
1585 Lisp_String. The sdata structure points to the Lisp_String it
1586 belongs to. The Lisp_String points back to the `u.data' member of
1587 its sdata structure.
1589 When a Lisp_String is freed during GC, it is put back on
1590 string_free_list, and its `data' member and its sdata's `string'
1591 pointer is set to null. The size of the string is recorded in the
1592 `u.nbytes' member of the sdata. So, sdata structures that are no
1593 longer used, can be easily recognized, and it's easy to compact the
1594 sblocks of small strings which we do in compact_small_strings. */
1596 /* Size in bytes of an sblock structure used for small strings. This
1597 is 8192 minus malloc overhead. */
1599 #define SBLOCK_SIZE 8188
1601 /* Strings larger than this are considered large strings. String data
1602 for large strings is allocated from individual sblocks. */
1604 #define LARGE_STRING_BYTES 1024
1606 /* Structure describing string memory sub-allocated from an sblock.
1607 This is where the contents of Lisp strings are stored. */
1611 /* Back-pointer to the string this sdata belongs to. If null, this
1612 structure is free, and the NBYTES member of the union below
1613 contains the string's byte size (the same value that STRING_BYTES
1614 would return if STRING were non-null). If non-null, STRING_BYTES
1615 (STRING) is the size of the data, and DATA contains the string's
1617 struct Lisp_String
*string
;
1619 #ifdef GC_CHECK_STRING_BYTES
1622 unsigned char data
[1];
1624 #define SDATA_NBYTES(S) (S)->nbytes
1625 #define SDATA_DATA(S) (S)->data
1626 #define SDATA_SELECTOR(member) member
1628 #else /* not GC_CHECK_STRING_BYTES */
1632 /* When STRING is non-null. */
1633 unsigned char data
[1];
1635 /* When STRING is null. */
1639 #define SDATA_NBYTES(S) (S)->u.nbytes
1640 #define SDATA_DATA(S) (S)->u.data
1641 #define SDATA_SELECTOR(member) u.member
1643 #endif /* not GC_CHECK_STRING_BYTES */
1645 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1649 /* Structure describing a block of memory which is sub-allocated to
1650 obtain string data memory for strings. Blocks for small strings
1651 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1652 as large as needed. */
1657 struct sblock
*next
;
1659 /* Pointer to the next free sdata block. This points past the end
1660 of the sblock if there isn't any space left in this block. */
1661 struct sdata
*next_free
;
1663 /* Start of data. */
1664 struct sdata first_data
;
1667 /* Number of Lisp strings in a string_block structure. The 1020 is
1668 1024 minus malloc overhead. */
1670 #define STRING_BLOCK_SIZE \
1671 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1673 /* Structure describing a block from which Lisp_String structures
1678 /* Place `strings' first, to preserve alignment. */
1679 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1680 struct string_block
*next
;
1683 /* Head and tail of the list of sblock structures holding Lisp string
1684 data. We always allocate from current_sblock. The NEXT pointers
1685 in the sblock structures go from oldest_sblock to current_sblock. */
1687 static struct sblock
*oldest_sblock
, *current_sblock
;
1689 /* List of sblocks for large strings. */
1691 static struct sblock
*large_sblocks
;
1693 /* List of string_block structures. */
1695 static struct string_block
*string_blocks
;
1697 /* Free-list of Lisp_Strings. */
1699 static struct Lisp_String
*string_free_list
;
1701 /* Number of live and free Lisp_Strings. */
1703 static EMACS_INT total_strings
, total_free_strings
;
1705 /* Number of bytes used by live strings. */
1707 static EMACS_INT total_string_bytes
;
1709 /* Given a pointer to a Lisp_String S which is on the free-list
1710 string_free_list, return a pointer to its successor in the
1713 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1715 /* Return a pointer to the sdata structure belonging to Lisp string S.
1716 S must be live, i.e. S->data must not be null. S->data is actually
1717 a pointer to the `u.data' member of its sdata structure; the
1718 structure starts at a constant offset in front of that. */
1720 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1723 #ifdef GC_CHECK_STRING_OVERRUN
1725 /* We check for overrun in string data blocks by appending a small
1726 "cookie" after each allocated string data block, and check for the
1727 presence of this cookie during GC. */
1729 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1730 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1731 { '\xde', '\xad', '\xbe', '\xef' };
1734 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1737 /* Value is the size of an sdata structure large enough to hold NBYTES
1738 bytes of string data. The value returned includes a terminating
1739 NUL byte, the size of the sdata structure, and padding. */
1741 #ifdef GC_CHECK_STRING_BYTES
1743 #define SDATA_SIZE(NBYTES) \
1744 ((SDATA_DATA_OFFSET \
1746 + sizeof (ptrdiff_t) - 1) \
1747 & ~(sizeof (ptrdiff_t) - 1))
1749 #else /* not GC_CHECK_STRING_BYTES */
1751 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1752 less than the size of that member. The 'max' is not needed when
1753 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1754 alignment code reserves enough space. */
1756 #define SDATA_SIZE(NBYTES) \
1757 ((SDATA_DATA_OFFSET \
1758 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1760 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1762 + sizeof (ptrdiff_t) - 1) \
1763 & ~(sizeof (ptrdiff_t) - 1))
1765 #endif /* not GC_CHECK_STRING_BYTES */
1767 /* Extra bytes to allocate for each string. */
1769 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1771 /* Exact bound on the number of bytes in a string, not counting the
1772 terminating null. A string cannot contain more bytes than
1773 STRING_BYTES_BOUND, nor can it be so long that the size_t
1774 arithmetic in allocate_string_data would overflow while it is
1775 calculating a value to be passed to malloc. */
1776 static ptrdiff_t const STRING_BYTES_MAX
=
1777 min (STRING_BYTES_BOUND
,
1778 ((SIZE_MAX
- XMALLOC_OVERRUN_CHECK_OVERHEAD
1780 - offsetof (struct sblock
, first_data
)
1781 - SDATA_DATA_OFFSET
)
1782 & ~(sizeof (EMACS_INT
) - 1)));
1784 /* Initialize string allocation. Called from init_alloc_once. */
1789 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1790 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1794 #ifdef GC_CHECK_STRING_BYTES
1796 static int check_string_bytes_count
;
1798 /* Like STRING_BYTES, but with debugging check. Can be
1799 called during GC, so pay attention to the mark bit. */
1802 string_bytes (struct Lisp_String
*s
)
1805 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1807 if (!PURE_POINTER_P (s
)
1809 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1814 /* Check validity of Lisp strings' string_bytes member in B. */
1817 check_sblock (struct sblock
*b
)
1819 struct sdata
*from
, *end
, *from_end
;
1823 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1825 /* Compute the next FROM here because copying below may
1826 overwrite data we need to compute it. */
1829 /* Check that the string size recorded in the string is the
1830 same as the one recorded in the sdata structure. */
1831 nbytes
= SDATA_SIZE (from
->string
? string_bytes (from
->string
)
1832 : SDATA_NBYTES (from
));
1833 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1838 /* Check validity of Lisp strings' string_bytes member. ALL_P
1839 means check all strings, otherwise check only most
1840 recently allocated strings. Used for hunting a bug. */
1843 check_string_bytes (bool all_p
)
1849 for (b
= large_sblocks
; b
; b
= b
->next
)
1851 struct Lisp_String
*s
= b
->first_data
.string
;
1856 for (b
= oldest_sblock
; b
; b
= b
->next
)
1859 else if (current_sblock
)
1860 check_sblock (current_sblock
);
1863 #else /* not GC_CHECK_STRING_BYTES */
1865 #define check_string_bytes(all) ((void) 0)
1867 #endif /* GC_CHECK_STRING_BYTES */
1869 #ifdef GC_CHECK_STRING_FREE_LIST
1871 /* Walk through the string free list looking for bogus next pointers.
1872 This may catch buffer overrun from a previous string. */
1875 check_string_free_list (void)
1877 struct Lisp_String
*s
;
1879 /* Pop a Lisp_String off the free-list. */
1880 s
= string_free_list
;
1883 if ((uintptr_t) s
< 1024)
1885 s
= NEXT_FREE_LISP_STRING (s
);
1889 #define check_string_free_list()
1892 /* Return a new Lisp_String. */
1894 static struct Lisp_String
*
1895 allocate_string (void)
1897 struct Lisp_String
*s
;
1899 /* eassert (!handling_signal); */
1903 /* If the free-list is empty, allocate a new string_block, and
1904 add all the Lisp_Strings in it to the free-list. */
1905 if (string_free_list
== NULL
)
1907 struct string_block
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1910 b
->next
= string_blocks
;
1913 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1916 /* Every string on a free list should have NULL data pointer. */
1918 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1919 string_free_list
= s
;
1922 total_free_strings
+= STRING_BLOCK_SIZE
;
1925 check_string_free_list ();
1927 /* Pop a Lisp_String off the free-list. */
1928 s
= string_free_list
;
1929 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1931 MALLOC_UNBLOCK_INPUT
;
1933 --total_free_strings
;
1936 consing_since_gc
+= sizeof *s
;
1938 #ifdef GC_CHECK_STRING_BYTES
1939 if (!noninteractive
)
1941 if (++check_string_bytes_count
== 200)
1943 check_string_bytes_count
= 0;
1944 check_string_bytes (1);
1947 check_string_bytes (0);
1949 #endif /* GC_CHECK_STRING_BYTES */
1955 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1956 plus a NUL byte at the end. Allocate an sdata structure for S, and
1957 set S->data to its `u.data' member. Store a NUL byte at the end of
1958 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1959 S->data if it was initially non-null. */
1962 allocate_string_data (struct Lisp_String
*s
,
1963 EMACS_INT nchars
, EMACS_INT nbytes
)
1965 struct sdata
*data
, *old_data
;
1967 ptrdiff_t needed
, old_nbytes
;
1969 if (STRING_BYTES_MAX
< nbytes
)
1972 /* Determine the number of bytes needed to store NBYTES bytes
1974 needed
= SDATA_SIZE (nbytes
);
1977 old_data
= SDATA_OF_STRING (s
);
1978 old_nbytes
= STRING_BYTES (s
);
1985 if (nbytes
> LARGE_STRING_BYTES
)
1987 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
1989 #ifdef DOUG_LEA_MALLOC
1990 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1991 because mapped region contents are not preserved in
1994 In case you think of allowing it in a dumped Emacs at the
1995 cost of not being able to re-dump, there's another reason:
1996 mmap'ed data typically have an address towards the top of the
1997 address space, which won't fit into an EMACS_INT (at least on
1998 32-bit systems with the current tagging scheme). --fx */
1999 mallopt (M_MMAP_MAX
, 0);
2002 b
= lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2004 #ifdef DOUG_LEA_MALLOC
2005 /* Back to a reasonable maximum of mmap'ed areas. */
2006 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2009 b
->next_free
= &b
->first_data
;
2010 b
->first_data
.string
= NULL
;
2011 b
->next
= large_sblocks
;
2014 else if (current_sblock
== NULL
2015 || (((char *) current_sblock
+ SBLOCK_SIZE
2016 - (char *) current_sblock
->next_free
)
2017 < (needed
+ GC_STRING_EXTRA
)))
2019 /* Not enough room in the current sblock. */
2020 b
= lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2021 b
->next_free
= &b
->first_data
;
2022 b
->first_data
.string
= NULL
;
2026 current_sblock
->next
= b
;
2034 data
= b
->next_free
;
2035 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2037 MALLOC_UNBLOCK_INPUT
;
2040 s
->data
= SDATA_DATA (data
);
2041 #ifdef GC_CHECK_STRING_BYTES
2042 SDATA_NBYTES (data
) = nbytes
;
2045 s
->size_byte
= nbytes
;
2046 s
->data
[nbytes
] = '\0';
2047 #ifdef GC_CHECK_STRING_OVERRUN
2048 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2049 GC_STRING_OVERRUN_COOKIE_SIZE
);
2052 /* Note that Faset may call to this function when S has already data
2053 assigned. In this case, mark data as free by setting it's string
2054 back-pointer to null, and record the size of the data in it. */
2057 SDATA_NBYTES (old_data
) = old_nbytes
;
2058 old_data
->string
= NULL
;
2061 consing_since_gc
+= needed
;
2065 /* Sweep and compact strings. */
2068 sweep_strings (void)
2070 struct string_block
*b
, *next
;
2071 struct string_block
*live_blocks
= NULL
;
2073 string_free_list
= NULL
;
2074 total_strings
= total_free_strings
= 0;
2075 total_string_bytes
= 0;
2077 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2078 for (b
= string_blocks
; b
; b
= next
)
2081 struct Lisp_String
*free_list_before
= string_free_list
;
2085 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2087 struct Lisp_String
*s
= b
->strings
+ i
;
2091 /* String was not on free-list before. */
2092 if (STRING_MARKED_P (s
))
2094 /* String is live; unmark it and its intervals. */
2097 /* Do not use string_(set|get)_intervals here. */
2098 s
->intervals
= balance_intervals (s
->intervals
);
2101 total_string_bytes
+= STRING_BYTES (s
);
2105 /* String is dead. Put it on the free-list. */
2106 struct sdata
*data
= SDATA_OF_STRING (s
);
2108 /* Save the size of S in its sdata so that we know
2109 how large that is. Reset the sdata's string
2110 back-pointer so that we know it's free. */
2111 #ifdef GC_CHECK_STRING_BYTES
2112 if (string_bytes (s
) != SDATA_NBYTES (data
))
2115 data
->u
.nbytes
= STRING_BYTES (s
);
2117 data
->string
= NULL
;
2119 /* Reset the strings's `data' member so that we
2123 /* Put the string on the free-list. */
2124 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2125 string_free_list
= s
;
2131 /* S was on the free-list before. Put it there again. */
2132 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2133 string_free_list
= s
;
2138 /* Free blocks that contain free Lisp_Strings only, except
2139 the first two of them. */
2140 if (nfree
== STRING_BLOCK_SIZE
2141 && total_free_strings
> STRING_BLOCK_SIZE
)
2144 string_free_list
= free_list_before
;
2148 total_free_strings
+= nfree
;
2149 b
->next
= live_blocks
;
2154 check_string_free_list ();
2156 string_blocks
= live_blocks
;
2157 free_large_strings ();
2158 compact_small_strings ();
2160 check_string_free_list ();
2164 /* Free dead large strings. */
2167 free_large_strings (void)
2169 struct sblock
*b
, *next
;
2170 struct sblock
*live_blocks
= NULL
;
2172 for (b
= large_sblocks
; b
; b
= next
)
2176 if (b
->first_data
.string
== NULL
)
2180 b
->next
= live_blocks
;
2185 large_sblocks
= live_blocks
;
2189 /* Compact data of small strings. Free sblocks that don't contain
2190 data of live strings after compaction. */
2193 compact_small_strings (void)
2195 struct sblock
*b
, *tb
, *next
;
2196 struct sdata
*from
, *to
, *end
, *tb_end
;
2197 struct sdata
*to_end
, *from_end
;
2199 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2200 to, and TB_END is the end of TB. */
2202 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2203 to
= &tb
->first_data
;
2205 /* Step through the blocks from the oldest to the youngest. We
2206 expect that old blocks will stabilize over time, so that less
2207 copying will happen this way. */
2208 for (b
= oldest_sblock
; b
; b
= b
->next
)
2211 eassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2213 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2215 /* Compute the next FROM here because copying below may
2216 overwrite data we need to compute it. */
2218 struct Lisp_String
*s
= from
->string
;
2220 #ifdef GC_CHECK_STRING_BYTES
2221 /* Check that the string size recorded in the string is the
2222 same as the one recorded in the sdata structure. */
2223 if (s
&& string_bytes (s
) != SDATA_NBYTES (from
))
2225 #endif /* GC_CHECK_STRING_BYTES */
2227 nbytes
= s
? STRING_BYTES (s
) : SDATA_NBYTES (from
);
2228 eassert (nbytes
<= LARGE_STRING_BYTES
);
2230 nbytes
= SDATA_SIZE (nbytes
);
2231 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2233 #ifdef GC_CHECK_STRING_OVERRUN
2234 if (memcmp (string_overrun_cookie
,
2235 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2236 GC_STRING_OVERRUN_COOKIE_SIZE
))
2240 /* Non-NULL S means it's alive. Copy its data. */
2243 /* If TB is full, proceed with the next sblock. */
2244 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2245 if (to_end
> tb_end
)
2249 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2250 to
= &tb
->first_data
;
2251 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2254 /* Copy, and update the string's `data' pointer. */
2257 eassert (tb
!= b
|| to
< from
);
2258 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2259 to
->string
->data
= SDATA_DATA (to
);
2262 /* Advance past the sdata we copied to. */
2268 /* The rest of the sblocks following TB don't contain live data, so
2269 we can free them. */
2270 for (b
= tb
->next
; b
; b
= next
)
2278 current_sblock
= tb
;
2282 string_overflow (void)
2284 error ("Maximum string size exceeded");
2287 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2288 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2289 LENGTH must be an integer.
2290 INIT must be an integer that represents a character. */)
2291 (Lisp_Object length
, Lisp_Object init
)
2293 register Lisp_Object val
;
2294 register unsigned char *p
, *end
;
2298 CHECK_NATNUM (length
);
2299 CHECK_CHARACTER (init
);
2301 c
= XFASTINT (init
);
2302 if (ASCII_CHAR_P (c
))
2304 nbytes
= XINT (length
);
2305 val
= make_uninit_string (nbytes
);
2307 end
= p
+ SCHARS (val
);
2313 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2314 int len
= CHAR_STRING (c
, str
);
2315 EMACS_INT string_len
= XINT (length
);
2317 if (string_len
> STRING_BYTES_MAX
/ len
)
2319 nbytes
= len
* string_len
;
2320 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2325 memcpy (p
, str
, len
);
2335 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2336 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2337 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2338 (Lisp_Object length
, Lisp_Object init
)
2340 register Lisp_Object val
;
2341 struct Lisp_Bool_Vector
*p
;
2342 ptrdiff_t length_in_chars
;
2343 EMACS_INT length_in_elts
;
2345 int extra_bool_elts
= ((bool_header_size
- header_size
+ word_size
- 1)
2348 CHECK_NATNUM (length
);
2350 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2352 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2354 val
= Fmake_vector (make_number (length_in_elts
+ extra_bool_elts
), Qnil
);
2356 /* No Lisp_Object to trace in there. */
2357 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0);
2359 p
= XBOOL_VECTOR (val
);
2360 p
->size
= XFASTINT (length
);
2362 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2363 / BOOL_VECTOR_BITS_PER_CHAR
);
2364 if (length_in_chars
)
2366 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2368 /* Clear any extraneous bits in the last byte. */
2369 p
->data
[length_in_chars
- 1]
2370 &= (1 << ((XFASTINT (length
) - 1) % BOOL_VECTOR_BITS_PER_CHAR
+ 1)) - 1;
2377 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2378 of characters from the contents. This string may be unibyte or
2379 multibyte, depending on the contents. */
2382 make_string (const char *contents
, ptrdiff_t nbytes
)
2384 register Lisp_Object val
;
2385 ptrdiff_t nchars
, multibyte_nbytes
;
2387 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2388 &nchars
, &multibyte_nbytes
);
2389 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2390 /* CONTENTS contains no multibyte sequences or contains an invalid
2391 multibyte sequence. We must make unibyte string. */
2392 val
= make_unibyte_string (contents
, nbytes
);
2394 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2399 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2402 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2404 register Lisp_Object val
;
2405 val
= make_uninit_string (length
);
2406 memcpy (SDATA (val
), contents
, length
);
2411 /* Make a multibyte string from NCHARS characters occupying NBYTES
2412 bytes at CONTENTS. */
2415 make_multibyte_string (const char *contents
,
2416 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2418 register Lisp_Object val
;
2419 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2420 memcpy (SDATA (val
), contents
, nbytes
);
2425 /* Make a string from NCHARS characters occupying NBYTES bytes at
2426 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2429 make_string_from_bytes (const char *contents
,
2430 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2432 register Lisp_Object val
;
2433 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2434 memcpy (SDATA (val
), contents
, nbytes
);
2435 if (SBYTES (val
) == SCHARS (val
))
2436 STRING_SET_UNIBYTE (val
);
2441 /* Make a string from NCHARS characters occupying NBYTES bytes at
2442 CONTENTS. The argument MULTIBYTE controls whether to label the
2443 string as multibyte. If NCHARS is negative, it counts the number of
2444 characters by itself. */
2447 make_specified_string (const char *contents
,
2448 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
2455 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2460 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2461 memcpy (SDATA (val
), contents
, nbytes
);
2463 STRING_SET_UNIBYTE (val
);
2468 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2469 occupying LENGTH bytes. */
2472 make_uninit_string (EMACS_INT length
)
2477 return empty_unibyte_string
;
2478 val
= make_uninit_multibyte_string (length
, length
);
2479 STRING_SET_UNIBYTE (val
);
2484 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2485 which occupy NBYTES bytes. */
2488 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2491 struct Lisp_String
*s
;
2496 return empty_multibyte_string
;
2498 s
= allocate_string ();
2499 s
->intervals
= NULL
;
2500 allocate_string_data (s
, nchars
, nbytes
);
2501 XSETSTRING (string
, s
);
2502 string_chars_consed
+= nbytes
;
2506 /* Print arguments to BUF according to a FORMAT, then return
2507 a Lisp_String initialized with the data from BUF. */
2510 make_formatted_string (char *buf
, const char *format
, ...)
2515 va_start (ap
, format
);
2516 length
= vsprintf (buf
, format
, ap
);
2518 return make_string (buf
, length
);
2522 /***********************************************************************
2524 ***********************************************************************/
2526 /* We store float cells inside of float_blocks, allocating a new
2527 float_block with malloc whenever necessary. Float cells reclaimed
2528 by GC are put on a free list to be reallocated before allocating
2529 any new float cells from the latest float_block. */
2531 #define FLOAT_BLOCK_SIZE \
2532 (((BLOCK_BYTES - sizeof (struct float_block *) \
2533 /* The compiler might add padding at the end. */ \
2534 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2535 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2537 #define GETMARKBIT(block,n) \
2538 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2539 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2542 #define SETMARKBIT(block,n) \
2543 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2544 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2546 #define UNSETMARKBIT(block,n) \
2547 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2548 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2550 #define FLOAT_BLOCK(fptr) \
2551 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2553 #define FLOAT_INDEX(fptr) \
2554 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2558 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2559 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2560 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2561 struct float_block
*next
;
2564 #define FLOAT_MARKED_P(fptr) \
2565 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2567 #define FLOAT_MARK(fptr) \
2568 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2570 #define FLOAT_UNMARK(fptr) \
2571 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2573 /* Current float_block. */
2575 static struct float_block
*float_block
;
2577 /* Index of first unused Lisp_Float in the current float_block. */
2579 static int float_block_index
= FLOAT_BLOCK_SIZE
;
2581 /* Free-list of Lisp_Floats. */
2583 static struct Lisp_Float
*float_free_list
;
2585 /* Return a new float object with value FLOAT_VALUE. */
2588 make_float (double float_value
)
2590 register Lisp_Object val
;
2592 /* eassert (!handling_signal); */
2596 if (float_free_list
)
2598 /* We use the data field for chaining the free list
2599 so that we won't use the same field that has the mark bit. */
2600 XSETFLOAT (val
, float_free_list
);
2601 float_free_list
= float_free_list
->u
.chain
;
2605 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2607 struct float_block
*new
2608 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT
);
2609 new->next
= float_block
;
2610 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2612 float_block_index
= 0;
2613 total_free_floats
+= FLOAT_BLOCK_SIZE
;
2615 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2616 float_block_index
++;
2619 MALLOC_UNBLOCK_INPUT
;
2621 XFLOAT_INIT (val
, float_value
);
2622 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2623 consing_since_gc
+= sizeof (struct Lisp_Float
);
2625 total_free_floats
--;
2631 /***********************************************************************
2633 ***********************************************************************/
2635 /* We store cons cells inside of cons_blocks, allocating a new
2636 cons_block with malloc whenever necessary. Cons cells reclaimed by
2637 GC are put on a free list to be reallocated before allocating
2638 any new cons cells from the latest cons_block. */
2640 #define CONS_BLOCK_SIZE \
2641 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2642 /* The compiler might add padding at the end. */ \
2643 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2644 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2646 #define CONS_BLOCK(fptr) \
2647 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2649 #define CONS_INDEX(fptr) \
2650 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2654 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2655 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2656 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2657 struct cons_block
*next
;
2660 #define CONS_MARKED_P(fptr) \
2661 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2663 #define CONS_MARK(fptr) \
2664 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2666 #define CONS_UNMARK(fptr) \
2667 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2669 /* Current cons_block. */
2671 static struct cons_block
*cons_block
;
2673 /* Index of first unused Lisp_Cons in the current block. */
2675 static int cons_block_index
= CONS_BLOCK_SIZE
;
2677 /* Free-list of Lisp_Cons structures. */
2679 static struct Lisp_Cons
*cons_free_list
;
2681 /* Explicitly free a cons cell by putting it on the free-list. */
2684 free_cons (struct Lisp_Cons
*ptr
)
2686 ptr
->u
.chain
= cons_free_list
;
2690 cons_free_list
= ptr
;
2691 consing_since_gc
-= sizeof *ptr
;
2692 total_free_conses
++;
2695 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2696 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2697 (Lisp_Object car
, Lisp_Object cdr
)
2699 register Lisp_Object val
;
2701 /* eassert (!handling_signal); */
2707 /* We use the cdr for chaining the free list
2708 so that we won't use the same field that has the mark bit. */
2709 XSETCONS (val
, cons_free_list
);
2710 cons_free_list
= cons_free_list
->u
.chain
;
2714 if (cons_block_index
== CONS_BLOCK_SIZE
)
2716 struct cons_block
*new
2717 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS
);
2718 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2719 new->next
= cons_block
;
2721 cons_block_index
= 0;
2722 total_free_conses
+= CONS_BLOCK_SIZE
;
2724 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2728 MALLOC_UNBLOCK_INPUT
;
2732 eassert (!CONS_MARKED_P (XCONS (val
)));
2733 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2734 total_free_conses
--;
2735 cons_cells_consed
++;
2739 #ifdef GC_CHECK_CONS_LIST
2740 /* Get an error now if there's any junk in the cons free list. */
2742 check_cons_list (void)
2744 struct Lisp_Cons
*tail
= cons_free_list
;
2747 tail
= tail
->u
.chain
;
2751 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2754 list1 (Lisp_Object arg1
)
2756 return Fcons (arg1
, Qnil
);
2760 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2762 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2767 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2769 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2774 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2776 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2781 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2783 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2784 Fcons (arg5
, Qnil
)))));
2787 /* Make a list of COUNT Lisp_Objects, where ARG is the
2788 first one. Allocate conses from pure space if TYPE
2789 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2792 listn (enum constype type
, ptrdiff_t count
, Lisp_Object arg
, ...)
2796 Lisp_Object val
, *objp
;
2798 /* Change to SAFE_ALLOCA if you hit this eassert. */
2799 eassert (count
<= MAX_ALLOCA
/ word_size
);
2801 objp
= alloca (count
* word_size
);
2804 for (i
= 1; i
< count
; i
++)
2805 objp
[i
] = va_arg (ap
, Lisp_Object
);
2808 for (val
= Qnil
, i
= count
- 1; i
>= 0; i
--)
2810 if (type
== CONSTYPE_PURE
)
2811 val
= pure_cons (objp
[i
], val
);
2812 else if (type
== CONSTYPE_HEAP
)
2813 val
= Fcons (objp
[i
], val
);
2820 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2821 doc
: /* Return a newly created list with specified arguments as elements.
2822 Any number of arguments, even zero arguments, are allowed.
2823 usage: (list &rest OBJECTS) */)
2824 (ptrdiff_t nargs
, Lisp_Object
*args
)
2826 register Lisp_Object val
;
2832 val
= Fcons (args
[nargs
], val
);
2838 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2839 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2840 (register Lisp_Object length
, Lisp_Object init
)
2842 register Lisp_Object val
;
2843 register EMACS_INT size
;
2845 CHECK_NATNUM (length
);
2846 size
= XFASTINT (length
);
2851 val
= Fcons (init
, val
);
2856 val
= Fcons (init
, val
);
2861 val
= Fcons (init
, val
);
2866 val
= Fcons (init
, val
);
2871 val
= Fcons (init
, val
);
2886 /***********************************************************************
2888 ***********************************************************************/
2890 /* This value is balanced well enough to avoid too much internal overhead
2891 for the most common cases; it's not required to be a power of two, but
2892 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2894 #define VECTOR_BLOCK_SIZE 4096
2896 /* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2899 roundup_size
= COMMON_MULTIPLE (word_size
, USE_LSB_TAG
? GCALIGNMENT
: 1)
2902 /* ROUNDUP_SIZE must be a power of 2. */
2903 verify ((roundup_size
& (roundup_size
- 1)) == 0);
2905 /* Verify assumptions described above. */
2906 verify ((VECTOR_BLOCK_SIZE
% roundup_size
) == 0);
2907 verify (VECTOR_BLOCK_SIZE
<= (1 << PSEUDOVECTOR_SIZE_BITS
));
2909 /* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2911 #define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2913 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2915 #define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2917 /* Size of the minimal vector allocated from block. */
2919 #define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2921 /* Size of the largest vector allocated from block. */
2923 #define VBLOCK_BYTES_MAX \
2924 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2926 /* We maintain one free list for each possible block-allocated
2927 vector size, and this is the number of free lists we have. */
2929 #define VECTOR_MAX_FREE_LIST_INDEX \
2930 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2932 /* Common shortcut to advance vector pointer over a block data. */
2934 #define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2936 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2938 #define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2940 /* Common shortcut to setup vector on a free list. */
2942 #define SETUP_ON_FREE_LIST(v, nbytes, index) \
2944 XSETPVECTYPESIZE (v, PVEC_FREE, nbytes); \
2945 eassert ((nbytes) % roundup_size == 0); \
2946 (index) = VINDEX (nbytes); \
2947 eassert ((index) < VECTOR_MAX_FREE_LIST_INDEX); \
2948 (v)->header.next.vector = vector_free_lists[index]; \
2949 vector_free_lists[index] = (v); \
2950 total_free_vector_slots += (nbytes) / word_size; \
2955 char data
[VECTOR_BLOCK_BYTES
];
2956 struct vector_block
*next
;
2959 /* Chain of vector blocks. */
2961 static struct vector_block
*vector_blocks
;
2963 /* Vector free lists, where NTH item points to a chain of free
2964 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2966 static struct Lisp_Vector
*vector_free_lists
[VECTOR_MAX_FREE_LIST_INDEX
];
2968 /* Singly-linked list of large vectors. */
2970 static struct Lisp_Vector
*large_vectors
;
2972 /* The only vector with 0 slots, allocated from pure space. */
2974 Lisp_Object zero_vector
;
2976 /* Number of live vectors. */
2978 static EMACS_INT total_vectors
;
2980 /* Total size of live and free vectors, in Lisp_Object units. */
2982 static EMACS_INT total_vector_slots
, total_free_vector_slots
;
2984 /* Get a new vector block. */
2986 static struct vector_block
*
2987 allocate_vector_block (void)
2989 struct vector_block
*block
= xmalloc (sizeof *block
);
2991 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2992 mem_insert (block
->data
, block
->data
+ VECTOR_BLOCK_BYTES
,
2993 MEM_TYPE_VECTOR_BLOCK
);
2996 block
->next
= vector_blocks
;
2997 vector_blocks
= block
;
3001 /* Called once to initialize vector allocation. */
3006 zero_vector
= make_pure_vector (0);
3009 /* Allocate vector from a vector block. */
3011 static struct Lisp_Vector
*
3012 allocate_vector_from_block (size_t nbytes
)
3014 struct Lisp_Vector
*vector
, *rest
;
3015 struct vector_block
*block
;
3016 size_t index
, restbytes
;
3018 eassert (VBLOCK_BYTES_MIN
<= nbytes
&& nbytes
<= VBLOCK_BYTES_MAX
);
3019 eassert (nbytes
% roundup_size
== 0);
3021 /* First, try to allocate from a free list
3022 containing vectors of the requested size. */
3023 index
= VINDEX (nbytes
);
3024 if (vector_free_lists
[index
])
3026 vector
= vector_free_lists
[index
];
3027 vector_free_lists
[index
] = vector
->header
.next
.vector
;
3028 vector
->header
.next
.nbytes
= nbytes
;
3029 total_free_vector_slots
-= nbytes
/ word_size
;
3033 /* Next, check free lists containing larger vectors. Since
3034 we will split the result, we should have remaining space
3035 large enough to use for one-slot vector at least. */
3036 for (index
= VINDEX (nbytes
+ VBLOCK_BYTES_MIN
);
3037 index
< VECTOR_MAX_FREE_LIST_INDEX
; index
++)
3038 if (vector_free_lists
[index
])
3040 /* This vector is larger than requested. */
3041 vector
= vector_free_lists
[index
];
3042 vector_free_lists
[index
] = vector
->header
.next
.vector
;
3043 vector
->header
.next
.nbytes
= nbytes
;
3044 total_free_vector_slots
-= nbytes
/ word_size
;
3046 /* Excess bytes are used for the smaller vector,
3047 which should be set on an appropriate free list. */
3048 restbytes
= index
* roundup_size
+ VBLOCK_BYTES_MIN
- nbytes
;
3049 eassert (restbytes
% roundup_size
== 0);
3050 rest
= ADVANCE (vector
, nbytes
);
3051 SETUP_ON_FREE_LIST (rest
, restbytes
, index
);
3055 /* Finally, need a new vector block. */
3056 block
= allocate_vector_block ();
3058 /* New vector will be at the beginning of this block. */
3059 vector
= (struct Lisp_Vector
*) block
->data
;
3060 vector
->header
.next
.nbytes
= nbytes
;
3062 /* If the rest of space from this block is large enough
3063 for one-slot vector at least, set up it on a free list. */
3064 restbytes
= VECTOR_BLOCK_BYTES
- nbytes
;
3065 if (restbytes
>= VBLOCK_BYTES_MIN
)
3067 eassert (restbytes
% roundup_size
== 0);
3068 rest
= ADVANCE (vector
, nbytes
);
3069 SETUP_ON_FREE_LIST (rest
, restbytes
, index
);
3074 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
3076 #define VECTOR_IN_BLOCK(vector, block) \
3077 ((char *) (vector) <= (block)->data \
3078 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
3080 /* Number of bytes used by vector-block-allocated object. This is the only
3081 place where we actually use the `nbytes' field of the vector-header.
3082 I.e. we could get rid of the `nbytes' field by computing it based on the
3085 #define PSEUDOVECTOR_NBYTES(vector) \
3086 (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) \
3087 ? vector->header.size & PSEUDOVECTOR_SIZE_MASK \
3088 : vector->header.next.nbytes)
3090 /* Reclaim space used by unmarked vectors. */
3093 sweep_vectors (void)
3095 struct vector_block
*block
= vector_blocks
, **bprev
= &vector_blocks
;
3096 struct Lisp_Vector
*vector
, *next
, **vprev
= &large_vectors
;
3098 total_vectors
= total_vector_slots
= total_free_vector_slots
= 0;
3099 memset (vector_free_lists
, 0, sizeof (vector_free_lists
));
3101 /* Looking through vector blocks. */
3103 for (block
= vector_blocks
; block
; block
= *bprev
)
3105 bool free_this_block
= 0;
3107 for (vector
= (struct Lisp_Vector
*) block
->data
;
3108 VECTOR_IN_BLOCK (vector
, block
); vector
= next
)
3110 if (VECTOR_MARKED_P (vector
))
3112 VECTOR_UNMARK (vector
);
3114 total_vector_slots
+= vector
->header
.next
.nbytes
/ word_size
;
3115 next
= ADVANCE (vector
, vector
->header
.next
.nbytes
);
3119 ptrdiff_t nbytes
= PSEUDOVECTOR_NBYTES (vector
);
3120 ptrdiff_t total_bytes
= nbytes
;
3122 next
= ADVANCE (vector
, nbytes
);
3124 /* While NEXT is not marked, try to coalesce with VECTOR,
3125 thus making VECTOR of the largest possible size. */
3127 while (VECTOR_IN_BLOCK (next
, block
))
3129 if (VECTOR_MARKED_P (next
))
3131 nbytes
= PSEUDOVECTOR_NBYTES (next
);
3132 total_bytes
+= nbytes
;
3133 next
= ADVANCE (next
, nbytes
);
3136 eassert (total_bytes
% roundup_size
== 0);
3138 if (vector
== (struct Lisp_Vector
*) block
->data
3139 && !VECTOR_IN_BLOCK (next
, block
))
3140 /* This block should be freed because all of it's
3141 space was coalesced into the only free vector. */
3142 free_this_block
= 1;
3146 SETUP_ON_FREE_LIST (vector
, total_bytes
, tmp
);
3151 if (free_this_block
)
3153 *bprev
= block
->next
;
3154 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
3155 mem_delete (mem_find (block
->data
));
3160 bprev
= &block
->next
;
3163 /* Sweep large vectors. */
3165 for (vector
= large_vectors
; vector
; vector
= *vprev
)
3167 if (VECTOR_MARKED_P (vector
))
3169 VECTOR_UNMARK (vector
);
3171 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
3173 struct Lisp_Bool_Vector
*b
= (struct Lisp_Bool_Vector
*) vector
;
3175 /* All non-bool pseudovectors are small enough to be allocated
3176 from vector blocks. This code should be redesigned if some
3177 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
3178 eassert (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_BOOL_VECTOR
));
3181 += (bool_header_size
3182 + ((b
->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
3183 / BOOL_VECTOR_BITS_PER_CHAR
)) / word_size
;
3187 += header_size
/ word_size
+ vector
->header
.size
;
3188 vprev
= &vector
->header
.next
.vector
;
3192 *vprev
= vector
->header
.next
.vector
;
3198 /* Value is a pointer to a newly allocated Lisp_Vector structure
3199 with room for LEN Lisp_Objects. */
3201 static struct Lisp_Vector
*
3202 allocate_vectorlike (ptrdiff_t len
)
3204 struct Lisp_Vector
*p
;
3208 /* This gets triggered by code which I haven't bothered to fix. --Stef */
3209 /* eassert (!handling_signal); */
3212 p
= XVECTOR (zero_vector
);
3215 size_t nbytes
= header_size
+ len
* word_size
;
3217 #ifdef DOUG_LEA_MALLOC
3218 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
3219 because mapped region contents are not preserved in
3221 mallopt (M_MMAP_MAX
, 0);
3224 if (nbytes
<= VBLOCK_BYTES_MAX
)
3225 p
= allocate_vector_from_block (vroundup (nbytes
));
3228 p
= lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
3229 p
->header
.next
.vector
= large_vectors
;
3233 #ifdef DOUG_LEA_MALLOC
3234 /* Back to a reasonable maximum of mmap'ed areas. */
3235 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
3238 consing_since_gc
+= nbytes
;
3239 vector_cells_consed
+= len
;
3242 MALLOC_UNBLOCK_INPUT
;
3248 /* Allocate a vector with LEN slots. */
3250 struct Lisp_Vector
*
3251 allocate_vector (EMACS_INT len
)
3253 struct Lisp_Vector
*v
;
3254 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
3256 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
3257 memory_full (SIZE_MAX
);
3258 v
= allocate_vectorlike (len
);
3259 v
->header
.size
= len
;
3264 /* Allocate other vector-like structures. */
3266 struct Lisp_Vector
*
3267 allocate_pseudovector (int memlen
, int lisplen
, int tag
)
3269 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3272 /* Only the first lisplen slots will be traced normally by the GC. */
3273 for (i
= 0; i
< lisplen
; ++i
)
3274 v
->contents
[i
] = Qnil
;
3276 XSETPVECTYPESIZE (v
, tag
, lisplen
);
3281 allocate_buffer (void)
3283 struct buffer
*b
= lisp_malloc (sizeof *b
, MEM_TYPE_BUFFER
);
3285 XSETPVECTYPESIZE (b
, PVEC_BUFFER
, (offsetof (struct buffer
, own_text
)
3286 - header_size
) / word_size
);
3287 /* Put B on the chain of all buffers including killed ones. */
3288 b
->header
.next
.buffer
= all_buffers
;
3290 /* Note that the rest fields of B are not initialized. */
3294 struct Lisp_Hash_Table
*
3295 allocate_hash_table (void)
3297 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3301 allocate_window (void)
3305 w
= ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3306 /* Users assumes that non-Lisp data is zeroed. */
3307 memset (&w
->current_matrix
, 0,
3308 sizeof (*w
) - offsetof (struct window
, current_matrix
));
3313 allocate_terminal (void)
3317 t
= ALLOCATE_PSEUDOVECTOR (struct terminal
, next_terminal
, PVEC_TERMINAL
);
3318 /* Users assumes that non-Lisp data is zeroed. */
3319 memset (&t
->next_terminal
, 0,
3320 sizeof (*t
) - offsetof (struct terminal
, next_terminal
));
3325 allocate_frame (void)
3329 f
= ALLOCATE_PSEUDOVECTOR (struct frame
, face_cache
, PVEC_FRAME
);
3330 /* Users assumes that non-Lisp data is zeroed. */
3331 memset (&f
->face_cache
, 0,
3332 sizeof (*f
) - offsetof (struct frame
, face_cache
));
3336 struct Lisp_Process
*
3337 allocate_process (void)
3339 struct Lisp_Process
*p
;
3341 p
= ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3342 /* Users assumes that non-Lisp data is zeroed. */
3344 sizeof (*p
) - offsetof (struct Lisp_Process
, pid
));
3348 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3349 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3350 See also the function `vector'. */)
3351 (register Lisp_Object length
, Lisp_Object init
)
3354 register ptrdiff_t sizei
;
3355 register ptrdiff_t i
;
3356 register struct Lisp_Vector
*p
;
3358 CHECK_NATNUM (length
);
3360 p
= allocate_vector (XFASTINT (length
));
3361 sizei
= XFASTINT (length
);
3362 for (i
= 0; i
< sizei
; i
++)
3363 p
->contents
[i
] = init
;
3365 XSETVECTOR (vector
, p
);
3370 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3371 doc
: /* Return a newly created vector with specified arguments as elements.
3372 Any number of arguments, even zero arguments, are allowed.
3373 usage: (vector &rest OBJECTS) */)
3374 (ptrdiff_t nargs
, Lisp_Object
*args
)
3376 register Lisp_Object len
, val
;
3378 register struct Lisp_Vector
*p
;
3380 XSETFASTINT (len
, nargs
);
3381 val
= Fmake_vector (len
, Qnil
);
3383 for (i
= 0; i
< nargs
; i
++)
3384 p
->contents
[i
] = args
[i
];
3389 make_byte_code (struct Lisp_Vector
*v
)
3391 if (v
->header
.size
> 1 && STRINGP (v
->contents
[1])
3392 && STRING_MULTIBYTE (v
->contents
[1]))
3393 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3394 earlier because they produced a raw 8-bit string for byte-code
3395 and now such a byte-code string is loaded as multibyte while
3396 raw 8-bit characters converted to multibyte form. Thus, now we
3397 must convert them back to the original unibyte form. */
3398 v
->contents
[1] = Fstring_as_unibyte (v
->contents
[1]);
3399 XSETPVECTYPE (v
, PVEC_COMPILED
);
3402 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3403 doc
: /* Create a byte-code object with specified arguments as elements.
3404 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3405 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3406 and (optional) INTERACTIVE-SPEC.
3407 The first four arguments are required; at most six have any
3409 The ARGLIST can be either like the one of `lambda', in which case the arguments
3410 will be dynamically bound before executing the byte code, or it can be an
3411 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3412 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3413 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3414 argument to catch the left-over arguments. If such an integer is used, the
3415 arguments will not be dynamically bound but will be instead pushed on the
3416 stack before executing the byte-code.
3417 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3418 (ptrdiff_t nargs
, Lisp_Object
*args
)
3420 register Lisp_Object len
, val
;
3422 register struct Lisp_Vector
*p
;
3424 /* We used to purecopy everything here, if purify-flga was set. This worked
3425 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3426 dangerous, since make-byte-code is used during execution to build
3427 closures, so any closure built during the preload phase would end up
3428 copied into pure space, including its free variables, which is sometimes
3429 just wasteful and other times plainly wrong (e.g. those free vars may want
3432 XSETFASTINT (len
, nargs
);
3433 val
= Fmake_vector (len
, Qnil
);
3436 for (i
= 0; i
< nargs
; i
++)
3437 p
->contents
[i
] = args
[i
];
3439 XSETCOMPILED (val
, p
);
3445 /***********************************************************************
3447 ***********************************************************************/
3449 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3450 of the required alignment if LSB tags are used. */
3452 union aligned_Lisp_Symbol
3454 struct Lisp_Symbol s
;
3456 unsigned char c
[(sizeof (struct Lisp_Symbol
) + GCALIGNMENT
- 1)
3461 /* Each symbol_block is just under 1020 bytes long, since malloc
3462 really allocates in units of powers of two and uses 4 bytes for its
3465 #define SYMBOL_BLOCK_SIZE \
3466 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3470 /* Place `symbols' first, to preserve alignment. */
3471 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3472 struct symbol_block
*next
;
3475 /* Current symbol block and index of first unused Lisp_Symbol
3478 static struct symbol_block
*symbol_block
;
3479 static int symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3481 /* List of free symbols. */
3483 static struct Lisp_Symbol
*symbol_free_list
;
3485 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3486 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3487 Its value and function definition are void, and its property list is nil. */)
3490 register Lisp_Object val
;
3491 register struct Lisp_Symbol
*p
;
3493 CHECK_STRING (name
);
3495 /* eassert (!handling_signal); */
3499 if (symbol_free_list
)
3501 XSETSYMBOL (val
, symbol_free_list
);
3502 symbol_free_list
= symbol_free_list
->next
;
3506 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3508 struct symbol_block
*new
3509 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL
);
3510 new->next
= symbol_block
;
3512 symbol_block_index
= 0;
3513 total_free_symbols
+= SYMBOL_BLOCK_SIZE
;
3515 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3516 symbol_block_index
++;
3519 MALLOC_UNBLOCK_INPUT
;
3522 set_symbol_name (val
, name
);
3523 set_symbol_plist (val
, Qnil
);
3524 p
->redirect
= SYMBOL_PLAINVAL
;
3525 SET_SYMBOL_VAL (p
, Qunbound
);
3526 set_symbol_function (val
, Qunbound
);
3527 set_symbol_next (val
, NULL
);
3529 p
->interned
= SYMBOL_UNINTERNED
;
3531 p
->declared_special
= 0;
3532 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3534 total_free_symbols
--;
3540 /***********************************************************************
3541 Marker (Misc) Allocation
3542 ***********************************************************************/
3544 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3545 the required alignment when LSB tags are used. */
3547 union aligned_Lisp_Misc
3551 unsigned char c
[(sizeof (union Lisp_Misc
) + GCALIGNMENT
- 1)
3556 /* Allocation of markers and other objects that share that structure.
3557 Works like allocation of conses. */
3559 #define MARKER_BLOCK_SIZE \
3560 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3564 /* Place `markers' first, to preserve alignment. */
3565 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3566 struct marker_block
*next
;
3569 static struct marker_block
*marker_block
;
3570 static int marker_block_index
= MARKER_BLOCK_SIZE
;
3572 static union Lisp_Misc
*marker_free_list
;
3574 /* Return a newly allocated Lisp_Misc object of specified TYPE. */
3577 allocate_misc (enum Lisp_Misc_Type type
)
3581 /* eassert (!handling_signal); */
3585 if (marker_free_list
)
3587 XSETMISC (val
, marker_free_list
);
3588 marker_free_list
= marker_free_list
->u_free
.chain
;
3592 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3594 struct marker_block
*new = lisp_malloc (sizeof *new, MEM_TYPE_MISC
);
3595 new->next
= marker_block
;
3597 marker_block_index
= 0;
3598 total_free_markers
+= MARKER_BLOCK_SIZE
;
3600 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3601 marker_block_index
++;
3604 MALLOC_UNBLOCK_INPUT
;
3606 --total_free_markers
;
3607 consing_since_gc
+= sizeof (union Lisp_Misc
);
3608 misc_objects_consed
++;
3609 XMISCTYPE (val
) = type
;
3610 XMISCANY (val
)->gcmarkbit
= 0;
3614 /* Free a Lisp_Misc object */
3617 free_misc (Lisp_Object misc
)
3619 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3620 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3621 marker_free_list
= XMISC (misc
);
3622 consing_since_gc
-= sizeof (union Lisp_Misc
);
3623 total_free_markers
++;
3626 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3627 INTEGER. This is used to package C values to call record_unwind_protect.
3628 The unwind function can get the C values back using XSAVE_VALUE. */
3631 make_save_value (void *pointer
, ptrdiff_t integer
)
3633 register Lisp_Object val
;
3634 register struct Lisp_Save_Value
*p
;
3636 val
= allocate_misc (Lisp_Misc_Save_Value
);
3637 p
= XSAVE_VALUE (val
);
3638 p
->pointer
= pointer
;
3639 p
->integer
= integer
;
3644 /* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3647 build_overlay (Lisp_Object start
, Lisp_Object end
, Lisp_Object plist
)
3649 register Lisp_Object overlay
;
3651 overlay
= allocate_misc (Lisp_Misc_Overlay
);
3652 OVERLAY_START (overlay
) = start
;
3653 OVERLAY_END (overlay
) = end
;
3654 set_overlay_plist (overlay
, plist
);
3655 XOVERLAY (overlay
)->next
= NULL
;
3659 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3660 doc
: /* Return a newly allocated marker which does not point at any place. */)
3663 register Lisp_Object val
;
3664 register struct Lisp_Marker
*p
;
3666 val
= allocate_misc (Lisp_Misc_Marker
);
3672 p
->insertion_type
= 0;
3676 /* Return a newly allocated marker which points into BUF
3677 at character position CHARPOS and byte position BYTEPOS. */
3680 build_marker (struct buffer
*buf
, ptrdiff_t charpos
, ptrdiff_t bytepos
)
3683 struct Lisp_Marker
*m
;
3685 /* No dead buffers here. */
3686 eassert (BUFFER_LIVE_P (buf
));
3688 /* Every character is at least one byte. */
3689 eassert (charpos
<= bytepos
);
3691 obj
= allocate_misc (Lisp_Misc_Marker
);
3694 m
->charpos
= charpos
;
3695 m
->bytepos
= bytepos
;
3696 m
->insertion_type
= 0;
3697 m
->next
= BUF_MARKERS (buf
);
3698 BUF_MARKERS (buf
) = m
;
3702 /* Put MARKER back on the free list after using it temporarily. */
3705 free_marker (Lisp_Object marker
)
3707 unchain_marker (XMARKER (marker
));
3712 /* Return a newly created vector or string with specified arguments as
3713 elements. If all the arguments are characters that can fit
3714 in a string of events, make a string; otherwise, make a vector.
3716 Any number of arguments, even zero arguments, are allowed. */
3719 make_event_array (register int nargs
, Lisp_Object
*args
)
3723 for (i
= 0; i
< nargs
; i
++)
3724 /* The things that fit in a string
3725 are characters that are in 0...127,
3726 after discarding the meta bit and all the bits above it. */
3727 if (!INTEGERP (args
[i
])
3728 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3729 return Fvector (nargs
, args
);
3731 /* Since the loop exited, we know that all the things in it are
3732 characters, so we can make a string. */
3736 result
= Fmake_string (make_number (nargs
), make_number (0));
3737 for (i
= 0; i
< nargs
; i
++)
3739 SSET (result
, i
, XINT (args
[i
]));
3740 /* Move the meta bit to the right place for a string char. */
3741 if (XINT (args
[i
]) & CHAR_META
)
3742 SSET (result
, i
, SREF (result
, i
) | 0x80);
3751 /************************************************************************
3752 Memory Full Handling
3753 ************************************************************************/
3756 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3757 there may have been size_t overflow so that malloc was never
3758 called, or perhaps malloc was invoked successfully but the
3759 resulting pointer had problems fitting into a tagged EMACS_INT. In
3760 either case this counts as memory being full even though malloc did
3764 memory_full (size_t nbytes
)
3766 /* Do not go into hysterics merely because a large request failed. */
3767 bool enough_free_memory
= 0;
3768 if (SPARE_MEMORY
< nbytes
)
3773 p
= malloc (SPARE_MEMORY
);
3777 enough_free_memory
= 1;
3779 MALLOC_UNBLOCK_INPUT
;
3782 if (! enough_free_memory
)
3788 memory_full_cons_threshold
= sizeof (struct cons_block
);
3790 /* The first time we get here, free the spare memory. */
3791 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3792 if (spare_memory
[i
])
3795 free (spare_memory
[i
]);
3796 else if (i
>= 1 && i
<= 4)
3797 lisp_align_free (spare_memory
[i
]);
3799 lisp_free (spare_memory
[i
]);
3800 spare_memory
[i
] = 0;
3803 /* Record the space now used. When it decreases substantially,
3804 we can refill the memory reserve. */
3805 #if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3806 bytes_used_when_full
= BYTES_USED
;
3810 /* This used to call error, but if we've run out of memory, we could
3811 get infinite recursion trying to build the string. */
3812 xsignal (Qnil
, Vmemory_signal_data
);
3815 /* If we released our reserve (due to running out of memory),
3816 and we have a fair amount free once again,
3817 try to set aside another reserve in case we run out once more.
3819 This is called when a relocatable block is freed in ralloc.c,
3820 and also directly from this file, in case we're not using ralloc.c. */
3823 refill_memory_reserve (void)
3825 #ifndef SYSTEM_MALLOC
3826 if (spare_memory
[0] == 0)
3827 spare_memory
[0] = malloc (SPARE_MEMORY
);
3828 if (spare_memory
[1] == 0)
3829 spare_memory
[1] = lisp_align_malloc (sizeof (struct cons_block
),
3831 if (spare_memory
[2] == 0)
3832 spare_memory
[2] = lisp_align_malloc (sizeof (struct cons_block
),
3834 if (spare_memory
[3] == 0)
3835 spare_memory
[3] = lisp_align_malloc (sizeof (struct cons_block
),
3837 if (spare_memory
[4] == 0)
3838 spare_memory
[4] = lisp_align_malloc (sizeof (struct cons_block
),
3840 if (spare_memory
[5] == 0)
3841 spare_memory
[5] = lisp_malloc (sizeof (struct string_block
),
3843 if (spare_memory
[6] == 0)
3844 spare_memory
[6] = lisp_malloc (sizeof (struct string_block
),
3846 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3847 Vmemory_full
= Qnil
;
3851 /************************************************************************
3853 ************************************************************************/
3855 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3857 /* Conservative C stack marking requires a method to identify possibly
3858 live Lisp objects given a pointer value. We do this by keeping
3859 track of blocks of Lisp data that are allocated in a red-black tree
3860 (see also the comment of mem_node which is the type of nodes in
3861 that tree). Function lisp_malloc adds information for an allocated
3862 block to the red-black tree with calls to mem_insert, and function
3863 lisp_free removes it with mem_delete. Functions live_string_p etc
3864 call mem_find to lookup information about a given pointer in the
3865 tree, and use that to determine if the pointer points to a Lisp
3868 /* Initialize this part of alloc.c. */
3873 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3874 mem_z
.parent
= NULL
;
3875 mem_z
.color
= MEM_BLACK
;
3876 mem_z
.start
= mem_z
.end
= NULL
;
3881 /* Value is a pointer to the mem_node containing START. Value is
3882 MEM_NIL if there is no node in the tree containing START. */
3884 static inline struct mem_node
*
3885 mem_find (void *start
)
3889 if (start
< min_heap_address
|| start
> max_heap_address
)
3892 /* Make the search always successful to speed up the loop below. */
3893 mem_z
.start
= start
;
3894 mem_z
.end
= (char *) start
+ 1;
3897 while (start
< p
->start
|| start
>= p
->end
)
3898 p
= start
< p
->start
? p
->left
: p
->right
;
3903 /* Insert a new node into the tree for a block of memory with start
3904 address START, end address END, and type TYPE. Value is a
3905 pointer to the node that was inserted. */
3907 static struct mem_node
*
3908 mem_insert (void *start
, void *end
, enum mem_type type
)
3910 struct mem_node
*c
, *parent
, *x
;
3912 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3913 min_heap_address
= start
;
3914 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3915 max_heap_address
= end
;
3917 /* See where in the tree a node for START belongs. In this
3918 particular application, it shouldn't happen that a node is already
3919 present. For debugging purposes, let's check that. */
3923 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3925 while (c
!= MEM_NIL
)
3927 if (start
>= c
->start
&& start
< c
->end
)
3930 c
= start
< c
->start
? c
->left
: c
->right
;
3933 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3935 while (c
!= MEM_NIL
)
3938 c
= start
< c
->start
? c
->left
: c
->right
;
3941 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3943 /* Create a new node. */
3944 #ifdef GC_MALLOC_CHECK
3945 x
= _malloc_internal (sizeof *x
);
3949 x
= xmalloc (sizeof *x
);
3955 x
->left
= x
->right
= MEM_NIL
;
3958 /* Insert it as child of PARENT or install it as root. */
3961 if (start
< parent
->start
)
3969 /* Re-establish red-black tree properties. */
3970 mem_insert_fixup (x
);
3976 /* Re-establish the red-black properties of the tree, and thereby
3977 balance the tree, after node X has been inserted; X is always red. */
3980 mem_insert_fixup (struct mem_node
*x
)
3982 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3984 /* X is red and its parent is red. This is a violation of
3985 red-black tree property #3. */
3987 if (x
->parent
== x
->parent
->parent
->left
)
3989 /* We're on the left side of our grandparent, and Y is our
3991 struct mem_node
*y
= x
->parent
->parent
->right
;
3993 if (y
->color
== MEM_RED
)
3995 /* Uncle and parent are red but should be black because
3996 X is red. Change the colors accordingly and proceed
3997 with the grandparent. */
3998 x
->parent
->color
= MEM_BLACK
;
3999 y
->color
= MEM_BLACK
;
4000 x
->parent
->parent
->color
= MEM_RED
;
4001 x
= x
->parent
->parent
;
4005 /* Parent and uncle have different colors; parent is
4006 red, uncle is black. */
4007 if (x
== x
->parent
->right
)
4010 mem_rotate_left (x
);
4013 x
->parent
->color
= MEM_BLACK
;
4014 x
->parent
->parent
->color
= MEM_RED
;
4015 mem_rotate_right (x
->parent
->parent
);
4020 /* This is the symmetrical case of above. */
4021 struct mem_node
*y
= x
->parent
->parent
->left
;
4023 if (y
->color
== MEM_RED
)
4025 x
->parent
->color
= MEM_BLACK
;
4026 y
->color
= MEM_BLACK
;
4027 x
->parent
->parent
->color
= MEM_RED
;
4028 x
= x
->parent
->parent
;
4032 if (x
== x
->parent
->left
)
4035 mem_rotate_right (x
);
4038 x
->parent
->color
= MEM_BLACK
;
4039 x
->parent
->parent
->color
= MEM_RED
;
4040 mem_rotate_left (x
->parent
->parent
);
4045 /* The root may have been changed to red due to the algorithm. Set
4046 it to black so that property #5 is satisfied. */
4047 mem_root
->color
= MEM_BLACK
;
4058 mem_rotate_left (struct mem_node
*x
)
4062 /* Turn y's left sub-tree into x's right sub-tree. */
4065 if (y
->left
!= MEM_NIL
)
4066 y
->left
->parent
= x
;
4068 /* Y's parent was x's parent. */
4070 y
->parent
= x
->parent
;
4072 /* Get the parent to point to y instead of x. */
4075 if (x
== x
->parent
->left
)
4076 x
->parent
->left
= y
;
4078 x
->parent
->right
= y
;
4083 /* Put x on y's left. */
4097 mem_rotate_right (struct mem_node
*x
)
4099 struct mem_node
*y
= x
->left
;
4102 if (y
->right
!= MEM_NIL
)
4103 y
->right
->parent
= x
;
4106 y
->parent
= x
->parent
;
4109 if (x
== x
->parent
->right
)
4110 x
->parent
->right
= y
;
4112 x
->parent
->left
= y
;
4123 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
4126 mem_delete (struct mem_node
*z
)
4128 struct mem_node
*x
, *y
;
4130 if (!z
|| z
== MEM_NIL
)
4133 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
4138 while (y
->left
!= MEM_NIL
)
4142 if (y
->left
!= MEM_NIL
)
4147 x
->parent
= y
->parent
;
4150 if (y
== y
->parent
->left
)
4151 y
->parent
->left
= x
;
4153 y
->parent
->right
= x
;
4160 z
->start
= y
->start
;
4165 if (y
->color
== MEM_BLACK
)
4166 mem_delete_fixup (x
);
4168 #ifdef GC_MALLOC_CHECK
4176 /* Re-establish the red-black properties of the tree, after a
4180 mem_delete_fixup (struct mem_node
*x
)
4182 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
4184 if (x
== x
->parent
->left
)
4186 struct mem_node
*w
= x
->parent
->right
;
4188 if (w
->color
== MEM_RED
)
4190 w
->color
= MEM_BLACK
;
4191 x
->parent
->color
= MEM_RED
;
4192 mem_rotate_left (x
->parent
);
4193 w
= x
->parent
->right
;
4196 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
4203 if (w
->right
->color
== MEM_BLACK
)
4205 w
->left
->color
= MEM_BLACK
;
4207 mem_rotate_right (w
);
4208 w
= x
->parent
->right
;
4210 w
->color
= x
->parent
->color
;
4211 x
->parent
->color
= MEM_BLACK
;
4212 w
->right
->color
= MEM_BLACK
;
4213 mem_rotate_left (x
->parent
);
4219 struct mem_node
*w
= x
->parent
->left
;
4221 if (w
->color
== MEM_RED
)
4223 w
->color
= MEM_BLACK
;
4224 x
->parent
->color
= MEM_RED
;
4225 mem_rotate_right (x
->parent
);
4226 w
= x
->parent
->left
;
4229 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
4236 if (w
->left
->color
== MEM_BLACK
)
4238 w
->right
->color
= MEM_BLACK
;
4240 mem_rotate_left (w
);
4241 w
= x
->parent
->left
;
4244 w
->color
= x
->parent
->color
;
4245 x
->parent
->color
= MEM_BLACK
;
4246 w
->left
->color
= MEM_BLACK
;
4247 mem_rotate_right (x
->parent
);
4253 x
->color
= MEM_BLACK
;
4257 /* Value is non-zero if P is a pointer to a live Lisp string on
4258 the heap. M is a pointer to the mem_block for P. */
4261 live_string_p (struct mem_node
*m
, void *p
)
4263 if (m
->type
== MEM_TYPE_STRING
)
4265 struct string_block
*b
= (struct string_block
*) m
->start
;
4266 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
4268 /* P must point to the start of a Lisp_String structure, and it
4269 must not be on the free-list. */
4271 && offset
% sizeof b
->strings
[0] == 0
4272 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
4273 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4280 /* Value is non-zero if P is a pointer to a live Lisp cons on
4281 the heap. M is a pointer to the mem_block for P. */
4284 live_cons_p (struct mem_node
*m
, void *p
)
4286 if (m
->type
== MEM_TYPE_CONS
)
4288 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4289 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
4291 /* P must point to the start of a Lisp_Cons, not be
4292 one of the unused cells in the current cons block,
4293 and not be on the free-list. */
4295 && offset
% sizeof b
->conses
[0] == 0
4296 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4298 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4299 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4306 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4307 the heap. M is a pointer to the mem_block for P. */
4310 live_symbol_p (struct mem_node
*m
, void *p
)
4312 if (m
->type
== MEM_TYPE_SYMBOL
)
4314 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4315 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4317 /* P must point to the start of a Lisp_Symbol, not be
4318 one of the unused cells in the current symbol block,
4319 and not be on the free-list. */
4321 && offset
% sizeof b
->symbols
[0] == 0
4322 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4323 && (b
!= symbol_block
4324 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4325 && !EQ (((struct Lisp_Symbol
*)p
)->function
, Vdead
));
4332 /* Value is non-zero if P is a pointer to a live Lisp float on
4333 the heap. M is a pointer to the mem_block for P. */
4336 live_float_p (struct mem_node
*m
, void *p
)
4338 if (m
->type
== MEM_TYPE_FLOAT
)
4340 struct float_block
*b
= (struct float_block
*) m
->start
;
4341 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4343 /* P must point to the start of a Lisp_Float and not be
4344 one of the unused cells in the current float block. */
4346 && offset
% sizeof b
->floats
[0] == 0
4347 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4348 && (b
!= float_block
4349 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4356 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4357 the heap. M is a pointer to the mem_block for P. */
4360 live_misc_p (struct mem_node
*m
, void *p
)
4362 if (m
->type
== MEM_TYPE_MISC
)
4364 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4365 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4367 /* P must point to the start of a Lisp_Misc, not be
4368 one of the unused cells in the current misc block,
4369 and not be on the free-list. */
4371 && offset
% sizeof b
->markers
[0] == 0
4372 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4373 && (b
!= marker_block
4374 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4375 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4382 /* Value is non-zero if P is a pointer to a live vector-like object.
4383 M is a pointer to the mem_block for P. */
4386 live_vector_p (struct mem_node
*m
, void *p
)
4388 if (m
->type
== MEM_TYPE_VECTOR_BLOCK
)
4390 /* This memory node corresponds to a vector block. */
4391 struct vector_block
*block
= (struct vector_block
*) m
->start
;
4392 struct Lisp_Vector
*vector
= (struct Lisp_Vector
*) block
->data
;
4394 /* P is in the block's allocation range. Scan the block
4395 up to P and see whether P points to the start of some
4396 vector which is not on a free list. FIXME: check whether
4397 some allocation patterns (probably a lot of short vectors)
4398 may cause a substantial overhead of this loop. */
4399 while (VECTOR_IN_BLOCK (vector
, block
)
4400 && vector
<= (struct Lisp_Vector
*) p
)
4402 if (PSEUDOVECTOR_TYPEP (&vector
->header
, PVEC_FREE
))
4403 vector
= ADVANCE (vector
, (vector
->header
.size
4404 & PSEUDOVECTOR_SIZE_MASK
));
4405 else if (vector
== p
)
4408 vector
= ADVANCE (vector
, vector
->header
.next
.nbytes
);
4411 else if (m
->type
== MEM_TYPE_VECTORLIKE
&& p
== m
->start
)
4412 /* This memory node corresponds to a large vector. */
4418 /* Value is non-zero if P is a pointer to a live buffer. M is a
4419 pointer to the mem_block for P. */
4422 live_buffer_p (struct mem_node
*m
, void *p
)
4424 /* P must point to the start of the block, and the buffer
4425 must not have been killed. */
4426 return (m
->type
== MEM_TYPE_BUFFER
4428 && !NILP (((struct buffer
*) p
)->INTERNAL_FIELD (name
)));
4431 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4435 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4437 /* Array of objects that are kept alive because the C stack contains
4438 a pattern that looks like a reference to them . */
4440 #define MAX_ZOMBIES 10
4441 static Lisp_Object zombies
[MAX_ZOMBIES
];
4443 /* Number of zombie objects. */
4445 static EMACS_INT nzombies
;
4447 /* Number of garbage collections. */
4449 static EMACS_INT ngcs
;
4451 /* Average percentage of zombies per collection. */
4453 static double avg_zombies
;
4455 /* Max. number of live and zombie objects. */
4457 static EMACS_INT max_live
, max_zombies
;
4459 /* Average number of live objects per GC. */
4461 static double avg_live
;
4463 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4464 doc
: /* Show information about live and zombie objects. */)
4467 Lisp_Object args
[8], zombie_list
= Qnil
;
4469 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4470 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4471 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4472 args
[1] = make_number (ngcs
);
4473 args
[2] = make_float (avg_live
);
4474 args
[3] = make_float (avg_zombies
);
4475 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4476 args
[5] = make_number (max_live
);
4477 args
[6] = make_number (max_zombies
);
4478 args
[7] = zombie_list
;
4479 return Fmessage (8, args
);
4482 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4485 /* Mark OBJ if we can prove it's a Lisp_Object. */
4488 mark_maybe_object (Lisp_Object obj
)
4496 po
= (void *) XPNTR (obj
);
4503 switch (XTYPE (obj
))
4506 mark_p
= (live_string_p (m
, po
)
4507 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4511 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4515 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4519 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4522 case Lisp_Vectorlike
:
4523 /* Note: can't check BUFFERP before we know it's a
4524 buffer because checking that dereferences the pointer
4525 PO which might point anywhere. */
4526 if (live_vector_p (m
, po
))
4527 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4528 else if (live_buffer_p (m
, po
))
4529 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4533 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4542 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4543 if (nzombies
< MAX_ZOMBIES
)
4544 zombies
[nzombies
] = obj
;
4553 /* If P points to Lisp data, mark that as live if it isn't already
4557 mark_maybe_pointer (void *p
)
4561 /* Quickly rule out some values which can't point to Lisp data.
4562 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4563 Otherwise, assume that Lisp data is aligned on even addresses. */
4564 if ((intptr_t) p
% (USE_LSB_TAG
? GCALIGNMENT
: 2))
4570 Lisp_Object obj
= Qnil
;
4574 case MEM_TYPE_NON_LISP
:
4575 case MEM_TYPE_SPARE
:
4576 /* Nothing to do; not a pointer to Lisp memory. */
4579 case MEM_TYPE_BUFFER
:
4580 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4581 XSETVECTOR (obj
, p
);
4585 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4589 case MEM_TYPE_STRING
:
4590 if (live_string_p (m
, p
)
4591 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4592 XSETSTRING (obj
, p
);
4596 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4600 case MEM_TYPE_SYMBOL
:
4601 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4602 XSETSYMBOL (obj
, p
);
4605 case MEM_TYPE_FLOAT
:
4606 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4610 case MEM_TYPE_VECTORLIKE
:
4611 case MEM_TYPE_VECTOR_BLOCK
:
4612 if (live_vector_p (m
, p
))
4615 XSETVECTOR (tem
, p
);
4616 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4631 /* Alignment of pointer values. Use alignof, as it sometimes returns
4632 a smaller alignment than GCC's __alignof__ and mark_memory might
4633 miss objects if __alignof__ were used. */
4634 #define GC_POINTER_ALIGNMENT alignof (void *)
4636 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4637 not suffice, which is the typical case. A host where a Lisp_Object is
4638 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4639 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4640 suffice to widen it to to a Lisp_Object and check it that way. */
4641 #if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4642 # if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4643 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4644 nor mark_maybe_object can follow the pointers. This should not occur on
4645 any practical porting target. */
4646 # error "MSB type bits straddle pointer-word boundaries"
4648 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4649 pointer words that hold pointers ORed with type bits. */
4650 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4652 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4653 words that hold unmodified pointers. */
4654 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4657 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4658 or END+OFFSET..START. */
4661 mark_memory (void *start
, void *end
)
4662 #if defined (__clang__) && defined (__has_feature)
4663 #if __has_feature(address_sanitizer)
4664 /* Do not allow -faddress-sanitizer to check this function, since it
4665 crosses the function stack boundary, and thus would yield many
4667 __attribute__((no_address_safety_analysis
))
4674 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4678 /* Make START the pointer to the start of the memory region,
4679 if it isn't already. */
4687 /* Mark Lisp data pointed to. This is necessary because, in some
4688 situations, the C compiler optimizes Lisp objects away, so that
4689 only a pointer to them remains. Example:
4691 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4694 Lisp_Object obj = build_string ("test");
4695 struct Lisp_String *s = XSTRING (obj);
4696 Fgarbage_collect ();
4697 fprintf (stderr, "test `%s'\n", s->data);
4701 Here, `obj' isn't really used, and the compiler optimizes it
4702 away. The only reference to the life string is through the
4705 for (pp
= start
; (void *) pp
< end
; pp
++)
4706 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4708 void *p
= *(void **) ((char *) pp
+ i
);
4709 mark_maybe_pointer (p
);
4710 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4711 mark_maybe_object (XIL ((intptr_t) p
));
4715 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4716 the GCC system configuration. In gcc 3.2, the only systems for
4717 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4718 by others?) and ns32k-pc532-min. */
4720 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4722 static bool setjmp_tested_p
;
4723 static int longjmps_done
;
4725 #define SETJMP_WILL_LIKELY_WORK "\
4727 Emacs garbage collector has been changed to use conservative stack\n\
4728 marking. Emacs has determined that the method it uses to do the\n\
4729 marking will likely work on your system, but this isn't sure.\n\
4731 If you are a system-programmer, or can get the help of a local wizard\n\
4732 who is, please take a look at the function mark_stack in alloc.c, and\n\
4733 verify that the methods used are appropriate for your system.\n\
4735 Please mail the result to <emacs-devel@gnu.org>.\n\
4738 #define SETJMP_WILL_NOT_WORK "\
4740 Emacs garbage collector has been changed to use conservative stack\n\
4741 marking. Emacs has determined that the default method it uses to do the\n\
4742 marking will not work on your system. We will need a system-dependent\n\
4743 solution for your system.\n\
4745 Please take a look at the function mark_stack in alloc.c, and\n\
4746 try to find a way to make it work on your system.\n\
4748 Note that you may get false negatives, depending on the compiler.\n\
4749 In particular, you need to use -O with GCC for this test.\n\
4751 Please mail the result to <emacs-devel@gnu.org>.\n\
4755 /* Perform a quick check if it looks like setjmp saves registers in a
4756 jmp_buf. Print a message to stderr saying so. When this test
4757 succeeds, this is _not_ a proof that setjmp is sufficient for
4758 conservative stack marking. Only the sources or a disassembly
4768 /* Arrange for X to be put in a register. */
4774 if (longjmps_done
== 1)
4776 /* Came here after the longjmp at the end of the function.
4778 If x == 1, the longjmp has restored the register to its
4779 value before the setjmp, and we can hope that setjmp
4780 saves all such registers in the jmp_buf, although that
4783 For other values of X, either something really strange is
4784 taking place, or the setjmp just didn't save the register. */
4787 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4790 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4797 if (longjmps_done
== 1)
4798 sys_longjmp (jbuf
, 1);
4801 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4804 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4806 /* Abort if anything GCPRO'd doesn't survive the GC. */
4814 for (p
= gcprolist
; p
; p
= p
->next
)
4815 for (i
= 0; i
< p
->nvars
; ++i
)
4816 if (!survives_gc_p (p
->var
[i
]))
4817 /* FIXME: It's not necessarily a bug. It might just be that the
4818 GCPRO is unnecessary or should release the object sooner. */
4822 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4829 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4830 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4832 fprintf (stderr
, " %d = ", i
);
4833 debug_print (zombies
[i
]);
4837 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4840 /* Mark live Lisp objects on the C stack.
4842 There are several system-dependent problems to consider when
4843 porting this to new architectures:
4847 We have to mark Lisp objects in CPU registers that can hold local
4848 variables or are used to pass parameters.
4850 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4851 something that either saves relevant registers on the stack, or
4852 calls mark_maybe_object passing it each register's contents.
4854 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4855 implementation assumes that calling setjmp saves registers we need
4856 to see in a jmp_buf which itself lies on the stack. This doesn't
4857 have to be true! It must be verified for each system, possibly
4858 by taking a look at the source code of setjmp.
4860 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4861 can use it as a machine independent method to store all registers
4862 to the stack. In this case the macros described in the previous
4863 two paragraphs are not used.
4867 Architectures differ in the way their processor stack is organized.
4868 For example, the stack might look like this
4871 | Lisp_Object | size = 4
4873 | something else | size = 2
4875 | Lisp_Object | size = 4
4879 In such a case, not every Lisp_Object will be aligned equally. To
4880 find all Lisp_Object on the stack it won't be sufficient to walk
4881 the stack in steps of 4 bytes. Instead, two passes will be
4882 necessary, one starting at the start of the stack, and a second
4883 pass starting at the start of the stack + 2. Likewise, if the
4884 minimal alignment of Lisp_Objects on the stack is 1, four passes
4885 would be necessary, each one starting with one byte more offset
4886 from the stack start. */
4893 #ifdef HAVE___BUILTIN_UNWIND_INIT
4894 /* Force callee-saved registers and register windows onto the stack.
4895 This is the preferred method if available, obviating the need for
4896 machine dependent methods. */
4897 __builtin_unwind_init ();
4899 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4900 #ifndef GC_SAVE_REGISTERS_ON_STACK
4901 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4902 union aligned_jmpbuf
{
4906 volatile bool stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4908 /* This trick flushes the register windows so that all the state of
4909 the process is contained in the stack. */
4910 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4911 needed on ia64 too. See mach_dep.c, where it also says inline
4912 assembler doesn't work with relevant proprietary compilers. */
4914 #if defined (__sparc64__) && defined (__FreeBSD__)
4915 /* FreeBSD does not have a ta 3 handler. */
4922 /* Save registers that we need to see on the stack. We need to see
4923 registers used to hold register variables and registers used to
4925 #ifdef GC_SAVE_REGISTERS_ON_STACK
4926 GC_SAVE_REGISTERS_ON_STACK (end
);
4927 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4929 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4930 setjmp will definitely work, test it
4931 and print a message with the result
4933 if (!setjmp_tested_p
)
4935 setjmp_tested_p
= 1;
4938 #endif /* GC_SETJMP_WORKS */
4941 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4942 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4943 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4945 /* This assumes that the stack is a contiguous region in memory. If
4946 that's not the case, something has to be done here to iterate
4947 over the stack segments. */
4948 mark_memory (stack_base
, end
);
4950 /* Allow for marking a secondary stack, like the register stack on the
4952 #ifdef GC_MARK_SECONDARY_STACK
4953 GC_MARK_SECONDARY_STACK ();
4956 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4961 #endif /* GC_MARK_STACK != 0 */
4964 /* Determine whether it is safe to access memory at address P. */
4966 valid_pointer_p (void *p
)
4969 return w32_valid_pointer_p (p
, 16);
4973 /* Obviously, we cannot just access it (we would SEGV trying), so we
4974 trick the o/s to tell us whether p is a valid pointer.
4975 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4976 not validate p in that case. */
4980 bool valid
= emacs_write (fd
[1], (char *) p
, 16) == 16;
4981 emacs_close (fd
[1]);
4982 emacs_close (fd
[0]);
4990 /* Return 2 if OBJ is a killed or special buffer object.
4991 Return 1 if OBJ is a valid lisp object.
4992 Return 0 if OBJ is NOT a valid lisp object.
4993 Return -1 if we cannot validate OBJ.
4994 This function can be quite slow,
4995 so it should only be used in code for manual debugging. */
4998 valid_lisp_object_p (Lisp_Object obj
)
5008 p
= (void *) XPNTR (obj
);
5009 if (PURE_POINTER_P (p
))
5012 if (p
== &buffer_defaults
|| p
== &buffer_local_symbols
)
5016 return valid_pointer_p (p
);
5023 int valid
= valid_pointer_p (p
);
5035 case MEM_TYPE_NON_LISP
:
5036 case MEM_TYPE_SPARE
:
5039 case MEM_TYPE_BUFFER
:
5040 return live_buffer_p (m
, p
) ? 1 : 2;
5043 return live_cons_p (m
, p
);
5045 case MEM_TYPE_STRING
:
5046 return live_string_p (m
, p
);
5049 return live_misc_p (m
, p
);
5051 case MEM_TYPE_SYMBOL
:
5052 return live_symbol_p (m
, p
);
5054 case MEM_TYPE_FLOAT
:
5055 return live_float_p (m
, p
);
5057 case MEM_TYPE_VECTORLIKE
:
5058 case MEM_TYPE_VECTOR_BLOCK
:
5059 return live_vector_p (m
, p
);
5072 /***********************************************************************
5073 Pure Storage Management
5074 ***********************************************************************/
5076 /* Allocate room for SIZE bytes from pure Lisp storage and return a
5077 pointer to it. TYPE is the Lisp type for which the memory is
5078 allocated. TYPE < 0 means it's not used for a Lisp object. */
5081 pure_alloc (size_t size
, int type
)
5085 size_t alignment
= GCALIGNMENT
;
5087 size_t alignment
= alignof (EMACS_INT
);
5089 /* Give Lisp_Floats an extra alignment. */
5090 if (type
== Lisp_Float
)
5091 alignment
= alignof (struct Lisp_Float
);
5097 /* Allocate space for a Lisp object from the beginning of the free
5098 space with taking account of alignment. */
5099 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
5100 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
5104 /* Allocate space for a non-Lisp object from the end of the free
5106 pure_bytes_used_non_lisp
+= size
;
5107 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5109 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
5111 if (pure_bytes_used
<= pure_size
)
5114 /* Don't allocate a large amount here,
5115 because it might get mmap'd and then its address
5116 might not be usable. */
5117 purebeg
= xmalloc (10000);
5119 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
5120 pure_bytes_used
= 0;
5121 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
5126 /* Print a warning if PURESIZE is too small. */
5129 check_pure_size (void)
5131 if (pure_bytes_used_before_overflow
)
5132 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
5134 pure_bytes_used
+ pure_bytes_used_before_overflow
);
5138 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5139 the non-Lisp data pool of the pure storage, and return its start
5140 address. Return NULL if not found. */
5143 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
5146 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
5147 const unsigned char *p
;
5150 if (pure_bytes_used_non_lisp
<= nbytes
)
5153 /* Set up the Boyer-Moore table. */
5155 for (i
= 0; i
< 256; i
++)
5158 p
= (const unsigned char *) data
;
5160 bm_skip
[*p
++] = skip
;
5162 last_char_skip
= bm_skip
['\0'];
5164 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
5165 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
5167 /* See the comments in the function `boyer_moore' (search.c) for the
5168 use of `infinity'. */
5169 infinity
= pure_bytes_used_non_lisp
+ 1;
5170 bm_skip
['\0'] = infinity
;
5172 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
5176 /* Check the last character (== '\0'). */
5179 start
+= bm_skip
[*(p
+ start
)];
5181 while (start
<= start_max
);
5183 if (start
< infinity
)
5184 /* Couldn't find the last character. */
5187 /* No less than `infinity' means we could find the last
5188 character at `p[start - infinity]'. */
5191 /* Check the remaining characters. */
5192 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
5194 return non_lisp_beg
+ start
;
5196 start
+= last_char_skip
;
5198 while (start
<= start_max
);
5204 /* Return a string allocated in pure space. DATA is a buffer holding
5205 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
5206 means make the result string multibyte.
5208 Must get an error if pure storage is full, since if it cannot hold
5209 a large string it may be able to hold conses that point to that
5210 string; then the string is not protected from gc. */
5213 make_pure_string (const char *data
,
5214 ptrdiff_t nchars
, ptrdiff_t nbytes
, bool multibyte
)
5217 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5218 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
5219 if (s
->data
== NULL
)
5221 s
->data
= pure_alloc (nbytes
+ 1, -1);
5222 memcpy (s
->data
, data
, nbytes
);
5223 s
->data
[nbytes
] = '\0';
5226 s
->size_byte
= multibyte
? nbytes
: -1;
5227 s
->intervals
= NULL
;
5228 XSETSTRING (string
, s
);
5232 /* Return a string allocated in pure space. Do not
5233 allocate the string data, just point to DATA. */
5236 make_pure_c_string (const char *data
, ptrdiff_t nchars
)
5239 struct Lisp_String
*s
= pure_alloc (sizeof *s
, Lisp_String
);
5242 s
->data
= (unsigned char *) data
;
5243 s
->intervals
= NULL
;
5244 XSETSTRING (string
, s
);
5248 /* Return a cons allocated from pure space. Give it pure copies
5249 of CAR as car and CDR as cdr. */
5252 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
5255 struct Lisp_Cons
*p
= pure_alloc (sizeof *p
, Lisp_Cons
);
5257 XSETCAR (new, Fpurecopy (car
));
5258 XSETCDR (new, Fpurecopy (cdr
));
5263 /* Value is a float object with value NUM allocated from pure space. */
5266 make_pure_float (double num
)
5269 struct Lisp_Float
*p
= pure_alloc (sizeof *p
, Lisp_Float
);
5271 XFLOAT_INIT (new, num
);
5276 /* Return a vector with room for LEN Lisp_Objects allocated from
5280 make_pure_vector (ptrdiff_t len
)
5283 size_t size
= header_size
+ len
* word_size
;
5284 struct Lisp_Vector
*p
= pure_alloc (size
, Lisp_Vectorlike
);
5285 XSETVECTOR (new, p
);
5286 XVECTOR (new)->header
.size
= len
;
5291 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
5292 doc
: /* Make a copy of object OBJ in pure storage.
5293 Recursively copies contents of vectors and cons cells.
5294 Does not copy symbols. Copies strings without text properties. */)
5295 (register Lisp_Object obj
)
5297 if (NILP (Vpurify_flag
))
5300 if (PURE_POINTER_P (XPNTR (obj
)))
5303 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5305 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
5311 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
5312 else if (FLOATP (obj
))
5313 obj
= make_pure_float (XFLOAT_DATA (obj
));
5314 else if (STRINGP (obj
))
5315 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
5317 STRING_MULTIBYTE (obj
));
5318 else if (COMPILEDP (obj
) || VECTORP (obj
))
5320 register struct Lisp_Vector
*vec
;
5321 register ptrdiff_t i
;
5325 if (size
& PSEUDOVECTOR_FLAG
)
5326 size
&= PSEUDOVECTOR_SIZE_MASK
;
5327 vec
= XVECTOR (make_pure_vector (size
));
5328 for (i
= 0; i
< size
; i
++)
5329 vec
->contents
[i
] = Fpurecopy (AREF (obj
, i
));
5330 if (COMPILEDP (obj
))
5332 XSETPVECTYPE (vec
, PVEC_COMPILED
);
5333 XSETCOMPILED (obj
, vec
);
5336 XSETVECTOR (obj
, vec
);
5338 else if (MARKERP (obj
))
5339 error ("Attempt to copy a marker to pure storage");
5341 /* Not purified, don't hash-cons. */
5344 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5345 Fputhash (obj
, obj
, Vpurify_flag
);
5352 /***********************************************************************
5354 ***********************************************************************/
5356 /* Put an entry in staticvec, pointing at the variable with address
5360 staticpro (Lisp_Object
*varaddress
)
5362 staticvec
[staticidx
++] = varaddress
;
5363 if (staticidx
>= NSTATICS
)
5368 /***********************************************************************
5370 ***********************************************************************/
5372 /* Temporarily prevent garbage collection. */
5375 inhibit_garbage_collection (void)
5377 ptrdiff_t count
= SPECPDL_INDEX ();
5379 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5383 /* Used to avoid possible overflows when
5384 converting from C to Lisp integers. */
5386 static inline Lisp_Object
5387 bounded_number (EMACS_INT number
)
5389 return make_number (min (MOST_POSITIVE_FIXNUM
, number
));
5392 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5393 doc
: /* Reclaim storage for Lisp objects no longer needed.
5394 Garbage collection happens automatically if you cons more than
5395 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5396 `garbage-collect' normally returns a list with info on amount of space in use,
5397 where each entry has the form (NAME SIZE USED FREE), where:
5398 - NAME is a symbol describing the kind of objects this entry represents,
5399 - SIZE is the number of bytes used by each one,
5400 - USED is the number of those objects that were found live in the heap,
5401 - FREE is the number of those objects that are not live but that Emacs
5402 keeps around for future allocations (maybe because it does not know how
5403 to return them to the OS).
5404 However, if there was overflow in pure space, `garbage-collect'
5405 returns nil, because real GC can't be done.
5406 See Info node `(elisp)Garbage Collection'. */)
5409 struct specbinding
*bind
;
5410 struct buffer
*nextb
;
5411 char stack_top_variable
;
5414 ptrdiff_t count
= SPECPDL_INDEX ();
5416 Lisp_Object retval
= Qnil
;
5421 /* Can't GC if pure storage overflowed because we can't determine
5422 if something is a pure object or not. */
5423 if (pure_bytes_used_before_overflow
)
5428 /* Don't keep undo information around forever.
5429 Do this early on, so it is no problem if the user quits. */
5430 FOR_EACH_BUFFER (nextb
)
5431 compact_buffer (nextb
);
5433 start
= current_emacs_time ();
5435 /* In case user calls debug_print during GC,
5436 don't let that cause a recursive GC. */
5437 consing_since_gc
= 0;
5439 /* Save what's currently displayed in the echo area. */
5440 message_p
= push_message ();
5441 record_unwind_protect (pop_message_unwind
, Qnil
);
5443 /* Save a copy of the contents of the stack, for debugging. */
5444 #if MAX_SAVE_STACK > 0
5445 if (NILP (Vpurify_flag
))
5448 ptrdiff_t stack_size
;
5449 if (&stack_top_variable
< stack_bottom
)
5451 stack
= &stack_top_variable
;
5452 stack_size
= stack_bottom
- &stack_top_variable
;
5456 stack
= stack_bottom
;
5457 stack_size
= &stack_top_variable
- stack_bottom
;
5459 if (stack_size
<= MAX_SAVE_STACK
)
5461 if (stack_copy_size
< stack_size
)
5463 stack_copy
= xrealloc (stack_copy
, stack_size
);
5464 stack_copy_size
= stack_size
;
5466 memcpy (stack_copy
, stack
, stack_size
);
5469 #endif /* MAX_SAVE_STACK > 0 */
5471 if (garbage_collection_messages
)
5472 message1_nolog ("Garbage collecting...");
5476 shrink_regexp_cache ();
5480 /* Mark all the special slots that serve as the roots of accessibility. */
5482 mark_buffer (&buffer_defaults
);
5483 mark_buffer (&buffer_local_symbols
);
5485 for (i
= 0; i
< staticidx
; i
++)
5486 mark_object (*staticvec
[i
]);
5488 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5490 mark_object (bind
->symbol
);
5491 mark_object (bind
->old_value
);
5500 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5501 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5505 register struct gcpro
*tail
;
5506 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5507 for (i
= 0; i
< tail
->nvars
; i
++)
5508 mark_object (tail
->var
[i
]);
5512 struct catchtag
*catch;
5513 struct handler
*handler
;
5515 for (catch = catchlist
; catch; catch = catch->next
)
5517 mark_object (catch->tag
);
5518 mark_object (catch->val
);
5520 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5522 mark_object (handler
->handler
);
5523 mark_object (handler
->var
);
5529 #ifdef HAVE_WINDOW_SYSTEM
5530 mark_fringe_data ();
5533 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5537 /* Everything is now marked, except for the things that require special
5538 finalization, i.e. the undo_list.
5539 Look thru every buffer's undo list
5540 for elements that update markers that were not marked,
5542 FOR_EACH_BUFFER (nextb
)
5544 /* If a buffer's undo list is Qt, that means that undo is
5545 turned off in that buffer. Calling truncate_undo_list on
5546 Qt tends to return NULL, which effectively turns undo back on.
5547 So don't call truncate_undo_list if undo_list is Qt. */
5548 if (! EQ (nextb
->INTERNAL_FIELD (undo_list
), Qt
))
5550 Lisp_Object tail
, prev
;
5551 tail
= nextb
->INTERNAL_FIELD (undo_list
);
5553 while (CONSP (tail
))
5555 if (CONSP (XCAR (tail
))
5556 && MARKERP (XCAR (XCAR (tail
)))
5557 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5560 nextb
->INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5564 XSETCDR (prev
, tail
);
5574 /* Now that we have stripped the elements that need not be in the
5575 undo_list any more, we can finally mark the list. */
5576 mark_object (nextb
->INTERNAL_FIELD (undo_list
));
5581 /* Clear the mark bits that we set in certain root slots. */
5583 unmark_byte_stack ();
5584 VECTOR_UNMARK (&buffer_defaults
);
5585 VECTOR_UNMARK (&buffer_local_symbols
);
5587 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5597 consing_since_gc
= 0;
5598 if (gc_cons_threshold
< GC_DEFAULT_THRESHOLD
/ 10)
5599 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
/ 10;
5601 gc_relative_threshold
= 0;
5602 if (FLOATP (Vgc_cons_percentage
))
5603 { /* Set gc_cons_combined_threshold. */
5606 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5607 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5608 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5609 tot
+= total_string_bytes
;
5610 tot
+= total_vector_slots
* word_size
;
5611 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5612 tot
+= total_intervals
* sizeof (struct interval
);
5613 tot
+= total_strings
* sizeof (struct Lisp_String
);
5615 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5618 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5619 gc_relative_threshold
= tot
;
5621 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5625 if (garbage_collection_messages
)
5627 if (message_p
|| minibuf_level
> 0)
5630 message1_nolog ("Garbage collecting...done");
5633 unbind_to (count
, Qnil
);
5635 Lisp_Object total
[11];
5636 int total_size
= 10;
5638 total
[0] = list4 (Qconses
, make_number (sizeof (struct Lisp_Cons
)),
5639 bounded_number (total_conses
),
5640 bounded_number (total_free_conses
));
5642 total
[1] = list4 (Qsymbols
, make_number (sizeof (struct Lisp_Symbol
)),
5643 bounded_number (total_symbols
),
5644 bounded_number (total_free_symbols
));
5646 total
[2] = list4 (Qmiscs
, make_number (sizeof (union Lisp_Misc
)),
5647 bounded_number (total_markers
),
5648 bounded_number (total_free_markers
));
5650 total
[3] = list4 (Qstrings
, make_number (sizeof (struct Lisp_String
)),
5651 bounded_number (total_strings
),
5652 bounded_number (total_free_strings
));
5654 total
[4] = list3 (Qstring_bytes
, make_number (1),
5655 bounded_number (total_string_bytes
));
5657 total
[5] = list3 (Qvectors
, make_number (sizeof (struct Lisp_Vector
)),
5658 bounded_number (total_vectors
));
5660 total
[6] = list4 (Qvector_slots
, make_number (word_size
),
5661 bounded_number (total_vector_slots
),
5662 bounded_number (total_free_vector_slots
));
5664 total
[7] = list4 (Qfloats
, make_number (sizeof (struct Lisp_Float
)),
5665 bounded_number (total_floats
),
5666 bounded_number (total_free_floats
));
5668 total
[8] = list4 (Qintervals
, make_number (sizeof (struct interval
)),
5669 bounded_number (total_intervals
),
5670 bounded_number (total_free_intervals
));
5672 total
[9] = list3 (Qbuffers
, make_number (sizeof (struct buffer
)),
5673 bounded_number (total_buffers
));
5675 #ifdef DOUG_LEA_MALLOC
5677 total
[10] = list4 (Qheap
, make_number (1024),
5678 bounded_number ((mallinfo ().uordblks
+ 1023) >> 10),
5679 bounded_number ((mallinfo ().fordblks
+ 1023) >> 10));
5681 retval
= Flist (total_size
, total
);
5684 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5686 /* Compute average percentage of zombies. */
5688 = (total_conses
+ total_symbols
+ total_markers
+ total_strings
5689 + total_vectors
+ total_floats
+ total_intervals
+ total_buffers
);
5691 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5692 max_live
= max (nlive
, max_live
);
5693 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5694 max_zombies
= max (nzombies
, max_zombies
);
5699 if (!NILP (Vpost_gc_hook
))
5701 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5702 safe_run_hooks (Qpost_gc_hook
);
5703 unbind_to (gc_count
, Qnil
);
5706 /* Accumulate statistics. */
5707 if (FLOATP (Vgc_elapsed
))
5709 EMACS_TIME since_start
= sub_emacs_time (current_emacs_time (), start
);
5710 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
)
5711 + EMACS_TIME_TO_DOUBLE (since_start
));
5720 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5721 only interesting objects referenced from glyphs are strings. */
5724 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5726 struct glyph_row
*row
= matrix
->rows
;
5727 struct glyph_row
*end
= row
+ matrix
->nrows
;
5729 for (; row
< end
; ++row
)
5733 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5735 struct glyph
*glyph
= row
->glyphs
[area
];
5736 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5738 for (; glyph
< end_glyph
; ++glyph
)
5739 if (STRINGP (glyph
->object
)
5740 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5741 mark_object (glyph
->object
);
5747 /* Mark Lisp faces in the face cache C. */
5750 mark_face_cache (struct face_cache
*c
)
5755 for (i
= 0; i
< c
->used
; ++i
)
5757 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5761 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5762 mark_object (face
->lface
[j
]);
5770 /* Mark reference to a Lisp_Object.
5771 If the object referred to has not been seen yet, recursively mark
5772 all the references contained in it. */
5774 #define LAST_MARKED_SIZE 500
5775 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5776 static int last_marked_index
;
5778 /* For debugging--call abort when we cdr down this many
5779 links of a list, in mark_object. In debugging,
5780 the call to abort will hit a breakpoint.
5781 Normally this is zero and the check never goes off. */
5782 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5785 mark_vectorlike (struct Lisp_Vector
*ptr
)
5787 ptrdiff_t size
= ptr
->header
.size
;
5790 eassert (!VECTOR_MARKED_P (ptr
));
5791 VECTOR_MARK (ptr
); /* Else mark it. */
5792 if (size
& PSEUDOVECTOR_FLAG
)
5793 size
&= PSEUDOVECTOR_SIZE_MASK
;
5795 /* Note that this size is not the memory-footprint size, but only
5796 the number of Lisp_Object fields that we should trace.
5797 The distinction is used e.g. by Lisp_Process which places extra
5798 non-Lisp_Object fields at the end of the structure... */
5799 for (i
= 0; i
< size
; i
++) /* ...and then mark its elements. */
5800 mark_object (ptr
->contents
[i
]);
5803 /* Like mark_vectorlike but optimized for char-tables (and
5804 sub-char-tables) assuming that the contents are mostly integers or
5808 mark_char_table (struct Lisp_Vector
*ptr
)
5810 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5813 eassert (!VECTOR_MARKED_P (ptr
));
5815 for (i
= 0; i
< size
; i
++)
5817 Lisp_Object val
= ptr
->contents
[i
];
5819 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5821 if (SUB_CHAR_TABLE_P (val
))
5823 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5824 mark_char_table (XVECTOR (val
));
5831 /* Mark the chain of overlays starting at PTR. */
5834 mark_overlay (struct Lisp_Overlay
*ptr
)
5836 for (; ptr
&& !ptr
->gcmarkbit
; ptr
= ptr
->next
)
5839 mark_object (ptr
->start
);
5840 mark_object (ptr
->end
);
5841 mark_object (ptr
->plist
);
5845 /* Mark Lisp_Objects and special pointers in BUFFER. */
5848 mark_buffer (struct buffer
*buffer
)
5850 /* This is handled much like other pseudovectors... */
5851 mark_vectorlike ((struct Lisp_Vector
*) buffer
);
5853 /* ...but there are some buffer-specific things. */
5855 MARK_INTERVAL_TREE (buffer_intervals (buffer
));
5857 /* For now, we just don't mark the undo_list. It's done later in
5858 a special way just before the sweep phase, and after stripping
5859 some of its elements that are not needed any more. */
5861 mark_overlay (buffer
->overlays_before
);
5862 mark_overlay (buffer
->overlays_after
);
5864 /* If this is an indirect buffer, mark its base buffer. */
5865 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5866 mark_buffer (buffer
->base_buffer
);
5869 /* Remove killed buffers or items whose car is a killed buffer from
5870 LIST, and mark other items. Return changed LIST, which is marked. */
5873 mark_discard_killed_buffers (Lisp_Object list
)
5875 Lisp_Object tail
, *prev
= &list
;
5877 for (tail
= list
; CONSP (tail
) && !CONS_MARKED_P (XCONS (tail
));
5880 Lisp_Object tem
= XCAR (tail
);
5883 if (BUFFERP (tem
) && !BUFFER_LIVE_P (XBUFFER (tem
)))
5884 *prev
= XCDR (tail
);
5887 CONS_MARK (XCONS (tail
));
5888 mark_object (XCAR (tail
));
5889 prev
= &XCDR_AS_LVALUE (tail
);
5895 /* Determine type of generic Lisp_Object and mark it accordingly. */
5898 mark_object (Lisp_Object arg
)
5900 register Lisp_Object obj
= arg
;
5901 #ifdef GC_CHECK_MARKED_OBJECTS
5905 ptrdiff_t cdr_count
= 0;
5909 if (PURE_POINTER_P (XPNTR (obj
)))
5912 last_marked
[last_marked_index
++] = obj
;
5913 if (last_marked_index
== LAST_MARKED_SIZE
)
5914 last_marked_index
= 0;
5916 /* Perform some sanity checks on the objects marked here. Abort if
5917 we encounter an object we know is bogus. This increases GC time
5918 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5919 #ifdef GC_CHECK_MARKED_OBJECTS
5921 po
= (void *) XPNTR (obj
);
5923 /* Check that the object pointed to by PO is known to be a Lisp
5924 structure allocated from the heap. */
5925 #define CHECK_ALLOCATED() \
5927 m = mem_find (po); \
5932 /* Check that the object pointed to by PO is live, using predicate
5934 #define CHECK_LIVE(LIVEP) \
5936 if (!LIVEP (m, po)) \
5940 /* Check both of the above conditions. */
5941 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5943 CHECK_ALLOCATED (); \
5944 CHECK_LIVE (LIVEP); \
5947 #else /* not GC_CHECK_MARKED_OBJECTS */
5949 #define CHECK_LIVE(LIVEP) (void) 0
5950 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5952 #endif /* not GC_CHECK_MARKED_OBJECTS */
5954 switch (XTYPE (obj
))
5958 register struct Lisp_String
*ptr
= XSTRING (obj
);
5959 if (STRING_MARKED_P (ptr
))
5961 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5963 MARK_INTERVAL_TREE (ptr
->intervals
);
5964 #ifdef GC_CHECK_STRING_BYTES
5965 /* Check that the string size recorded in the string is the
5966 same as the one recorded in the sdata structure. */
5968 #endif /* GC_CHECK_STRING_BYTES */
5972 case Lisp_Vectorlike
:
5974 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5975 register ptrdiff_t pvectype
;
5977 if (VECTOR_MARKED_P (ptr
))
5980 #ifdef GC_CHECK_MARKED_OBJECTS
5982 if (m
== MEM_NIL
&& !SUBRP (obj
))
5984 #endif /* GC_CHECK_MARKED_OBJECTS */
5986 if (ptr
->header
.size
& PSEUDOVECTOR_FLAG
)
5987 pvectype
= ((ptr
->header
.size
& PVEC_TYPE_MASK
)
5988 >> PSEUDOVECTOR_SIZE_BITS
);
5992 if (pvectype
!= PVEC_SUBR
&& pvectype
!= PVEC_BUFFER
)
5993 CHECK_LIVE (live_vector_p
);
5998 #ifdef GC_CHECK_MARKED_OBJECTS
6007 #endif /* GC_CHECK_MARKED_OBJECTS */
6008 mark_buffer ((struct buffer
*) ptr
);
6012 { /* We could treat this just like a vector, but it is better
6013 to save the COMPILED_CONSTANTS element for last and avoid
6015 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
6019 for (i
= 0; i
< size
; i
++)
6020 if (i
!= COMPILED_CONSTANTS
)
6021 mark_object (ptr
->contents
[i
]);
6022 if (size
> COMPILED_CONSTANTS
)
6024 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
6031 mark_vectorlike (ptr
);
6032 mark_face_cache (((struct frame
*) ptr
)->face_cache
);
6037 struct window
*w
= (struct window
*) ptr
;
6038 bool leaf
= NILP (w
->hchild
) && NILP (w
->vchild
);
6040 /* For live windows, Lisp code filters out killed buffers
6041 from both buffer lists. For dead windows, we do it here
6042 in attempt to help GC to reclaim killed buffers faster. */
6043 if (leaf
&& NILP (w
->buffer
))
6046 (w
, mark_discard_killed_buffers (w
->prev_buffers
));
6048 (w
, mark_discard_killed_buffers (w
->next_buffers
));
6051 mark_vectorlike (ptr
);
6052 /* Mark glyphs for leaf windows. Marking window
6053 matrices is sufficient because frame matrices
6054 use the same glyph memory. */
6055 if (leaf
&& w
->current_matrix
)
6057 mark_glyph_matrix (w
->current_matrix
);
6058 mark_glyph_matrix (w
->desired_matrix
);
6063 case PVEC_HASH_TABLE
:
6065 struct Lisp_Hash_Table
*h
= (struct Lisp_Hash_Table
*) ptr
;
6067 mark_vectorlike (ptr
);
6068 /* If hash table is not weak, mark all keys and values.
6069 For weak tables, mark only the vector. */
6071 mark_object (h
->key_and_value
);
6073 VECTOR_MARK (XVECTOR (h
->key_and_value
));
6077 case PVEC_CHAR_TABLE
:
6078 mark_char_table (ptr
);
6081 case PVEC_BOOL_VECTOR
:
6082 /* No Lisp_Objects to mark in a bool vector. */
6093 mark_vectorlike (ptr
);
6100 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
6101 struct Lisp_Symbol
*ptrx
;
6105 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
6107 mark_object (ptr
->function
);
6108 mark_object (ptr
->plist
);
6109 switch (ptr
->redirect
)
6111 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
6112 case SYMBOL_VARALIAS
:
6115 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
6119 case SYMBOL_LOCALIZED
:
6121 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
6122 Lisp_Object where
= blv
->where
;
6123 /* If the value is set up for a killed buffer or deleted
6124 frame, restore it's global binding. If the value is
6125 forwarded to a C variable, either it's not a Lisp_Object
6126 var, or it's staticpro'd already. */
6127 if ((BUFFERP (where
) && !BUFFER_LIVE_P (XBUFFER (where
)))
6128 || (FRAMEP (where
) && !FRAME_LIVE_P (XFRAME (where
))))
6129 swap_in_global_binding (ptr
);
6130 mark_object (blv
->where
);
6131 mark_object (blv
->valcell
);
6132 mark_object (blv
->defcell
);
6135 case SYMBOL_FORWARDED
:
6136 /* If the value is forwarded to a buffer or keyboard field,
6137 these are marked when we see the corresponding object.
6138 And if it's forwarded to a C variable, either it's not
6139 a Lisp_Object var, or it's staticpro'd already. */
6141 default: emacs_abort ();
6143 if (!PURE_POINTER_P (XSTRING (ptr
->name
)))
6144 MARK_STRING (XSTRING (ptr
->name
));
6145 MARK_INTERVAL_TREE (string_intervals (ptr
->name
));
6150 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun. */
6151 XSETSYMBOL (obj
, ptrx
);
6158 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
6160 if (XMISCANY (obj
)->gcmarkbit
)
6163 switch (XMISCTYPE (obj
))
6165 case Lisp_Misc_Marker
:
6166 /* DO NOT mark thru the marker's chain.
6167 The buffer's markers chain does not preserve markers from gc;
6168 instead, markers are removed from the chain when freed by gc. */
6169 XMISCANY (obj
)->gcmarkbit
= 1;
6172 case Lisp_Misc_Save_Value
:
6173 XMISCANY (obj
)->gcmarkbit
= 1;
6176 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
6177 /* If DOGC is set, POINTER is the address of a memory
6178 area containing INTEGER potential Lisp_Objects. */
6181 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
6183 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
6184 mark_maybe_object (*p
);
6190 case Lisp_Misc_Overlay
:
6191 mark_overlay (XOVERLAY (obj
));
6201 register struct Lisp_Cons
*ptr
= XCONS (obj
);
6202 if (CONS_MARKED_P (ptr
))
6204 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
6206 /* If the cdr is nil, avoid recursion for the car. */
6207 if (EQ (ptr
->u
.cdr
, Qnil
))
6213 mark_object (ptr
->car
);
6216 if (cdr_count
== mark_object_loop_halt
)
6222 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
6223 FLOAT_MARK (XFLOAT (obj
));
6234 #undef CHECK_ALLOCATED
6235 #undef CHECK_ALLOCATED_AND_LIVE
6237 /* Mark the Lisp pointers in the terminal objects.
6238 Called by Fgarbage_collect. */
6241 mark_terminals (void)
6244 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
6246 eassert (t
->name
!= NULL
);
6247 #ifdef HAVE_WINDOW_SYSTEM
6248 /* If a terminal object is reachable from a stacpro'ed object,
6249 it might have been marked already. Make sure the image cache
6251 mark_image_cache (t
->image_cache
);
6252 #endif /* HAVE_WINDOW_SYSTEM */
6253 if (!VECTOR_MARKED_P (t
))
6254 mark_vectorlike ((struct Lisp_Vector
*)t
);
6260 /* Value is non-zero if OBJ will survive the current GC because it's
6261 either marked or does not need to be marked to survive. */
6264 survives_gc_p (Lisp_Object obj
)
6268 switch (XTYPE (obj
))
6275 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
6279 survives_p
= XMISCANY (obj
)->gcmarkbit
;
6283 survives_p
= STRING_MARKED_P (XSTRING (obj
));
6286 case Lisp_Vectorlike
:
6287 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
6291 survives_p
= CONS_MARKED_P (XCONS (obj
));
6295 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
6302 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
6307 /* Sweep: find all structures not marked, and free them. */
6312 /* Remove or mark entries in weak hash tables.
6313 This must be done before any object is unmarked. */
6314 sweep_weak_hash_tables ();
6317 check_string_bytes (!noninteractive
);
6319 /* Put all unmarked conses on free list */
6321 register struct cons_block
*cblk
;
6322 struct cons_block
**cprev
= &cons_block
;
6323 register int lim
= cons_block_index
;
6324 EMACS_INT num_free
= 0, num_used
= 0;
6328 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
6332 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
6334 /* Scan the mark bits an int at a time. */
6335 for (i
= 0; i
< ilim
; i
++)
6337 if (cblk
->gcmarkbits
[i
] == -1)
6339 /* Fast path - all cons cells for this int are marked. */
6340 cblk
->gcmarkbits
[i
] = 0;
6341 num_used
+= BITS_PER_INT
;
6345 /* Some cons cells for this int are not marked.
6346 Find which ones, and free them. */
6347 int start
, pos
, stop
;
6349 start
= i
* BITS_PER_INT
;
6351 if (stop
> BITS_PER_INT
)
6352 stop
= BITS_PER_INT
;
6355 for (pos
= start
; pos
< stop
; pos
++)
6357 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
6360 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
6361 cons_free_list
= &cblk
->conses
[pos
];
6363 cons_free_list
->car
= Vdead
;
6369 CONS_UNMARK (&cblk
->conses
[pos
]);
6375 lim
= CONS_BLOCK_SIZE
;
6376 /* If this block contains only free conses and we have already
6377 seen more than two blocks worth of free conses then deallocate
6379 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
6381 *cprev
= cblk
->next
;
6382 /* Unhook from the free list. */
6383 cons_free_list
= cblk
->conses
[0].u
.chain
;
6384 lisp_align_free (cblk
);
6388 num_free
+= this_free
;
6389 cprev
= &cblk
->next
;
6392 total_conses
= num_used
;
6393 total_free_conses
= num_free
;
6396 /* Put all unmarked floats on free list */
6398 register struct float_block
*fblk
;
6399 struct float_block
**fprev
= &float_block
;
6400 register int lim
= float_block_index
;
6401 EMACS_INT num_free
= 0, num_used
= 0;
6403 float_free_list
= 0;
6405 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6409 for (i
= 0; i
< lim
; i
++)
6410 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6413 fblk
->floats
[i
].u
.chain
= float_free_list
;
6414 float_free_list
= &fblk
->floats
[i
];
6419 FLOAT_UNMARK (&fblk
->floats
[i
]);
6421 lim
= FLOAT_BLOCK_SIZE
;
6422 /* If this block contains only free floats and we have already
6423 seen more than two blocks worth of free floats then deallocate
6425 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6427 *fprev
= fblk
->next
;
6428 /* Unhook from the free list. */
6429 float_free_list
= fblk
->floats
[0].u
.chain
;
6430 lisp_align_free (fblk
);
6434 num_free
+= this_free
;
6435 fprev
= &fblk
->next
;
6438 total_floats
= num_used
;
6439 total_free_floats
= num_free
;
6442 /* Put all unmarked intervals on free list */
6444 register struct interval_block
*iblk
;
6445 struct interval_block
**iprev
= &interval_block
;
6446 register int lim
= interval_block_index
;
6447 EMACS_INT num_free
= 0, num_used
= 0;
6449 interval_free_list
= 0;
6451 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6456 for (i
= 0; i
< lim
; i
++)
6458 if (!iblk
->intervals
[i
].gcmarkbit
)
6460 set_interval_parent (&iblk
->intervals
[i
], interval_free_list
);
6461 interval_free_list
= &iblk
->intervals
[i
];
6467 iblk
->intervals
[i
].gcmarkbit
= 0;
6470 lim
= INTERVAL_BLOCK_SIZE
;
6471 /* If this block contains only free intervals and we have already
6472 seen more than two blocks worth of free intervals then
6473 deallocate this block. */
6474 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6476 *iprev
= iblk
->next
;
6477 /* Unhook from the free list. */
6478 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6483 num_free
+= this_free
;
6484 iprev
= &iblk
->next
;
6487 total_intervals
= num_used
;
6488 total_free_intervals
= num_free
;
6491 /* Put all unmarked symbols on free list */
6493 register struct symbol_block
*sblk
;
6494 struct symbol_block
**sprev
= &symbol_block
;
6495 register int lim
= symbol_block_index
;
6496 EMACS_INT num_free
= 0, num_used
= 0;
6498 symbol_free_list
= NULL
;
6500 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6503 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6504 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6506 for (; sym
< end
; ++sym
)
6508 /* Check if the symbol was created during loadup. In such a case
6509 it might be pointed to by pure bytecode which we don't trace,
6510 so we conservatively assume that it is live. */
6511 bool pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.name
));
6513 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6515 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6516 xfree (SYMBOL_BLV (&sym
->s
));
6517 sym
->s
.next
= symbol_free_list
;
6518 symbol_free_list
= &sym
->s
;
6520 symbol_free_list
->function
= Vdead
;
6528 UNMARK_STRING (XSTRING (sym
->s
.name
));
6529 sym
->s
.gcmarkbit
= 0;
6533 lim
= SYMBOL_BLOCK_SIZE
;
6534 /* If this block contains only free symbols and we have already
6535 seen more than two blocks worth of free symbols then deallocate
6537 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6539 *sprev
= sblk
->next
;
6540 /* Unhook from the free list. */
6541 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6546 num_free
+= this_free
;
6547 sprev
= &sblk
->next
;
6550 total_symbols
= num_used
;
6551 total_free_symbols
= num_free
;
6554 /* Put all unmarked misc's on free list.
6555 For a marker, first unchain it from the buffer it points into. */
6557 register struct marker_block
*mblk
;
6558 struct marker_block
**mprev
= &marker_block
;
6559 register int lim
= marker_block_index
;
6560 EMACS_INT num_free
= 0, num_used
= 0;
6562 marker_free_list
= 0;
6564 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6569 for (i
= 0; i
< lim
; i
++)
6571 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6573 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6574 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6575 /* Set the type of the freed object to Lisp_Misc_Free.
6576 We could leave the type alone, since nobody checks it,
6577 but this might catch bugs faster. */
6578 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6579 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6580 marker_free_list
= &mblk
->markers
[i
].m
;
6586 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6589 lim
= MARKER_BLOCK_SIZE
;
6590 /* If this block contains only free markers and we have already
6591 seen more than two blocks worth of free markers then deallocate
6593 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6595 *mprev
= mblk
->next
;
6596 /* Unhook from the free list. */
6597 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6602 num_free
+= this_free
;
6603 mprev
= &mblk
->next
;
6607 total_markers
= num_used
;
6608 total_free_markers
= num_free
;
6611 /* Free all unmarked buffers */
6613 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6617 if (!VECTOR_MARKED_P (buffer
))
6620 prev
->header
.next
= buffer
->header
.next
;
6622 all_buffers
= buffer
->header
.next
.buffer
;
6623 next
= buffer
->header
.next
.buffer
;
6629 VECTOR_UNMARK (buffer
);
6630 /* Do not use buffer_(set|get)_intervals here. */
6631 buffer
->text
->intervals
= balance_intervals (buffer
->text
->intervals
);
6633 prev
= buffer
, buffer
= buffer
->header
.next
.buffer
;
6638 check_string_bytes (!noninteractive
);
6644 /* Debugging aids. */
6646 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6647 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6648 This may be helpful in debugging Emacs's memory usage.
6649 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6654 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6659 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6660 doc
: /* Return a list of counters that measure how much consing there has been.
6661 Each of these counters increments for a certain kind of object.
6662 The counters wrap around from the largest positive integer to zero.
6663 Garbage collection does not decrease them.
6664 The elements of the value are as follows:
6665 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6666 All are in units of 1 = one object consed
6667 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6669 MISCS include overlays, markers, and some internal types.
6670 Frames, windows, buffers, and subprocesses count as vectors
6671 (but the contents of a buffer's text do not count here). */)
6674 return listn (CONSTYPE_HEAP
, 8,
6675 bounded_number (cons_cells_consed
),
6676 bounded_number (floats_consed
),
6677 bounded_number (vector_cells_consed
),
6678 bounded_number (symbols_consed
),
6679 bounded_number (string_chars_consed
),
6680 bounded_number (misc_objects_consed
),
6681 bounded_number (intervals_consed
),
6682 bounded_number (strings_consed
));
6685 /* Find at most FIND_MAX symbols which have OBJ as their value or
6686 function. This is used in gdbinit's `xwhichsymbols' command. */
6689 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6691 struct symbol_block
*sblk
;
6692 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6693 Lisp_Object found
= Qnil
;
6697 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6699 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6702 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6704 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6708 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6711 XSETSYMBOL (tem
, sym
);
6712 val
= find_symbol_value (tem
);
6714 || EQ (sym
->function
, obj
)
6715 || (!NILP (sym
->function
)
6716 && COMPILEDP (sym
->function
)
6717 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6720 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6722 found
= Fcons (tem
, found
);
6723 if (--find_max
== 0)
6731 unbind_to (gc_count
, Qnil
);
6735 #ifdef ENABLE_CHECKING
6737 bool suppress_checking
;
6740 die (const char *msg
, const char *file
, int line
)
6742 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6744 fatal_error_backtrace (SIGABRT
, INT_MAX
);
6748 /* Initialization */
6751 init_alloc_once (void)
6753 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6755 pure_size
= PURESIZE
;
6757 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6759 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6762 #ifdef DOUG_LEA_MALLOC
6763 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6764 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6765 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6771 malloc_hysteresis
= 32;
6773 malloc_hysteresis
= 0;
6776 refill_memory_reserve ();
6777 gc_cons_threshold
= GC_DEFAULT_THRESHOLD
;
6784 byte_stack_list
= 0;
6786 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6787 setjmp_tested_p
= longjmps_done
= 0;
6790 Vgc_elapsed
= make_float (0.0);
6795 syms_of_alloc (void)
6797 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6798 doc
: /* Number of bytes of consing between garbage collections.
6799 Garbage collection can happen automatically once this many bytes have been
6800 allocated since the last garbage collection. All data types count.
6802 Garbage collection happens automatically only when `eval' is called.
6804 By binding this temporarily to a large number, you can effectively
6805 prevent garbage collection during a part of the program.
6806 See also `gc-cons-percentage'. */);
6808 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6809 doc
: /* Portion of the heap used for allocation.
6810 Garbage collection can happen automatically once this portion of the heap
6811 has been allocated since the last garbage collection.
6812 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6813 Vgc_cons_percentage
= make_float (0.1);
6815 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6816 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6818 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6819 doc
: /* Number of cons cells that have been consed so far. */);
6821 DEFVAR_INT ("floats-consed", floats_consed
,
6822 doc
: /* Number of floats that have been consed so far. */);
6824 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6825 doc
: /* Number of vector cells that have been consed so far. */);
6827 DEFVAR_INT ("symbols-consed", symbols_consed
,
6828 doc
: /* Number of symbols that have been consed so far. */);
6830 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6831 doc
: /* Number of string characters that have been consed so far. */);
6833 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6834 doc
: /* Number of miscellaneous objects that have been consed so far.
6835 These include markers and overlays, plus certain objects not visible
6838 DEFVAR_INT ("intervals-consed", intervals_consed
,
6839 doc
: /* Number of intervals that have been consed so far. */);
6841 DEFVAR_INT ("strings-consed", strings_consed
,
6842 doc
: /* Number of strings that have been consed so far. */);
6844 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6845 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6846 This means that certain objects should be allocated in shared (pure) space.
6847 It can also be set to a hash-table, in which case this table is used to
6848 do hash-consing of the objects allocated to pure space. */);
6850 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6851 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6852 garbage_collection_messages
= 0;
6854 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6855 doc
: /* Hook run after garbage collection has finished. */);
6856 Vpost_gc_hook
= Qnil
;
6857 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6859 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6860 doc
: /* Precomputed `signal' argument for memory-full error. */);
6861 /* We build this in advance because if we wait until we need it, we might
6862 not be able to allocate the memory to hold it. */
6864 = listn (CONSTYPE_PURE
, 2, Qerror
,
6865 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6867 DEFVAR_LISP ("memory-full", Vmemory_full
,
6868 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6869 Vmemory_full
= Qnil
;
6871 DEFSYM (Qconses
, "conses");
6872 DEFSYM (Qsymbols
, "symbols");
6873 DEFSYM (Qmiscs
, "miscs");
6874 DEFSYM (Qstrings
, "strings");
6875 DEFSYM (Qvectors
, "vectors");
6876 DEFSYM (Qfloats
, "floats");
6877 DEFSYM (Qintervals
, "intervals");
6878 DEFSYM (Qbuffers
, "buffers");
6879 DEFSYM (Qstring_bytes
, "string-bytes");
6880 DEFSYM (Qvector_slots
, "vector-slots");
6881 DEFSYM (Qheap
, "heap");
6883 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6884 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6886 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6887 doc
: /* Accumulated time elapsed in garbage collections.
6888 The time is in seconds as a floating point value. */);
6889 DEFVAR_INT ("gcs-done", gcs_done
,
6890 doc
: /* Accumulated number of garbage collections done. */);
6895 defsubr (&Smake_byte_code
);
6896 defsubr (&Smake_list
);
6897 defsubr (&Smake_vector
);
6898 defsubr (&Smake_string
);
6899 defsubr (&Smake_bool_vector
);
6900 defsubr (&Smake_symbol
);
6901 defsubr (&Smake_marker
);
6902 defsubr (&Spurecopy
);
6903 defsubr (&Sgarbage_collect
);
6904 defsubr (&Smemory_limit
);
6905 defsubr (&Smemory_use_counts
);
6907 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6908 defsubr (&Sgc_status
);
6912 /* When compiled with GCC, GDB might say "No enum type named
6913 pvec_type" if we don't have at least one symbol with that type, and
6914 then xbacktrace could fail. Similarly for the other enums and
6918 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS
;
6919 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS
;
6920 enum char_bits char_bits
;
6921 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE
;
6922 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE
;
6923 enum enum_USE_LSB_TAG enum_USE_LSB_TAG
;
6924 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE
;
6925 enum Lisp_Bits Lisp_Bits
;
6926 enum Lisp_Compiled Lisp_Compiled
;
6927 enum maxargs maxargs
;
6928 enum MAX_ALLOCA MAX_ALLOCA
;
6929 enum More_Lisp_Bits More_Lisp_Bits
;
6930 enum pvec_type pvec_type
;
6932 enum lsb_bits lsb_bits
;
6934 } const EXTERNALLY_VISIBLE gdb_make_enums_visible
= {0};